Jump to content
IGNORED

fbForth—TI Forth with File-based Block I/O [Post #1 UPDATED: 06/09/2023]


Lee Stewart

Recommended Posts

Well at least it doesn't happen often like it does with me. Until I get more focused on my writing style it'll always happen. My problem is thinking ahead and then coding  before I placed pertinent information first. 

I have to remember to go back and read everything no matter how insignificant.

 

Link to comment
Share on other sites

32 minutes ago, Lee Stewart said:

You may have noticed the time of my last post (2:17 AM). I had no intention of staying up that late last night, but at one point I added something to the code that caused the assembly to blow up. I panicked, thinking that somehow I had screwed up more than just the file I was editing because the surfeit of error messages made no sense. I finally figured out that the problem was a couple of odd characters I had included in a comment as is my wont—the open and close quotes (“ [alt+0147] and ” [alt+0148]). I am in such a habit of using them in any text I type that it did not occur to me to even look there. I did narrow it down to the comments, but was thinking that I might have hit some source-code size maximum. At one point, I thought the ‘#’ was the culprit. While poring over the added comments for anything else odd, those quotes sort of reached out and slapped me! Oh, well....

 

...lee

I went through a lot of that while trying to stabilize the cross-compiler. 

I was chasing my tail. Is it the Forth code in the kernel or Forth code in the compiler or the Forth code in the kernel or the...  :) 

 

I am hoping it staves off dementia but it might lead to high blood pressure!.

  • Haha 1
Link to comment
Share on other sites

Here is another version that is a little faster, but no difference in size, unfortunately. I will leave comparing the two routines as an exercise for the reader. |:)

Spoiler

