+TheBF Posted October 30, 2020 Author Share Posted October 30, 2020 Two Barbers WHILEs, No Waiting I made mention of what you can do with these new ISO loops so here is an example. I have been working on the VIBE block editor by Samuel Falvo and it's working well now in 80 column mode. I was reading the commands in the VI editor and one that is missing in VIBE is $ key which puts the cursor at the end of the text on the editing line. I had read the these double WHILE constructs are handy for string functions and now I can see why. One WHILE is handling the absolute end of the loop. It is resolved by the THEN word which maybe should be renamed to ENDWHILE. (?) The 2nd WHILE is for the processing action of finding the space character. I did this for my own edification because I think -TRAILING would work faster for this job. ( WH sets "where" the cursor is in memory in VIBE, SOL and EOL are just the addresses of the start and end of line in memory) : EOTEXT SOL EOL ( addr1 addr2) \ start & end of edit line BEGIN 2DUP <> WHILE \ while we are not at SOL DUP C@ BL = WHILE \ while the char at EOL is blank 1- \ decrement the EOL address REPEAT \ BOTH loops jumps to BEGIN on true logic THEN \ 1st WHILE jumps to here on false logic - ABS 1+ X ! WH ; \ compute new X coord and set where cursor goes Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted October 30, 2020 Share Posted October 30, 2020 4 hours ago, TheBF said: : EOTEXT SOL EOL ( addr1 addr2) \ start & end of edit line BEGIN 2DUP <> WHILE \ while we are not at SOL DUP C@ BL = WHILE \ while the char at EOL is blank 1- \ decrement the EOL address REPEAT \ BOTH loops jumps to BEGIN on true logic THEN \ 1st WHILE jumps to here on false logic - ABS 1+ X ! WH ; \ compute new X coord and set where cursor goes I am probably missing something here, but this appears to be overlapping loops, which I would think a bad idea. If there must be a second resolver for WHILE , I would think it should be resolved within any other loop construct. I would expect the first WHILE to be resolved by REPEAT and that THEN or ENDWHILE (placed before REPEAT ) would properly resolve the second WHILE . ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted October 30, 2020 Author Share Posted October 30, 2020 I believe they are overlapping and I can accept that in a purely structured paradigm it is a bad idea. However all ALC programmers know that sometimes jumping is more efficient that structured programming albeit more confusing and prone to error. But then force fitting pure structure onto something that just needs a damned jump can loop be ugly too. So this structure, like using EXIT THEN, is letting Forth jump around a bit but in a "structured" manner. But I admit my first look at this made me say "That ain't right". Consider: With these simplified loops structures WHILE is really just IF . ( I guess the SWAP is getting the HERE from BEGIN in the correct order. ? ) : WHILE POSTPONE IF SWAP ; IMMEDIATE And REPEAT is AGAIN followed by THEN to resolve the IF ( ie: WHILE) : REPEAT POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE So after the REPEAT we need that extra THEN to resolve the first WHILE. It almost makes sense to me. I am amazed by the people who come up with this stuff however. I would never have considered this. Today I was studying a faster smaller way to do a CASE statement that came from the mind of the late Neil Baud (aka Wil Baden) When I get a working version on my system I will publish here. Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted October 30, 2020 Share Posted October 30, 2020 I still don’t like it. There must be a better way than to expose that kind of cleanup in high-level code. But, that is just my problem, I suppose. ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted October 30, 2020 Author Share Posted October 30, 2020 Yes perhaps you could make a word called REPEATS. It would compile AGAIN and then a two THEN words Un-tested!!! : REPEATS POSTPONE AGAIN POSTPONE THEN POSTPONE THEN ; IMMEDIATE That would handle 2 while conditions. But I am looking at something right now call THENS : THENS BEGIN ?DUP WHILE POSTPONE THEN REPEAT ; IMMEDIATE This mops up like ENDCASE in the Eaker case statement. So in theory we could do : REPEATS POSTPONE AGAIN POSTPONE THENS ; IMMEDIATE Would that remove any discomfort for you? 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted October 30, 2020 Share Posted October 30, 2020 25 minutes ago, TheBF said: Would that remove any discomfort for you? Probably. ? I guess it would work something like : EOTEXT SOL EOL ( addr1 addr2) \ start & end of edit line BEGIN 2DUP <> WHILE \ while we are not at SOL DUP C@ BL = WHILE \ while the char at EOL is blank 1- \ decrement the EOL address REPEATS \ BOTH loops jump to BEGIN on true logic and exit on false logic - ABS 1+ X ! WH ; \ compute new X coord and set where cursor goes ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 1, 2020 Author Share Posted November 1, 2020 Updated FoxShell *EDIT* See new version for 2021 later in this topic As I put my new kernel through its paces I used the new SAVESYS utility to compile a version of my DV80 disk utilities. It's not Force Command by any stretch but handy for me with a large number of text files in the system. At this time they only work with DV80 files. I am still thinking about the best way deal with other file types to make a simple syntax for the end user. There is an APND command that lets you append files to a second file. You can copy files. It is record by record so not a speed demon. In Classic99 it is very handy to to COPY DSK1.MYFILE CLIP and copy a TI-99 file to the windows clipboard. The zip file includes a 40 column and an 80column version. 80 columns was only tested on Classic99. Latest Source for those interested is here: Spoiler \ FOXSHELL.FTH CAMEL99 shell for disk file management \ Oct 2020: built with SAVESYS to create stand alone program NEEDS DUMP FROM DSK1.TOOLS NEEDS OPEN-FILE FROM DSK1.ANSFILES NEEDS VALUE FROM DSK1.VALUES NEEDS CASE FROM DSK1.CASE NEEDS BUFFER: FROM DSK1.BUFFER NEEDS MALLOC FROM DSK1.MALLOC NEEDS COMPARE FROM DSK1.COMPARE NEEDS U.R FROM DSK1.UDOTR \ right justified printing CR .( Compiling FOXSHELL ) VARIABLE WARNINGS WARNINGS ON VARIABLE #BYTES \ busy spinner to show activity VARIABLE SPIN# CREATE SCHARS CHAR | C, CHAR / C, CHAR - C, CHAR \ C, : GETXY ( -- col row) VROW 2@ ; : SPINCHAR ( -- char ) SPIN# @ 1+ 3 AND DUP SPIN# ! SCHARS + C@ ; : SPINNER ( -- ) SPINCHAR GETXY >VPOS VC! ; \ simplified file language \ Usage example: S" DSK2.MYFILE" R/W OPEN AS: #1 HEX .( .) 0 VALUE #1 0 VALUE #2 0 VALUE #3 : AS: ( n -- <value> ) POSTPONE TO ; IMMEDIATE : OPEN ( addr len -- hndl ) OPEN-FILE ?FILERR ; : CLOSE ( hndl -- ) CLOSE-FILE ?FILERR ; : READH ( hndl -- ) READ-LINE ?FILERR 2DROP ; DECIMAL \ CR if near end of screen : ?CR ( n -- ) LINES @ 3 MOD 0= IF CR THEN ; .( .) HEX \ string helpers : ARG$ ( -- addr len ) BL PARSE-WORD ?FILE ; : $. ( $addr -- ) COUNT TYPE ; : $.LEFT ( $ width -- ) OVER C@ - >R $. R> SPACES ; : NEXT$ ( addr len -- addr' len') + COUNT ; \ : +PLACE ( addr n $ -- ) 2DUP 2>R COUNT + SWAP CMOVE 2R> C+! ; .( .) HEX : CLOSE-ALL ( --) 4 1 DO I ]FID @ IF I CLOSE-FILE DROP THEN LOOP ; \ ?break closes all open files. : ?BREAK ( ? -- ) IF CLOSE-ALL TRUE ABORT" *BREAK*" THEN ; \ Modify key to allow it to break and close files : FKEY ( -- char) VPOS VC@ >R BEGIN \ start the loop CURS @ \ fetch 2 char cursor (space & _ ) TMR@ 1FFF < \ compare hardware timer to 1FFF IF DROP R@ THEN VPUT \ swap cursor for screen char, write ?TERMINAL ?BREAK \ test for Break key KEY? \ check the keyboard ?DUP \ DUP IF <> 0 UNTIL \ loop until a key pressed R> VPUT ; \ put the space char on screen \ screen control : SPACE? ( -- ?) KEY? BL = ; : SPACEBAR ( -- ) SPACE? IF FKEY DROP THEN ; .( .) : OPEN-CATFILE ( adr len -- hndl) RELATIVE 100 FIXED R/O BIN OPEN ; \ 3 DIGIT BCD to int convertor. Limited to 999 HEX : F>INT ( addr len -- addr len n) OVER C@ ( -- mantissa) CASE 0 OF 0 ENDOF 40 OF OVER 1+ C@ ENDOF 41 OF OVER 1+ C@ 64 * >R OVER 2+ C@ R> + ENDOF ( default) -1 \ bad # indicator ENDCASE ; DECIMAL : DIR.TYPE ( addr -- ) F>INT CASE 1 OF ." Txt/Fix" ENDOF 2 OF ." Txt/Var" ENDOF 3 OF ." Bin/Fix" ENDOF 4 OF ." Bin/Var" ENDOF 5 OF ." Program" ENDOF ." ????" ENDCASE ; .( .) : HEAD.REC ( addr -- ) DECIMAL DUP 7 $.LEFT SPACE COUNT ( addr len) NEXT$ ." Size " NEXT$ F>INT 5 U.R ." Used " NEXT$ F>INT 5 U.R 2DROP ; : DIR.REC ( addr -- ) DUP 11 $.LEFT SPACE COUNT ( addr len) NEXT$ DIR.TYPE NEXT$ F>INT 7 U.R NEXT$ F>INT 7 U.R 2DROP ; : FILE.REPORT CR LINES @ . ." lines, " #BYTES @ . ." bytes" ; \ ======================================== \ * \ * User commands: CAT DIR MORE DEL COPY \ * : CAT ( <DSK?.> ) \ needs the '.' ONLY shows file name BASE @ >R DECIMAL ARG$ OPEN-CATFILE >R \ store file handle PAD 80 R@ READH CR PAD HEAD.REC CR 13 SPACES ." -type- -sect- -b/rec-" LINES OFF BEGIN PAD DUP 80 R@ READH ( PAD) C@ \ do while length > 0 WHILE CR PAD DIR.REC 1 LINES +! SPACEBAR ?TERMINAL ?BREAK REPEAT R> CLOSE CR LINES @ . ." files" CR R> BASE ! ; .( .) HEX : DIR ( <DSK?.> ) ARG$ OPEN-CATFILE >R \ push handle PAD 50 R@ READH CR PAD HEAD.REC CR LINES OFF BEGIN PAD DUP 80 R@ READH ( PAD) C@ \ do while length <> 0 WHILE PAD 0D $.LEFT ?CR 1 LINES +! SPACEBAR ?TERMINAL ?BREAK REPEAT R> CLOSE DECIMAL CR LINES @ . ." files" CR HEX ; .( .) : MORE ( <filename>) LINES OFF #BYTES OFF ARG$ DV80 R/O OPEN >R BEGIN PAD DUP 50 R@ READ-LINE ?FILERR ( adr len flag) WHILE DUP #BYTES +! CR TYPE LINES 1+! SPACEBAR ?TERMINAL ?BREAK REPEAT R> CLOSE 2DROP FILE.REPORT ; HEX : TOUPPER ( char -- upperchar ) 5F AND ; : SURE? ( -- ?) WARNINGS @ IF CR ." Are you sure? (Y/N)" KEY TOUPPER [CHAR] Y = THEN ; : .CANCEL CR ." Cancelled" CR ; : DEL ( <filename>) ARG$ 2DUP R/W OPEN-FILE ?FILERR CR ." Delete " TYPE SURE? IF 7 FILEOP ?FILERR CLOSE-FILE 2DROP CR ." Done" ELSE DROP .CANCEL THEN ; : MOVE-FILE ( buff-size -- buff-size) #BYTES OFF DUP MALLOC >R LINES OFF SPACE BEGIN R@ 50 #1 READ-LINE ?FILERR ( -- #bytes eof?) WHILE DUP #BYTES +! R@ SWAP #2 WRITE-LINE ?FILERR LINES 1+! SPINNER REPEAT R> DROP \ DROP buffer address from rstack MFREE ; .( .) DECIMAL : COPY ( <file1> <file2> ) ARG$ ARG$ SURE? IF DV80 W/O OPEN AS: #2 DV80 R/O OPEN AS: #1 52 MOVE-FILE #2 CLOSE #1 CLOSE BASE @ >R DECIMAL CR ." Copy complete. " FILE.REPORT R> BASE ! ELSE 2DROP 2DROP .CANCEL THEN ; : W/O+ ( -- fam ) APPEND FAM @ ; \ TI-99 file access mode: write/append HEX : APND ( <file1> <file2> ) ARG$ ARG$ DV80 W/O+ OPEN AS: #2 DV80 R/O OPEN AS: #1 52 MOVE-FILE #2 CLOSE #1 CLOSE BASE @ >R DECIMAL CR ." Append complete" FILE.REPORT R> BASE ! ; : CLS PAGE ; : HELP CR CR ." Commands" CR ." --------------------" CR ." HELP Show this list" CR ." DIR <DSK?.> show file names" CR ." CAT <DSK?.> show files and types" CR ." MORE <path> show contents of DV80 file" CR ." DEL <path> delete file at path" CR ." COPY <path1> <space> <path2> " CR ." Copy file at path1 to path2" CR ." APND <path1> <space> <path2" CR ." Append file1 to file2" CR ." WAITFOR <path> Paste to Classic99" CR ." CLS Clear screen" CR ." BYE Return to Home screen" CR ." WARNINGS OFF Disables 'Are you sure?'" CR ." ------------------" CR ." SPACE bar will stop scrolling" CR ." FNCT 4 halts operations" ; \ re-write accept to use new KEY. ( could patch it but this is clearer) : FACCEPT ( c-addr +n -- +n') OVER + OVER BEGIN FKEY DUP 0D <> WHILE DUP EMIT DUP 8 = IF DROP 1- 3 PICK UMAX \ changed to use: 3 PICK B.F. ELSE OVER C! 1+ OVER UMIN THEN REPEAT DROP NIP SWAP - ; .( .) : RCV ( caddr len -- ) DV80 W/O OPEN AS: #1 BEGIN PAD DUP 50 FACCEPT ( addr len) #1 WRITE-LINE ?FILERR AGAIN ; \ USED WITH Classic99. Pastes text into DV80 FILE : WAITFOR ( <PATH> ) ARG$ CR ." Waiting for file " 2DUP TYPE CR ." Press FCTN 4 to halt & SAVE" CR RCV ; : SHELL WARM PAGE ." Fox Shell V1.0, Brian Fox 2020" DECIMAL HELP WARNINGS ON ABORT ; CR .( Save as EA5 binary files) INCLUDE DSK1.SAVESYS ' SHELL SAVESYS DSK2.FOXSHELL FSHELL.zip 4 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted November 1, 2020 Share Posted November 1, 2020 1 hour ago, TheBF said: Updated FoxShell As I put my new kernel through its paces I used the new SAVESYS utility to compile a version of my DV80 disk utilities. It's not Force Command by any stretch but handy for me with a large number of text files in the system. At this time they only work with DV80 files. I am still thinking about the best way deal with other file types to make a simple syntax for the end user. Very nice, indeed! You are giving me ideas for fbForth 2.0 I don’t need. I have other fish to fry. Well done! ...lee 1 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 3, 2020 Author Share Posted November 3, 2020 Going through my Demo files and testing things on V2.66 I did some improvements to AUTOMOTION. The motion vectors now correct the X vector (-1) when Y vector is a negative value. I had that on my list for while. Changed motion table access to a machine code word. Same size as Forth but much faster. In my coincidence test nowI first do COINCALL before testing coincidence. This allows faster polling. : COINC ( spr#1 spr#2 tol -- ?) COINCALL IF >R POSITION ROT POSITION ( -- x1 y1 x2 y2 ) ROT - ABS R@ < -ROT - ABS R> < AND EXIT \ get out THEN \ if coincall=true then do this 2DROP DROP \ drop parameters FALSE \ return false flag ; Wrote this demo a while back and it seems to work. It reads the motion table and the sprite location table directly to "trap" the sprites on the screen. Spoiler \ Sprite COINC under Automotion Nov 2020 BFox \ NEEDS DUMP FROM DSK1.TOOLS NEEDS SPRITE FROM DSK1.DIRSPRIT NEEDS AUTOMOTION FROM DSK1.AUTOMOTION NEEDS HZ FROM DSK1.SOUND MARKER /DEMO DECIMAL : NEGATE.VC! ( Vaddr -- ) DUP VC@ NEGATE SWAP VC! ; : BOUNCE.X ( spr# -- ) ]SMT 1+ NEGATE.VC! ; : BOUNCE.Y ( spr# -- ) ]SMT NEGATE.VC! ; DECIMAL : TINK GEN1 1600 HZ -6 DB 40 MS MUTE ; : THUMP GEN2 150 HZ 0 DB ; : TRAP ( spr# -- ) DUP SP.X VC@ 240 1 WITHIN IF DUP BOUNCE.X TINK THEN DUP SP.Y VC@ 180 1 WITHIN IF DUP BOUNCE.Y TINK THEN DROP ; : RAINBOW ( spr# -- ) THUMP 16 3 DO I OVER SP.COLOR 25 MS 1 TRAP 2 TRAP \ keep the other guys trapped GEN2 I DB \ FADE the sound down LOOP DROP MUTE ; : SP.STOP ( spr# ) 0 0 ROT MOTION ; : COLLISION ( spr1 spr2 -- ) 2DUP 8 COINC IF ( spr2) DUP BOUNCE.X BOUNCE.Y ( spr1) DUP SP.STOP \ stop the sprite 1 DUP BOUNCE.X DUP BOUNCE.Y DUP RAINBOW \ show his displeasure :) 15 15 ROT MOTION \ start up again ELSE 2DROP THEN ; DECIMAL : TITLES 7 SCREEN PAGE CR ." CAMEL99 Forth" CR ." Automotion Coincidence Test" CR 4 21 AT-XY ." '#' and '@' will collide" ; : RUN ( motionx motiony -- ) TITLES ( char colr x y sp# vx vy spr# ) [CHAR] @ 16 90 100 0 SPRITE 14 15 0 MOTION [CHAR] # 3 200 100 1 SPRITE 20 22 1 MOTION [CHAR] Q 8 200 100 2 SPRITE 10 11 2 MOTION 1 MAGNIFY AUTOMOTION BEGIN 0 TRAP 0 1 COLLISION \ poll for trap and coincidence 1 TRAP 0 1 COLLISION 2 TRAP 0 1 COLLISION ?TERMINAL UNTIL STOPMOTION ; CR .( Type RUN to start demo) AUTOMOTION_COINC.mp4 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 3, 2020 Author Share Posted November 3, 2020 Updating the MORSE Code Demo program using WORDLISTs. The way this demo worked was to redefine letters and punctuation so that they would transmit as Morse Code. This meant that the Forth words that were single characters and part of the Morse system were now unavailable. The solution always was to use a different namespace for the Morse code characters but I didn't have that until now. I also took the liberty of adding upper case conversion to TRANSMIT so that it doesn't barf on a lower case string. Spoiler \ MORSE CODE GENERATOR for Rosetta Code Brian Fox, Feb 2016 \ Ported to Camel99 Forth May 2020 \ Updated with wordlist and lower case ability Nov 2020 NEEDS VALUE FROM DSK1.VALUES NEEDS SOUND FROM DSK1.SOUND NEEDS TOOLS FROM DSK1.TOOLS NEEDS WORDLIST FROM DSK1.WORDLISTS ONLY FORTH DEFINITIONS MARKER /MORSE HEX : LOWER? ( c -- c ?) DUP [CHAR] a [CHAR] z 1+ WITHIN ; : TOUPPER ( c -- c') LOWER? IF 5F AND THEN ; : $UPPER ( addr len -- ) BOUNDS ?DO I C@ TOUPPER I C! LOOP ; DECIMAL 750 VALUE FREQ \ 750 Hz will be the tone freq. 100 VALUE ADIT \ duration of one "dit" for ~10 words per minute : WPM ( n -- ) 1000 SWAP / 25 MAX TO ADIT ; \ Compute all durations based on ADIT : DIT_DUR ADIT MS ; : DAH_DUR ADIT 3 * MS ; : WORDGAP ADIT 5 * MS ; : OFF_DUR ADIT 2/ MS ; : LETTERGAP DAH_DUR ; \ space between letters is commonly a DAH. : TONE ( -- ) FREQ HZ 0 DB ; : MORSE-EMIT ( char -- ) DUP BL = \ check for space character IF DROP WORDGAP \ ignore char and delay ELSE PAD C! \ write char to buffer PAD 1 EVALUATE \ evaluate 1 character string LETTERGAP THEN ; : TRANSMIT ( ADDR LEN -- ) 2DUP $UPPER \ convert string, leave a copy CR \ newline, BOUNDS \ convert loop indices to address ranges DO I C@ DUP EMIT \ dup and send char to console MORSE-EMIT \ send the morse code LOOP ; \ **** new namespace stops conflict with FORTH words and numbers *** VOCABULARY MORSE ALSO MORSE DEFINITIONS \ dit and dah define all the rest : . ( -- ) TONE DIT_DUR MUTE OFF_DUR ; : - ( -- ) TONE DAH_DUR MUTE OFF_DUR ; \ define morse letters as Forth words. They transmit when executed : A . - ; : B - . . . ; : C - . - . ; : D - . . ; : E . ; : F . . - . ; : G - - . ; : H . . . . ; : I . . ; : J . - - - ; : K - . - ; : L . - . . ; : M - - ; : N - . ; : O - - - ; : P . - - . ; : Q - - . - ; : R . - . ; : S . . . ; : T - ; : U . . - ; : V . . . - ; : W . - - ; : X - . . - ; : Y - . - - ; : Z - - . . ; : 0 - - - - - ; : 1 . - - - - ; : 2 . . - - - ; : 3 . . . - - ; : 4 . . . . - ; : 5 . . . . . ; : 6 - . . . . ; : 7 - - . . . ; : 8 - - - . . ; : 9 - - - - . ; : ' - . . - . ; : \ . - - - . ; : ! . - . - . ; : ? . . - - . . ; : , - - . . - - ; : / . . . - . - ; ( SK means end of transmission in int'l Morse code) : . . - . - . - ; FORTH DEFINITIONS ( ~ 10 words per minute ) : TEST PAGE ." Morse Code Transmitter Demo" CR CR S" Let's try a lower case string." 2DUP TYPE 1000 MS CR MORSE TRANSMIT CR CR ." Now something more appropriate:" 500 MS CR S" CQ CQ CQ DE VE3CFW / K " MORSE TRANSMIT ; MORSE_CODE_WORDLIST.mp4 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 10, 2020 Author Share Posted November 10, 2020 ISR Sound List Player Re-visited As I a slowly go through the system libraries looking for unfinished bits and bobs I found my ISR sound list player. I have experimented with playing sound under the cooperative multi-tasker and it works but you have to "tune" the other programs carefully to get hard timing for the music player. The previous work meant that I had everything I needed to create named sound lists in VDP RAM but I recalled that I had never got my ISRPLAY word to actually play sounds. Page 312 of the E/A manual gave me all the detail I needed, so I thought, but my code didn't work. For some reason way back then I had not looked into the purpose of what I have seen called the AMSQ byte (>83C2) From: http://www.unige.ch/medecine/nouspikel/ti99/ints.htm#VDP ISR Four bits in byte >83C2 are used to enable/disable the first 3 functions: If the first bit (weight >80) is set, the ISR jumps directly to point 4. If the second bit (>40) is set, the ISR won't handle sprites. If the third bit (>20) is set, the ISR won't process the sound list. If the fourth bit (>10) is set, the ISR won't test the <quit> key I had learned about these control bits when I got AUTOMOTION running but had not circled back on the sound list player. Armed with knowledge it was simple to make the player work. Since I wanted this in Forth I need two machine code words to control interrupts. CODE 0LIMI ( -- ) 0300 , 0000 , NEXT, ENDCODE CODE 2LIMI ( -- ) 0300 , 0002 , NEXT, ENDCODE \ ........................................ \ ISR sound list player HEX : ISRPLAY ( vaddr -- ) 0LIMI \ interrupts off 83CC ! \ Vaddr -> sound table AMSQ C@ 5 AND AMSQ C! \ enable sound interrupts 01 83CE C! \ trigger sound processing 83FD C@ 01 OR 83FD C! \ set VDP flag 2LIMI ; \ interrupts on To make a sound list I used the VDPMEM library which lets you manage VDP memory the same way the Forth dictionary is managed. To that I added a VBYTE directive so that it is easy to transport Assembly language sound lists over to Forth. VBYTE compiles directly to VDP RAM so there is no need to take-up CPU ram space in your program if you compile from source code and then run it. Here is the CHIME example from page 322 of the E/A manual using the VBYTE directive: ( Not too much text editing required) Edit: accidently removed the CHIME code Spoiler \ chime demo sound from TI E/A Manual page 322 \ play from VDP memory with VDPBGSND HEX VCREATE CHIME VBYTE 05,9F,8F,DF,FF,E3,1 VBYTE 09,8E,01,A4,02,C5,01,90,B6,D3,6 VBYTE 03,91,B7,D4,5 VBYTE 03,92,B8,D5,4 VBYTE 05,A7,04,93,B0,D6,5 VBYTE 03,94,B1,D7,6 VBYTE 03,95,B2,D8,7 VBYTE 05,CA,02,96,B3,D0,6 VBYTE 03,97,B4,D1,5 VBYTE 03,98,B5,D2,4 VBYTE 05,85,03,90,B6,D3,5 VBYTE 03,97,B4,D1,5 VBYTE 03,95,B2,D8,7 VBYTE 05,CA,02,96,B3,D0,6 VBYTE 03,97,B4,D1,5 VBYTE 03,98,B5,D2,4 VBYTE 05,85,03,90,B6,D3,5 VBYTE 03,91,B7,D4,6 VBYTE 03,92,B8,D5,7 VBYTE 05,A4,02,93,B0,D6,6 VBYTE 03,94,B1,D7,5 VBYTE 03,95,B2,D8,4 VBYTE 05,C5,01,96,B3,D0,5 VBYTE 03,97,B4,D1,6 VBYTE 03,98,B5,D2,7 VBYTE 03,9F,BF,DF,0 /VEND For reference here is VDPMEM Spoiler \ vdp memory manager lexicon BJF \ VDP Memory Usage in Camel99 Forth when this file is loaded \ | VDP screen | \ + --------------| \ | RESERVED | sprites, patterns color tables \ | | \ +---------------+ HEX 1000, VDP HEAP start \ | VHERE | VDP heap moves upwards \ | . | \ | . | \ | . | \ | . | \ | | \ | | \ | | ^^^^^^^ \ | ^^^^^^^ | move downwards \ | PAB stack | PABs start here \ +---------------+ <-- VDPTOP returns this address \ | 99 O/S space | \ |---------------| \ INCLUDE DSK1.TOOLS \ debugging only \ VARIABLE VP ( moved to kernel for V2.55 ) HEX 1000 VP ! \ "VDP pointer" start of free VDP RAM : VHERE ( -- addr) VP @ ; \ FETCH the value in VDP pointer : VALLOT ( n -- ) VP +! ; \ add n to the value in VDP pointer : VC, ( n -- ) VHERE VC! 1 VALLOT ; : V, ( n -- ) VHERE V! 2 VALLOT ; : VCOUNT ( vdp$adr -- vdpadr len ) DUP 1+ SWAP VC@ ; : VCREATE ( <text> -- ) VHERE CONSTANT ; \ address when <text> invoked The complete sound player lib file Spoiler \ ISR Sound player for Camel99 Forth Jan 10, 2019 BJF \ Changed to use VDPMEM library Nov 10, 2020 BJF NEEDS VHERE FROM DSK1.VDPMEM 83C2 CONSTANT AMSQ \ interrupt DISABLE bits \ AMSQ bit meaning: \ 80 all interrupts disabled \ 40 motion disabled \ 20 Sound disabled \ 10 quit key disabled \ VDP BYTE directive: compile bytes into VDP RAM : VBYTE ( -- ) \ read input stream of bytes and compile to VDP mem. BEGIN [CHAR] , PARSE-WORD DUP ( -- adr len len ) WHILE EVALUATE DUP FF00 AND ABORT" Not a byte" VC, REPEAT 2DROP ; : /VEND ( -- ) 0 VC, ; \ compile a zero BYTE into VDP RAM CODE 0LIMI ( -- ) 0300 , 0000 , NEXT, ENDCODE CODE 2LIMI ( -- ) 0300 , 0002 , NEXT, ENDCODE \ ........................................ \ ISR sound list player HEX : ISRPLAY ( vaddr -- ) 0LIMI \ interrupts off 83CC ! \ Vaddr -> sound table AMSQ C@ 5 AND AMSQ C! \ enable sound interrupts 01 83CE C! \ trigger sound processing 83FD C@ 01 OR 83FD C! \ set VDP flag 2LIMI ; \ interrupts on \ example list 1000 VP ! \ reset VDP memory heap VCREATE PACMAN VBYTE 6,86,0D,97,AC,1A,B7,8 VBYTE 2,8F,08,2 VBYTE 2,AB,23,5 VBYTE 2,86,0D,4 VBYTE 1,BF,3 VBYTE 2,8E,0B,8 VBYTE 2,8A,0A,2 VBYTE 3,AC,1A,B7,8 VBYTE 2,9F,BF \ mute generators 1 & 2 /VEND isrsound_camel_forth.mp4 2 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted November 10, 2020 Share Posted November 10, 2020 1 hour ago, TheBF said: [CHAR] , PARSE-WORD How does PARSE-WORD know to stop at the end of a VBYTE comma-delimited string without a terminal comma? I ask this with a passing interest in how I might implement such a thing in fbForth, where I would actually need a pair of commas to get a token with a null length were there any spaces after the string as there would surely be in LOADing a block with such code. ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 10, 2020 Author Share Posted November 10, 2020 It seems to take what ever is left at the end up to the "enter" key. The CODE is rather hard to follow but here it is. I recently took PARSE from GForth because it was simpler that Brad's version. Of course PARSE et al. is part of the push to stack strings versus counted strings however they have not deprecated FIND and so WORD is still required. It's not easy to shepherd a language standard especially one that doesn't actually have syntax. :-)))) Spoiler : SOURCE ( -- addr len) 'SOURCE 2@ ; \ Common factor, saves space : PARSE ( char -- c-addr u ) \ gForth >R SOURCE >IN @ OVER MIN /STRING OVER SWAP R> SCAN >R OVER - DUP R> IF 1+ THEN >IN +! ; : PARSE-WORD ( char -- c-addr n) \ Camel/BFox common factor for WORD DUP SOURCE >IN @ /STRING ROT SKIP DROP SOURCE -ROT - MIN 0 MAX >IN ! PARSE ; : WORD ( char -- c-addr) PARSE-WORD HERE 2DUP C! \ store length byte count 1+ SWAP CMOVE \ write the string to HERE HERE BL OVER COUNT + C! ; \ append BLank character For reference here is /STRING SKIP and SCAN Spoiler CODE: /STRING ( c-addr1 u1 n -- c-addr2 u2 ) TOS *SP SUB, TOS 2 (SP) ADD, TOS POP, NEXT, END-CODE Spoiler CODE: SKIP ( c-addr u char -- c-addr' u') \ skip matching chars TOS SWPB, 2 (SP) W MOV, \ get address->w, leave space on stack *SP+ R1 MOV, \ POP count into R1, char is already in TOS NE IF, \ if r1=0 get out BEGIN, TOS *W+ CMPB, \ does character match? auto-incr. address @@2 JNE, \ NO MATCH jump out R1 DEC, \ decr loop counter EQ UNTIL, \ loop until R1=0 @@2: W DEC, \ correct result address after auto-inc. ENDIF, W *SP MOV, \ store updated address on stack R1 TOS MOV, \ updated count to TOS NEXT, END-CODE CODE: SCAN ( adr len char -- adr' len' ) \ find matching char TOS SWPB, 2 (SP) W MOV, \ get address->w *SP+ R1 MOV, \ POP count into R1, char is already in TOS NE IF, \ R1<>0 ? BEGIN, TOS *W CMPB, \ does character match? @@2 JEQ, \ YES, we are done, JUMP OUT W INC, \ next character R1 DEC, \ dec. loop counter EQ UNTIL, \ hit end of string, jmp out ENDIF, @@2: W *SP MOV, \ store updated address on stack R1 TOS MOV, \ updated count to TOS NEXT, END-CODE Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted November 10, 2020 Share Posted November 10, 2020 41 minutes ago, TheBF said: It seems to take what ever is left at the end up to the "enter" key. I figured as much. With fbForth, a null (which is waiting in the TIB where <enter> was hit, as well as at the end of any block buffer) will stop parsing, but, again, everything between the last delimiter and those nulls will be part of the last token. That will probably work as long as there is nothing but spaces after the last good datum. However, putting two VBYTE constructs on the same line will probably not end well because EVALUATE will properly put the last byte of the first VBYTE on the stack, but will surely interpret the second VBYTE before the first one can finish. ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 10, 2020 Author Share Posted November 10, 2020 5 minutes ago, Lee Stewart said: I figured as much. With fbForth, a null (which is waiting in the TIB where <enter> was hit, as well as at the end of any block buffer) will stop parsing, but, again, everything between the last delimiter and those nulls will be part of the last token. That will probably work as long as there is nothing but spaces after the last good datum. However, putting two VBYTE constructs on the same line will probably not end well because EVALUATE will properly put the last byte of the first VBYTE on the stack, but will surely interpret the second VBYTE before the first one can finish. ...lee Yes on the same line would end badly. I think it would be ok if you added the final comma. Not at my machine right now but I will test that. Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 11, 2020 Author Share Posted November 11, 2020 5 hours ago, Lee Stewart said: I figured as much. With fbForth, a null (which is waiting in the TIB where <enter> was hit, as well as at the end of any block buffer) will stop parsing, but, again, everything between the last delimiter and those nulls will be part of the last token. That will probably work as long as there is nothing but spaces after the last good datum. However, putting two VBYTE constructs on the same line will probably not end well because EVALUATE will properly put the last byte of the first VBYTE on the stack, but will surely interpret the second VBYTE before the first one can finish. ...lee Lee your fastidiousness made me re-think this. Here is an alternative that will error out if there is anything on the line but numbers and commas -OR- if the number is not a byte This will of course preclude comments as well, which EVALUATE handles as a matter of course, but oh well. What do you think? EDIT: To make it less error prone I add BL SKIP to remove leading blanks before the numbers : VBYTE ( -- ) \ read input stream of bytes and compile to VDP mem. BEGIN [CHAR] , PARSE-WORD BL SKIP DUP ( -- adr len len ) WHILE NUMBER? ( -- n ?) \ text->n ?=0 if good OVER FF00 AND \ test if we have a byte OR ABORT" VBYTE error" \ Error out on either VC, REPEAT 2DROP ; 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 11, 2020 Author Share Posted November 11, 2020 80 COL VIBE Editor by Sam Falvo. I finally have this interesting editor working reliably on TI-99. It is only 80 columns at the moment because I wanted to work on the editing functions and not the screen display. It works very much like VI but on Forth block files. VI is pretty strange if you have never encountered it, but it has a following. One of the interesting things in this code, that I have never done, is just drop an item off the return stack to escape from a part of the program. See the definition for ?CONFIRM. Spoiler \ VIBE Release 2.2 \ Copyright (c) 2001-2003 Samuel A. Falvo II \ All Rights Reserved \ * Use with written permission for Camel99 Forth * \ \ Highly portable block editor -- works under nearly every ANS Forth \ I can think of, and with only a single screenful of words, will \ work under Pygmy and FS/Forth too. \ \ USAGE: vibe ( n -- ) Edits block 'n'. Sets SCR variable to 'n'. \ ed ( -- ) From Pygmy. Re-edits last edited block. \ \ \ 2.1 -- Fixed stack overflow bugs; forgot to DROP in the non-default \ key handlers. \ \ 2.2 Ported to CAMEL99 Forth B. Fox 2019 \ Removed some character constants to save space. \ Changed TYPE for VTYPE. \ Removed shadow block function \ Added some block navigation commands \ 2.3 Fixed keyboard bugs for TI-99/4A \ VI command takes a filename parameter like real VI \ simplfied wipe screen logic and saved bytes \ Add $ command: goto end of line \ Add PC delete KEY for Classic99 NEEDS DUMP FROM DSK1.TOOLS NEEDS 80COLS FROM DSK1.80COL NEEDS RKEY FROM DSK1.RKEY NEEDS BLOCK FROM DSK1.BLOCKS NEEDS -TRAILING FROM DSK1.TRAILING MARKER /VIBE HERE ( Editor Constants ) CHAR i CONSTANT 'i \ Insert mode CHAR c CONSTANT 'c \ Command mode \ camel99 values DECIMAL 64 CONSTANT WIDTH 80 CONSTANT MAXBLKS ( Editor State ) VARIABLE SCR \ Current block VARIABLE X \ Cursor X position 0..63 VARIABLE Y \ Cursor Y position 0..15 VARIABLE MODE \ current mode: INSERT or command ( 'i OR 'c \ CMDNAME the command string, is built, found and executed CREATE CMDNAME 5 C, CHAR $ C, CHAR $ C, 0 C, 0 C, 0 C, ( Editor Display ) DECIMAL : BLANKS BL FILL ; \ BF add : MODE. 63 0 AT-XY MODE @ EMIT ; : VTYPE ( addr len -- ) TUCK VPOS SWAP VWRITE VCOL +! ; : SCR. 0 0 AT-XY S" Block: " VTYPE SCR @ . ( S" " VTYPE ) ; : HEADER SCR. MODE. ; : 8-S S" --------" VTYPE ; : WIDTH-S 8-S 8-S 8-S 8-S 8-S 8-S 8-S 8-S ; : BORDER SPACE WIDTH-S CR ; : ROW ( addr -- addr') DUP 63 VTYPE 64 + ; \ FAST \ : ROW ( addr -- addr') DUP 63 TYPE 63 + ; \ SLOW : LINE ." |" ROW CR ; : 4LINES LINE LINE LINE LINE ; : 16LINES SCR @ BLOCK 4LINES 4LINES 4LINES 4LINES DROP ; : CARD 0 1 AT-XY BORDER 16LINES BORDER ; : CURSOR X @ 1+ Y @ 2+ AT-XY ; : SCREEN HEADER CARD CURSOR ; ( Editor State Control ) : INSERT 'i MODE ! ; : REPLACE [CHAR] r MODE ! ; : CMD 'c MODE ! ; : BOUNDED ( addr n -- ) 0 MAX MAXBLKS MIN SWAP ! ; : PREVBLOCK SCR DUP @ 1- BOUNDED ; : NEXTBLOCK SCR DUP @ 1+ BOUNDED ; \ : TOGGLESHADOW 1 SCR @ XOR SCR ! ; ( Editor Cursor Control ) : FLUSHLEFT 0 X ! ; : BOUNDX X @ 0 MAX 63 MIN X ! ; : BOUNDY Y @ 0 MAX 15 MIN Y ! ; : BOUNDXY BOUNDX BOUNDY ; : LEFT X 1-! BOUNDXY ; : RIGHT X 1+! BOUNDXY ; : UP Y 1-! BOUNDXY ; : DOWN Y 1+! BOUNDXY ; \ : beep 7 EMIT ; : NEXTLINE Y @ 15 < IF FLUSHLEFT DOWN THEN ; : NEXT X @ 63 = IF NEXTLINE EXIT THEN RIGHT ; ( Editor Insert/Replace Text ) : WIDTH* 6 LSHIFT ; \ x64 : WHERE SCR @ BLOCK SWAP WIDTH* + SWAP + ; : WH X @ Y @ WHERE ; : SOL 0 Y @ WHERE ; : EOL 63 Y @ WHERE ; : PLACE WH C! UPDATE NEXT ; : -EOL? X @ 63 < ; : OPENR WH DUP 1+ 63 X @ - MOVE ; : OPENRIGHT -EOL? IF OPENR THEN ; : INSERTING? MODE @ 'i = ; : CHR INSERTING? IF OPENRIGHT THEN PLACE ; : EOTEXT SOL 63 -TRAILING NIP X ! ; : NEXTWORD WH EOL OVER - DUP -ROT ( len adr len) BL SKIP \ skip spaces BL SCAN \ find next space NIP - 1+ X ! BOUNDX WH ; ( Editor Keyboard Handler CMDWORD encoding) \ CMD name key: $ $ _ _ _ \ | | | \ 'c'=command mode --+ | | \ 'i"=ins/repl mode | | \ | | \ Key code (hex#) -----+-+ \ \ Called with ( k -- ) where k is the ASCII key code. ( Editor COMMANDS: Quit, cursor, block, et. al. ) ( Modified for Ti-99 keyboard ) : $$c51 DROP 0 19 AT-XY R> R> DROP >R ; \ : -- quit main loop : $$c30 DROP FLUSHLEFT ; \ 0 goto start of line : $$c24 DROP EOTEXT ; \ $ goto end of line : $$c69 DROP INSERT ; \ i : $$c49 DROP FLUSHLEFT INSERT ; \ I : $$c52 DROP REPLACE ; \ R : $$i0F DROP CMD ; \ (escape) GOTO command mode : $$c68 DROP LEFT ; \ h : $$c6A DROP DOWN ; \ j : $$c6B DROP UP ; \ k : $$c6C DROP RIGHT ; \ l : $$c5B DROP PREVBLOCK ; \ [ \ : $$c5C DROP TOGGLESHADOW ; \ \ : $$c5D DROP NEXTBLOCK ; \ ] : $$c77 DROP NEXTWORD ; \ w ( Editor Backspace/Delete ) : PADDING BL EOL C! UPDATE ; : DEL WH DUP 1+ SWAP 63 X @ - MOVE ; : DELETE -EOL? IF DEL THEN PADDING ; : BS LEFT DELETE ; : BACKSPACE X @ 0 > IF BS THEN ; ( Editor Carriage Return ) : NEXTLN EOL 1+ ; : #CHRS SCR @ BLOCK 1024 + NEXTLN - WIDTH - ; : COPYDOWN Y @ 14 < IF NEXTLN DUP WIDTH + #CHRS MOVE THEN ; : BLANKDOWN NEXTLN WIDTH BLANKS UPDATE ; : SPLITDOWN WH NEXTLN 2DUP SWAP - MOVE ; : BLANKREST WH NEXTLN OVER - BLANKS ; : OPENDOWN COPYDOWN BLANKDOWN ; : SPLITLINE OPENDOWN SPLITDOWN BLANKREST ; : RETRN INSERTING? IF SPLITLINE THEN FLUSHLEFT NEXTLINE ; : RETURN Y @ 15 < IF RETRN THEN ; ( Editor Wipe Block ) \ simplified by BFox HEX : >UPPER ( c -- c') 5F AND ; DECIMAL : PROMPT 0 19 AT-XY ; : MSG PROMPT ." Are you sure? (Y/N) " ; : CLRMSG PROMPT WIDTH SPACES ; : NO? MSG KEY >UPPER CLRMSG [CHAR] Y <> ; : ?CONFIRM NO? IF R> DROP THEN ; : WIPE ?CONFIRM SCR @ BLOCK 1024 BLANKS UPDATE 0 X ! 0 Y ! ; ( Editor Commands: backspace, delete, et. al. ) : $$i04 DROP DELETE ; \ ^D : $$i03 DROP DELETE ; \ PC delete key : $$i08 DROP BACKSPACE ; \ Backspace \ : $$i7F DROP BACKSPACE ; \ DEL -- for Unix : $$i0D DROP RETURN ; \ Enter : $$c5A DROP WIPE ; \ Z : $$c6F DROP OPENDOWN DOWN $$c49 ; \ o : $$c4F DROP OPENDOWN ; \ O : $$i15 DROP X OFF Y OFF ; \ "HOME" key INSERT mode : $$c15 $$i15 ; HEX 0F CONSTANT $0F F0 CONSTANT $F0 : KEYBOARD RKEY 7F AND ; \ for TI-99 we need to mask upper bit DECIMAL : CMD? MODE @ 'c = ; : INS? MODE @ 'i = MODE @ [CHAR] r = OR ; : MODE! INS? 'i AND CMD? 'c AND OR CMDNAME 3 + C! ; : >HEX DUP 9 > IF 7 + THEN [CHAR] 0 + ; : H! DUP $F0 AND 4 RSHIFT >HEX CMDNAME 4 + C! ; : L! $0F AND >HEX CMDNAME 5 + C! ; : NAME! MODE! H! L! ; : NOMAPPING DROP ['] HONK CMD? AND ['] CHR INS? AND OR ; \ : .CMDNAME 68 0 AT-XY CMDNAME COUNT TYPE ; \ debugging : HANDLERWORD NAME! CMDNAME ( .CMDNAME) FIND 0= IF NOMAPPING THEN ; : HANDLER DUP HANDLERWORD EXECUTE ; : EDITOR 'c MODE ! BEGIN KEYBOARD HANDLER SCREEN ?BREAK AGAIN ; : VIBE ( n -- ) DECIMAL SCR ! PAGE SCREEN EDITOR ; \ VI command additions : VI ( <path>) BL PARSE-WORD DUP 0> IF OPEN-BLOCKS SCR OFF THEN SCR @ VIBE ; : LIST ( n -- ) SCR ! PAGE SCREEN 50 18 AT-XY ; : ?BREAK ?TERMINAL ABORT" *BREAK*" ; : INDEX ( from to -- ) 1+ SWAP ?DO CR I 4 .R 2 SPACES I BLOCK 64 TYPE ?BREAK LOOP ; \ VI like command interpreter is handled by Forth interpreter : :X ." Saving... " FLUSH ; : :WQ :X ." Removing VIBE" /VIBE CR ; SCR OFF 80COLS HERE SWAP - DECIMAL . .( bytes) VIBE DEMO.mp4 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted November 11, 2020 Share Posted November 11, 2020 8 hours ago, TheBF said: One of the interesting things in this code, that I have never done, is just drop an item off the return stack to escape from a part of the program. See the definition for ?CONFIRM. There are one or two other words in fbForth 2.0 that use that device, but the following definition of “<null>” is from figForth and is how INTERPRET (an infinite loop) is exited at the end of the TIB or a disk block: \ The name of this word is actually a true null, i.e., ASCII 0 : <null> ( --- ) \ <null> = 0 BLK @ IF ?EXEC THEN R> DROP ; IMMEDIATE ...lee 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 12, 2020 Author Share Posted November 12, 2020 A Different (Better?) Case Statement I am going over ED99 code which has a big (inefficient) Eaker case statement in it for the key handler. HEX : KEYHANDLER ( char -- ) \ TI-99 BASIC key codes used CASE 01 OF +TAB ENDOF \ TAB 02 OF PGDN ENDOF \ FCTN 6 03 OF DEL-CHAR ENDOF \ PC Delete / FCTN 1 04 OF TOGGLE ENDOF \ PC Insert / FCTN 2 06 OF NEW-LINE ENDOF \ FCTN 8 07 OF DEL-LINE ENDOF \ FCTN 3 08 OF LEFT ENDOF \ FCTN S 09 OF RIGHT ENDOF \ FCTN D 0A OF CURSDWN ENDOF \ FCTN X 0B OF CURSUP ENDOF \ FCNT E 0C OF PGUP ENDOF \ FCTN 4 0D OF ENTER ENDOF \ ENTER 0F OF ESCAPE ENDOF \ Esc 81 OF COPYALL ENDOF \ ^A 83 OF COPY-LINE ENDOF \ ^C 84 OF TOEND ENDOF \ ^D 86 OF LASTSRCH @ LOCATE ENDOF \ ^F 90 OF APPENDALL ENDOF \ ^P 93 OF BSPACE ENDOF \ ^backspace 95 OF TOSTART ENDOF \ ^U / PC Home 96 OF PASTE ENDOF \ ^V 99 OF CUT ENDOF \ ^Y 9B OF 1 +FILE ENDOF \ ^> B7 OF -TAB ENDOF \ ^TAB 80 OF -1 +FILE ENDOF \ ^< HONK ENDCASE RKEY? DROP \ clear any accidental keys ; I had played around with something simpler and it seems to work just as well and saves over 100 bytes in the project. And it is faster because it doesn't have to go through the whole chain to get out. The BREAK; word use EXIT which is like an R> DROP so it jumps out of the routine right away when a match is detected : CASE: ( -- ) POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; IMMEDIATE : BREAK; POSTPONE EXIT POSTPONE THEN ; IMMEDIATE The revised code version is very little different but the repeating key is faster now when cursoring around because of the faster CASE: HEX : KEYHANDLER ( char -- ) \ TI-99 BASIC key codes used 01 CASE: +TAB BREAK; \ TAB 02 CASE: PGDN BREAK; \ FCTN 6 03 CASE: DEL-CHAR BREAK; \ PC Delete / FCTN 1 04 CASE: TOGGLE BREAK; \ PC Insert / FCTN 2 06 CASE: NEW-LINE BREAK; \ FCTN 8 07 CASE: DEL-LINE BREAK; \ FCTN 3 08 CASE: LEFT BREAK; \ FCTN S 09 CASE: RIGHT BREAK; \ FCTN D 0A CASE: CURSDWN BREAK; \ FCTN X 0B CASE: CURSUP BREAK; \ FCNT E 0C CASE: PGUP BREAK; \ FCTN 4 0D CASE: ENTER BREAK; \ ENTER 0F CASE: ESCAPE BREAK; \ Esc 81 CASE: COPYALL BREAK; \ ^A 83 CASE: COPY-LINE BREAK; \ ^C 84 CASE: TOEND BREAK; \ ^D 86 CASE: LASTSRCH @ LOCATE BREAK; \ ^F 90 CASE: APPENDALL BREAK; \ ^P 93 CASE: BSPACE BREAK; \ ^backspace 95 CASE: TOSTART BREAK; \ ^U / PC Home 96 CASE: PASTE BREAK; \ ^V 99 CASE: CUT BREAK; \ ^Y 9B CASE: 1 +FILE BREAK; \ ^> B7 CASE: -TAB BREAK; \ ^TAB 80 CASE: -1 +FILE BREAK; \ ^< HONK RKEY? DROP \ clear any accidental keys ; Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 27, 2020 Author Share Posted November 27, 2020 Faster Forth Programs So I have been head-down working on getting something working that I wanted to make for while. I did not have all the modules needed until recently. The Classic Forth system works on a system called indirect-threaded code. Programs consist of lists of addresses where the addresses point to some machine code operation that runs the CPU code that does the job. In the last 25 years the inventor of Forth, Charles Moore, has abandoned that approach for his own projects favouring instead something he first called Machine Forth and later evolved into Color Forth. Machine Forth creates native code programs like Assembler or C but uses Forth syntax. The programs also typically do not have the text names of the words in the final binary program as well. The way it is done is to create a set of primitive functions that operate like Assembler macros and compile a few instructions directly into memory. For example here the machine code version of the Forth word '1+' which increments the value on the top of the data stack. : 1+ ( n -- n') TOS INC, ; This is a Forth "word" but when you invoke it, it writes real machine language into a memory image location. That's the general concept. The devil is in the details but I have something that is a working. It is a remarkably different way to make a compiler. It's really assembler but the machine details are still hidden behind a virtual 2 stack machine. To make a practical Machine Forth system but I needed the following pieces of infrastructure: Name space management. The compiler needs to be able to select between Forth words that operate the compiler and Forth words that compile machine code even if they have the same name. Code to save the finished program image as a stand alone program loadable by TI-99. I had made a Cross-assembler before which gave me a foundation. With the creation of the WORDLISTS I got namespace management. The final piece will be modifying SAVESYS to work correctly with a binary image in Low RAM. At the moment it only works for code starting at >A000...FFFF I am using ideas from: "FORTH PROGRAMMERS HANDBOOK", 1997-2010, Conklin and Rather, to handle namespaces by setting the search order of the different VOCABULARYs (See: COMPILER: TARGET: HOST: in the spoiler) As with all Forth cross-compilers there are extra incantations required to handle some details but the code is pretty normal Forth in the program sections as seen below: Differences: One difference is numbers in Moore's machine Forth require the # and they compile into the TOS register with a LI instruction. Another difference is the words IF and WHILE do not consume their stack argument. This is efficient since we many times use DUP before these words. In Machine Forth the programmer has to DROP the argument when they are finished with it. Also there is a NOT IF ( -IF) and NOT WHILE ( -WHILE) so that you don't have to use a logic inversion on some loops. The native CPU status register is used for branching as well unlike standard Forth. Many of these ideas came from designing Forth hardware and realizing some of Forth's early ideas did not work as well on real silicon in native code. \ MFORTH DEMO #3: Use separate workspace, return to Camel99 NEEDS TARGET: FROM DSK2.MFORTH \ Compiler Preamble COMPILER: NEW. HEX 2000 ORIGIN. \ allocate stacks \ *STACKS descend so we allot 1st, then create the name 20 CELLS ALLOT CREATE DSTK2 20 CELLS ALLOT CREATE RSTK2 CREATE WKSP2 12 CELLS ALLOT \ create the workspace TARGET: : MYWORD ( -- n ) \ a simple sub-routine 994A # 1+ 1+ 2- ; \ PROG: section does initialization, sets program start address PROG: DEMO4 WKSP2 WORKSPACE DSTK2 DSTACK RSTK2 RSTACK \ program begins FFFF # BEGIN 1- WHILE \ *MForth WHILE does not consume parameter MYWORD DROP REPEAT DROP 8300 WORKSPACE \ restore FORTH workspace NEXT, \ return to Camel99 Forth END. \ end directive test program size, tests for stack junk So what the difference? The final program is much faster. DEMO4 ( 65536 iterations) above runs in 8.5 seconds versus 25.6 seconds in threaded Camel Forth. And when I put DEMO4 in the >8300 workspace it ran in 6.3 seconds! The programs are less space efficient in general but because many Machine Forth instructions convert to very few 9900 instructions and because we don't keep the dictionary in the program the difference is less than one might expect. Specifics: The 34 Machine Forth "inline instructions" that are created consume on average 3.7 bytes and 1.6 CPU instructions. The threaded Forth version of the program including the dictionary header for both MYWORD and DEMO4 added 60 bytes to the Forth system. The machine Forth program, not including the stacks and workspace, used 61 bytes. Machine Forth introduces the "address register", an extra data storage space. This is to minimize stack juggling when indexing through memory and it also leverages the auto increment feature of the CPU. (I have not played with that yet but I like the idea) Overall it is a fun exercise and it should be possible to make significant programs in the 8K of low RAM. It could also be used to make fast code modules for threaded Forth systems that are loaded into RAM and called rather than using assembler. If I wanted bigger programs I could use disk virtual memory or SAMS memory. It's not ready for release yet but I am pleased with the preliminary results. Another fun feature is that with addition of a RUN command I can branch into this compiled program and then return to Camel99 Forth. How fun is that? The compiler in 185 lines of Forth: (It's bigger that Charles Moore's version) Edit: As I go through this code I am finding many errors and wrong ideas so this will be changing as I work on it. Spoiler \ MACHINE FORTH COMPILER Nov 2020 Brian Fox, Kilworth Ontario NEEDS LOAD-FILE FROM DSK1.LOADSAVE NEEDS .S FROM DSK1.TOOLS NEEDS ORG FROM DSK2.TINYXASM \ CROSS-COMPILER Name Space management FORTH DEFINITIONS VOCABULARY MFORTH \ for mforth compiler words VOCABULARY TARGET \ for words in the compiled program : HOST: ONLY MFORTH ALSO XASSEMBLER ALSO FORTH DEFINITIONS ; : TARGET: ONLY FORTH ALSO XASSEMBLER ALSO MFORTH ALSO TARGET DEFINITIONS ; : COMPILER: ONLY FORTH ALSO XASSEMBLER ALSO MFORTH DEFINITIONS ; \ Rename HOST FORTH version of colon/semi-colon. Will be used to define \ target compiler colon & semi-colon : ;H POSTPONE ; ; IMMEDIATE : H: : ;H \ Cross-compiler and image management COMPILER: HEX VARIABLE LORG A000 LORG ! \ LORG is TI-99 load address VARIABLE XSTATE 2000 CONSTANT CDATA \ CODE compiles to this buffer CDATA CELL+ CONSTANT 'BOOT \ holds program boot address CODE RUN ( addr -- ) 0460 , CDATA , ENDCODE \ 2000 @@ B, \ cross-compiler directives : NEW. 1000 2000 0 VFILL \ erase VDP RAM 8K block CDATA 2000 FF FILL \ fill program space with FFFF CDATA ORG \ reset program pointer to beginning DEAD @@ B, \ Compile 1ST instruction. branch to DEAD address ; : ORIGIN. ( addr ) LORG ! ; \ use for relocatable origin : EVEN. TDP @ ALIGNED TDP ! ; : RELOCATE ( Taddr -- addr') CDATA - LORG @ + ; : AUTOBOOT ( addr -- ) RELOCATE 'BOOT ! ; \ create a label in HOST Forth \ Returns a relocated TARGET address when executed : L: CREATE THERE , DOES> @ RELOCATE ; \ nestable sub-routines ** MUST END WITH RET, ** : RET, ( -- ) R11 RPOP, RT, ; \ nestable return psuedo-instruction \ machine Forth colon/semi-colon (creates nestable sub-routines) : M: CREATE !CSP THERE , \ remember the program address in the HOST R11 RPUSH, \ compile "enter sub-routine" code DOES> @ RELOCATE S" @@ BL," EVALUATE ; \ compile BL to : ;M RET, ?CSP ; \ compile exit sub-routine code \ text compiling word in MFORTH VOCABULARY : S, ( c-addr u -- ) THERE OVER 1+ TALLOT PLACE EVEN. ; \ Forth virtual machine setup directives : WORKSPACE ( addr --) LWPI, ; \ Forth workspace : DSTACK ( addr --) SP SWAP LI, ; \ data stack : RSTACK ( addr --) RP SWAP LI, ; \ return stack \ hi-level Forth compiling words COMPILER: : VARIABLE CREATE THERE , \ remember variable's target address 0 T, \ compile 0 into that target address DOES> @ # ; \ INVOKED: compile the address as literl no. : CONSTANT CREATE ( n) , \ Compile value in Host Forth DOES> @ # ; \ generate code to compile n as literal no. : CREATE THERE CONSTANT ; \ **CARE! only returns address to compiler : ALLOT TALLOT ; : PROG: ( -- <label> ) CREATE !CSP THERE DUP , \ record code location AUTOBOOT \ store address in program header XSTATE ON DOES> @ ; \ Runtime: return relocated address : END. ?CSP THERE DUP 3FFF > ABORT" Prog > 8K" XSTATE OFF ; \ ---------------------------------------------------------- COMPILER: CR .( Structured branching and looping ) \ compile an offset byte into the 2nd byte of a JUMP instruction : OFFSET, ( byte --) 2- 2/ SWAP 1+ C! ; : <BACK ( addr addr' -- ) TUCK - OFFSET, ; : IF ( -- $$ ) THERE 0 JEQ, ; \ goto THEN if TOS=0 : -IF ( -- $$ ) THERE 0 JGT, ; \ goto THEN if TOS not negative : THEN ( addr --) THERE OVER - OFFSET, ; : ELSE ( -- $$ ) THERE 0 JMP, SWAP THEN ; : BEGIN THERE ; : WHILE IF SWAP ; \ loop while TOS <> 0 : -WHILE -IF SWAP ; \ loop while TOS = 0 : AGAIN ( addr --) THERE 0 JMP, <BACK ; : UNTIL ( addr --) THERE 0 JNE, <BACK ; : REPEAT AGAIN THEN ; CR .( Forth Intrinics) \ primitives that compile inline HEX TARGET: : CALL, ( label -- ) \ call a label R11 RPUSH, ( label) @@ BL, R11 RPOP, ; : -; ( addr --) @@ B, ; \ Jump to word ie: tail call optimization : DUP ( n -- n n) TOS PUSH, ; \ 4 bytes : # ( n -- ) DUP TOS SWAP LI, ; \ 8 bytes : @ ( addr -- n) DUP @@ TOS MOV, ; \ 8 bytes : DROP ( n -- ) *SP+ TOS MOV, ; \ 2 bytes : ! ( n addr -- ) *SP+ *TOS MOV, DROP ; \ 8 bytes : 2* ( n -- n ) TOS 1 SLA, ; : 2/ ( n -- n) TOS 1 SRA, ; : - ( n -- ) TOS INV, ; : AND, ( n mask -- n) *SP INV, *SP+ TOS SZC, ; \ (option 1) : #AND ( n n -- n ) TOS SWAP ANDI, ; \ (option 2 ) : XOR ( n n -- n) *SP+ TOS XOR, ; \ (option 1) : + ( n n -- n) *SP+ TOS ADD, ; \ (option 1) : #+ ( n n -- ) TOS SWAP AI, ; \ (option 2) \ return stack operators : >R ( n -- ) TOS RPUSH, ; \ PUSH in original Machine Forth : R> ( -- n) DUP, TOS RPOP, ; \ POP in original Machine Forth : R@ ( -- n ) DUP *RP TOS MOV, ; : !R ( n -- ) TOS *RP+ MOV, ; \ undocumented ?? \ Address register ( R9 ) control : A@ ( -- addr) DUP AREG TOS MOV, ; : A@+ ( -- n) DUP *AREG+ TOS MOV, ; : A! ( addr -- ) TOS AREG MOV, DROP ; : A!+ ( n -- ) TOS *AREG+ MOV, ; : OVER ( n1 n2 -- n1 n2 n1) DUP, 2 (SP) TOS MOV, ; : NIP ( n1 n2 -- n2) SP INCT, ; \ ==============[ Chuck Moore Machine Forth ends ]============= \ Machine Forth for F21 CPU did not have swap. What? Really. : SWAP ( n1 n2 -- n2 n1) TOS W MOV, *SP TOS MOV, W *SP MOV, ; \ 9900 instructions that leverage the processor's instruction set : 1+ ( n -- n') TOS INC, ; : 2+ ( n -- n') TOS INCT, ; : 1- ( n -- n') TOS DEC, ; : 2- ( n -- n') TOS DECT, ; \ inc/dec variables directly : 1+! ( n -- n') *TOS INC, ; : 2+! ( n -- n') *TOS INCT, ; : 1-! ( n -- n') *TOS DEC, ; : 2-! ( n -- n') *TOS DECT, ; : := ( var1 var2 --) SWAP @@ SWAP @@ MOV, ; \ assign var1 to var2 : NOP ( -- ) 0 JMP, ; : >< ( n -- n) SWPB, ; \ Last definitions: \ alias mforth compiler colon/semi-colon words H: ; ;M ;H H: : M: ;H PAGE ." Machine Forth Cross-compiler 1.0" CR 3 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted November 27, 2020 Share Posted November 27, 2020 Impressive! I have sometimes thought about compiling fbForth programs to machine code, but was daunted by how to manage the compiled program with/without block buffers (text files, line by line to the TIB with no block buffers?) or handling the support routines differently (inline code?)—titillating, to say the least! ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted November 27, 2020 Author Share Posted November 27, 2020 3 hours ago, Lee Stewart said: Impressive! I have sometimes thought about compiling fbForth programs to machine code, but was daunted by how to manage the compiled program with/without block buffers (text files, line by line to the TIB with no block buffers?) or handling the support routines differently (inline code?)—titillating, to say the least! ...lee Ya the big eye opener for me was finding an old article describing Chuck's system for the F21 CPU and he used a DOS Forth called FPC by Tom Zimmer to build the cross-compiler for his CPU! He used the threaded system to make the native code system. So then it became achievable in my eyes. His is so sparse however it is barely recognizable but that's Chuck. Always trying to remove things from his code. Anyway when I get this stable and making finished binary programs I may take a run at building a full Forth kernel sub-routine threaded just to see how it performs. It will easily be 50..60% bigger than my 8K kernel but it's a goal to keep an old guy working. 1 Quote Link to comment Share on other sites More sharing options...
GDMike Posted November 27, 2020 Share Posted November 27, 2020 Btw...Tom Zimmer here. http://www.mailsend-online.com/blog/an-interview-with-tom-zimmer-forth-system-developer.html Quote Link to comment Share on other sites More sharing options...
GDMike Posted November 27, 2020 Share Posted November 27, 2020 (edited) Mr. Zimmer once said.. "Well, I describe myself as a C programmer, who is really a Forth programmer". I suppose he's right as far as making a living in programming revenue. Edited November 27, 2020 by GDMike Quote Link to comment Share on other sites More sharing options...
+FarmerPotato Posted November 27, 2020 Share Posted November 27, 2020 This is eye-popping amazing! I had never thought outside the threaded-indirect box. Do I understand correctly that the output is a standalone machine language program? So if you compile in necessary utilities, it's all there? No runtime needed? What happens in high-level words? When the compiler finds one, does it make a BL call? (maybe that's what the code field does? compiles a BL?) If I write a word that contains only machine instructions, what tells the compiler whether I want it as a subroutine (with BL/RT linkage), or a new macro that creates machine code inline?Example : SETVA ( address -- address ) TOS SWPB, TOS 8C02 MOVB, TOS SWPB, TOS 8C02 MOVB, ; : VSBW ( byte address -- ) TOS 4000 ORI, SETVA DROP TOS 8C00 MOVB, DROP ; I might want to invoke SETVA as a subroutine call sometimes, but in VSBW I want to generate those 4 instructions inline, for fastest results. (Did I get the stack operations right?) 1 Quote Link to comment Share on other sites More sharing options...
Like us on Facebook
Follow us on Twitter
AtariAge on Instagram
Watch us on YouTube
Chat on Discord
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.