GDMike Posted September 13, 2020 Share Posted September 13, 2020 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. Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 13, 2020 Share Posted September 13, 2020 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!. 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 14, 2020 Author Share Posted September 14, 2020 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 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 15, 2020 Author Share Posted September 15, 2020 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 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 15, 2020 Share Posted September 15, 2020 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? Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 15, 2020 Author Share Posted September 15, 2020 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 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 15, 2020 Share Posted September 15, 2020 Could you write a short test in Forth Assembler to confirm or deny your suspicions? Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 15, 2020 Author Share Posted September 15, 2020 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 1 Quote Link to comment Share on other sites More sharing options...
Asmusr Posted September 16, 2020 Share Posted September 16, 2020 (edited) How about: mov @gstat,r12 andi r12,>2000 Or is [the value of] r12 used somewhere else? Edited September 16, 2020 by Asmusr Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 16, 2020 Author Share Posted September 16, 2020 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 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 18, 2020 Author Share Posted September 18, 2020 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 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 18, 2020 Share Posted September 18, 2020 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. Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 18, 2020 Author Share Posted September 18, 2020 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 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 18, 2020 Share Posted September 18, 2020 Just tried it on real iron. No go. That sucks. Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 18, 2020 Share Posted September 18, 2020 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. (?) Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 18, 2020 Author Share Posted September 18, 2020 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 1 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 19, 2020 Author Share Posted September 19, 2020 OK, here we go. Here are the different versions of DSRLNK that I can find: 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 ^^^^^^^^^^^^^^^^^^^^^^^^ 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 ;] 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 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 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 2 Quote Link to comment Share on other sites More sharing options...
+InsaneMultitasker Posted September 19, 2020 Share Posted September 19, 2020 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...? 1 1 Quote Link to comment Share on other sites More sharing options...
Tursi Posted September 19, 2020 Share Posted September 19, 2020 The scratchpad loader is the only one I was involved in, though I did use an adaptation of the E/A one in many places. 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 20, 2020 Share Posted September 20, 2020 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: 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 ^^^^^^^^^^^^^^^^^^^^^^^^ 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 ;] 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 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 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 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 21, 2020 Author Share Posted September 21, 2020 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 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 21, 2020 Share Posted September 21, 2020 Thank you for clarifying that. I wonder how it came to be? Quote Link to comment Share on other sites More sharing options...
+InsaneMultitasker Posted September 22, 2020 Share Posted September 22, 2020 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. 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 22, 2020 Author Share Posted September 22, 2020 (edited) 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 (Δx,Δy) 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 September 23, 2020 by Lee Stewart CODE Modification 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 22, 2020 Share Posted September 22, 2020 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" 1 Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.