;[*++ Check for presence of SAMS card.
***++ SAMS flag will be set to highest available page #.

* To test, Map >000E + lowest bank not in next lower SAMS to >E000. For
* 32 MiB, this is >1000 + >000E. We initially store >0010 (LSB,MSB) in
* R3 to allow a circular shift each round before MOVing to R0 to then add
* >0E00 (LSB,MSB) for the next test. If the test fails at >001E, the last
* viable SAMS (128 KiB), R3 will go to >0800, at which point the loop
* exits, setting R3 to 0, effectively reporting "no SAMS".
*
* Set up SAMS check.
*
       LI   R2,>994A      `check-value
       MOV  R2,@>E000      check-value to check-location
       ; Classic99 emulator can do 32 MiB
       LI   R3,>0010       lowest page > next lower SAMS to R3 (LSB,MSB)
       LI   CRU,>1E00      CRU address of SAMS
*
*
SAMS_CHECK: 
       MOV  R3,R0          lowest bank above next lower SAMS range
       AI   R0,>0E00       get >000E pages higher
       SBO  0              enable SAMS registers
       MOV  R0,@>401C      poke SAMS register for >E000
       SBZ  0              disable SAMS registers
       C    @>E000,R2      compare possible copy with test value
       JNE  SAMS_EXIT      exit if SAMS mapped, viz., no match
       SRC  R3,1           shift right circularly by ^2 to next lower SAMS
       CI   R3,>0800       too far?
       JNE  SAMS_CHECK     try half as much if not >0008 (LSB,MSB)
       CLR  R3             no-SAMS..set flag to 0
       JMP  SAMS_EXIT0     we're outta here
SAMS_EXIT:
       SWPB R3             restore page #
       SLA  R3,1           double value (highest page# + 1)
       DEC  R3             decrement to highest page#
SAMS_EXIT0:
       MOV  R3,@ARG        save SAMS flag to ARG (hoping it survives!)
       JEQ  FRTHCP         go to copying Forth inner interpreter if no SAMS
*                          ...no need to restore anything if no SAMS
*
* Remap default bank >0E to >E000.
* CRU should still have correct value.
*
       LI   R0,>0E00       load SAMS bank >000E
       SBO  0              enable SAMS registers
       MOV  R0,@>401C      poke SAMS register for >E000
       SBZ  0              disable SAMS registers
;]*

 

 

...lee

  • Like 1
Link to comment
Share on other sites

In perusing the MG DSRLNK I use in fbForth, I noticed a suspicious COC:

GSTAT  EQU  >837C            GPL Status byte location
       LI   R12,>2000        for testing GPL status CND bit
*       ...
       COC  @GSTAT,R12       test CND bit for Link Error (00)

I think it is risky testing a byte with a word operation with the mask in the destination operand. This is relying on the LSB of @GSTAT being 0 and the DSR only setting the CND bit (perhaps true). The operands should be swapped, but the destination operand of COC must be a register. To be safe, I would need an additional instruction:

GSTAT  EQU  >837C            GPL Status byte location
       LI   R12,>2000        for testing GPL status CND bit
*       ...
       MOV  @GSTAT,R0        put GPL status in R0 for testing
       COC  R12,R0           test CND bit for Link Error (00)

Craig Miller and D. C. Warren must have thought it was safe enough, but I worry a little about it because I have not found (yet) where the entire word is cleared before the DSRLNK process starts. I will take a look later at the GPL DSRLNK that gets  called to see what might be going on. Anyone know for sure?

 

...lee

Link to comment
Share on other sites

10 hours ago, Lee Stewart said:

In perusing the MG DSRLNK I use in fbForth, I noticed a suspicious COC:


GSTAT  EQU  >837C            GPL Status byte location
       LI   R12,>2000        for testing GPL status CND bit
*       ...
       COC  @GSTAT,R12       test CND bit for Link Error (00)

I think it is risky testing a byte with a word operation with the mask in the destination operand. This is relying on the LSB of @GSTAT being 0 and the DSR only setting the CND bit (perhaps true). The operands should be swapped, but the destination operand of COC must be a register. To be safe, I would need an additional instruction:


GSTAT  EQU  >837C            GPL Status byte location
       LI   R12,>2000        for testing GPL status CND bit
*       ...
       MOV  @GSTAT,R0        put GPL status in R0 for testing
       COC  R12,R0           test CND bit for Link Error (00)

Craig Miller and D. C. Warren must have thought it was safe enough, but I worry a little about it because I have not found (yet) where the entire word is cleared before the DSRLNK process starts. I will take a look later at the GPL DSRLNK that gets  called to see what might be going on. Anyone know for sure?

 

...lee

Masking R0 before testing would remove all doubt no?

 

 

 

Link to comment
Share on other sites

13 minutes ago, TheBF said:

Masking R0 before testing would remove all doubt no?

 

It would. It is just that I keep chipping away at the few bytes I have left in bank 1. That is exactly what I will do, though, if no one convinces me otherwise. >837D is, I believe, only used by GPL display routine(s) for the current, on-screen character. I do not use that, explicitly, anywhere in fbForth, so, if I can find that GPL’s DSRLNK or the DSR itself clears the whole word at >837C, I am probably safe. Otherwise, ....

 

...lee

Link to comment
Share on other sites

32 minutes ago, TheBF said:

Could you write a short test in Forth Assembler to confirm or deny your suspicions?

 

Surely. It should be doable in high-level Forth, as well. I did look at >837C and >837D during a small TI Basic session—typing, listing and running a small, idiotic program. >837D was always 0; >837C flickered when there were errors, etc., but seemed to always get reset, so GPL does not seem to be using >837D for display in TI Basic, anyway. I will run with your test idea soon.

 

...lee

  • Like 1
Link to comment
Share on other sites

3 hours ago, Asmusr said:

How about:

mov @gstat,r12

andi r12,>2000

Or is [the value of] r12 used somewhere else?

 

Yeah, R12 doubles as the “GPL DSRLNK found” flag and CND bit mask and needs to hang around.

 

My use of R0  to hold @GSTAT for the COC test works fine (also could be used in your example) and is 1 memory access less than ANDI—I was just bemoaning the necessity of the extra instruction.

 

...lee

Link to comment
Share on other sites

Back in post #1565, I listed what I hoped to improve/fix for fbForth 2.0:13. The last item on the list was “DSRLNK improvements”. Unfortunately, the only way I can do anything about that is to abandon the MG DSRLNK (allows cassette use) I am using in favor of the one used in TI Forth or Paolo Bagnaresi’s version (may be identical). The problem with making this change is that it eliminates cassette access (not sure anyone cares) and increases DSRLNK’s footprint by about 90 bytes before attempting any improvements. The relevant bank has only 84 bytes left! I would need to do some serious refactoring, I am afraid.

 

...lee

Link to comment
Share on other sites

I am not sure you would get much benefit. Doesn't the MG version call some ROM code? If so it probably runs faster than something running in cartridge space.

I have not tried my changes on real hardware yet but I found what seemed to be some superfluous code in the Bagnaresi (RIP) version last night because of the structure of the code.

There is a lot of spaghetti ( molto italiano :) ) and I made some of it simpler when I reorganized the loops.

 

We shall see today what I don't understand. :) 

 

 

Link to comment
Share on other sites

40 minutes ago, TheBF said:

I am not sure you would get much benefit. Doesn't the MG version call some ROM code? If so it probably runs faster than something running in cartridge space.

I have not tried my changes on real hardware yet but I found what seemed to be some superfluous code in the Bagnaresi (RIP) version last night because of the structure of the code.

There is a lot of spaghetti ( molto italiano :) ) and I made some of it simpler when I reorganized the loops.

 

We shall see today what I don't understand. :) 

 

Well. The MG code calls the GPL DSRLNK, which is 59 bytes of GPL. That code does some name-length checking, verifies the ‘.’ and copies the filename from VRAM (PAB) to FAC (>834A) before it calls the main routine in 16-bit ROM 0, which may well beat the 8-bit TI Forth or Bagnaresi (yes, RIP) code.

 

Not that it makes a speed difference, but fbForth 2.0’s DSRLNK is copied to and runs in low RAM.

 

Hope your refactoring works. ?

 

...lee

Link to comment
Share on other sites

I posted the version that works.  It is still a little convoluted. I tried to use structured loops, but Senore Bagnaresi used lots of unstructured methods to save space so there are jumps in and out of my loops.

Doesn't look nice but it works.

 

There is some logic in the original that used the CRU address 1300.  I am not sure why.  I removed it.

I loop through cards and error out if R12 gets to >2000.

Perhaps his made some assumptions about the highest card. (?)

 

 

Link to comment
Share on other sites

25 minutes ago, TheBF said:

I posted the version that works.  It is still a little convoluted. I tried to use structured loops, but Senore Bagnaresi used lots of unstructured methods to save space so there are jumps in and out of my loops.  Doesn't look nice but it works.

 

There is some logic in the original that used the CRU address 1300.  I am not sure why.  I removed it.  I loop through cards and error out if R12 gets to >2000.  Perhaps his made some assumptions about the highest card. (?)

 

Well, >1300 is the CRU of the first RS232 card. ISTR a problem with RS232 and the timer interrupt, but I have no idea how that computes here.

 

Earlier I said that the TI Forth DSRLNK code and that of Bagnaresi might be identical (or nearly so). That was because Mark Wills (@Willsy) marked TurboForth’s DSRLNK as having been written by Bagnaresi, but, unless he modified it, I think he misspoke because it is practically identical to TI Forth’s code, right down to the labels, and has no reference to >1300. Mark handles subroutine errors (@>8350) in the routine, whereas TI Forth handles them after DSRLNK (>A) returned. Maybe we can sort out what is really going on among all the extant versions of DSRLNK we are aware of. I can lay my hands on five and will post them all after supper.

 

...lee

  • Like 1
  • Thanks 1
Link to comment
Share on other sites

OK, here we go. Here are the different versions of DSRLNK that I can find:

  1. TI Forth:
    Spoiler
    
    ** vvvvvvvvvvvv UTILEQU vvvvv below vvvvvvvvvvvvvvvvvvvvvvvv
    **
    SCNKEY EQU  >000E
    ; XMLTAB EQU  >0CFA        XML TABLES (BASE)
    FLAG2  EQU  >8349
    SCLEN  EQU  >8355
    SCNAME EQU  >8356
    SUBSTK EQU  >8373
    CRULST EQU  >83D0
    SADDR  EQU  >83D2
    GPLWS  EQU  >83E0        GPL/EXTENDED BASIC WORKSPACE
    SCRPAD EQU  >8300
    VDPRD  EQU  >8800        VDP read data address
    VDPWD  EQU  >8C00        VDP write data address
    VDPWA  EQU  >8C02        VDP write address address
    R0LB   EQU  >83E1
    R1LB   EQU  >83E3
    R3LB   EQU  >83E7
    **
    ** ^^^^^^^^^^^^ UTILEQU ^^^^^ above ^^^^^^^^^^^^^^^^^^^^^^^^
    **
    H20    EVEN
    H2000  DATA >2000
    DECMAL TEXT '.'
    HAA    BYTE >AA
           EVEN
    *
    * Utility Vectors
    *
    GPLLNK DATA UTILWS,GLENTR     Link to GROM routines
    XMLLNK DATA UTILWS,XMLENT     Link to ROM routines
    KSCAN  DATA UTILWS,KSENTR     Keyboard scan
    VSBW   DATA UTILWS,VSBWEN     VDP single byte write
    VMBW   DATA UTILWS,VMBWEN     VDP multiple byte write
    VSBR   DATA UTILWS,VSBREN     VDP single byte read
    VMBR   DATA UTILWS,VMBREN     VDP multiple byte read
    VWTR   DATA UTILWS,VWTREN     VDP write to register
    DSRLNK DATA DLNKWS,DLENTR     Link to device service routine
    *
    *
    *===========================================================
    *** Link to device service routine *************************
    *===========================================================
    *
    DLENTR MOV  *R14+,R5          Fetch program type for link
           SZCB @H20,R15          Reset equal bit
           MOV  @SCNAME,R0        Fetch pointer into PAB
           MOV  R0,R9             Save pointer
           AI   R9,-8             Adjust pointer to flag byte
           BLWP @VSBR             Read device name length
           MOVB R1,R3             Store it elsewhere
           SRL  R3,8              Make it a word value
           SETO R4                Initialize a counter
           LI   R2,NAMBUF         Point to NAMBUF
    LNK$LP INC  R0                Point to next char of name
           INC  R4                Increment character counter
           C    R4,R3             End of name?
           JEQ  LNK$LN            Yes
           BLWP @VSBR             Read current character
           MOVB R1,*R2+           Move it to NAMBUF
           CB   R1,@DECMAL        Is it a decimal point?
           JNE  LNK$LP            No
    LNK$LN MOV  R4,R4             Is name length zero?
           JEQ  LNKERR            Yes, error
           CI   R4,7              Is name length > 7?
           JGT  LNKERR            Yes, error
           CLR  @CRULST
           MOV  R4,@SCLEN-1       Store name length for search
           MOV  R4,@SAVLEN        Save device name length
           INC  R4                Adjust it
           A    R4,@SCNAME        Point to position after name
           MOV  @SCNAME,@SAVPAB   Save pointer into device name
    *
    *** Search ROM CROM GROM for DSR
    *
    SROM   LWPI GPLWS             Use GPL workspace to search
           CLR  R1                Version found of DSR etc.
           LI   R12,>0F00         Start over again
    NOROM  MOV  R12,R12           Anything to turn off
           JEQ  NOOFF             No
           SBZ  0                 Yes, turn it off
    NOOFF  AI   R12,>0100         Next ROM'S turn on
           CLR  @CRULST           Clear in case we're finished
           CI   R12,>2000         At the end
           JEQ  NODSR             No more ROMs to turn on
           MOV  R12,@CRULST       Save address of next CRU
           SBO  0                 Turn on ROM
           LI   R2,>4000          Start at beginning
           CB   *R2,@HAA          Is it a valid ROM?
           JNE  NOROM             No
           A    @TYPE$,R2          Go to first pointer
           JMP SGO2
    SGO    MOV  @SADDR,R2         Continue where we left off
           SBO  0                 Turn ROM back on
    SGO2   MOV  *R2,R2            Is address a zero
           JEQ  NOROM             Yes, no program to look at
           MOV  R2,@SADDR         Remember where we go next
           INCT R2                Go to entry point
           MOV  *R2+,R9           Get entry address
    *
    *** See if name matches
    *
           MOVB @SCLEN,R5         Get length as counter
           JEQ  NAME2             Zero length, don't do match
           CB   R5,*R2+           Does length match?
           JNE  SGO               No
           SRL  R5,8              Move to right place
           LI   R6,NAMBUF         Point to NAMBUF
    NAME1  CB   *R6+,*R2+         Is character correct?
           JNE  SGO               No
           DEC  R5                More to look at?
           JNE  NAME1             Yes
    NAME2  INC  R1                Next version found
           MOV  R1,@SAVVER        Save version number
           MOV  R9,@SAVENT        Save entry address
           MOV  R12,@SAVCRU       Save CRU address
           BL   *R9               Match, call subroutine
           JMP  SGO               Not right version
           SBZ  0                 Turn off ROM
           LWPI DLNKWS            Select DSRLNK workspace
           MOV  R9,R0             Point to flag byte in PAB
           BLWP @VSBR             Read flag byte
           SRL  R1,13             Just want the error flags
           JNE  IOERR             Error!
           RTWP
    *
    *** Error handling
    *
    NODSR  LWPI DLNKWS       Select DSRLNK workspace
    LNKERR CLR  R1           Clear the error flags
    IOERR  SWPB R1
           MOVB R1,*R13      Store error flags in calling R0
           SOCB @H20,R15     Indicate an error occured
           RTWP              Return to caller
    **
    ** ^^^^^^^^^^^^ UTILROM ^^^^^ above ^^^^^^^^^^^^^^^^^^^^^^^^
    **
    **       COPY "DSK2.UTILRAM"
    **
    ** vvvvvvvvvvvv UTILRAM vvvvv below vvvvvvvvvvvvvvvvvvvvvvvv
    **
    SVGPRT DATA 0            Save GPL return address
    SAVCRU DATA 0            CRU address of peripheral
    SAVENT DATA 0            Entry address of DSR
    SAVLEN DATA 0            Save device name length
    SAVPAB DATA 0            Ptr into device name in PAB
    SAVVER DATA 0            Version number of DSR
    NAMBUF DATA 0,0,0,0
    *
    *** General utility workspace registers (Overlaps next WS)
    UTILWS DATA 0,0
           BYTE 0
    R2LB   BYTE 0
    *
    *** DSR link routine workspace registers (Overlaps prev. WS)
    DLNKWS DATA 0,0,0,0,0
    TYPE$  DATA 0,0,0,0,0,0,0,0,0,0,0
    *
    ** ^^^^^^^^^^^^ UTILRAM ^^^^^ above ^^^^^^^^^^^^^^^^^^^^^^^^
    

     

     

  2. TurboForth 1.2:2:
    Spoiler
    
    ;==============================================================
    ;*** DSRLNK ***************************************************
    ;==============================================================
    ;[ dsr link routine - Written by Paolo Bagnaresi
    dsrlnk  data dsrlws                 ; dsrlnk workspace
            data dlentr                 ; entry point
    
    dlentr  li r0,>aa00
            movb r0,@haa                ; load haa
            mov *r14+,r5                ; get pgm type for link
            mov r5,@sav8a               ; save data following blwp @dsrlnk (8 or >a)
            szcb @h20,r15               ; reset equal bit
            mov @>8356,r0               ; get ptr to pab
            mov r0,r9                   ; save ptr
            mov r0,@flgptr              ; save again pointer to pab+1 for dsrlnk 
                                        ; data 8
            ai r9,>fff8                 ; adjust to flag
            bl @_vsbr                   ; read device name length
            movb r1,r3                  ; copy it
            srl r3,8                    ; make it lo byter
            seto r4                     ; init counter
            li r2,namsto                ; point to buffer
    lnkslp  inc r0                      ; point to next char of name
            inc r4                      ; incr char counter
            ci r4,>0007                 ; see if length more than 7 chars
            jgt lnkerr                  ; yes, error
            c r4,r3                     ; end of name?
            jeq lnksln                  ; yes
            bl @_vsbr                   ; read curr char
            movb r1,*r2+                ; move into buffer
            cb r1,@decmal               ; is it a period?
            jne lnkslp                  ; no
    lnksln  mov r4,r4                   ; see if 0 length
            jeq lnkerr                  ; yes, error
            clr @>83d0
            mov r4,@>8354               ; save name length for search
            mov r4,@savlen              ; save it here too
            inc r4                      ; adjust for period
            a r4,@>8356                 ; point to position after name
            mov @>8356,@savpab          ; save pointer to position after name
    srom    lwpi >83e0                  ; use gplws
            clr r1                      ; version found of dsr
            li r12,>0f00                ; init cru addr
    norom   mov r12,r12                 ; anything to turn off?
            jeq nooff                   ; no
            sbz 0                       ; yes, turn off
    nooff   ai r12,>0100                ; next rom to turn on
            clr @>83d0                  ; clear in case we are done
            ci r12,>2000                ; see if done
            jeq nodsr                   ; yes, no dsr match
            mov r12,@>83d0              ; save addr of next cru
            sbo 0                       ; turn on rom
            li r2,>4000                 ; start at beginning of rom
            cb *r2,@haa                 ; check for a valid rom
            jne norom                   ; no rom here
            a @dstype,r2                ; go to first pointer
            jmp sgo2
    sgo     mov @>83d2,r2               ; continue where we left off
            sbo 0                       ; turn rom back on
    sgo2    mov *r2,r2                  ; is addr a zero (end of link)
            jeq norom                   ; yes, no programs to check
            mov r2,@>83d2               ; remember where to go next
            inct r2                     ; go to entry point
            mov *r2+,r9                 ; get entry addr just in case
            movb @>8355,r5              ; get length as counter
            jeq namtwo                  ; if zero, do not check
            cb r5,*r2+                  ; see if length matches
            jne sgo                     ; no, try next
            srl r5,8                    ; yes, move to lo byte as counter
            li r6,namsto                ; point to buffer
    namone  cb *r6+,*r2+                ; compare buffer with rom
            jne sgo                     ; try next if no match
            dec r5                      ; loop til full length checked
            jne namone
    namtwo  inc r1                      ; next version found
            mov r1,@savver              ; save version
            mov r9,@savent              ; save entry addr
            mov r12,@savcru             ; save cru
            bl *r9                      ; go run routine
            jmp sgo                     ; error return
            sbz 0                       ; turn off rom if good return
            lwpi dsrlws                 ; restore workspace
            mov r9,r0                   ; point to flag in pab
    frmdsr  mov @sav8a,r1               ; get back data following blwp @dsrlnk
                                        ; (8 or >a)
            ci r1,8                     ; was it 8?
            jeq dsrdt8                  ; yes, jump: normal dsrlnk
            movb @>8350,r1              ; no, we have a data >a. get error byte from
                                        ; >8350
            jmp dsrdta                  ; go and return error byte to the caller
    dsrdt8  bl @_vsbr                   ; read flag
    dsrdta  srl r1,13                   ; just keep error bits
            jne ioerr                   ; handle error
            rtwp
    nodsr   lwpi dsrlws                 ; no dsr, restore workspace
    lnkerr  clr r1                      ; clear flag for error 0 = bad device name
    ioerr   swpb r1                     ; put error in hi byte
            movb r1,*r13                ; store error flags in callers r0
            socb @h20,r15               ; set equal bit to indicate error
            rtwp
    
    data8   data >8                     ; just to compare. 8 is the data that
                                        ; usually follows a blwp @dsrlnk
    decmal  text '.'                    ; for finding end of device name
            even
    h20     data >2000
    ;]
    

     

     

  3. Editor/Assembler cartridge (If you remove the ‘A’ in front of each label, you are left with the actual address in low RAM)
    Spoiler
    
    *=========================================================
    * Assembly routines loaded in low memory expansion
    * ----------------- but stored in GROM at addressES >7000-772F
    *
    *=========================================================
    *G7000 DATA >0008,>2000            size, address where to load
    *      ML99                        assembly language stored here
    *
           AORG >2000
     
    A2000  DATA >A55A                  prog flag
           DATA A2128                  xml 21 link label
           DATA A2398                  xml 22 loader
           DATA A225A                  xml 23 int->real
     
    *---------------------------------------------------------
    *      GPL
    *G700C DATA >0654,>2022            size, address where to load
    *      ML99                        assembly language stored here
    *
           AORG >2022
     
    A2022  DATA >0000                  err code/sub addr
    A2024  DATA >A000                  fsthi
    A2026  DATA >FFD7                  lsthi
    A2028  DATA A2676                  fstlow
    A202A  DATA A3F38                  lstlow
    A202C  DATA >0000                  checksum
    A202E  DATA >0000                  pab status ptr
    A2030  DATA >0000                  xml r11 buffer
    A2032  DATA >0000                  cru base for dsr
    A2034  DATA >0000                  dsr address   "
    A2036  DATA >0000                  name size     "
    A2038  DATA >0000                  e o name ptr  "
    A203A  DATA >0000                  counts        "
    A203C  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
           DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
           DATA 0,0,0,0,0,0,0,0        record buffer
    A208C  DATA 0,0,0,0                dsr name buffer
    A2094  DATA 0,0,0                  workspaces
    A209A  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
    A20BA  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
    A20DA  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
    A20FA  DATA 100                    constants
    A20FC  DATA >2000
    A20FE  TEXT '.'
    A20FF  BYTE >AA
    *
    A2100  DATA A2094,A21C4            gpllnk wp,pc
    A2104  DATA A2094,A2196            xmllnk
    A2108  DATA A2094,A21DE            kscan
    A210C  DATA A2094,A21F4            vsbw
    A2110  DATA A2094,A2200            vmbw
    A2114  DATA A2094,A220E            vsbr
    A2118  DATA A2094,A221A            vmbr
    A211C  DATA A2094,A2228            vwtr
    A2120  DATA A209A,A22B2            dsrlnk wp,pc
    A2124  DATA A20DA,A23BA            loader wp,pc
    *PA
    A2128  MOV  11,@A2030              run program xml 21
           MOVB @>8349,1               -----------
           COC  @A20FC,1               gpllnk flag
           JEQ  A218A                  return to prog
           MOV  @>8350,0
           JEQ  A215E                  same name
           BL   @A2646                 check if undef
           JMP  A217E                  error >0D
    A2142  CI   1,A3F38                last = predefined
           JEQ  A217A
           MOV  1,0                    label list
           LI   2,>834A                label to be run
           C    *0+,*2+
           JNE  A2174                  compare names
           C    *0+,*2+
           JNE  A2174
           C    *0+,*2+
           JNE  A2174
           MOV  *0,@A2022              save value
    A215E  LWPI A20BA
           MOV  @A2022,0               get address
           JEQ  A217A
           BL   *0                     link to sub
           LWPI >83E0
           MOV  @A2030,11              restore r11
           B    *11                    to xml end
    A2174  AI   1,>0008
           JMP  A2142                  next label
    A217A  LI   0,>0F00                not found
    A217E  MOVB 0,@>8322               err code >0F
           LWPI >83E0
           B    @>00CE                 to gpl, bit set
    A218A  SZCB @A20FC,@>8349          clear flag
           LWPI A2094                  to gpllnk call
           RTWP
    *                                  xmllnk
    A2196  MOV  *14+,@>83E2            ======
           LWPI >83E0
           MOV  11,@A2094+22           save r11
           MOV  1,2                    xml code
           CI   1,>8000
           JH   A21B8                  direct address
           SRL  1,12                   from tables
           SLA  1,1
           SLA  2,4
           SRL  2,11
           A    @>0CFA(1),2
           MOV  *2,2
    A21B8  BL   *2                     execute
           LWPI A2094
           MOV  11,@>83F6              restore gpl r11
           RTWP
    *                                  gpllnk
    A21C4  MOVB @>8373,1               ======
           SRL  1,8
           MOV  *14+,@>8304(1)         addr on stack
           SOCB @A20FC,@>8349          >20 flag
           LWPI >83E0                  to xml end
           MOV  @A2030,11              (load and run)
           B    *11
    *                                  kscan
    A21DE  LWPI >83E0                  =====
           MOV  11,@A2094+22           save to old r11
           BL   @>000E
           LWPI A2094
           MOV  11,@>83F6              restore gpl r11
           RTWP
    *PA
    *                                  vsbw
    A21F4  BL   @A223A                 ====
           MOVB @>0002(13),@>8C00
           RTWP
    *                                  vmbw
    A2200  BL   @A223A                 ====
    A2204  MOVB *1+,@>8C00
           DEC  2
           JNE  A2204                  loop
           RTWP
    *                                  vsbr
    A220E  BL   @A2240                 ====
           MOVB @>8800,@>0002(13)
           RTWP
    *                                  vmbr
    A221A  BL   @A2240                 ====
    A221E  MOVB @>8800,*1+
           DEC  2
           JNE  A221E                  loop
           RTWP
    *                                  vwtr
    A2228  MOV  *13,1                  ====
           MOVB @>0001(13),@>8C02
           ORI  1,>8000
           MOVB 1,@>8C02
           RTWP
    *
    A223A  LI   1,>4000                vdp write
           JMP  A2242                  ---------
    A2240  CLR  1                      vdp read
    A2242  MOV  *13,2                  --------
           MOVB @A2094+5,@>8C02
           SOC  1,2
           MOVB 2,@>8C02
           MOV  @>0002(13),1           fetch old r1,r2
           MOV  @>0004(13),2
           B    *11
    *                                  int to real xml 23
    A225A  LI   4,>834A                -----------
           MOV  *4,0                   int
           MOV  4,6
           CLR  *6+                    clear space
           CLR  *6+
           MOV  0,5
           JEQ  A22B0                  =0
           ABS  0
           LI   3,>0040                exponent
           CLR  *6+
           CLR  *6
           CI   0,100
           JL   A22A0                  < 100
           CI   0,10000
           JL   A2290                  < 10000
           INC  3                      exp+1 *100
           MOV  0,1
           CLR  0
           DIV  @A20FA,0               div by 100
           MOVB @>83E3,@>0003(4)        remainder
    A2290  INC  3                      exp+1 *100
           MOV  0,1
           CLR  0
           DIV  @A20FA,0               div by 100
           MOVB @>83E3,@>0002(4)       remainder
    A22A0  MOVB @>83E1,@>0001(4)       result
           MOVB @>83E7,*4              exponent
           INV  5
           JLT  A22B0                  positive
           NEG  *4                     negative
    A22B0  B    *11
    *PA
    *                                  dsrlnk wp A209A
    A22B2  MOV  *14+,5                 ======
           SZCB @A20FC,15              >20 eq=0
           MOV  @>8356,0
           MOV  0,9
           AI   9,-8                   pab status
           BLWP @A2114                 vsbr: read size
           MOVB 1,3
           SRL  3,8
           SETO 4
           LI   2,A208C                name buffer
    A22D0  INC  0
           INC  4
           C    4,3
           JEQ  A22E4                  full size
           BLWP @A2114                 vsbr
           MOVB 1,*2+                  copy 1 char
           CB   1,@A20FE               is it .
           JNE  A22D0
    A22E4  MOV  4,4
           JEQ  A238C                  size=0
           CI   4,>0007
           JGT  A238C                  size>7
           CLR  @>83D0
           MOV  4,@>8354
           MOV  4,@A2036               save size
           INC  4
           A    4,@>8356
           MOV  @>8356,@A2038          e o name ptr
           LWPI >83E0                  call dsr
           CLR  1
           LI   12,>0F00
    A2310  MOV  12,12
           JEQ  A2316
           SBZ  0                      card off
    A2316  AI   12,>0100
           CLR  @>83D0
           CI   12,>2000
           JEQ  A2388                  last
           MOV  12,@>83D0              save cru base
           SBO  0                      card on
           LI   2,>4000
           CB   *2,@A20FF              >AA = header
           JNE  A2310                  no: next card
           A    @A209A+10,2            old r5: offset
           JMP  A2340
    A233A  MOV  @>83D2,2               next sub
           SBO  0                      card on
    A2340  MOV  *2,2                   link to next
           JEQ  A2310                  last: next card
           MOV  2,@>83D2               save link
           INCT 2
           MOV  *2+,9                  save address
           MOVB @>8355,5
           JEQ  A2364                  size=0
           CB   5,*2+
           JNE  A233A                  diff size: next
           SRL  5,8
           LI   6,A208C                name buffer
    A235C  CB   *6+,*2+                check name
           JNE  A233A                  diff name: next
           DEC  5
           JNE  A235C                  ok: next char
    A2364  INC  1                      same name
           MOV  1,@A203A               save # of calls
           MOV  9,@A2034               save address
           MOV  12,@A2032              save cru base
           BL   *9                     link
           JMP  A233A                  skip or next
    *PA
           SBZ  0                      card off
           LWPI A209A
           MOV  9,0
           BLWP @A2114                 read pab status
           SRL  1,13
           JNE  A238E                  err
           RTWP
    A2388  LWPI A209A                  errors
    A238C  CLR  1                      code 0
    A238E  SWPB 1
           MOVB 1,*13                  code in r0
           SOCB @A20FC,15              eq=1
           RTWP
    *PA
    *                                  gpl load xml 22
    A2398  MOV  11,@A2030              --------
           LWPI A20BA
           BLWP @A2124                 call loader
           LWPI >83E0
           JEQ  A23B0                  error
           MOV  @A2030,11              restore r11
           B    *11                    to xml end
    A23B0  MOVB @A20BA,@>8322           err code
           B    @>00CE                 to gpl, bit set
    *
    *                                  loader wp A20DA
    A23BA  CLR  @A2022                 ======
           SZCB @A20FC,15              clear eq + err code
           MOV  @>8356,0
           BLWP @A2120                 dsrlnk
           DATA >0008                  code for dsr
           JEQ  A2432                  err
           AI   0,-9
           LI   1,>0200
           BLWP @A210C                 set read opcode
           INC  0
           MOV  0,@A202E               save status addr
           MOV  @A2024,7               fsthi
           MOV  7,5
           CLR  12                     no comp flag
           BL   @A25E0                 input a record
           CI   3,>0001
           JNE  A243A                  to case table
           INC  12                     compressed flag
           CLR  3
           JMP  A243E                  to case table
    *
    A23F8  CI   3,>0046       |J|      special tag
           JNE  A243A                  value -> tag
    A23FE  CLR  2             |F|      next record
    A2400  BL   @A262E        |8|      next char
           CI   3,>003A
           JNE  A23F8                  not : => loop
           MOV  @A202E,0      |:|      end
           DEC  0
           LI   1,>0100                opcode = close
           BLWP @A210C                 vsbw
           BL   @A25E0                 call dsr
           MOV  @A2022,0
           JEQ  A2430
           BL   @A2646                 all defined?
           JMP  A2432                  no:  error >0D
           MOV  14,@>0016(13)          old pc > r11
           MOV  @A2022,14              new return address
    A2430  RTWP
    A2432  MOVB 0,*13                  r0
           SOCB @A20FC,15              eq=1
           RTWP
    *                                  case table
    A243A  BL   @A25C2                 ----------
    A243E  CLR  4                      convert char^
           MOVB @A2662(3),4            offset
           SRL  4,7
           MOV  8,@A202C               save checksum
           BL   @A2594                 put value in r0
           B    @A23F8(4)              to char routine
    *PA
    A2452  INC  0             |0|      new module
           ANDI 0,>FFFE                even
           MOV  @A2024,4               fsthi
           A    0,4
           JOC  A2470                  too big: in low
           C    4,@A2026               lsthi
    A2464  JH   A2470                  too big: in low
           MOV  @A2024,5               save old
           MOV  4,@A2024               new fsthi
           JMP  A2484
    A2470  MOV  @A2028,4               fstlo
           A    0,4
           C    4,@A202A               lstlo
           JHE  A2494                  too big
           MOV  @A2028,5               save old
           MOV  4,@A2028               new fstlo
    A2484  MOV  5,7                    new pointer
    A2486  LI   9,>0008       |I|      segment id
    A248A  BL   @A262E                 skip name (8 chars)
           DEC  9
           JNE  A248A
           JMP  A2400
    A2494  LI   0,>0800                mem overflow
           JMP  A2432
    *
    A249A  A    5,0           |2|      auto start
    A249C  MOV  0,@A2022      |1|      save address
           JMP  A2400
    *
    A24A2  A    0,@A202C      |7|      test checksum
           JEQ  A2400
           LI   0,>0B00                checksum err
           JMP  A2432
    *
    A24AE  A    5,0           |A|      rel new ptr
    A24B0  MOV  0,7           |9|      abs new ptr
           JMP  A2400
    *
    A24B4  A    5,0           |C|      rel data
    A24B6  MOVB 0,*7+         |B|      abs data
           MOVB @A20DA+1,*7+           r0 byte 2
           JMP  A2400
    *
    A24BE  A    5,0           |3|      rel ref
    A24C0  BL   @A2566        |4|      abs ref
           MOV  0,0                    make new label
           JEQ  A24F4                  no ref list
    A24C8  AI   6,-8                   fisrt label
           C    6,4
           JH   A24D4                  last ?
           NEG  *4                     undef
    A24D2  JMP  A2400
    A24D4  C    *4,*6                  compare name
           JNE  A24C8                  diff: next
           C    @>0002(4),@>0002(6)
           JNE  A24C8
           C    @>0004(4),@>0004(6)
           JNE  A24C8
           MOV  @>0006(6),3            same: get value
    A24EC  MOV  *0,9                   get list link
           MOV  3,*0                   place value
           MOV  9,0                    next occurence
           JNE  A24EC
    A24F4  AI   4,>0008
           MOV  4,@A202A               del new copy
           JMP  A24D2
    *PA
    A24FE  A    5,0           |5|      rel def
    A2500  BL   @A2566        |6|      abs def
    A2504  AI   6,-8                   make new label
    A2508  C    6,4
           JEQ  A24D2                  last: continue
           MOV  *6,10                  get name
           JGT  A2512                  defined
           NEG  10                     undefined
    A2512  C    *4,10                  compare names
           JNE  A2504                  diff: next
           C    @>0002(4),@>0002(6)
           JNE  A2504
           C    @>0004(4),@>0004(6)
           JNE  A2504
           MOV  *6,10                  same
           JGT  A2556                  defined: err
           MOV  @>0006(6),3            undef: get link
    A252E  MOV  *3,9                   get old link
           MOV  0,*3                   place value
           MOV  9,3                    next occurence
           JNE  A252E
           MOV  6,9                    del old label
           S    4,9                    size to last
           MOV  6,10
           AI   10,>0008               next
           MOV  6,3                    current
    A2542  DECT 3
           DECT 10
           MOV  *3,*10                 copy next on current
           DECT 9
           JNE  A2542
           AI   4,>0008
           MOV  4,@A202A               update lstlo
           JMP  A2508                  to next ref
    *
    A2556  MOV  4,@>0002(13)           name ptr in r1
           LI   0,>0C00                duplicate def
           B    @A2432                 rtwp with err
    A2562  B    @A2494
    *                                  make new label
    A2566  MOV  11,10                  --------------
           LI   9,>0006                value in r0
           MOV  @A202A,6               lstlo
           AI   6,-8
           MOV  6,4                    new address
           C    6,@A2028               check fstlo
           JL   A2562                  mem overflow
           MOV  6,@A202A               new lstlo
    A2580  BL   @A262E                 read 1 byte
           MOVB @A20DA+7,*6+
           DEC  9
           JNE  A2580                  copy name
           MOV  0,*6                   copy address
           LI   6,A4000
           B    *10
    *PA
    *                                  read number
    A2594  MOV  11,10                  -----------
           CLR  0                      returned in r0
           MOV  12,12
           JEQ  A25AC
           BL   @A262E                 read 1 byte
           MOVB @A20DA+7,0             in r0 byte 1
           BL   @A262E                 one more
           A    3,0                    in r0 byte 2
           B    *10
    A25AC  LI   9,>0004                not compressed
    A25B0  BL   @A262E                 read 1 byte
           BL   @A25C2                 convert char
           SLA  0,4
           A    3,0                    in r0 nibble 4
           DEC  9
           JNE  A25B0                  4 times
           B    *10
    *                                  byte to tag
    A25C2  AI   3,>FFD0                -----------
           CI   3,>000A                returned in r3
           JL   A25D6                  0-9
           AI   3,-7                   A-O
           CI   3,>0019
           JH   A25D8                  after O: illegal
    A25D6  B    *11
    A25D8  LI   0,>0A00      |DEGH|    illegal tag
           B    @A2432
    *                                  input a record
    A25E0  LWPI >83E0                  --------------
           LI   0,A2032                saved by dsrlnk
           MOV  *0+,12                 cru base
           MOV  *0+,9                  prog address
           MOV  *0+,@>8354             name size
           MOV  *0+,@>8356             e o name ptr
           MOV  *0,1                   # of calls
           SBO  0                      card on
           CB   @>4000,@A20FF
           JNE  A263A                  no header
           BL   *9                     link
           JMP  A263A                  err (skipped)
           SBZ  0                      card off
           LWPI A20DA
           MOV  @A202E,0               pab status
           LI   1,A20DA+1              r0 2nd byte
           LI   2,>0004
           BLWP @A2118                 vmbr
           SB   0,0
           SRL  0,5
           JNE  A2640                  error flagged
           SRL  2,8                    rec len
           MOV  1,0                    data buffer
           LI   1,A203C                record buffer
           BLWP @A2118                 vmbr
           CLR  8                      read 1 byte
    A262E  DEC  2                      -----------
    A2630  JLT  A25E0                  next record
           MOVB *1+,3
           SRL  3,8                    returned in r3
           A    3,8                    checksum
           B    *11
    A263A  LWPI A20DA                  io error 0
           CLR  0
    A2640  SWPB 0
           B    @A2432
    *PA
    *                                  check if undef
    A2646  LI   1,A3F38+8              --------------
    A264A  AI   1,-8
           MOV  *1,0
           JLT  A265C                  undefined
           C    @A202A,1
           JNE  A264A                  not lstlo: loop
           INCT 11                     ok: skip
           B    *11
    A265C  LI   0,>0D00                unresolved ref
           B    *11
    *                   tag    -    jump table
    A2662  BYTE >2D      0             A2452
           BYTE >52      1             A249C
           BYTE >51      2             A249A
           BYTE >63      3             A24BE
           BYTE >64      4             A24C0
           BYTE >83      5             A24FE
           BYTE >84      6             A2500
           BYTE >55      7             A24A2
           BYTE >04      8             A2400
           BYTE >5C      9             A24B0
           BYTE >5B      A             A24AE
           BYTE >5F      B             A24B6
           BYTE >5E      C             A24B4
           BYTE >F0      D             A25D8
           BYTE >F0      E             A25D8
           BYTE >03      F             A23FE
           BYTE >F0      G             A25D8
           BYTE >F0      H             A25D8
           BYTE >47      I             A2486
           BYTE >00      J             A23F8
    A2676  BSS  6        K-P            ?   not loaded
    *
    *---------------------------------------------------------
    *PA
    *      GPL
    *G7664 DATA >00C8,>3F38            size, address where to load
    *      ML99                        assembly language stored here
     
           AORG >3F38                  def table
    *                                  ---------
    A3F38  TEXT 'UTLTAB'
           DATA A2022
           TEXT 'PAD   '
           DATA >8300
           TEXT 'GPLWS '
           DATA >83E0
           TEXT 'SOUND '
           DATA >8400
           TEXT 'VDPRD '
           DATA >8800
           TEXT 'VDPSTA'
           DATA >8802
           TEXT 'VDPWD '
           DATA >8C00
           TEXT 'VDPWA '
           DATA >8C02
           TEXT 'SPCHRD'
           DATA >9000
           TEXT 'SPCHWT'
           DATA >9400
           TEXT 'GRMRD '
           DATA >9800
           TEXT 'GRMRA '
           DATA >9802
           TEXT 'GRMWD '
           DATA >9C00
           TEXT 'GRMWA '
           DATA >9C02
           TEXT 'SCAN  '
           DATA >000E
           TEXT 'XMLLNK'
           DATA A2104
           TEXT 'KSCAN '
           DATA A2108
           TEXT 'VSBW  '
           DATA A210C
           TEXT 'VMBW  '
           DATA A2110
           TEXT 'VSBR  '
           DATA A2114
           TEXT 'VMBR  '
           DATA A2118
           TEXT 'VWTR  '
           DATA A211C
           TEXT 'DSRLNK'
           DATA A2120
           TEXT 'LOADER'
           DATA A2124
           TEXT 'GPLLNK'
           DATA A2100
    A4000  BYTE 0                      e o cpu mem
    *                                  e o grom >7730
           END
    

     

      
  4. From Tim (@InsaneMultitasker), a collaboration with @Tursi@acadiel and others, I think:
    Spoiler
    
    **********************
    
    VDPWA  EQU  >8C02
    VDWWD  EQU  >8C00
    VDPRD  EQU  >8800
    STATUS EQU  >837C
    DSRLNK DATA DREGS,DSR1
    HEX20  BYTE ' '
    HEXAA  BYTE >AA
    PERIOD BYTE '.'
           EVEN
    SAVE1  DATA >0000
    SAVE2  DATA >0000
    SAVE3  DATA >0000
    SAVE4  DATA >0000
    SAVE5  DATA >0000
    NAMBUF BSS  6      'SINCE WE KNOW WERE USING "DSKn."
    *
    H2000  DATA  >2000
    CYC1   DATA  0
    H1300  DATA  >1300
    
    DSR1   MOV   *R14+,R5
           SZCB  @HEX20,R15
           MOV   @>8356,R0
           MOV   R0,R9
           AI    R9,>FFF8
           SWPB  R0
           MOVB  R0,@VDPWA
           SWPB  R0
           MOVB  R0,@VDPWA
           NOP
           MOVB  @VDPRD,R1
           MOVB  R1,R3
           SRL   R3,>8
           SETO  R4
           LI    R2,NAMBUF
    DLOOP1 INC   R0
           INC   R4
           C     R4,R3
           JEQ   DJUMP1
           SWPB  R0
           MOVB  R0,@VDPWA
           SWPB  R0
           MOVB  R0,@VDPWA
           NOP
           MOVB  @VDPRD,R1
           MOVB  R1,*R2+
           CB    R1,@PERIOD
           JNE   DLOOP1
    DJUMP1 MOV   R4,R4
           JEQ   DJUMP6
           CI    R4,>0007
           JGT   DJUMP6
           CLR   @>83D0
           MOV   R4,@>8354
           MOV   R4,@SAVE3
           INC   R4
           A     R4,@>8356
           MOV   @>8356,@SAVE4
    SROM   LWPI  >83E0
           CLR   R1
           MOV   @H2000,@CYC1
           LI    R12,>1100
           JMP   DLOOP2
    SROM1  LI    R12,>0F00
           MOV   @H1300,@CYC1
    
    DLOOP2 MOV   R12,R12
           JEQ   DJUMP2
           SBZ   >00
    DJUMP2 AI    R12,>0100
           CLR   @>83D0
           CI    R12,>2000
           JEQ   SROM1
           C     R12,@CYC1
           JEQ   DJUMP5
           MOV   R12,@>83D0
           SBO   >00
           LI    R2,>4000
           CB    *R2,@HEXAA
           JNE   DLOOP2
           A     @5*2+DREGS,R2
           JMP   DJUMP3
    DLOOP3 MOV   @>83D2,R2
           SBO   >00
    DJUMP3 MOV   *R2,R2
           JEQ   DLOOP2
           MOV   R2,@>83D2
           INCT  R2
           MOV   *R2+,R9
           MOVB  @>8355,R5
           JEQ   DJUMP4
           CB    R5,*R2+
           JNE   DLOOP3
           SRL   R5,>8
           LI    R6,NAMBUF
    DLOOP4 CB    *R6+,*R2+
           JNE   DLOOP3
           DEC   R5
           JNE   DLOOP4
    DJUMP4 INC   R1
           MOV   R1,@SAVE5
           MOV   R9,@SAVE2
           MOV   R12,@SAVE1
           BL    *R9
           JMP   DLOOP3
           SBZ   >00
           LWPI  DREGS
           MOV   R9,R0
           SWPB  R0
           MOVB  R0,@VDPWA
           SWPB  R0
           MOVB  R0,@VDPWA
           NOP
           MOVB  @VDPRD,R1
           SRL   R1,>D
           JNE   DJUMP7
           RTWP
    DJUMP5 LWPI  DREGS
    DJUMP6 CLR   R1
    DJUMP7 SWPB  R1
           MOVB  R1,*R13
           SOCB  @HEX20,R15
           RTWP
    

     

     

  5. fbForth 2.0, using MG-->GPL (GROM0)-->ROM0: 
    Spoiler
    
    *     ___  _______  __   _  ____ __           __  ________
    *    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
    *   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
    *  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
    * 
    *-----------------------------------------------------------------------*
    ;[*== 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
    ;]*
    
    ;===========================================================================
    ;===========================================================================
    ; *** GPL Code from GROM0 per Heiner Martin ********************************
    ;===========================================================================
    ;===========================================================================
    GPL DSRLNK:
    03D9 : FETC @>836D            Fetch data
    03DB : CLR  @>8354
    03DD : ST   @>8355,VDP*>8356  Fetch length byte name
    03E1 : CLR  @>8358
    03E3 : DST  @>8352,@>8356
    03E6 : DINC @>8352
    03E8 : CEQ  @>8358,@>8355     Length = length of name?
    03EB : BS   GROM@>03F7
    03ED : CEQ  VDP*>8352,>2E     Point?
    03F1 : BS   GROM@>03F7        Yes, go on
    03F3 : INC  @>8358            Length DSR name+1
    03F5 : BR   GROM@>03E6        Go on
    03F7 : CZ   @>8358            Length 0?
    03F9 : BS   GROM@>0435        Yes, end with condition bit
    03FB : ST   @>8355,@>8358     Length on >8355
    03FE : CGE  @>8355,>08        Longer than 8?
    0401 : BS   GROM@>0435        Yes, end with set condition bit
    0403 : CLR  @>8354
    0405 : DCLR @>83D0            Clear GROM search pointer
    0408 : DINC @>8356            Beginning of name
    040A : MOVE @>8354 TO @>834A FROM VDP*>8356     Fetch name on FAC
    040F : DADD @>8356,@>8354     Left pointing!
    0412 : XML  >19               Execute with following RTN (if found) otherwise
                                  go on with GSRLNK
    GSRLNK:
    0414 : INCT @>8373            GROM read data on substack
    0416 : DST  *>8373,@>83FA
    041B : XML  >1A               GSRLNK
    041D : BR   GROM@>0429
    041F : INCT @>8373
    0421 : DST  *>8373,*>8372     Data stack on substack
    0426 : DECT @>8372
    0428 : RTN
    0429 : DCZ  @>83D0            GROM search pointer 0?
    042C : BR   GROM@>041B
    042E : DST  @>83FA,*>8373     GROM read address from substack
    0433 : DECT @>8373
    0435 : CEQ  @>8300,@>8300
    0438 : RTNC                   Return condition bit is set
    0439 : DECT @>8373
    043B : DST  @>83FA,*>8373     Fetch R13 GPLWS from substack
    0440 : DECT @>8373
    0442 : RTN                    Return
    
    ;===========================================================================
    ;===========================================================================
    ; *** Assembly Code from ROM0 **********************************************
    ;===========================================================================
    ;===========================================================================
    * ------ SEARCH ROM FOR DSR OR LINK -------
    * SEARCH FOR PERIPHERALS, MEM ADR 4000 TO 5FFF.
    * ENABLE BY CRU ADR 1000 TO 1F00
    * = BR TABLE
    SROM   CLR  R1               VERSION FOUND OF DSR ETC
           MOV  @CRULST,R12      SEARCH ROM FOR ROUTINE
           JNE  SGO              IF <> 0, CONTINUE SEARCH
           LI   R12,>0F00        START OVER AGAIN
    NOROM  MOV  R12,R12
           JEQ  NOOFF
           SBZ  0
    NOOFF  AI   R12,>0100        NEXT ROM'S TURN ON
           CLR  @CRULST          CLR IN CASE WE'RE FINISHED
           CI   R12,>2000        AT THE END (1F00 IS LAST PERIPH)
           JEQ  NOSET            NO MORE PERIPHS TO TURN ON
           MOV  R12,@CRULST      SAVE ADR. OF NEXT CRU
           SBO  0                TURN ON PERIPH
           LI   R2,>4000         START AT BEGINING (PERIPH ADR)
           CB   *R2,@HX30AA+1    IS IT A VALID ROM?
           JNE  NOROM            NO
           AB   @TYPE,@R2LSB
           JMP  SGO2
    SGO    MOV  @SADDR,R2        CONTINUE WHERE WE LEFT OFF
           SBO  0                TURN PERIPH BACK ON
    SGO2   MOV  *R2,R2           IS ADR. ZERO?
           JEQ  NOROM            YES, NO PROG. TO LOOK AT
           MOV  R2,@SADDR        REMEMBER WHERE TO GO NEXT
           INCT R2               GO TO ENTRY POINT
           MOV  *R2+,R9          GET ENTRY ADR
           BL   @NAME            SEE IF NAME MATCHES
           JMP  SGO              NO MATCH, TRY NEXT PROGG
           INC  R1               NEXT VERSION FOUND
           BL   *R9              MATCH, CALL SUBROUTINE
           JMP  SGO              NOT RIGHT VERSION
    * = BR TABLE
    CB16   SBZ  0
           JMP  NOGR2
    NOGR1  CLR  *R8
    NOGR2  BL   @GETSTK
    NOSET  B    @RESET
    * ------ SEARCH GROM FOR DSR OR LINK ------
    * ENTRY = BR TABLE (FPT)
    SGROM  LI   R7,SADDR
           LI   R8,CRULST
           BL   @PUTSTK          SAVE GROM ADR
    SGROMA MOV  *R7,R1           START WHERE WE LEFT OFF
           MOV  *R8,R2           IS IT A RESTART?
           JNE  SGROM3           NO
           LI   R2,>9800         START OF GROMS
    SGROM1 LI   R1,>E000         START OF GROM
    SGROM3 CZC  @HX1FFF,R1       IS IT A NEW GROM OR CONTIUATION?
           JNE  SGROM2
           MOV  R2,*R8           SAVE GROM ADR
           MOVB R1,@GWAOFF(R2)   LOAD ADR
           MOVB @R1LSB,@GWAOFF(R2)
           AB   @TYPE,@R1LSB     LOOK FOR PGM ADR.
           MOVB R1,@SAVEG        SAVE GROM ADR. OF HEADER
           CB   *R2,@HX30AA+1    VALID GROM?
           JNE  NOGR             NO GROM HERE
    HX81   EQU  $+1
    SGROM2 MOVB R1,@GWAOFF(R2)   LOOK FOR PGM
           MOVB @R1LSB,@GWAOFF(R2)
           SLA  R10,4            STALL
           MOVB *R2,R3           READ PGM ADR
           NOP
           MOVB *R2,@R3LSB
           MOV  R3,*R7           GET NEXT HEADER'S ADR
           JEQ  NOGR             IF ZERO, GO TO NEXT PGM
           INCT R3               GO TO PGM ENTRY ADR
           MOVB R3,@GWAOFF(R2)   GO TO PGM ENTRY ADR
           MOVB @R3LSB,@GWAOFF(R2)
           NOP
           MOVB *R2,R9           ENTRY ADR
           SLA  R10,4            STALL
           MOVB *R2,@R9LSB
           BL   @NAME            SEE IF NAME MATCHES
           JMP  SGROMA           NO, LOOK FOR NEXT PGM
           AB   @C030,@STKDAT    FOUND NAME SO PUSH IT
           AB   R14,@TEMP2       INCREASE PGM COUNT
           MOVB @STKDAT,R4
           SRL  R4,8
           DECT R3               POINT BACK TO START OF HEADER
           CB   @TYPE,@HX06      IS IT A USER PGM LOOKUP?
           JNE  SGROM4           YES
           MOV  R3,R9            PUSH HEADER ADR. FOR USER PGM
    SGROM4 MOVB R9,@PAD(R4)      NO, PUSH ENTRY ADR
           MOVB @R9LSB,@PAD+1(R4)
           MOV  R2,R13           GO TO THAT LIBRARY
           BL   @GETSTK          RESTORE GROM ADR
           B    @SET             SET STATUS AND RETURN
    NOGR   CLR  R1               GET ADR OF GROM HEADER
           MOVB @SAVEG,R1
           AI   R1,->2000        NEXT GROM DOWN
           MOV  R1,*R7           SAVE ADR OF WHERE WE'RE AT
           CI   R1,>E000         FINISHED?
           JNE  SGROM3           NO, CHECK THIS GROM
           C    *R2+,*R2+        INC GROM MAPPED ADR BY 4
           MOV  R2,*R8           SAVE THE NEW MAP ADR
           CI   R2,GR+>40        AT END OF LIBRAY
           JEQ  NOGR1            YES
           MOVB @SCLEN,R5        ARE WE LOOKING FOR A MENU?
           JNE  SGROM1           YES SO DO ONLY ONE SLOT
           JMP  NOGR2            NO, CONTINUE SEARCH
    * = BL, CALLED WITH 2 RETURNS
    NAME   MOVB @SCLEN,R5        GET LENGTH AS COUNTER
           JEQ  NAME2A           ZERO LENGTH, DON'T DO MATCH
           CB   R5,*R2           DOES LENGTH MATCH?
           JNE  NAME3            NO
           SRL  R5,8             MOVE TO RIGHT PLACE
           LI   R6,FAC
    NAME1  CI   R2,GR            IS IT GROM?
           JHE  NAME2            YES, DON'T INC ADR.
           INC  R2
    NAME2  CB   *R6+,*R2         IS NAME THE SAME?
           JNE  NAME3            NO
    HX06   DEC  R5               MORE TO LOOK AT? REF IS NASTY
           JNE  NAME1            YES
    NAME2A INCT R11              RETURN, NAME FOUND
    NAME3  RT
    
    

     

     

...lee

  • Like 2
Link to comment
Share on other sites

Howdy.  #4 was simply an 'ultra' standard example I shared that didn't require REFerences to VDP utilities and thus was 'standalone' (looks as if the source is missing one or two pieces of info, such as the workspace BSS).  

 

I was not responsible for the collaborative version you mentioned though I was a participant at the time.   IIRC, it started with a copy of Paolo's DSRLNK routine and was augmented to account for various updates including a level 2 error return modification; it might be included with the CPU scratchpad loader...?

  • Like 1
  • Thanks 1
Link to comment
Share on other sites

On 9/18/2020 at 10:30 PM, Lee Stewart said:

OK, here we go. Here are the different versions of DSRLNK that I can find:

  1. TI Forth:
      Reveal hidden contents
    
    
    ** vvvvvvvvvvvv UTILEQU vvvvv below vvvvvvvvvvvvvvvvvvvvvvvv
    **
    SCNKEY EQU  >000E
    ; XMLTAB EQU  >0CFA        XML TABLES (BASE)
    FLAG2  EQU  >8349
    SCLEN  EQU  >8355
    SCNAME EQU  >8356
    SUBSTK EQU  >8373
    CRULST EQU  >83D0
    SADDR  EQU  >83D2
    GPLWS  EQU  >83E0        GPL/EXTENDED BASIC WORKSPACE
    SCRPAD EQU  >8300
    VDPRD  EQU  >8800        VDP read data address
    VDPWD  EQU  >8C00        VDP write data address
    VDPWA  EQU  >8C02        VDP write address address
    R0LB   EQU  >83E1
    R1LB   EQU  >83E3
    R3LB   EQU  >83E7
    **
    ** ^^^^^^^^^^^^ UTILEQU ^^^^^ above ^^^^^^^^^^^^^^^^^^^^^^^^
    **
    H20    EVEN
    H2000  DATA >2000
    DECMAL TEXT '.'
    HAA    BYTE >AA
           EVEN
    *
    * Utility Vectors
    *
    GPLLNK DATA UTILWS,GLENTR     Link to GROM routines
    XMLLNK DATA UTILWS,XMLENT     Link to ROM routines
    KSCAN  DATA UTILWS,KSENTR     Keyboard scan
    VSBW   DATA UTILWS,VSBWEN     VDP single byte write
    VMBW   DATA UTILWS,VMBWEN     VDP multiple byte write
    VSBR   DATA UTILWS,VSBREN     VDP single byte read
    VMBR   DATA UTILWS,VMBREN     VDP multiple byte read
    VWTR   DATA UTILWS,VWTREN     VDP write to register
    DSRLNK DATA DLNKWS,DLENTR     Link to device service routine
    *
    *
    *===========================================================
    *** Link to device service routine *************************
    *===========================================================
    *
    DLENTR MOV  *R14+,R5          Fetch program type for link
           SZCB @H20,R15          Reset equal bit
           MOV  @SCNAME,R0        Fetch pointer into PAB
           MOV  R0,R9             Save pointer
           AI   R9,-8             Adjust pointer to flag byte
           BLWP @VSBR             Read device name length
           MOVB R1,R3             Store it elsewhere
           SRL  R3,8              Make it a word value
           SETO R4                Initialize a counter
           LI   R2,NAMBUF         Point to NAMBUF
    LNK$LP INC  R0                Point to next char of name
           INC  R4                Increment character counter
           C    R4,R3             End of name?
           JEQ  LNK$LN            Yes
           BLWP @VSBR             Read current character
           MOVB R1,*R2+           Move it to NAMBUF
           CB   R1,@DECMAL        Is it a decimal point?
           JNE  LNK$LP            No
    LNK$LN MOV  R4,R4             Is name length zero?
           JEQ  LNKERR            Yes, error
           CI   R4,7              Is name length > 7?
           JGT  LNKERR            Yes, error
           CLR  @CRULST
           MOV  R4,@SCLEN-1       Store name length for search
           MOV  R4,@SAVLEN        Save device name length
           INC  R4                Adjust it
           A    R4,@SCNAME        Point to position after name
           MOV  @SCNAME,@SAVPAB   Save pointer into device name
    *
    *** Search ROM CROM GROM for DSR
    *
    SROM   LWPI GPLWS             Use GPL workspace to search
           CLR  R1                Version found of DSR etc.
           LI   R12,>0F00         Start over again
    NOROM  MOV  R12,R12           Anything to turn off
           JEQ  NOOFF             No
           SBZ  0                 Yes, turn it off
    NOOFF  AI   R12,>0100         Next ROM'S turn on
           CLR  @CRULST           Clear in case we're finished
           CI   R12,>2000         At the end
           JEQ  NODSR             No more ROMs to turn on
           MOV  R12,@CRULST       Save address of next CRU
           SBO  0                 Turn on ROM
           LI   R2,>4000          Start at beginning
           CB   *R2,@HAA          Is it a valid ROM?
           JNE  NOROM             No
           A    @TYPE$,R2          Go to first pointer
           JMP SGO2
    SGO    MOV  @SADDR,R2         Continue where we left off
           SBO  0                 Turn ROM back on
    SGO2   MOV  *R2,R2            Is address a zero
           JEQ  NOROM             Yes, no program to look at
           MOV  R2,@SADDR         Remember where we go next
           INCT R2                Go to entry point
           MOV  *R2+,R9           Get entry address
    *
    *** See if name matches
    *
           MOVB @SCLEN,R5         Get length as counter
           JEQ  NAME2             Zero length, don't do match
           CB   R5,*R2+           Does length match?
           JNE  SGO               No
           SRL  R5,8              Move to right place
           LI   R6,NAMBUF         Point to NAMBUF
    NAME1  CB   *R6+,*R2+         Is character correct?
           JNE  SGO               No
           DEC  R5                More to look at?
           JNE  NAME1             Yes
    NAME2  INC  R1                Next version found
           MOV  R1,@SAVVER        Save version number
           MOV  R9,@SAVENT        Save entry address
           MOV  R12,@SAVCRU       Save CRU address
           BL   *R9               Match, call subroutine
           JMP  SGO               Not right version
           SBZ  0                 Turn off ROM
           LWPI DLNKWS            Select DSRLNK workspace
           MOV  R9,R0             Point to flag byte in PAB
           BLWP @VSBR             Read flag byte
           SRL  R1,13             Just want the error flags
           JNE  IOERR             Error!
           RTWP
    *
    *** Error handling
    *
    NODSR  LWPI DLNKWS       Select DSRLNK workspace
    LNKERR CLR  R1           Clear the error flags
    IOERR  SWPB R1
           MOVB R1,*R13      Store error flags in calling R0
           SOCB @H20,R15     Indicate an error occured
           RTWP              Return to caller
    **
    ** ^^^^^^^^^^^^ UTILROM ^^^^^ above ^^^^^^^^^^^^^^^^^^^^^^^^
    **
    **       COPY "DSK2.UTILRAM"
    **
    ** vvvvvvvvvvvv UTILRAM vvvvv below vvvvvvvvvvvvvvvvvvvvvvvv
    **
    SVGPRT DATA 0            Save GPL return address
    SAVCRU DATA 0            CRU address of peripheral
    SAVENT DATA 0            Entry address of DSR
    SAVLEN DATA 0            Save device name length
    SAVPAB DATA 0            Ptr into device name in PAB
    SAVVER DATA 0            Version number of DSR
    NAMBUF DATA 0,0,0,0
    *
    *** General utility workspace registers (Overlaps next WS)
    UTILWS DATA 0,0
           BYTE 0
    R2LB   BYTE 0
    *
    *** DSR link routine workspace registers (Overlaps prev. WS)
    DLNKWS DATA 0,0,0,0,0
    TYPE$  DATA 0,0,0,0,0,0,0,0,0,0,0
    *
    ** ^^^^^^^^^^^^ UTILRAM ^^^^^ above ^^^^^^^^^^^^^^^^^^^^^^^^
    

     

     

  2. TurboForth 1.2:2:
      Reveal hidden contents
    
    
    ;==============================================================
    ;*** DSRLNK ***************************************************
    ;==============================================================
    ;[ dsr link routine - Written by Paolo Bagnaresi
    dsrlnk  data dsrlws                 ; dsrlnk workspace
            data dlentr                 ; entry point
    
    dlentr  li r0,>aa00
            movb r0,@haa                ; load haa
            mov *r14+,r5                ; get pgm type for link
            mov r5,@sav8a               ; save data following blwp @dsrlnk (8 or >a)
            szcb @h20,r15               ; reset equal bit
            mov @>8356,r0               ; get ptr to pab
            mov r0,r9                   ; save ptr
            mov r0,@flgptr              ; save again pointer to pab+1 for dsrlnk 
                                        ; data 8
            ai r9,>fff8                 ; adjust to flag
            bl @_vsbr                   ; read device name length
            movb r1,r3                  ; copy it
            srl r3,8                    ; make it lo byter
            seto r4                     ; init counter
            li r2,namsto                ; point to buffer
    lnkslp  inc r0                      ; point to next char of name
            inc r4                      ; incr char counter
            ci r4,>0007                 ; see if length more than 7 chars
            jgt lnkerr                  ; yes, error
            c r4,r3                     ; end of name?
            jeq lnksln                  ; yes
            bl @_vsbr                   ; read curr char
            movb r1,*r2+                ; move into buffer
            cb r1,@decmal               ; is it a period?
            jne lnkslp                  ; no
    lnksln  mov r4,r4                   ; see if 0 length
            jeq lnkerr                  ; yes, error
            clr @>83d0
            mov r4,@>8354               ; save name length for search
            mov r4,@savlen              ; save it here too
            inc r4                      ; adjust for period
            a r4,@>8356                 ; point to position after name
            mov @>8356,@savpab          ; save pointer to position after name
    srom    lwpi >83e0                  ; use gplws
            clr r1                      ; version found of dsr
            li r12,>0f00                ; init cru addr
    norom   mov r12,r12                 ; anything to turn off?
            jeq nooff                   ; no
            sbz 0                       ; yes, turn off
    nooff   ai r12,>0100                ; next rom to turn on
            clr @>83d0                  ; clear in case we are done
            ci r12,>2000                ; see if done
            jeq nodsr                   ; yes, no dsr match
            mov r12,@>83d0              ; save addr of next cru
            sbo 0                       ; turn on rom
            li r2,>4000                 ; start at beginning of rom
            cb *r2,@haa                 ; check for a valid rom
            jne norom                   ; no rom here
            a @dstype,r2                ; go to first pointer
            jmp sgo2
    sgo     mov @>83d2,r2               ; continue where we left off
            sbo 0                       ; turn rom back on
    sgo2    mov *r2,r2                  ; is addr a zero (end of link)
            jeq norom                   ; yes, no programs to check
            mov r2,@>83d2               ; remember where to go next
            inct r2                     ; go to entry point
            mov *r2+,r9                 ; get entry addr just in case
            movb @>8355,r5              ; get length as counter
            jeq namtwo                  ; if zero, do not check
            cb r5,*r2+                  ; see if length matches
            jne sgo                     ; no, try next
            srl r5,8                    ; yes, move to lo byte as counter
            li r6,namsto                ; point to buffer
    namone  cb *r6+,*r2+                ; compare buffer with rom
            jne sgo                     ; try next if no match
            dec r5                      ; loop til full length checked
            jne namone
    namtwo  inc r1                      ; next version found
            mov r1,@savver              ; save version
            mov r9,@savent              ; save entry addr
            mov r12,@savcru             ; save cru
            bl *r9                      ; go run routine
            jmp sgo                     ; error return
            sbz 0                       ; turn off rom if good return
            lwpi dsrlws                 ; restore workspace
            mov r9,r0                   ; point to flag in pab
    frmdsr  mov @sav8a,r1               ; get back data following blwp @dsrlnk
                                        ; (8 or >a)
            ci r1,8                     ; was it 8?
            jeq dsrdt8                  ; yes, jump: normal dsrlnk
            movb @>8350,r1              ; no, we have a data >a. get error byte from
                                        ; >8350
            jmp dsrdta                  ; go and return error byte to the caller
    dsrdt8  bl @_vsbr                   ; read flag
    dsrdta  srl r1,13                   ; just keep error bits
            jne ioerr                   ; handle error
            rtwp
    nodsr   lwpi dsrlws                 ; no dsr, restore workspace
    lnkerr  clr r1                      ; clear flag for error 0 = bad device name
    ioerr   swpb r1                     ; put error in hi byte
            movb r1,*r13                ; store error flags in callers r0
            socb @h20,r15               ; set equal bit to indicate error
            rtwp
    
    data8   data >8                     ; just to compare. 8 is the data that
                                        ; usually follows a blwp @dsrlnk
    decmal  text '.'                    ; for finding end of device name
            even
    h20     data >2000
    ;]
    

     

     

  3. Editor/Assembler cartridge (If you remove the ‘A’ in front of each label, you are left with the actual address in low RAM)
      Reveal hidden contents
    
    
    *=========================================================
    * Assembly routines loaded in low memory expansion
    * ----------------- but stored in GROM at addressES >7000-772F
    *
    *=========================================================
    *G7000 DATA >0008,>2000            size, address where to load
    *      ML99                        assembly language stored here
    *
           AORG >2000
     
    A2000  DATA >A55A                  prog flag
           DATA A2128                  xml 21 link label
           DATA A2398                  xml 22 loader
           DATA A225A                  xml 23 int->real
     
    *---------------------------------------------------------
    *      GPL
    *G700C DATA >0654,>2022            size, address where to load
    *      ML99                        assembly language stored here
    *
           AORG >2022
     
    A2022  DATA >0000                  err code/sub addr
    A2024  DATA >A000                  fsthi
    A2026  DATA >FFD7                  lsthi
    A2028  DATA A2676                  fstlow
    A202A  DATA A3F38                  lstlow
    A202C  DATA >0000                  checksum
    A202E  DATA >0000                  pab status ptr
    A2030  DATA >0000                  xml r11 buffer
    A2032  DATA >0000                  cru base for dsr
    A2034  DATA >0000                  dsr address   "
    A2036  DATA >0000                  name size     "
    A2038  DATA >0000                  e o name ptr  "
    A203A  DATA >0000                  counts        "
    A203C  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
           DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
           DATA 0,0,0,0,0,0,0,0        record buffer
    A208C  DATA 0,0,0,0                dsr name buffer
    A2094  DATA 0,0,0                  workspaces
    A209A  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
    A20BA  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
    A20DA  DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
    A20FA  DATA 100                    constants
    A20FC  DATA >2000
    A20FE  TEXT '.'
    A20FF  BYTE >AA
    *
    A2100  DATA A2094,A21C4            gpllnk wp,pc
    A2104  DATA A2094,A2196            xmllnk
    A2108  DATA A2094,A21DE            kscan
    A210C  DATA A2094,A21F4            vsbw
    A2110  DATA A2094,A2200            vmbw
    A2114  DATA A2094,A220E            vsbr
    A2118  DATA A2094,A221A            vmbr
    A211C  DATA A2094,A2228            vwtr
    A2120  DATA A209A,A22B2            dsrlnk wp,pc
    A2124  DATA A20DA,A23BA            loader wp,pc
    *PA
    A2128  MOV  11,@A2030              run program xml 21
           MOVB @>8349,1               -----------
           COC  @A20FC,1               gpllnk flag
           JEQ  A218A                  return to prog
           MOV  @>8350,0
           JEQ  A215E                  same name
           BL   @A2646                 check if undef
           JMP  A217E                  error >0D
    A2142  CI   1,A3F38                last = predefined
           JEQ  A217A
           MOV  1,0                    label list
           LI   2,>834A                label to be run
           C    *0+,*2+
           JNE  A2174                  compare names
           C    *0+,*2+
           JNE  A2174
           C    *0+,*2+
           JNE  A2174
           MOV  *0,@A2022              save value
    A215E  LWPI A20BA
           MOV  @A2022,0               get address
           JEQ  A217A
           BL   *0                     link to sub
           LWPI >83E0
           MOV  @A2030,11              restore r11
           B    *11                    to xml end
    A2174  AI   1,>0008
           JMP  A2142                  next label
    A217A  LI   0,>0F00                not found
    A217E  MOVB 0,@>8322               err code >0F
           LWPI >83E0
           B    @>00CE                 to gpl, bit set
    A218A  SZCB @A20FC,@>8349          clear flag
           LWPI A2094                  to gpllnk call
           RTWP
    *                                  xmllnk
    A2196  MOV  *14+,@>83E2            ======
           LWPI >83E0
           MOV  11,@A2094+22           save r11
           MOV  1,2                    xml code
           CI   1,>8000
           JH   A21B8                  direct address
           SRL  1,12                   from tables
           SLA  1,1
           SLA  2,4
           SRL  2,11
           A    @>0CFA(1),2
           MOV  *2,2
    A21B8  BL   *2                     execute
           LWPI A2094
           MOV  11,@>83F6              restore gpl r11
           RTWP
    *                                  gpllnk
    A21C4  MOVB @>8373,1               ======
           SRL  1,8
           MOV  *14+,@>8304(1)         addr on stack
           SOCB @A20FC,@>8349          >20 flag
           LWPI >83E0                  to xml end
           MOV  @A2030,11              (load and run)
           B    *11
    *                                  kscan
    A21DE  LWPI >83E0                  =====
           MOV  11,@A2094+22           save to old r11
           BL   @>000E
           LWPI A2094
           MOV  11,@>83F6              restore gpl r11
           RTWP
    *PA
    *                                  vsbw
    A21F4  BL   @A223A                 ====
           MOVB @>0002(13),@>8C00
           RTWP
    *                                  vmbw
    A2200  BL   @A223A                 ====
    A2204  MOVB *1+,@>8C00
           DEC  2
           JNE  A2204                  loop
           RTWP
    *                                  vsbr
    A220E  BL   @A2240                 ====
           MOVB @>8800,@>0002(13)
           RTWP
    *                                  vmbr
    A221A  BL   @A2240                 ====
    A221E  MOVB @>8800,*1+
           DEC  2
           JNE  A221E                  loop
           RTWP
    *                                  vwtr
    A2228  MOV  *13,1                  ====
           MOVB @>0001(13),@>8C02
           ORI  1,>8000
           MOVB 1,@>8C02
           RTWP
    *
    A223A  LI   1,>4000                vdp write
           JMP  A2242                  ---------
    A2240  CLR  1                      vdp read
    A2242  MOV  *13,2                  --------
           MOVB @A2094+5,@>8C02
           SOC  1,2
           MOVB 2,@>8C02
           MOV  @>0002(13),1           fetch old r1,r2
           MOV  @>0004(13),2
           B    *11
    *                                  int to real xml 23
    A225A  LI   4,>834A                -----------
           MOV  *4,0                   int
           MOV  4,6
           CLR  *6+                    clear space
           CLR  *6+
           MOV  0,5
           JEQ  A22B0                  =0
           ABS  0
           LI   3,>0040                exponent
           CLR  *6+
           CLR  *6
           CI   0,100
           JL   A22A0                  < 100
           CI   0,10000
           JL   A2290                  < 10000
           INC  3                      exp+1 *100
           MOV  0,1
           CLR  0
           DIV  @A20FA,0               div by 100
           MOVB @>83E3,@>0003(4)        remainder
    A2290  INC  3                      exp+1 *100
           MOV  0,1
           CLR  0
           DIV  @A20FA,0               div by 100
           MOVB @>83E3,@>0002(4)       remainder
    A22A0  MOVB @>83E1,@>0001(4)       result
           MOVB @>83E7,*4              exponent
           INV  5
           JLT  A22B0                  positive
           NEG  *4                     negative
    A22B0  B    *11
    *PA
    *                                  dsrlnk wp A209A
    A22B2  MOV  *14+,5                 ======
           SZCB @A20FC,15              >20 eq=0
           MOV  @>8356,0
           MOV  0,9
           AI   9,-8                   pab status
           BLWP @A2114                 vsbr: read size
           MOVB 1,3
           SRL  3,8
           SETO 4
           LI   2,A208C                name buffer
    A22D0  INC  0
           INC  4
           C    4,3
           JEQ  A22E4                  full size
           BLWP @A2114                 vsbr
           MOVB 1,*2+                  copy 1 char
           CB   1,@A20FE               is it .
           JNE  A22D0
    A22E4  MOV  4,4
           JEQ  A238C                  size=0
           CI   4,>0007
           JGT  A238C                  size>7
           CLR  @>83D0
           MOV  4,@>8354
           MOV  4,@A2036               save size
           INC  4
           A    4,@>8356
           MOV  @>8356,@A2038          e o name ptr
           LWPI >83E0                  call dsr
           CLR  1
           LI   12,>0F00
    A2310  MOV  12,12
           JEQ  A2316
           SBZ  0                      card off
    A2316  AI   12,>0100
           CLR  @>83D0
           CI   12,>2000
           JEQ  A2388                  last
           MOV  12,@>83D0              save cru base
           SBO  0                      card on
           LI   2,>4000
           CB   *2,@A20FF              >AA = header
           JNE  A2310                  no: next card
           A    @A209A+10,2            old r5: offset
           JMP  A2340
    A233A  MOV  @>83D2,2               next sub
           SBO  0                      card on
    A2340  MOV  *2,2                   link to next
           JEQ  A2310                  last: next card
           MOV  2,@>83D2               save link
           INCT 2
           MOV  *2+,9                  save address
           MOVB @>8355,5
           JEQ  A2364                  size=0
           CB   5,*2+
           JNE  A233A                  diff size: next
           SRL  5,8
           LI   6,A208C                name buffer
    A235C  CB   *6+,*2+                check name
           JNE  A233A                  diff name: next
           DEC  5
           JNE  A235C                  ok: next char
    A2364  INC  1                      same name
           MOV  1,@A203A               save # of calls
           MOV  9,@A2034               save address
           MOV  12,@A2032              save cru base
           BL   *9                     link
           JMP  A233A                  skip or next
    *PA
           SBZ  0                      card off
           LWPI A209A
           MOV  9,0
           BLWP @A2114                 read pab status
           SRL  1,13
           JNE  A238E                  err
           RTWP
    A2388  LWPI A209A                  errors
    A238C  CLR  1                      code 0
    A238E  SWPB 1
           MOVB 1,*13                  code in r0
           SOCB @A20FC,15              eq=1
           RTWP
    *PA
    *                                  gpl load xml 22
    A2398  MOV  11,@A2030              --------
           LWPI A20BA
           BLWP @A2124                 call loader
           LWPI >83E0
           JEQ  A23B0                  error
           MOV  @A2030,11              restore r11
           B    *11                    to xml end
    A23B0  MOVB @A20BA,@>8322           err code
           B    @>00CE                 to gpl, bit set
    *
    *                                  loader wp A20DA
    A23BA  CLR  @A2022                 ======
           SZCB @A20FC,15              clear eq + err code
           MOV  @>8356,0
           BLWP @A2120                 dsrlnk
           DATA >0008                  code for dsr
           JEQ  A2432                  err
           AI   0,-9
           LI   1,>0200
           BLWP @A210C                 set read opcode
           INC  0
           MOV  0,@A202E               save status addr
           MOV  @A2024,7               fsthi
           MOV  7,5
           CLR  12                     no comp flag
           BL   @A25E0                 input a record
           CI   3,>0001
           JNE  A243A                  to case table
           INC  12                     compressed flag
           CLR  3
           JMP  A243E                  to case table
    *
    A23F8  CI   3,>0046       |J|      special tag
           JNE  A243A                  value -> tag
    A23FE  CLR  2             |F|      next record
    A2400  BL   @A262E        |8|      next char
           CI   3,>003A
           JNE  A23F8                  not : => loop
           MOV  @A202E,0      |:|      end
           DEC  0
           LI   1,>0100                opcode = close
           BLWP @A210C                 vsbw
           BL   @A25E0                 call dsr
           MOV  @A2022,0
           JEQ  A2430
           BL   @A2646                 all defined?
           JMP  A2432                  no:  error >0D
           MOV  14,@>0016(13)          old pc > r11
           MOV  @A2022,14              new return address
    A2430  RTWP
    A2432  MOVB 0,*13                  r0
           SOCB @A20FC,15              eq=1
           RTWP
    *                                  case table
    A243A  BL   @A25C2                 ----------
    A243E  CLR  4                      convert char^
           MOVB @A2662(3),4            offset
           SRL  4,7
           MOV  8,@A202C               save checksum
           BL   @A2594                 put value in r0
           B    @A23F8(4)              to char routine
    *PA
    A2452  INC  0             |0|      new module
           ANDI 0,>FFFE                even
           MOV  @A2024,4               fsthi
           A    0,4
           JOC  A2470                  too big: in low
           C    4,@A2026               lsthi
    A2464  JH   A2470                  too big: in low
           MOV  @A2024,5               save old
           MOV  4,@A2024               new fsthi
           JMP  A2484
    A2470  MOV  @A2028,4               fstlo
           A    0,4
           C    4,@A202A               lstlo
           JHE  A2494                  too big
           MOV  @A2028,5               save old
           MOV  4,@A2028               new fstlo
    A2484  MOV  5,7                    new pointer
    A2486  LI   9,>0008       |I|      segment id
    A248A  BL   @A262E                 skip name (8 chars)
           DEC  9
           JNE  A248A
           JMP  A2400
    A2494  LI   0,>0800                mem overflow
           JMP  A2432
    *
    A249A  A    5,0           |2|      auto start
    A249C  MOV  0,@A2022      |1|      save address
           JMP  A2400
    *
    A24A2  A    0,@A202C      |7|      test checksum
           JEQ  A2400
           LI   0,>0B00                checksum err
           JMP  A2432
    *
    A24AE  A    5,0           |A|      rel new ptr
    A24B0  MOV  0,7           |9|      abs new ptr
           JMP  A2400
    *
    A24B4  A    5,0           |C|      rel data
    A24B6  MOVB 0,*7+         |B|      abs data
           MOVB @A20DA+1,*7+           r0 byte 2
           JMP  A2400
    *
    A24BE  A    5,0           |3|      rel ref
    A24C0  BL   @A2566        |4|      abs ref
           MOV  0,0                    make new label
           JEQ  A24F4                  no ref list
    A24C8  AI   6,-8                   fisrt label
           C    6,4
           JH   A24D4                  last ?
           NEG  *4                     undef
    A24D2  JMP  A2400
    A24D4  C    *4,*6                  compare name
           JNE  A24C8                  diff: next
           C    @>0002(4),@>0002(6)
           JNE  A24C8
           C    @>0004(4),@>0004(6)
           JNE  A24C8
           MOV  @>0006(6),3            same: get value
    A24EC  MOV  *0,9                   get list link
           MOV  3,*0                   place value
           MOV  9,0                    next occurence
           JNE  A24EC
    A24F4  AI   4,>0008
           MOV  4,@A202A               del new copy
           JMP  A24D2
    *PA
    A24FE  A    5,0           |5|      rel def
    A2500  BL   @A2566        |6|      abs def
    A2504  AI   6,-8                   make new label
    A2508  C    6,4
           JEQ  A24D2                  last: continue
           MOV  *6,10                  get name
           JGT  A2512                  defined
           NEG  10                     undefined
    A2512  C    *4,10                  compare names
           JNE  A2504                  diff: next
           C    @>0002(4),@>0002(6)
           JNE  A2504
           C    @>0004(4),@>0004(6)
           JNE  A2504
           MOV  *6,10                  same
           JGT  A2556                  defined: err
           MOV  @>0006(6),3            undef: get link
    A252E  MOV  *3,9                   get old link
           MOV  0,*3                   place value
           MOV  9,3                    next occurence
           JNE  A252E
           MOV  6,9                    del old label
           S    4,9                    size to last
           MOV  6,10
           AI   10,>0008               next
           MOV  6,3                    current
    A2542  DECT 3
           DECT 10
           MOV  *3,*10                 copy next on current
           DECT 9
           JNE  A2542
           AI   4,>0008
           MOV  4,@A202A               update lstlo
           JMP  A2508                  to next ref
    *
    A2556  MOV  4,@>0002(13)           name ptr in r1
           LI   0,>0C00                duplicate def
           B    @A2432                 rtwp with err
    A2562  B    @A2494
    *                                  make new label
    A2566  MOV  11,10                  --------------
           LI   9,>0006                value in r0
           MOV  @A202A,6               lstlo
           AI   6,-8
           MOV  6,4                    new address
           C    6,@A2028               check fstlo
           JL   A2562                  mem overflow
           MOV  6,@A202A               new lstlo
    A2580  BL   @A262E                 read 1 byte
           MOVB @A20DA+7,*6+
           DEC  9
           JNE  A2580                  copy name
           MOV  0,*6                   copy address
           LI   6,A4000
           B    *10
    *PA
    *                                  read number
    A2594  MOV  11,10                  -----------
           CLR  0                      returned in r0
           MOV  12,12
           JEQ  A25AC
           BL   @A262E                 read 1 byte
           MOVB @A20DA+7,0             in r0 byte 1
           BL   @A262E                 one more
           A    3,0                    in r0 byte 2
           B    *10
    A25AC  LI   9,>0004                not compressed
    A25B0  BL   @A262E                 read 1 byte
           BL   @A25C2                 convert char
           SLA  0,4
           A    3,0                    in r0 nibble 4
           DEC  9
           JNE  A25B0                  4 times
           B    *10
    *                                  byte to tag
    A25C2  AI   3,>FFD0                -----------
           CI   3,>000A                returned in r3
           JL   A25D6                  0-9
           AI   3,-7                   A-O
           CI   3,>0019
           JH   A25D8                  after O: illegal
    A25D6  B    *11
    A25D8  LI   0,>0A00      |DEGH|    illegal tag
           B    @A2432
    *                                  input a record
    A25E0  LWPI >83E0                  --------------
           LI   0,A2032                saved by dsrlnk
           MOV  *0+,12                 cru base
           MOV  *0+,9                  prog address
           MOV  *0+,@>8354             name size
           MOV  *0+,@>8356             e o name ptr
           MOV  *0,1                   # of calls
           SBO  0                      card on
           CB   @>4000,@A20FF
           JNE  A263A                  no header
           BL   *9                     link
           JMP  A263A                  err (skipped)
           SBZ  0                      card off
           LWPI A20DA
           MOV  @A202E,0               pab status
           LI   1,A20DA+1              r0 2nd byte
           LI   2,>0004
           BLWP @A2118                 vmbr
           SB   0,0
           SRL  0,5
           JNE  A2640                  error flagged
           SRL  2,8                    rec len
           MOV  1,0                    data buffer
           LI   1,A203C                record buffer
           BLWP @A2118                 vmbr
           CLR  8                      read 1 byte
    A262E  DEC  2                      -----------
    A2630  JLT  A25E0                  next record
           MOVB *1+,3
           SRL  3,8                    returned in r3
           A    3,8                    checksum
           B    *11
    A263A  LWPI A20DA                  io error 0
           CLR  0
    A2640  SWPB 0
           B    @A2432
    *PA
    *                                  check if undef
    A2646  LI   1,A3F38+8              --------------
    A264A  AI   1,-8
           MOV  *1,0
           JLT  A265C                  undefined
           C    @A202A,1
           JNE  A264A                  not lstlo: loop
           INCT 11                     ok: skip
           B    *11
    A265C  LI   0,>0D00                unresolved ref
           B    *11
    *                   tag    -    jump table
    A2662  BYTE >2D      0             A2452
           BYTE >52      1             A249C
           BYTE >51      2             A249A
           BYTE >63      3             A24BE
           BYTE >64      4             A24C0
           BYTE >83      5             A24FE
           BYTE >84      6             A2500
           BYTE >55      7             A24A2
           BYTE >04      8             A2400
           BYTE >5C      9             A24B0
           BYTE >5B      A             A24AE
           BYTE >5F      B             A24B6
           BYTE >5E      C             A24B4
           BYTE >F0      D             A25D8
           BYTE >F0      E             A25D8
           BYTE >03      F             A23FE
           BYTE >F0      G             A25D8
           BYTE >F0      H             A25D8
           BYTE >47      I             A2486
           BYTE >00      J             A23F8
    A2676  BSS  6        K-P            ?   not loaded
    *
    *---------------------------------------------------------
    *PA
    *      GPL
    *G7664 DATA >00C8,>3F38            size, address where to load
    *      ML99                        assembly language stored here
     
           AORG >3F38                  def table
    *                                  ---------
    A3F38  TEXT 'UTLTAB'
           DATA A2022
           TEXT 'PAD   '
           DATA >8300
           TEXT 'GPLWS '
           DATA >83E0
           TEXT 'SOUND '
           DATA >8400
           TEXT 'VDPRD '
           DATA >8800
           TEXT 'VDPSTA'
           DATA >8802
           TEXT 'VDPWD '
           DATA >8C00
           TEXT 'VDPWA '
           DATA >8C02
           TEXT 'SPCHRD'
           DATA >9000
           TEXT 'SPCHWT'
           DATA >9400
           TEXT 'GRMRD '
           DATA >9800
           TEXT 'GRMRA '
           DATA >9802
           TEXT 'GRMWD '
           DATA >9C00
           TEXT 'GRMWA '
           DATA >9C02
           TEXT 'SCAN  '
           DATA >000E
           TEXT 'XMLLNK'
           DATA A2104
           TEXT 'KSCAN '
           DATA A2108
           TEXT 'VSBW  '
           DATA A210C
           TEXT 'VMBW  '
           DATA A2110
           TEXT 'VSBR  '
           DATA A2114
           TEXT 'VMBR  '
           DATA A2118
           TEXT 'VWTR  '
           DATA A211C
           TEXT 'DSRLNK'
           DATA A2120
           TEXT 'LOADER'
           DATA A2124
           TEXT 'GPLLNK'
           DATA A2100
    A4000  BYTE 0                      e o cpu mem
    *                                  e o grom >7730
           END
    

     

      
  4. From Tim (@InsaneMultitasker), a collaboration with @Tursi@acadiel and others, I think:
      Reveal hidden contents
    
    
    **********************
    
    VDPWA  EQU  >8C02
    VDWWD  EQU  >8C00
    VDPRD  EQU  >8800
    STATUS EQU  >837C
    DSRLNK DATA DREGS,DSR1
    HEX20  BYTE ' '
    HEXAA  BYTE >AA
    PERIOD BYTE '.'
           EVEN
    SAVE1  DATA >0000
    SAVE2  DATA >0000
    SAVE3  DATA >0000
    SAVE4  DATA >0000
    SAVE5  DATA >0000
    NAMBUF BSS  6      'SINCE WE KNOW WERE USING "DSKn."
    *
    H2000  DATA  >2000
    CYC1   DATA  0
    H1300  DATA  >1300
    
    DSR1   MOV   *R14+,R5
           SZCB  @HEX20,R15
           MOV   @>8356,R0
           MOV   R0,R9
           AI    R9,>FFF8
           SWPB  R0
           MOVB  R0,@VDPWA
           SWPB  R0
           MOVB  R0,@VDPWA
           NOP
           MOVB  @VDPRD,R1
           MOVB  R1,R3
           SRL   R3,>8
           SETO  R4
           LI    R2,NAMBUF
    DLOOP1 INC   R0
           INC   R4
           C     R4,R3
           JEQ   DJUMP1
           SWPB  R0
           MOVB  R0,@VDPWA
           SWPB  R0
           MOVB  R0,@VDPWA
           NOP
           MOVB  @VDPRD,R1
           MOVB  R1,*R2+
           CB    R1,@PERIOD
           JNE   DLOOP1
    DJUMP1 MOV   R4,R4
           JEQ   DJUMP6
           CI    R4,>0007
           JGT   DJUMP6
           CLR   @>83D0
           MOV   R4,@>8354
           MOV   R4,@SAVE3
           INC   R4
           A     R4,@>8356
           MOV   @>8356,@SAVE4
    SROM   LWPI  >83E0
           CLR   R1
           MOV   @H2000,@CYC1
           LI    R12,>1100
           JMP   DLOOP2
    SROM1  LI    R12,>0F00
           MOV   @H1300,@CYC1
    
    DLOOP2 MOV   R12,R12
           JEQ   DJUMP2
           SBZ   >00
    DJUMP2 AI    R12,>0100
           CLR   @>83D0
           CI    R12,>2000
           JEQ   SROM1
           C     R12,@CYC1
           JEQ   DJUMP5
           MOV   R12,@>83D0
           SBO   >00
           LI    R2,>4000
           CB    *R2,@HEXAA
           JNE   DLOOP2
           A     @5*2+DREGS,R2
           JMP   DJUMP3
    DLOOP3 MOV   @>83D2,R2
           SBO   >00
    DJUMP3 MOV   *R2,R2
           JEQ   DLOOP2
           MOV   R2,@>83D2
           INCT  R2
           MOV   *R2+,R9
           MOVB  @>8355,R5
           JEQ   DJUMP4
           CB    R5,*R2+
           JNE   DLOOP3
           SRL   R5,>8
           LI    R6,NAMBUF
    DLOOP4 CB    *R6+,*R2+
           JNE   DLOOP3
           DEC   R5
           JNE   DLOOP4
    DJUMP4 INC   R1
           MOV   R1,@SAVE5
           MOV   R9,@SAVE2
           MOV   R12,@SAVE1
           BL    *R9
           JMP   DLOOP3
           SBZ   >00
           LWPI  DREGS
           MOV   R9,R0
           SWPB  R0
           MOVB  R0,@VDPWA
           SWPB  R0
           MOVB  R0,@VDPWA
           NOP
           MOVB  @VDPRD,R1
           SRL   R1,>D
           JNE   DJUMP7
           RTWP
    DJUMP5 LWPI  DREGS
    DJUMP6 CLR   R1
    DJUMP7 SWPB  R1
           MOVB  R1,*R13
           SOCB  @HEX20,R15
           RTWP
    

     

     

  5. fbForth 2.0, using MG-->GPL (GROM0)-->ROM0: 
      Reveal hidden contents
    
    
    *     ___  _______  __   _  ____ __           __  ________
    *    / _ \/ __/ _ \/ /  / |/ / //_/          /  |/  / ___/
    *   / // /\ \/ , _/ /__/    / ,<      _ _ _ / /|_/ / (_ / 
    *  /____/___/_/|_/____/_/|_/_/|_|    (_|_|_)_/  /_/\___/  
    * 
    *-----------------------------------------------------------------------*
    ;[*== 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
    ;]*
    
    ;===========================================================================
    ;===========================================================================
    ; *** GPL Code from GROM0 per Heiner Martin ********************************
    ;===========================================================================
    ;===========================================================================
    GPL DSRLNK:
    03D9 : FETC @>836D            Fetch data
    03DB : CLR  @>8354
    03DD : ST   @>8355,VDP*>8356  Fetch length byte name
    03E1 : CLR  @>8358
    03E3 : DST  @>8352,@>8356
    03E6 : DINC @>8352
    03E8 : CEQ  @>8358,@>8355     Length = length of name?
    03EB : BS   GROM@>03F7
    03ED : CEQ  VDP*>8352,>2E     Point?
    03F1 : BS   GROM@>03F7        Yes, go on
    03F3 : INC  @>8358            Length DSR name+1
    03F5 : BR   GROM@>03E6        Go on
    03F7 : CZ   @>8358            Length 0?
    03F9 : BS   GROM@>0435        Yes, end with condition bit
    03FB : ST   @>8355,@>8358     Length on >8355
    03FE : CGE  @>8355,>08        Longer than 8?
    0401 : BS   GROM@>0435        Yes, end with set condition bit
    0403 : CLR  @>8354
    0405 : DCLR @>83D0            Clear GROM search pointer
    0408 : DINC @>8356            Beginning of name
    040A : MOVE @>8354 TO @>834A FROM VDP*>8356     Fetch name on FAC
    040F : DADD @>8356,@>8354     Left pointing!
    0412 : XML  >19               Execute with following RTN (if found) otherwise
                                  go on with GSRLNK
    GSRLNK:
    0414 : INCT @>8373            GROM read data on substack
    0416 : DST  *>8373,@>83FA
    041B : XML  >1A               GSRLNK
    041D : BR   GROM@>0429
    041F : INCT @>8373
    0421 : DST  *>8373,*>8372     Data stack on substack
    0426 : DECT @>8372
    0428 : RTN
    0429 : DCZ  @>83D0            GROM search pointer 0?
    042C : BR   GROM@>041B
    042E : DST  @>83FA,*>8373     GROM read address from substack
    0433 : DECT @>8373
    0435 : CEQ  @>8300,@>8300
    0438 : RTNC                   Return condition bit is set
    0439 : DECT @>8373
    043B : DST  @>83FA,*>8373     Fetch R13 GPLWS from substack
    0440 : DECT @>8373
    0442 : RTN                    Return
    
    ;===========================================================================
    ;===========================================================================
    ; *** Assembly Code from ROM0 **********************************************
    ;===========================================================================
    ;===========================================================================
    * ------ SEARCH ROM FOR DSR OR LINK -------
    * SEARCH FOR PERIPHERALS, MEM ADR 4000 TO 5FFF.
    * ENABLE BY CRU ADR 1000 TO 1F00
    * = BR TABLE
    SROM   CLR  R1               VERSION FOUND OF DSR ETC
           MOV  @CRULST,R12      SEARCH ROM FOR ROUTINE
           JNE  SGO              IF <> 0, CONTINUE SEARCH
           LI   R12,>0F00        START OVER AGAIN
    NOROM  MOV  R12,R12
           JEQ  NOOFF
           SBZ  0
    NOOFF  AI   R12,>0100        NEXT ROM'S TURN ON
           CLR  @CRULST          CLR IN CASE WE'RE FINISHED
           CI   R12,>2000        AT THE END (1F00 IS LAST PERIPH)
           JEQ  NOSET            NO MORE PERIPHS TO TURN ON
           MOV  R12,@CRULST      SAVE ADR. OF NEXT CRU
           SBO  0                TURN ON PERIPH
           LI   R2,>4000         START AT BEGINING (PERIPH ADR)
           CB   *R2,@HX30AA+1    IS IT A VALID ROM?
           JNE  NOROM            NO
           AB   @TYPE,@R2LSB
           JMP  SGO2
    SGO    MOV  @SADDR,R2        CONTINUE WHERE WE LEFT OFF
           SBO  0                TURN PERIPH BACK ON
    SGO2   MOV  *R2,R2           IS ADR. ZERO?
           JEQ  NOROM            YES, NO PROG. TO LOOK AT
           MOV  R2,@SADDR        REMEMBER WHERE TO GO NEXT
           INCT R2               GO TO ENTRY POINT
           MOV  *R2+,R9          GET ENTRY ADR
           BL   @NAME            SEE IF NAME MATCHES
           JMP  SGO              NO MATCH, TRY NEXT PROGG
           INC  R1               NEXT VERSION FOUND
           BL   *R9              MATCH, CALL SUBROUTINE
           JMP  SGO              NOT RIGHT VERSION
    * = BR TABLE
    CB16   SBZ  0
           JMP  NOGR2
    NOGR1  CLR  *R8
    NOGR2  BL   @GETSTK
    NOSET  B    @RESET
    * ------ SEARCH GROM FOR DSR OR LINK ------
    * ENTRY = BR TABLE (FPT)
    SGROM  LI   R7,SADDR
           LI   R8,CRULST
           BL   @PUTSTK          SAVE GROM ADR
    SGROMA MOV  *R7,R1           START WHERE WE LEFT OFF
           MOV  *R8,R2           IS IT A RESTART?
           JNE  SGROM3           NO
           LI   R2,>9800         START OF GROMS
    SGROM1 LI   R1,>E000         START OF GROM
    SGROM3 CZC  @HX1FFF,R1       IS IT A NEW GROM OR CONTIUATION?
           JNE  SGROM2
           MOV  R2,*R8           SAVE GROM ADR
           MOVB R1,@GWAOFF(R2)   LOAD ADR
           MOVB @R1LSB,@GWAOFF(R2)
           AB   @TYPE,@R1LSB     LOOK FOR PGM ADR.
           MOVB R1,@SAVEG        SAVE GROM ADR. OF HEADER
           CB   *R2,@HX30AA+1    VALID GROM?
           JNE  NOGR             NO GROM HERE
    HX81   EQU  $+1
    SGROM2 MOVB R1,@GWAOFF(R2)   LOOK FOR PGM
           MOVB @R1LSB,@GWAOFF(R2)
           SLA  R10,4            STALL
           MOVB *R2,R3           READ PGM ADR
           NOP
           MOVB *R2,@R3LSB
           MOV  R3,*R7           GET NEXT HEADER'S ADR
           JEQ  NOGR             IF ZERO, GO TO NEXT PGM
           INCT R3               GO TO PGM ENTRY ADR
           MOVB R3,@GWAOFF(R2)   GO TO PGM ENTRY ADR
           MOVB @R3LSB,@GWAOFF(R2)
           NOP
           MOVB *R2,R9           ENTRY ADR
           SLA  R10,4            STALL
           MOVB *R2,@R9LSB
           BL   @NAME            SEE IF NAME MATCHES
           JMP  SGROMA           NO, LOOK FOR NEXT PGM
           AB   @C030,@STKDAT    FOUND NAME SO PUSH IT
           AB   R14,@TEMP2       INCREASE PGM COUNT
           MOVB @STKDAT,R4
           SRL  R4,8
           DECT R3               POINT BACK TO START OF HEADER
           CB   @TYPE,@HX06      IS IT A USER PGM LOOKUP?
           JNE  SGROM4           YES
           MOV  R3,R9            PUSH HEADER ADR. FOR USER PGM
    SGROM4 MOVB R9,@PAD(R4)      NO, PUSH ENTRY ADR
           MOVB @R9LSB,@PAD+1(R4)
           MOV  R2,R13           GO TO THAT LIBRARY
           BL   @GETSTK          RESTORE GROM ADR
           B    @SET             SET STATUS AND RETURN
    NOGR   CLR  R1               GET ADR OF GROM HEADER
           MOVB @SAVEG,R1
           AI   R1,->2000        NEXT GROM DOWN
           MOV  R1,*R7           SAVE ADR OF WHERE WE'RE AT
           CI   R1,>E000         FINISHED?
           JNE  SGROM3           NO, CHECK THIS GROM
           C    *R2+,*R2+        INC GROM MAPPED ADR BY 4
           MOV  R2,*R8           SAVE THE NEW MAP ADR
           CI   R2,GR+>40        AT END OF LIBRAY
           JEQ  NOGR1            YES
           MOVB @SCLEN,R5        ARE WE LOOKING FOR A MENU?
           JNE  SGROM1           YES SO DO ONLY ONE SLOT
           JMP  NOGR2            NO, CONTINUE SEARCH
    * = BL, CALLED WITH 2 RETURNS
    NAME   MOVB @SCLEN,R5        GET LENGTH AS COUNTER
           JEQ  NAME2A           ZERO LENGTH, DON'T DO MATCH
           CB   R5,*R2           DOES LENGTH MATCH?
           JNE  NAME3            NO
           SRL  R5,8             MOVE TO RIGHT PLACE
           LI   R6,FAC
    NAME1  CI   R2,GR            IS IT GROM?
           JHE  NAME2            YES, DON'T INC ADR.
           INC  R2
    NAME2  CB   *R6+,*R2         IS NAME THE SAME?
           JNE  NAME3            NO
    HX06   DEC  R5               MORE TO LOOK AT? REF IS NASTY
           JNE  NAME1            YES
    NAME2A INCT R11              RETURN, NAME FOUND
    NAME3  RT
    
    

     

     

...lee

A variation of version #4 above, written specifically for Camel99 Forth.

This version simplifies how unknown device is detected. If CRU >  hex1F00  we jump out.

Removes need for 3 DATA locations.

Also adds GPLstatus to error code.

Not tested with RS232 yet.

 

Version #4  might not work with cards past hex1300. (Has anyone tested it?)

Spoiler

\ DSRLNKC.HSF for XFC99 cross-compiler/Assembler  19SEP2020
\ PASSES error code back to Forth workspace, TOS register

\ Source:
\ http://atariage.com/forums/topic/283914-specialized-file-access-from-xb/page-2
\ posted by InsaneMultitasker via Thierry Nouspikel

\ - Changed some jumps to structured loops & IF/THEN
\ - ADD GPl error byte to error code on Forth TOS
\ - Removed GPLSTAT constant from kernel, made an Equate here
\ - saved 44 bytes!!                                      B. Fox
\ 20SEPT2020
\ - remove code checking for CRU address >1300 and unused variables
\ - changed error handling for last card detection
\ - save 18 bytes

CROSS-ASSEMBLING  XASSEMBLER DEFINITIONS

\ we need more labels than I normally use for Forth style CODE Words
 A DUP refer: @@A    binder: @@A:
 B DUP refer: @@B    binder: @@B:

CROSS-COMPILING XASSEMBLER DEFINITIONS
\ MACRO to simplify the VDP code
: VDPWA, ( reg -- )
       DUP           SWPB,   \ setup VDP address
       DUP VDPWA @@  MOVB,   \ write 1st byte of address to VDP chip
       DUP           SWPB,
           VDPWA @@  MOVB,   \ write 2nd byte of address to VDP chip
                     NOP,  ; \ need this tiny delay for VDP chip

: [TOS]      8 (R13)  ;  \ gives access to Forth top of stack register

[CC]
HEX 837C EQU GPLSTAT

TARGET-COMPILING
l: HEX20   20 BYTE,
l: HEXAA   AA BYTE,
l: PERIOD  2E BYTE,      \ '.'
          .EVEN
l: CYC1    DATA 0000           \ this empty space seems to be required ??

[CC] RP0 80 -     EQU DREGS    \ memory below Forth RETURN stack is DSR workspace
[CC] 5 2* DREGS + EQU DREG(5)  \ compute address of DREGS register 5
[CC] DREGS 10 -   EQU NAMBUF   \ 16 byte buffer


CLR-JMPTABLE
\ === DSR ENTRY POINT ===
l: DSR1
                 0  LIMI,   \ disable interrupts for VDP access
      *R14+     R5  MOV,    \ fetch '8' from program ->R5, auto inc PC for return
       HEX20 @@ R15 SZCB,   \ status flag=0. *this is critical for REAL IRON*
       8356 @@  R0  MOV,    \ [PAB FNAME] to R0
       R0       R9  MOV,    \ dup R0 to R9
       R9       -8  ADDI,   \ R9-8 = [PAB FLG]
       R0          VDPWA,   \ set the VDP address to use
       VDPRD @@ R1  MOVB,   \ read length of FNAME -> R1

\ setup to copy VDP FNAME -> namebuf to '.' character
       R1       R3  MOVB,   \ DUP length byte to R3
       R3       08  SRL,    \ swap the byte to other side
       R4           SETO,   \ R4 = -1
       R2   NAMBUF  LI,     \ R2 is ^namebuf
       BEGIN,
         R0            INC,    \ point to next fname VDP address
         R4            INC,    \ counter starts at -1
         R4       R3   CMP,    \ is counter = fnamelength
         @@1           JEQ,    \ if true goto @@1:
         R0          VDPWA,    \ set VDP address
         VDPRD @@ R1  MOVB,    \ read next VDP char from fname
         R1      *R2+ MOVB,    \ copy to namebuf & inc pointer
         R1 PERIOD @@ CMPB,    \ is it a '.'
       EQ UNTIL,               \ until '.' found  34 bytes!!!

@@1:   R4        R4  MOV,    \ test R4(device name length)=0
       @@6           JEQ,    \ if so, goto ERROR
       R4        07  CMPI,   \ is dev name length>7
       @@8           JGT,    \ if so, goto @@8 ERROR
       83D0 @@       CLR,    \ erase magic CRU addr. holder
       R4   8354 @@  MOV,    \ put length in magic address
       R4            INC,    \ +1 points to '.' character
       R4   8356 @@  ADD,    \ add offset to PAB address (makes "real PAB")

\ ==== GPL WORKSPACE ====
       83E0         LWPI,    \ SROM (search ROM device list)
       R1           CLR,     \ MAGIC GPL REG. 1 to call DSR, returns error
       R12     0F00 LI,      \ init CRU base to 0F00
\ scan for I/O cards
      BEGIN,
@@A:     R12   R12   MOV,
         NE IF,              \ if card address<>0
              00 SBZ,        \ turn off card
         ENDIF,
         R12    0100  ADDI,  \ advance CRU to next card
         83D0 @@      CLR,   \ erase magic address
         R12    1F00  CMPI,  \ last card?
         GT IF,
              DREGS   LWPI, \ Switch to DSR Workspace
              R1 0006 LI,   \ set error 6
              @@5 JMP,      \ jump to errors
         ENDIF,

\ card activation...
         R12  83D0 @@ MOV,   \ save card CRU in magic address
         00           SBO,   \ turn on the card
         R2   4000    LI,    \ ROM start addr -> R2
        *R2  HEXAA @@ CMPB,  \ test for card ID byte "AA"
      EQ UNTIL,              \ loop until card is found
      DREG(5) @@ R2 ADD,     \ add '8'+4000= >4008 DSR ROM list
      @@B           JMP,

@@3: \ scan ROM linked list for code address
      BEGIN,
         BEGIN,
           83D2 @@   R2 MOV,   \ start of ROM device list -> R2
           00           SBO,   \ turn card on
@@B:      *R2       R2  MOV,   \ Fetch next link
           @@A          JEQ,   \ if link=0 goto @@A (NEXT CARD)
           R2  83D2 @@  MOV,   \ save link address in magic address
           R2           INCT,  \ R2 = code pointer
          *R2+      R9  MOV,   \ fetch code address ->R9
           8355 @@  R5  MOVB,  \ dev length->R5
           @@4          JEQ,   \ if 0 we have a string match
           R5      *R2+ CMPB,
         EQ UNTIL,

\ find dev string match
         R5       08  SRL,     \ shift length byte
         R6   NAMBUF  LI,      \ R6 hold ^nambuf
         BEGIN,
           *R6+   *R2+ CMPB,   \ compare namebuf to ROM string
            @@3        JNE,    \ if mismatch goto @@3
            R5         DEC,    \ dec the counter register
         EQ UNTIL,
@@4: \ run DSR code
         R1        INC,        \ count entries into the DSR ?
        *R9         BL,        \ call the DSR code
      AGAIN,                   \ try next card
\   -- DSR returns here if we are done --

\ error handlers
 @@6:  \ device len=0 error
 @@8:  \ device len>7 error
       00            SBZ,  \ Turn off the card
       DREGS         LWPI, \ ==== DSR Workspace ====
       R9           VDPWA, \ set vdp address to [PAB FLAG]
       VDPRD @@  R1  MOVB, \ read error value to DREGS R1
       R1 0D         SRL,  \ shift error to correct range
       NE IF,
@@5:       \ end of cards error entry point
           R1      [TOS] MOV,  \ Move error code to Forth TOS
           GPLSTAT @@ R0 MOVB, \ get gpl status byte
                      R0 SWPB,
           R0       0020 ANDI, \ mask to get GPL error bit
           R0      [TOS] OR,   \ combine GPL & DSR error codes
       ENDIF,
       RTWP,                   \ return to Forth

\    ====== DSR LINK ENDS======
\ /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/

\ create the vector for BLWP
l: DLNK      DREGS DATA,   \ the workspace
             DSR1  DATA,   \ entry address of the code

CODE: DSRLNK  ( [pab_fname] -- ior)
      TOS  8356 @@ MOV,
               TOS CLR,
    TOS GPLSTAT @@ MOVB,   \ clear GPL status register
           DLNK @@ BLWP,
                 8 DATA,   \ Offset to DSR linked list in card ROM
                 2 LIMI,
                   NEXT,
END-CODE

 

 

  • Like 1
Link to comment
Share on other sites

12 hours ago, TheBF said:

Version #4  might not work with cards past hex1300. (Has anyone tested it?)

 

It should. It goes through the list to >2000 the first time without an explicit test for >1300. If it reaches >2000, it then changes CYC1 from >2000 to >1300 and starts the test again, this time exiting with R12 = >1300. I do not know what that accomplishes that could not be accomplished by setting R12 = >1300 and exiting immediately. Perhaps @InsaneMultitasker will enlighten us.

 

...lee

  • Like 1
Link to comment
Share on other sites

On 9/21/2020 at 1:06 AM, Lee Stewart said:

 

It should. It goes through the list to >2000 the first time without an explicit test for >1300. If it reaches >2000, it then changes CYC1 from >2000 to >1300 and starts the test again, this time exiting with R12 = >1300. I do not know what that accomplishes that could not be accomplished by setting R12 = >1300 and exiting immediately. Perhaps @InsaneMultitasker will enlighten us.

 

...lee

I believe the DSRLNK in question starts the scan at 0x1200 [R12 is first set to 0x1100 and 0x0100 is added to R12 before the test starts]  then loops back around to 0x1000 [R12 set to 0x0f00 then 0x0100 is added to R12] , thus skipping the floppy controller in favor of higher CRU bases. This was also done to hit the HFDC and other devices at 0x1000 before the floppy controller.  There are programs where changing the first scanned address was beneficial long ago.  If this is indeed the DSRLNK version I shared long ago, I probably had forgotten about this modification.  Good eagle eye. 

 

  • Thanks 1
Link to comment
Share on other sites

On 9/8/2020 at 8:51 PM, TheBF said:

: SQRT ( n -- n ) -1 TUCK DO 2+ DUP +LOOP 2/ ;

 

 

The above SQRT only works for n ≤ 32767. It works fine for the use @TheBF made of it in the above post, but the distance (Δxy) between pixels on the TI-99/4A screen can be as high as Δx = 255 and Δy = 191, which yields a maximum d2 = Δx2 + Δy2 = 2552 + 1912 = 10550610 = 18C8216, which is 17 bits wide and yields d = ~318. I decided to write an integer square root function (SQRTUD) that could handle such a number more quickly than via floating point and thus allow the timely calculation of the actual distance rather than limiting it to d2 ≤ 32767 (d = ~181).  requires an unsigned double (32 bits wide) number on the stack. A single (16 bits wide) number is easily converted to a double number by putting 0 on the stack after it:

HEX
\ 0 <= ud <= 0x1FFFF (13171)
\ d = sqrt(d^2) = sqrt(4*d'^2) = 2*d'
: SQRTUD ( ud -- n ) 
   DUP >R         \ MSW to return stack
   IF
      2 SRL       \ /4 if MSW > 0
      4000 +      \ correct for missing MSW
   THEN
   >R             \ loop limit to return stack
   -1 -1          \ index and root starts
   BEGIN        
      2+ DUP      \ add 2 to root and dup
      ROT + DUP   \ root+index and dup
      R U<        \ index < limit?
   WHILE        
      SWAP        \ yes..reorder index and root
   REPEAT         \ next round
   R> DROP DROP   \ drop limit and index
   1 SRL          \ correct root (# is small now so no need for 32-bit arithmetic)
   R> IF
      1 SLA       \ *2 to correct root for initial /4
   THEN
;
DECIMAL

[Edit: tightened up code between “ REPEAT ” and “ R> IF ”]

 

Later, I will convert this to ALC to speed up the calculation. 

 

It is extremely tempting to change DXY SPRDIST SPRDISTXY to all calculate d instead of the current d2 ≤ 32767, particularly, if I can squeeze it into bank 1 of the fbForth 2.0:13 ROM. In any event, I will try to get a beta out in a day or two.

 

...lee

Edited by Lee Stewart
CODE Modification
  • Like 2
Link to comment
Share on other sites

For a plotting package or some such app this is a great addition.

For sprites I think the TI programmers considered anything far away to be irrelevant.

 

Chuck Moore has been quoted as saying something like:

"It's hard to make a general solution because no one has defined the general problem"

:)

 

 

  • Like 1
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...