TI FORTH B.FOX version 1.5A 15AUG88 BASED ON THE fig-FORTH MODEL TEXAS INSTRUMENTS PERSONNEL WITH SIGNIFICANT INPUT TO THIS VERSION INCLUDE: Leon Tietz, Leslie O'Hagan, Edward E. Ferguson Extensions by: BRIAN FOX LONDON ONTARIO CANADA Hardware Configuration: Ti-99/4A console , 48K Ram 2-180K double sided drives RS232 card , Epson Rx-80 on PIO port ( SETUP BLOCK 15mar87 BJF ) HEX ." Loading TI-99 FORTH Development System" 10 83C2 C! ( disable quit key ) DECIMAL 20 LOAD ( load some handy extra stuff BLK 20 ) ( PAGE 0 2 .LINE CR MENU ( opening screen ) 74 LOAD HEX CODE 2DUP 0229 , -4 , CA69 , 6 , 2 , C669 , 4 , 045F , CODE 2DROP 8E79 , 045F , 68 USER VDPMDE ( def. new user var ) 1 VDPMDE ! ( set VDPMDE to 1 ) DECIMAL 1 DISK_LO ! 360 DISK_HI ! ( max block#= 360 ) 180 DISK_SIZE ! ( 180 blocks/drive ) CR ." Loading 64 column Editor binary image" 139 BLOAD FORTH 181 EDIT ( ERROR MESSAGES ) TI FORTH B.FOX version 1.5A 14AUG87 ( ERROR MESSAGES ) < ISR is active > < no ISR present> ( SYSTEM MESSAGES: 11MAR86 BJF ) Terminal off-line ...TI-99/4A Alternate terminal on line * Job terminated early by user Outputting to Line printer... Outputting to RS232/1... * Insert system disk in drive #1 * Press any key to continue * Press FCTN CLEAR to halt * Job completed --------------- RESERVED FOR THE STAMP ROUTINE ---------------- ( SYSTEM MESSAGES: 11MAR86 BJF ) ( ELECTIVE SYSTEM BLOCKS 40COL -->| 26APRBJF ) Graphics Development Utilities ------------ ------------ ----------- Synonymns 40 Editor 22 Backups 131 Text 51 Tracing 44 Float 45 Graph1 52 Bsaving 83 CRU 88 Multi 53 Dumping 42 Filing 68 Graph2 54 TTY 100 Strings 89 Split 55 Printing 72 Seek 96 Graph 57 Assembler 75 Tools 179 Code 74 Volker 103 Disking 41 Epson 108 Pages 104 32bit 115 DoerMake 117 Arrays 97 "EDITOR" loads programmers environment ( LANGUAGE ADDITIONS CONDITIONAL LOAD ETC 26JUN86 ) : PAGE 16 SYSTEM 0 0 GOTOXY ; : NOT 0= ; : \ ( skip the line ) IN @ C/L / 1+ C/L * IN ! ; IMMEDIATE : MENU CR 16 1 DO I 7 .LINE CR LOOP CR ; : SLIT ( --- ADDR OF STRING LITERAL ) R> DUP C@ 1+ =CELLS OVER + >R ; : WLITERAL ( WLITERAL word ) BL STATE @ IF COMPILE SLIT WORD HERE C@ 1+ =CELLS ALLOT ELSE WORD HERE ENDIF ; IMMEDIATE --> ( CONDITIONAL LOAD ) : ( SCREEN STRING_ADDR --- ) CONTEXT @ @ (FIND) IF DROP DROP 0= IF BLK @ IF R> DROP R> DROP ENDIF ENDIF ELSE -DUP IF LOAD ENDIF ENDIF ; : CLOAD ( scr_no CLOAD name ) [COMPILE] WLITERAL STATE @ IF COMPILE ELSE ENDIF ; IMMEDIATE ( EDITOR LOAD BLOCK: VERSION 2.02 BJF 22JAN87 ) BASE->R DECIMAL \ This editor compiles in approx. 2:55 mins. if all the \ elective blocks are loaded at compile time. 178 CLOAD Y/N? \ Handy stuff block 57 CLOAD LINE \ Graphics routines 51 CLOAD TEXT \ Text mode routines 54 CLOAD GRAPHICS2 \ sprites & stuff 55 CLOAD SPLIT3 \ Bit-map ( split ) mode 89 CLOAD ACCEPTSTR \ string routines 95 CLOAD SEEK \ assembler string search 65 CLOAD CLIST \ 64 column list 23 LOAD \ Load the editor R->BASE ( 64 COLUMN EDITOR... 21NOV86 BJF ) HEX 3800 ' SATR ! \ set Sprite Attribute Table VOCABULARY EDITOR IMMEDIATE EDITOR DEFINITIONS DECIMAL 0 VARIABLE CUR : !CUR ( n -- ) 0 MAX B/SCR B/BUF * 1- MIN CUR ! ; : +CUR ( n -- ) CUR @ + !CUR ; : +LIN ( n -- ) CUR @ C/L / + C/L * !CUR ; : LINE. ( last,1st ) DO I SCR @ (LINE) I CLINE LOOP ; : PTR ( -- n) SCR @ BLOCK CUR @ + ; : R/C ( -- col,row) CUR @ C/L /MOD ; : ROW@ ( -- row ) R/C SWAP DROP ; : COL@ ( -- col ) R/C DROP ; --> ( 64 COLUMN EDITOR ) BASE->R HEX : CINIT 3800 DUP ' SPDTAB ! 800 / 6 VWTR SATR 2 0 DO DUP >R D000 SP@ R> 2 VMBW DROP 4 + LOOP DROP 0000 0000 0000 0000 5 SPCHAR F0F0 9090 9090 F0F0 6 SPCHAR 0 1 F 5 0 SPRITE ; DECIMAL : PLACE CUR @ 64 /MOD 8 * 1+ SWAP 4 * 1- DUP 0< IF DROP 0 ENDIF SWAP 0 SPRPUT ; : UP -64 +CUR PLACE ; : DOWN 64 +CUR PLACE ; : LEFT -1 +CUR PLACE ; : RIGHT 1 +CUR PLACE ; : CGOTOXY ( col row -- ) 64 * + !CUR PLACE ; R->BASE --> ( 64 COLUMN EDITOR ) DECIMAL : .CUR R/C CGOTOXY ; : CURSOFF 5 0 SPRPAT ; : CURSON 6 0 SPRPAT ; : BLNKS PTR C/L COL@ - BL FILL ; : DELHALF PAD C/L BLANKS BLNKS ; : DELLIN R/C SWAP MINUS +CUR PTR PAD C/L CMOVE DUP L/SCR SWAP DO PTR 1 +LIN PTR SWAP C/L CMOVE LOOP 0 +LIN PTR C/L 32 FILL C/L * !CUR ; : INSLIN R/C SWAP MINUS +CUR L/SCR +LIN DUP 1+ L/SCR 0 +LIN DO PTR -1 +LIN PTR SWAP C/L CMOVE -1 +LOOP PAD PTR C/L CMOVE C/L * !CUR ; : RELINE ROW@ DUP LINE. UPDATE .CUR ; : +.CUR +CUR .CUR ; --> ( 64 COLUMN EDITOR ) : -TAB PTR DUP C@ BL > \ move to previous word IF BEGIN 1- DUP -1 +CUR C@ BL = UNTIL ENDIF BEGIN CUR @ IF 1- DUP -1 +CUR C@ BL > ELSE .CUR 1 ENDIF UNTIL BEGIN CUR @ IF 1- DUP -1 +CUR C@ BL = DUP IF 1 +.CUR ENDIF ELSE .CUR 1 ENDIF UNTIL DROP ; : TAB PTR DUP C@ BL = 0= \ move to next word IF BEGIN 1+ DUP 1 +CUR C@ BL = UNTIL ENDIF CUR @ 1023 = IF .CUR 1 ELSE BEGIN 1+ DUP 1 +CUR C@ BL > UNTIL .CUR ENDIF DROP ; --> ( 64 COLUMN EDITOR ) DECIMAL : !CHAR PTR C! UPDATE ; : HOME 0 0 CGOTOXY ; : REDRAW SCR @ CLIST UPDATE .CUR ; : .SCR# PAGE ." SCR #" SCR @ BASE->R DECIMAL U. R->BASE 7 SPACES ." Ctrl Q for help" CR ; : +SCR SCR @ 1+ DUP SCR ! .SCR# CLIST ; : -SCR SCR @ 1- 0 MAX DUP SCR ! .SCR# CLIST ; : DEL PTR DUP 1+ SWAP COL@ C/L SWAP - CMOVE 32 PTR COL@ - C/L + 1- C! ; : INS 32 PTR DUP COL@ C/L SWAP - + SWAP DO I C@ LOOP DROP PTR DUP COL@ C/L SWAP - + 1- SWAP 1- SWAP DO I C! -1 +LOOP ; : DRAWSCR .SCR# SCR @ CLIST ; --> ( 64 COLUMN EDITOR 15JUL82 LAO ) BASE->R DECIMAL 0 VARIABLE BLINK 0 VARIABLE OKEY 10 CONSTANT RL 40 CONSTANT RH 0 VARIABLE KC RH VARIABLE RLOG : GKEY BEGIN ?KEY -DUP 1 BLINK +! BLINK @ DUP 60 < IF CURSON ELSE CURSOFF ENDIF 120 = IF 0 BLINK ! ENDIF IF ( some key is pressed ) KC @ 1 KC +! 0 BLINK ! IF ( waiting to repeat ) RLOG @ KC @ < IF ( long enough ) RL RLOG ! 1 KC ! 1 ( FORCE EXT) ELSE OKEY @ OVER = IF ( need to wait more ) DROP 0 ELSE 1 ( force exit ) DUP KC ! ENDIF ENDIF ELSE ( new key ) 1 ( force loop exit ) ENDIF ELSE ( no key pressed) RH RLOG ! 0 KC ! 0 ENDIF UNTIL DUP OKEY ! ; R->BASE --> ( 64 COLUMN EDITOR : NEW STUFF 14OCT86 BJF ) HEX : SAVE-BUFFERS CURSOFF PAGE ." Saving buffers..." FLUSH .SCR# ; : BANNER ( B --) >R 0 100 R> VFILL ; : TOGGLEBANNER 0 VSBR F6 = IF C3 BANNER ELSE F6 BANNER ENDIF ; DECIMAL 37 CONSTANT HELPSCRN HEX : HELP CURSOFF 3 0 DO HELPSCRN I + CLIST F4 BANNER PAGE ." Press enter to go on" BEEP KEY 0D = NOT IF LEAVE ENDIF LOOP TOGGLEBANNER DRAWSCR ; --> ( 64 COLUMN EDITOR: NEW STUFF 14OCT86 BJF ) BASE->R DECIMAL : NEWBLOCK CURSOFF PAGE ." Block # :" BEEP ACCEPT# DISK_LO @ DISK_HI @ LIMITS SCR ! DRAWSCR ; : WIPE CURSOFF ." WIPE the screen ! You sure ? " BEEP Y/N? IF SCR @ CLEAR ENDIF DRAWSCR ; : ESCAPE ( -- ) CURSOFF 0 1 GOTOXY QUIT ; : QUIT.EDIT ( -- ) CURSOFF SAVE-BUFFERS TEXT ABORT ; \ text mode and abort R->BASE --> ( 64 COLUMN EDITOR... 21NOV86 BJF ) : WRITECHAR ( n -- ) !CHAR 1 +.CUR RELINE ; : ScreenSetUp ( scr# -- ) VDPMDE @ 5 = NOT \ check Video chip status IF SPLIT3 CINIT \ if not right correct it ENDIF DUP SCR ! DISK_LO @ DISK_HI @ WITHIN? NOT IF NEWBLOCK THEN DRAWSCR .CUR ; --> ( 64 COLUMN EDITOR... 21NOV86 BJF ) DECIMAL : !STAMP ( -- ) SCR @ BLOCK \ address of line 0 6 BLOCK 15 C/L * + \ block 6 line 16 C/L CMOVE UPDATE ; \ move 64 chars : STAMP ( move line 15 block 6 to current block line 0 ) 6 BLOCK 15 C/L * + \ block 6 line 16 SCR @ BLOCK C/L CMOVE UPDATE DRAWSCR HOME DOWN ; --> ( 64 COLUMN EDITOR... ) DECIMAL : CONTROL1 ( n -- n ) DUP CASE 01 OF DELHALF BLNKS RELINE ENDOF 02 OF +SCR ENDOF 03 OF DEL RELINE ENDOF 04 OF INS RELINE ENDOF 05 OF QUIT.EDIT ENDOF 06 OF INSLIN REDRAW ENDOF 07 OF DELLIN REDRAW ENDOF 08 OF LEFT ENDOF 09 OF RIGHT ENDOF 10 OF DOWN ENDOF 11 OF UP ENDOF 12 OF -SCR ENDOF 13 OF 1 +LIN .CUR ENDOF 14 OF HOME ENDOF 15 OF ESCAPE ENDOF ENDCASE ; --> ( 64 COLUMN EDITOR... 21NOV86 BJF ) : CONTROL2 ( n -- n ) DUP CASE 16 OF STAMP ENDOF 17 OF HELP ENDOF ( 18 OF ENDOF ) 19 OF SAVE-BUFFERS ENDOF 20 OF TOGGLEBANNER ENDOF 21 OF EMPTY-BUFFERS REDRAW ENDOF 23 OF WIPE ENDOF ( 25 OF YANKBLOCK ENDOF ) 26 OF NEWBLOCK ENDOF 27 OF TAB ENDOF 28 OF -TAB ENDOF 29 OF !STAMP ENDOF 30 OF INSLIN BLNKS REDRAW ENDOF ENDCASE ; --> ( 64 COLUMN EDITOR... main control loop 21NOV86 BJF ) : CONTROLLER ( n -- ) CONTROL1 CONTROL2 DROP ; : EDT ( n -- ) ScreenSetUp BEGIN GKEY DUP \ GetKey & DUP value 32 127 WITHIN? \ within ascii 32 & 127 IF WRITECHAR \ if so show it ELSE CONTROLLER \ must be a ctrl char ENDIF AGAIN ; \ here we go again ! DECIMAL \ return to decimal math --> ( 64 COLUMN EDITOR : FORTH Commands 13MAR87 BJF ) DECIMAL FORTH DEFINITIONS : COLD TEXT COLD ; ( changes to TEXT mode before booting ) : EDIT EDITOR EDT ; : ED@ EDITOR SCR @ EDT ; : WHERE EDITOR SCR ! 2 - CUR ! ED@ ; : SLOAD SCR @ LOAD ; ( - Control Short forms - ) : LS EDITOR DUP SCR ! .SCR# CLIST ; \ 64 column list : E EDIT ; : T TEXT ; : ED ED@ ; : W WHERE ; : SL SLOAD ; 172 LOAD ( string search commands ) FCTN KEYS ( FCTN key must be held down ! ) DELETE ... deletes 1 char and shortens line by 1 char INSERT ... inserts 1 space between existing characters ERASE ... erases 1 line & stores in a buffer CLEAR ... displays the next disk block BEGIN ... homes the cursor to row 1 col 1 PROCEED... displays the previous disk block AID ... delete line from cursor pos. & right REDO ... inserts ERASEd line at cursor location BACK ... returns to FORTH {escape} in 32 column window. QUIT ... Saves buffers,and returns to the 40 column screen -- CURSOR MOVMENT -- "E" ... moves the cursor up "X" ... moves the cursor down "S" ... moves the cursor left "D" ... moves the cursor right CTRL KEYS ( CTRL key must be held down ) "S" .... saves all buffers to disk ">" .... advances cursor one word ";" .... backs cursor up one word "T" .... sets TAB point { not in service } "Q" .... displays all help menus "N" .... home cursor to upper right corner "R" .... Runs thru disk looking for a search string REDO .... inserts blank line into block "Z" .... select a new block "P" .... Put stamp on current screen "=" .... save line 1 of current screen as the stamp line "U" .... Undoes changes to all unsaved buffers "Y" .... toggles RED banner on or off "X" .... Xtract given text from block ( Not in service ) FORTH COMMANDS | Function Performed EDIT or E .... edits selected block no. ED@ or ED .... invokes editor at currently active block. LS .... lists selected block from command line. FIND .... sets search string Ex: FIND APPLE GO .... Search blocks for string EX: 80 100 GO TEXT or T .... Switch to TEXT display mode. COLD .... re-starts FORTH from scratch. WHERE or W.... after an error in LOADing;WHERE will call the editor and display the un-defined word. ( the editor must be in ram at the time ) ( SYSTEM CALLS 09JUL82 LCT) 0 CLOAD RANDOMIZE BASE->R DECIMAL 74 R->BASE CLOAD ;CODE BASE->R DECIMAL : VSBW 0 SYSTEM ; : VMBW 2 SYSTEM ; : VSBR 4 SYSTEM ; : VMBR 6 SYSTEM ; : VWTR 8 SYSTEM ; : GPLLNK 0 33660 C! 10 SYSTEM ; : XMLLNK 12 SYSTEM ; : DSRLNK 8 14 SYSTEM ; : CLS 16 SYSTEM ; : FORMAT-DISK 1+ 18 SYSTEM ; : VFILL 20 SYSTEM ; : VAND 22 SYSTEM ; : VOR 24 SYSTEM ; : VXOR 26 SYSTEM ; HEX CODE MON 0200 , 4E4F , 0201 , 2000 , CC40 , 0281 , 4000 , 16FC , 0420 , 0000 , : RNDW 83C0 DUP @ 6FE5 * 7AB9 + 5 SRC DUP ROT ! ; : RND RNDW ABS SWAP MOD ; : SEED 83C0 ! ; : RANDOMIZE 8802 C@ DROP 0 BEGIN 1+ 8802 C@ 80 AND UNTIL SEED ; R->BASE ( DISKING: SCOPY SMOVE 12JUL82 LCT / EXCHAMGE 22MAR87 BJF ) BASE->R HEX 0 CONSTANT AD : SCOPY ( scr1,scr2 -- ) OFFSET @ + SWAP BLOCK 2- ! UPDATE FLUSH ; ( 1K BLOCKS ) : SMOVE ( scr1,scr2,cnt -- ) >R OVER OVER - DUP 0< SWAP R MINUS > + 2 = IF OVER OVER SWAP R + 1- SWAP R + 1- -1 ' AD ! ELSE 1 ' AD ! ENDIF R> 0 DO OVER OVER SCOPY AD + SWAP AD + SWAP LOOP DROP DROP ; R->BASE ( DUMP ROUTINES 12JUL82 LCT) 0 CLOAD WORDS BASE->R HEX : DUMP8 -DUP IF BASE->R HEX 0 OUT ! SPACE OVER 4 U.R OVER OVER 0 DO DUP @ 0 <# # # # # BL HOLD BL HOLD #> TYPE 2+ 2 +LOOP DROP 1F OUT @ - SPACES 0 DO DUP C@ DUP 20 < OVER 7E > OR IF DROP 2E ENDIF EMIT 1+ LOOP CR R->BASE ENDIF ; R->BASE --> ( DUMP ROUTINES 12JUL82 LCT) : DUMP CR 00 8 U/ >R SWAP R> -DUP IF 0 DO 8 DUMP8 PAUSE IF SWAP DROP 0 SWAP LEAVE ENDIF LOOP ENDIF SWAP DUMP8 DROP ; : .S CR SP@ 2- S0 @ 2- ." | " OVER OVER = 0= IF DO I @ U. -2 +LOOP ELSE DROP DROP ENDIF ; BASE->R HEX : WORDS ( -- ) \ displays words in vocabulary in 2 columns CR CR 0 OUT ! CONTEXT @ @ \ new line, get CONTEXT adr BEGIN DUP C@ 3F AND DUP \ get name length & DUP OUT @ + SCRN_WIDTH @ 3 - > \ check for EOL IF CR 0 OUT ! ENDIF \ if so, CR and reset OUT OVER ID. 12 SWAP - SPACES PFA LFA @ DUP 0= PAUSE OR UNTIL DROP ; R->BASE ( TRACE COLON WORDS-FORTH DIMENSIONS III/2 P.58 26OCT82 LCT) 0 CLOAD (TRACE) BASE->R DECIMAL 42 R->BASE CLOAD VLIST FORTH DEFINITIONS 0 VARIABLE TRACF ( CONTROLS INSERTION OF TRACE ROUTINE ) 0 VARIABLE TFLAG ( CONTROLS TRACE OUTPUT ) : TRACE 1 TRACF ! ; : UNTRACE 0 TRACF ! ; : TRON 1 TFLAG ! ; : TROFF 0 TFLAG ! ; : (TRACE) TFLAG @ ( GIVE TRACE OUTPUT? ) IF CR R 2- NFA ID. ( BACK TO PFA NFA FOR NAME ) .S ENDIF ; ( PRINT STACK CONTENTS ) : : ( REDEFINED TO INSERT TRACE WORD AFTER COLON ) ?EXEC !CSP CURRENT @ CONTEXT ! CREATE [ ' : CFA @ ] LITERAL HERE 2- ! TRACF @ IF ' (TRACE) CFA DUP @ HERE 2- ! , ENDIF ] ; IMMEDIATE ( FLOATING POINT <4 WORD> STACK ROUTINES 20APR85 GED { FAST } ) 0 CLOAD PI BASE->R DECIMAL 33 R->BASE CLOAD RANDOMIZE BASE->R DECIMAL 74 R->BASE CLOAD ;CODE BASE->R HEX CODE FDUP C009 , 0229 , FFF8 , C049 , CC70 , CC70 , C450 , 045F , CODE FDROP 0229 , 0008 , 045F , CODE FOVER 0229 , FFF8 , C049 , C001 , 0220 , 0010 CC70 , CC70 , CC70 , C450 , 045F , CODE FSWAP C009 , C070 , C0B0 , C0F0 , C130 , C670 , CA70 , 0002 , CA70 , 0004 , CA50 , 0006 , 0220 , FFFA , CC01 , CC02 , CC03 , C404 , 045F , CODE F! C039 , CC39 , CC39 , CC39 , C439 , 045F , CODE F@ C019 , 0229 , FFFA , C049 , CC70 , CC70 , CC70 , C450 , 045F , 834A CONSTANT FAC 835C CONSTANT ARG R->BASE --> ( FLOATING POINT ARITHMETIC ROUTINES 12JUL82 LCT 26APR85 GED ) BASE->R HEX : >FAC FAC F! ; : >ARG ARG F! ; : FAC> FAC F@ ; : SETFL >FAC >ARG ; : F+ SETFL 0600 XMLLNK FAC> ; : F- SETFL 0700 XMLLNK FAC> ; : F* SETFL 0800 XMLLNK FAC> ; : F/ SETFL 0900 XMLLNK FAC> ; : S->FAC FAC ! 2300 XMLLNK ; : FAC->S 1200 XMLLNK FAC @ ; : FAC>ARG FAC ARG 4 MOVE ; : F->S >FAC FAC->S ; : S->F S->FAC FAC> ; DECIMAL : FRND 3 0 DO 100 RND 100 RND 256 * + LOOP 100 RND 16128 + ; R->BASE --> ( FLOATING POINT CONVERSION ROUTINES CONTINUED 12JUL82 LCT) BASE->R HEX : DOSTR FAC B + C! 14 GPLLNK FAC B + C@ 8300 + FAC C + C@ DUP PAD C! PAD 1+ SWAP CMOVE ; ( NUMBER IN FAC CONVERTED TO BASIC STRING AND PLACED AT PAD) : STR 0 DOSTR ; ( NUMBER IN FAC CONVERTED TO FIXED STRING AND PLACED AT PAD) : STR. FAC D + C! FAC C + C! DOSTR ; ( STRING AT PAD CONVERTED TO NUMBER IN FAC) : VAL PAD 1+ 1000 DUP FAC C + ! PAD C@ OVER OVER + 20 SWAP VSBW VMBW 1000 XMLLNK ; R->BASE --> ( FLOATING POINT - COMPILE NO TO STACK 12JUL82 LCT) BASE->R HEX : F$ PAD 1+ SWAP >R R CMOVE R> PAD C! VAL FAC> ; : (>F) R COUNT DUP 1+ =CELLS R> + >R F$ ; : >F BL WORD HERE COUNT F$ STATE @ IF >R >R [COMPILE] DLITERAL R> R> [COMPILE] DLITERAL ENDIF ; IMMEDIATE ( FLOATING POINT OUTPUT ROUTINES ) : JST PAD C@ - SPACES PAD COUNT TYPE ; : F.R >R >FAC STR R> JST ; : F. 0 F.R ; : FF.R >R >R >R >FAC R> 0 R> STR. R> JST ; : FF. 0 FF.R ; R->BASE --> ( FLOATING POINT COMPARE ROUTINES 12JUL82 LCT) BASE->R HEX : FCLEAN >R DROP DROP DROP R> ; : F0< 0< FCLEAN ; : F0= 0= FCLEAN ; : FCOM SETFL 0A00 C SYSTEM 837C C@ ; : F> FCOM 40 AND MINUS 0< ; : F= FCOM 20 AND MINUS 0< ; : F< FCOM 60 AND 0= ; : FLERR 8354 C@ ; : ?FLERR FLERR A ?ERROR ; R->BASE --> ( FLOATING POINT TRANSCENDENTAL FUNCTIONS 12JUL82 LCT) BASE->R HEX 0 VARIABLE LNKSAV : GLNK 83C4 @ LNKSAV ! GPLLNK LNKSAV @ 83C4 ! ; : INT >FAC 22 GLNK FAC> ; : ^ SETFL ARG 836E @ 8 VMBW 24 GLNK FAC> 8 836E +! ; : SQR >FAC 26 GLNK FAC> ; : EXP >FAC 28 GLNK FAC> ; : LOG >FAC 2A GLNK FAC> ; : COS >FAC 2C GLNK FAC> ; : SIN >FAC 2E GLNK FAC> ; : TAN >FAC 30 GLNK FAC> ; : ATN >FAC 32 GLNK FAC> ; : PI >F 3.141592653590 ; R->BASE ( CONVERT TO TEXT MODE CONFIGURATION 14SEP82 LAO) 0 CLOAD TEXT BASE->R DECIMAL 56 R->BASE CLOAD SETVDP2 BASE->R HEX : TEXT 0 3C0 20 VFILL ( BLANKS TO SCREEN IMAGE AREA ) 28 SCRN_WIDTH ! 0 SCRN_START ! 3C0 SCRN_END ! 460 PABS ! SETVDP1 \ set-up VDP ram. see BLK 56 1 VDPMDE ! \ store the video mode we're in 01 06 VWTR \ set mode bit F4 07 VWTR \ set color to WHT on DARK BLUE F0 SETVDP2 ; \ R->BASE ( CONVERT TO GRAPHICS MODE CONFIG 14SEP82 LAO) 0 CLOAD GRAPHICS BASE->R DECIMAL 56 R->BASE CLOAD SETVDP2 BASE->R HEX : GRAPHICS 0 300 20 VFILL ( BLANKS TO SCREEN IMAGE AREA ) 300 80 0 VFILL 380 20 F4 VFILL 20 SCRN_WIDTH ! 0 SCRN_START ! 300 SCRN_END ! SETVDP1 2 VDPMDE ! ( NOW SET VDP REGISTERS ) 1 6 VWTR 0F4 7 VWTR E0 SETVDP2 ; R->BASE ( CONVERT TO MULTI-COLOR MODE CONFIG 14SEP82 LAO) 0 CLOAD MULTI BASE->R DECIMAL 56 R->BASE CLOAD VDPSET2 BASE->R HEX : MULTI 0B0 1 VWTR ( BLANK THE SCREEN ) -1 18 0 DO I 4 / 0FF SWAP DO 1+ I OVER VSBW 8 +LOOP LOOP DROP 800 800 0 VFILL ( INIT 256 CHAR PATTERNS TO 0 ) 300 80 0 VFILL 380 20 0F4 VFILL 20 SCRN_WIDTH ! 0 SCRN_START ! 300 SCRN_END ! 460 PABS ! 1000 DISK_BUF ! ( RESTORE USER VARIABLES ) 3 VDPMDE ! ( NOW SET VDP REGISTERS ) 4 6 VWTR 11 7 VWTR 0EB SETVDP2 ; R->BASE ( CONVERT TO GRAPHICS2 MODE CONFIG 14SEP82 LAO) 0 CLOAD GRAPHICS2 BASE->R DECIMAL 56 R->BASE CLOAD VDPSET2 BASE->R HEX : GRAPHICS2 0A0 1 VWTR -1 1B00 1800 DO 1+ DUP 0FF AND I VSBW LOOP DROP 1 PABS @ VSBW 16 PABS @ 1+ VSBW 1 ( #file) 834C C! PABS @ 8356 ! 0A 0E SYSTEM ( subroutine type DRSLNK to set 2 disk buffers ) 0 1800 0F0 VFILL ( init color table ) 2000 1800 0 VFILL ( init bit map ) 20 SCRN_WIDTH ! 1800 SCRN_START ! 1B00 SCRN_END ! 1B00 PABS ! 1C00 DISK_BUF ! ( user variables now set up ) 2 0 VWTR 6 2 VWTR ( set VDP registers ) 07F 3 VWTR 0FF 4 VWTR 70 5 VWTR 7 6 VWTR 0F1 7 VWTR 0E0 DUP 83D4 C! 1 VWTR 1BC0 836E ! ( VSPTR ) 0 0 GOTOXY 4 VDPMDE ! 0 837A C! ; R->BASE ( CONVERT TO SPLIT MODE CONFIG 14SEP82 LAO) 0 CLOAD SPLIT BASE->R DECIMAL 56 R->BASE CLOAD VDPSET2 BASE->R DECIMAL 54 R->BASE CLOAD GRAPHICS2 BASE->R HEX : SPLIT GRAPHICS2 1A00 SCRN_START ! 0A0 1 VWTR 3000 800 0FF VFILL 3100 834A ! 18 GPLLNK 3300 834A ! 4A GPLLNK 1A00 100 20 VFILL 1000 800 0F4 VFILL 0 0 GOTOXY 0E0 1 VWTR 5 VDPMDE ! 0 837A C! ; : SPLIT2 GRAPHICS2 1880 SCRN_END ! 2000 400 0FF VFILL 2100 834A ! 18 GPLLNK 2300 834A ! 4A GPLLNK 1800 80 20 VFILL 0 400 0F4 VFILL 0 0 GOTOXY 6 VDPMDE ! 0 837A C! ; : SPLIT3 ( editor mode with Red banner& grn screen ) SPLIT 0 100 F6 VFILL 100 F00 C3 VFILL ; R->BASE ( VDPMODES 14SEP82 LAO ) 0 CLOAD SETVDP2 BASE->R DECIMAL 40 R->BASE CLOAD RANDOMIZE BASE->R HEX : SETVDP1 0B0 1 VWTR \ blank the screen 800 800 0FF VFILL \ Init 256 char patterns to >FF 900 834A ! 18 GPLLNK \ Load Capital letters B00 834A ! 4A GPLLNK ; \ Load lower case - ON 99/4A ONLY : SETVDP2 ( n -- ) 460 PABS ! 1000 DISK_BUF ! \ Restore user variables 0 0 VWTR 0 2 VWTR 0E 3 VWTR \ set VDP registers 1 4 VWTR 6 5 VWTR 3E0 836E ! \ VSPTR routine 1 PABS @ VSBW 16 PABS @ 1+ VSBW 3 ( #FILE) 834C C! PABS @ 8356 ! 0A 0E SYSTEM \ SUB TYPE DSRLNK TO SET 3 DISK BUF 0 0 GOTOXY 0 837A C! DUP 83D4 C! 1 VWTR ; R->BASE ( GRAPHICS PRIMITIVES 12JUL82 LCT) 0 CLOAD CHAR BASE->R DECIMAL 40 R->BASE CLOAD RANDOMIZE BASE->R DECIMAL 74 R->BASE CLOAD ;CODE BASE->R HEX 380 CONSTANT COLTAB 300 CONSTANT SATR 780 CONSTANT SMTN 800 CONSTANT PDT 800 CONSTANT SPDTAB : CHAR ( W1 W2 W3 W4 CH --- ) 8 * PDT + >R -2 6 DO PAD I + ! -2 +LOOP PAD R> 8 VMBW ; : CHARPAT ( CH --- W1 W2 W3 W4 ) 8 * PDT + PAD 8 VMBR 8 0 DO PAD I + @ 2 +LOOP ; : VCHAR ( X Y CNT CH --- ) >R >R SCRN_WIDTH @ * + SCRN_END @ SCRN_START @ - SWAP R> R> SWAP 0 DO SWAP OVER OVER SCRN_START @ + VSBW SCRN_WIDTH @ + ROT OVER OVER /MOD IF 1+ SCRN_WIDTH @ OVER OVER = IF - ELSE DROP ENDIF ENDIF ROT DROP ROT LOOP DROP DROP DROP ; R->BASE --> ( GRAPHICS PRIMITIVES 20OCT83 LAO) BASE->R HEX : HCHAR ( X Y CNT CH --- ) >R >R SCRN_WIDTH @ * + SCRN_START @ + R> R> VFILL ; : COLOR ( FG BG CHSET --- ) >R SWAP 10 * + R> COLTAB + VSBW ; : SCREEN ( COLOR --- ) 7 VWTR ; : GCHAR ( X Y --- ASCII ) ( COLUMNS AND ROWS NUMBERED FROM 0 ) SCRN_WIDTH @ * + SCRN_START @ + VSBR ; : SSDT ( ADDR --- ) ( SET SPRITE DESCRIPTOR TABLE ADDRESS ) DUP ' SPDTAB ! 800 / 6 VWTR ( RESET VDP REG 6 ) SATR 20 0 DO DUP >R D000 SP@ R> 2 VMBW DROP 4 + LOOP DROP VDPMDE @ 4 < IF SMTN 80 0 VFILL 300 ! SATR ! ENDIF ( INIT ALL SPRITES ) ; : SPCHAR ( W1 W2 W3 W4 CH# --- ) 8 * SPDTAB + >R -2 6 DO PAD I + ! -2 +LOOP PAD R> 8 VMBW ; : SPRCOL ( COL # --- ) 4 * SATR 3 + + DUP >R VSBR 0F0 AND OR R> VSBW ; R->BASE --> ( GRAPHICS PRIMITIVES 20OCT83 LCT) BASE->R HEX : SPRPAT ( CH # --- ) 4 * SATR 2+ + VSBW ; : SPRPUT ( DX DY # --- ) 4 * SATR + >R 1- 100 U* DROP + SP@ R> 2 VMBW DROP ; : SPRITE ( DX DY COL CH # --- ) ( SPRITES NUMBERED 0 - 31 ) DUP 4 * SATR + >R DUP >R SPRPAT R SPRCOL R> SPRPUT R> 4 + SATR DO I VSBR D0 = IF C001 SP@ I 2 VMBW DROP ENDIF 4 +LOOP ; : MOTION ( SPX SPY # --- ) 4 * SMTN + >R 8 SLA SWAP 00FF AND OR SP@ R> 2 VMBW DROP ; : #MOTION ( NO --- ) 837A C! ; : SPRGET ( # --- DX DY ) 4 * SATR + DUP VSBR 1+ 0FF AND SWAP 1+ VSBR SWAP ; : DXY ( X2 Y2 X1 Y1 --- X^2 Y^2 ) ROT - ABS ROT ROT - ABS DUP * SWAP DUP * ; R->BASE --> ( GRAPHICS PRIMITIVES 12JUL82 LCT) BASE->R HEX : BEEP 34 GPLLNK ; : HONK 36 GPLLNK ; : SPRDIST ( #1 #2 --- DIST^2 ) ( distance between 2 sprites ) SPRGET ROT SPRGET DXY OVER OVER + DUP >R OR OR 8000 AND IF R> DROP 7FFF ELSE R> ENDIF ; : SPRDISTXY ( X Y # --- DIST^2 ) SPRGET DXY OVER OVER + DUP >R OR OR 8000 AND IF R> DROP 7FFF ELSE R> ENDIF ; : MAGNIFY ( MAG-FACTOR --- ) 83D4 C@ 0FC AND + DUP 83D4 C! 1 VWTR ; : JOYST ( KEYBDNO --- ASCII XSTAT YSTAT ) 8374 C! ?KEY DROP 8375 C@ DUP DUP 12 = IF DROP 0 0 ELSE 0FF = IF 8377 C@ 8376 C@ ELSE 8375 C@ CASE 4 OF 0FC 4 ENDOF 5 OF 0 4 ENDOF 6 OF 4 4 ENDOF 2 OF 0FC 0 ENDOF 3 OF 4 0 ENDOF 0 OF 0 0FC ENDOF 0F OF 0FC 0FC ENDOF 0E OF 4 0FC ENDOF DROP DROP 0 0 0 0 ENDCASE ENDIF ENDIF 4 8374 C! ; R->BASE --> ( GRAPHICS PRIMITIVES 12JUL82 LCT) BASE->R HEX : COINC ( #1 #2 TOL --- F ) ( 0= NO COINC 1= COINC ) DUP * DUP + >R SPRDIST R> > 0= ; : COINCXY ( DX DY # TOL --- F ) DUP * DUP + >R SPRDISTXY R> > 0= ; : COINCALL ( --- F ) ( BIT SET IF ANY TWO SPRITES OVERLAP ) 8802 C@ 20 AND 20 = ; : DELSPR ( # --- ) 4 * DUP SATR + >R 0 C001 SP@ R> 4 VMBW DROP DROP SMTN + >R 0 0 SP@ R> 4 VMBW DROP DROP ; : DELALL ( --- ) 0 #MOTION SATR 20 0 DO DUP D0 SWAP VSBW 4 + LOOP DROP SMTN 80 0 VFILL ; R->BASE --> ( GRAPHICS PRIMITIVES 24NOV82 LAO) BASE->R HEX 0 VARIABLE ADR : MINIT 18 0 DO 0 I 4 / 20 * DUP 20 + SWAP DO DUP J 1 I HCHAR 1+ LOOP DROP LOOP ; : MCHAR ( COLOR C R --- ) DUP >R 2 / SWAP DUP >R 2 / SWAP DUP >R GCHAR DUP 20 / 100 U* DROP 800 + >R 20 MOD 8 * R> + R> 4 MOD 2 * + ADR ! R> 2 MOD R> 2 MOD SWAP IF IF 3 ELSE 1 ENDIF ELSE IF 2 ELSE 0 ENDIF ENDIF DUP 2 MOD 0= IF SWAP 10 * SWAP ENDIF CASE 0 OF ADR @ VSBR 0F ENDOF 1 OF ADR @ VSBR F0 ENDOF 2 OF 1 ADR +! ADR @ VSBR 0F ENDOF 3 OF 1 ADR +! ADR @ VSBR F0 ENDOF ENDCASE AND + ADR @ VSBW ; 0 VARIABLE DMODE -1 VARIABLE DCOLOR : DRAW 0 DMODE ! ; : UNDRAW 1 DMODE ! ; : DTOG 2 DMODE ! ; 8040 VARIABLE DTAB 2010 , 804 , 201 , 7FBF , DFEF , F7FB , FDFE , 8040 , 2010 , 804 , 201 , R->BASE --> ( GRAPHICS PRIMITIVES ) BASE->R HEX CODE DDOT C079 , C0D9 , C081 , C103 , 0241 , 0007 , 0243 , 0007 , 0242 , 00F8 , 0244 , 00F8 , 0A52 , A042 , A044 , 0221 , 2000 , 04C4 , D123 , DTAB , 06C4 , C644 , 0649 , C641 , 045F , : DOT ( X Y --- ) DDOT DUP 2000 - >R DMODE @ CASE 0 OF VOR ENDOF ( DRAW ) 1 OF SWAP FF XOR SWAP VAND ENDOF ( UNDRAW ) 2 OF VXOR ENDOF ( TOGGLE ) DROP DROP ENDCASE R> DCOLOR @ 0 < IF DROP ELSE DCOLOR @ SWAP VSBW ENDIF ; R->BASE --> ( GRAPHICS PRIMITIVES 12JUL82 LCT) BASE->R HEX : SGN DUP IF DUP 0< IF -1 ELSE 1 ENDIF ELSE 0 ENDIF + ; : LINE >R R ROT >R R - SGN SWAP >R R ROT >R R - SGN OVER ABS OVER ABS < >R R 0= IF SWAP ENDIF 100 ROT ROT */ R> IF ( X axis ) R> R> 2DUP > IF ( make L to R ) SWAP R> DROP R> ELSE R> R> DROP ENDIF 100 * ROT ROT 1+ SWAP DO I OVER 0 100 M/ SWAP DROP DOT OVER + LOOP ELSE ( Y axis ) R> R> R> R> ROT >R ROT >R 2DUP > IF ( make T to B ) SWAP R> DROP R> ELSE R> R> DROP ENDIF 100 * ROT ROT 1+ SWAP DO DUP 0 100 M/ SWAP DROP I DOT OVER + LOOP ENDIF DROP DROP ; R->BASE ( COMPACT LIST ) 0 CLOAD SMASH BASE->R DECIMAL 74 R->BASE CLOAD ;CODE BASE->R DECIMAL 33 R->BASE CLOAD RANDOMIZE BASE->R DECIMAL 0 VARIABLE TCHAR 382 ALLOT 67 BLOCK TCHAR 384 CMOVE HEX TCHAR 7C - CONSTANT TC 0 VARIABLE BADDR 0 VARIABLE INDX 0 VARIABLE LB FE ALLOT CODE SMASH ( addr,#char,line# -- lb vaddr cnt ) C079 , C0B9 , C0D9 , 0204 , LB , C644 , 0649 , 06C1 , 0221 , 2000 , C641 , C042 , 0581 , 0241 , FFFE , 0649 , 0A21 , C641 , A083 , 80C2 , 1501 , 1020 , 04C5 , 04C6 , D173 , D1B3 , 0965 , 0966 , C025 , TC , C066 , TC , 0B41 , 020C , 0004 , C2C0 , 024B , F000 , C1C1 , 0247 , 0F00 , E1CB , DD07 , 0BC0 , 0BC1 , 060C , 16F4 , 05C5 , 05C6 , C305 , 024C , 0002 , 16E7 , 10DD , 045F , R->BASE --> ( COMPACT LIST ) DECIMAL : CLINE LB 100 ERASE SMASH VMBW ; : CLOOP ( addr,lastline,1stline -- ) DO I 64 * OVER + 64 I CLINE LOOP DROP ; : CLIST ( blk# -- ) BLOCK 16 0 CLOOP ; ( FILE I/O ROUTINES 12JUL82 LCT) 0 CLOAD STAT DECIMAL 40 CLOAD RANDOMIZE BASE->R HEX 0 VARIABLE PAB-ADDR 0 VARIABLE PAB-BUF 0 VARIABLE PAB-VBUF : FILE ( v-buf,r/w buf,pab-addr ) DUP DUP @ PAB-VBUF ! 2+ @ PAB-BUF ! 2+ @ PAB-ADDR ! ; : GET-FLAG PAB-ADDR @ 1+ VSBR ; : PUT-FLAG PAB-ADDR @ 1+ VSBW ; : AS: PAB-ADDR @ DUP 0A 0 VFILL 2+ PAB-VBUF SWAP 2 VMBW ; : CLR-STAT GET-FLAG 1F AND PUT-FLAG ; : CHK-STAT GET-FLAG 0E0 AND 837C C@ 20 AND OR 9 ?ERROR ; : FIXED GET-FLAG 0EF AND PUT-FLAG ; : VARIABL GET-FLAG 10 OR PUT-FLAG ; R->BASE --> ( FILE I/O ROUTINES 12JUL82 LCT REVISED 18/2/86 ) BASE->R HEX : DISPLAY GET-FLAG 0F7 AND PUT-FLAG ; ( SEE MANUAL FOR ) : INTERNAL GET-FLAG 8 OR PUT-FLAG ; ( CHANGES b.fox) : I/OMD GET-FLAG 0F9 AND ; : INPUT I/OMD 4 OR PUT-FLAG ; : OUTPUT I/OMD 2 OR PUT-FLAG ; : UPDAT I/OMD PUT-FLAG ; : APPEND I/OMD 6 OR PUT-FLAG ; : SEQUENTIAL GET-FLAG 0FE AND PUT-FLAG ; : RELATIVE GET-FLAG 1 OR PUT-FLAG ; : REC-LEN PAB-ADDR @ 4 + VSBW ; : CHAR-CNT! PAB-ADDR @ 5 + VSBW ; : CHAR-CNT@ PAB-ADDR @ 5 + VSBR ; : REC# ( N ) DUP SWPB PAB-ADDR @ 6 + VSBW PAB-ADDR @ 7 + VSBW ; : N-LEN! PAB-ADDR @ 9 + VSBW ; R->BASE --> ( FILE I/O ROUTINES 12JUL82 LCT) BASE->R HEX ( Compile a string which is moved to VDP-addr at execution ) : (DEV=) PAB-ADDR @ 0A + R COUNT DUP 1+ =CELLS R> + >R >R SWAP R VMBW R> N-LEN! ; : DEV= ( -- TI-99 device name. Example: DEV= DSK1.MYFILE ) 20 STATE @ IF COMPILE (DEV=) WORD HERE C@ 1+ =CELLS ALLOT ELSE PAB-ADDR @ 0A + SWAP WORD HERE COUNT >R SWAP R VMBW R> N-LEN! ENDIF ; IMMEDIATE R->BASE --> ( FILE I/O ROUTINES 12JUL82 LCT REV. 10/9/87 FOX ) BASE->R HEX : DOI/O CLR-STAT PAB-ADDR @ VSBW PAB-ADDR @ 9 + 8356 ! 0 837C C! DSRLNK CHK-STAT ; : OPEN 0 DOI/O ; : CLOSE 1 DOI/O ; : READ ( A --- ) 2 DOI/O PAB-VBUF @ SWAP CHAR-CNT@ VMBR ; : WRITE ( A,N--- ) PAB-VBUF @ SWAP DUP CHAR-CNT! VMBW 3 DOI/O ; : RESTORE REC# 4 DOI/O ; : OLD REC# 5 DOI/O ; ( Load a program file ) : SAV REC# 6 DOI/O ; ( Save a program file ) : DELETE 7 DOI/O ; : SCRATCH REC# 8 DOI/O ; : (CON) 0 ALTOUT ! 0 ALTIN ! CLOSE ; : STAT 9 DOI/O PAB-ADDR @ 8 + VSBR ; R->BASE ( Alternate I/O support and PRINTER control 30OCT87 FOX ) DECIMAL 68 CLOAD STAT 178 CLOAD Y/N? HEX : FORM 0C EMIT ; : LPTPORT PABS @ 2BF + DUP PAB-ADDR ! 1- PAB-VBUF ! ; : >ALTOUT 1 CHAR-CNT! 3 PAB-ADDR @ VSBW PAB-ADDR @ ALTOUT ! ; : >ALTIN 1 CHAR-CNT! 2 PAB-ADDR @ VSBW PAB-ADDR @ ALTIN ! ; : PRINT LPTPORT AS: OUTPUT DEV= PIO OPEN >ALTOUT ; : ?ASCII ( addr,cnt -- ? ) 1 ROT ROT OVER + SWAP DO I C@ BL 7F WITHIN? NOT IF NOT LEAVE ENDIF LOOP ; : LIST3 0 SWAP 3 / 3 * DUP 3 + SWAP ( scr# scr# -- ) DO I BLOCK B/BUF ?ASCII IF 1+ I LIST CR ENDIF LOOP -DUP IF 3 SWAP - 14 * 0 DO CR LOOP 0F MESSAGE FORM ENDIF ; --> ( SMART TRIADS and smart INDEX 30OCT87 BJF ) DECIMAL 100 CLOAD BYE : CON CR ALTIN @ IF TTYPORT \ re-open tty channel ELSE (CON) ENDIF ; \ re-open console : TRIAD PRINT LIST3 CON ; : TRIADS 3 / 3 * 1 + SWAP 3 / 3 * DO I TRIAD 3 +LOOP ; : INDEX ( n -- ) CR 1+ SWAP DO I 3 .R SPACE \ print block number I BLOCK C/L ?ASCII \ 1st line is ascii IF 0 I .LINE \ print the line ELSE 26 MESSAGE ENDIF CR PAUSE \ check for break key IF LEAVE ENDIF LOOP ; ( ASSEMBLER 12JUL82 LCT) FORTH DEFINITIONS 0 CLOAD CODE VOCABULARY ASSEMBLER IMMEDIATE : CODE ?EXEC CREATE SMUDGE LATEST PFA DUP CFA ! [COMPILE] ASSEMBLER ; : ;CODE ?CSP COMPILE (;CODE) SMUDGE [COMPILE] [ [COMPILE] ASSEMBLER ; ( ASSEMBLER 12JUL82 LCT) 0 CLOAD A$$M BASE->R DECIMAL 74 R->BASE CLOAD ;CODE BASE->R HEX ASSEMBLER DEFINITIONS : GOP' OVER DUP 1F > SWAP 30 < AND IF + , , ELSE + , ENDIF ; : GOP @ GOP' ; 0440 GOP B, 0680 GOP BL, 0400 GOP BLWP, 04C0 GOP CLR, 0700 GOP SETO, 0540 GOP INV, 0500 GOP NEG, 0740 GOP ABS, 06C0 GOP SWPB, 0580 GOP INC, 05C0 GOP INCT, 0600 GOP DEC, 0640 GOP DECT, 0480 GOP X, : GROP @ SWAP 40 * + GOP' ; 2000 GROP COC, 2400 GROP CZC, 2800 GROP XOR, 3800 GROP MPY, 3C00 GROP DIV, 2C00 GROP XOP, --> ( ASSEMBLER 12JUL82 LCT) : GGOP @ SWAP DUP DUP 1F > SWAP 30 < AND IF 40 * + SWAP >R GOP' R> , ELSE 40 * + GOP' ENDIF ; A000 GGOP A, B000 GGOP AB, 8000 GGOP C, 9000 GGOP CB, 6000 GGOP S, 7000 GGOP SB, E000 GGOP SOC, F000 GGOP SOCB, 4000 GGOP SZC, 5000 GGOP SZCB, C000 GGOP MOV, D000 GGOP MOVB, : 0OP @ , ; 0340 0OP IDLE, 0360 0OP RSET, 03C0 0OP CKOF, 03A0 0OP CKON, 03E0 0OP LREX, 0380 0OP RTWP, --> ( ASSEMBLER 12JUL82 LCT) : ROP @ + , ; 02C0 ROP STST, 02A0 ROP STWP, : IOP @ , , ; 02E0 IOP LWPI, 0300 IOP LIMI, : RIOP @ ROT + , , ; 0220 RIOP AI, 0240 RIOP ANDI, 0280 RIOP CI, 0200 RIOP LI, 0260 RIOP ORI, --> ( ASSEMBLER 12JUL82 LCT) : RCOP @ SWAP 10 * + + , ; 0A00 RCOP SLA, 0800 RCOP SRA, 0B00 RCOP SRC, 0900 RCOP SRL, : DOP @ SWAP 00FF AND OR , ; 1300 DOP JEQ, 1500 DOP JGT, 1B00 DOP JH, 1400 DOP JHE, 1A00 DOP JL, 1200 DOP JLE, 1100 DOP JLT, 1000 DOP JMP, 1700 DOP JNC, 1600 DOP JNE, 1900 DOP JNO, 1800 DOP JOC, 1C00 DOP JOP, 1D00 DOP SBO, 1E00 DOP SBZ, 1F00 DOP TB, : GCOP @ SWAP 000F AND 040 * + GOP' ; 3000 GCOP LDCR, 3400 GCOP STCR, --> ( ASSEMBLER 12JUL82 LCT) : @() 020 ; : *? 010 + ; : *?+ 030 + ; : @(?) 020 + ; : W 0A ; : @(W) W @(?) ; : *W W *? ; : *W+ W *?+ ; : RP 0E ; : @(RP) RP @(?) ; : *RP RP *? ; : *RP+ RP *?+ ; : IP 0D ; : @(IP) IP @(?) ; : *IP IP *? ; : *IP+ IP *?+ ; : SP 09 ; : @(SP) SP @(?) ; : *SP SP *? ; : *SP+ SP *?+ ; : UP 08 ; : @(UP) UP @(?) ; : *UP UP *? ; : *UP+ UP *?+ ; : NEXT 0F ; : *NEXT+ NEXT *?+ ; : *NEXT NEXT *? ; : @(NEXT) NEXT @(?) ; --> ( ASSEMBLER 12JUL82 LCT) ( DEFINE JUMP TOKENS ) : GTE 1 ; : H 2 ; : NE 3 ; : L 4 ; : LTE 5 ; : EQ 6 ; : OC 7 ; : NC 8 ; : OO 9 ; : HE 0A ; : LE 0B ; : NP 0C ; : LT 0D ; : GT 0E ; : NO 0F ; : OP 10 ; : CJMP ?EXEC CASE LT OF 1101 , 0 ENDOF GT OF 1501 , 0 ENDOF NO OF 1901 , 0 ENDOF OP OF 1C01 , 0 ENDOF DUP 0< OVER 10 > OR IF 19 ERROR ENDIF DUP ENDCASE 100 * 1000 + , ; --> ( ASSEMBLER 12JUL82 LCT) : IF, ?EXEC [COMPILE] CJMP HERE 2- 42 ; IMMEDIATE : ENDIF, ?EXEC 42 ?PAIRS HERE OVER - 2- 2 / SWAP 1+ C! ; IMMEDIATE : ELSE, ?EXEC 42 ?PAIRS 0 [COMPILE] CJMP HERE 2- SWAP 42 [COMPILE] ENDIF, 42 ; IMMEDIATE : BEGIN, ?EXEC HERE 41 ; IMMEDIATE : UNTIL, ?EXEC SWAP 41 ?PAIRS [COMPILE] CJMP HERE - 2 / 00FF AND HERE 1- C! ; IMMEDIATE : AGAIN, ?EXEC 0 [COMPILE] UNTIL, ; IMMEDIATE --> ( ASSEMBLER 12JUL82 LCT) : REPEAT, ?EXEC >R >R [COMPILE] AGAIN, R> R> 2- [COMPILE] ENDIF, ; IMMEDIATE : WHILE, ?EXEC [COMPILE] IF, 2+ ; IMMEDIATE : NEXT, *NEXT B, ; FORTH DEFINITIONS : A$$M ; R->BASE ( BSAVE -- BINARY SAVER FOR FORTH OVERLAYS LCT 14SEP82 ) 0 CLOAD BSAVE BASE->R DECIMAL : BSAVE ( addr scrn-no --- ) FLUSH BEGIN SWAP >R DUP 1+ SWAP OFFSET @ + BUFFER UPDATE DUP B/BUF ERASE R OVER ! 2+ HERE OVER ! 2+ CURRENT @ OVER ! 2+ LATEST OVER ! 2+ CONTEXT @ OVER ! 2+ CONTEXT @ @ OVER ! 2+ VOC-LINK @ OVER ! 2 + 29801 OVER ! 10 + HERE R - R> DUP 1000 + >R SWAP >R SWAP R> 1000 MIN CMOVE R SWAP HERE R> < UNTIL SWAP DROP FLUSH ; : WORKSPACE ' TASK ; ( use: WORKSPACE 25 BSAVE ) R->BASE ( NEW MESSAGE ROUTINE 13SEP82 LCT ) BASE->R DECIMAL ( THIS VERSION OF MESSAGE HAS THE SCREEN 4 AND 5 MESSAGES INCLUDED IN THIS ROUTINE. ) FLUSH EMPTY-BUFFERS HERE LIMIT$ @ B/BUF 4 + - DUP LIMIT$ ! DP ! ( PLACES message WHERE 5TH DISK BUF IS. NOW HAVE 4 BUFS ) : message WARNING @ IF -DUP IF ( NON-ZERO MESSAGE NUMBER ) DUP 26 < IF ( MESSAGE NEED NOT BE RETRIEVED FROM DISK ) CR CASE ( FOLLOWING CASES FOR MESSAGE NUMBERS ) --> ( NEW MESSAGE CONTINUED ) 01 OF ." empty stack" ENDOF 02 OF ." dictionary full" ENDOF 03 OF ." has incorrect address mode" ENDOF 04 OF ." isn't unique." ENDOF 06 OF ." disk error" ENDOF 07 OF ." full stack" ENDOF 09 OF ." file i/o error" ENDOF 10 OF ." floating point error" ENDOF 11 OF ." disk fence violation" ENDOF 12 OF ." can't load from screen zero" ENDOF 15 OF ." TI FORTH --- a fig-FORTH extension" ENDOF --> ( NEW MESSAGE CONTINUED ) 17 OF ." compilation only, use in definition" ENDOF 18 OF ." execution only" ENDOF 19 OF ." conditionals not paired" ENDOF 20 OF ." definition not finished" ENDOF 21 OF ." in protected dictionary" ENDOF 22 OF ." use only when loading" ENDOF 24 OF ." declare vocabulary" ENDOF 25 OF ." bad jump token" ENDOF ENDCASE --> ( NEW MESSAGE CONTINUED ) ELSE 4 OFFSET @ B/SCR / - .LINE ENDIF ENDIF ELSE ." MSG # " . ENDIF ; DP ! ( RESTORE DP TO POSITION PRIOR TO message ) ( INSTALL NEW MESSAGE ) ' BRANCH CFA ' MESSAGE ' message OVER - 2- OVER 2+ ! ! R->BASE ( CRU WORDS 12OCT82 LAO ) 0 CLOAD STCR BASE->R DECIMAL 74 R->BASE CLOAD ;CODE BASE->R HEX CODE SBO C339 , A30C , 1D00 , 045F , CODE SBZ C339 , A30C , 1E00 , 045F , CODE TB C319 , A30C , 04D9 , 1F00 , 1601 , 0599 , 045F , CODE LDCR C339 , A30C , C079 , C039 , 0241 , 000F , 1304 , 0281 , 0008 , 1501 , 06C0 , 0A61 , 0261 , 3000 , 0481 , 045F , CODE STCR C339 , A30C , C059 , 04C0 , 0241 , 000F , C081 , 0A61 , 0261 , 3400 , 0481 , C082 , 1304 , 0282 , 0008 , 1501 , 06C0 , C640 , 045F , R->BASE ( RE-ENTRANT STRING LEXICON: 08oct87 FOX ) \ String variables leave address only. Use C@, COUNT or LEN \ functions as needed to access length byte. \ CHAR.STRING format: size-byte,count-byte ,char,char,char, ... \ Maximum CHAR.STRING length is 255 characters. : CHAR.STRING ( byte-cnt -- var.name ) \ compile time 1+ ; ( STRING STACK LEXICON ) 1 VARIABLE SSP \ string stack pointer : +SSP 1 SSP +! ; \ next stack position : CLEARSSP 1 SSP ! ; \ collapse stack : STRBUF ( -- address-of-buffer ) \ current buffer address SSP @ 256 * PAD + ; --> ( STRING PRIMITIVES AND I/O WORDS FOX ) : LEN ( str -- length) C@ ; \ fetch the length : MAXLEN ( str -- maxlen) 1- C@ ; \ Max no. of bytes : MOVESTR ( str1,adr -- ) OVER LEN 1+ CMOVE ; \ no size checking : !LEN ( n,adr -- adr ) SWAP OVER C! ; \ store length : >STRBUF ( adr -- ) \ to string buffer +SSP STRBUF MOVESTR ; : .STR ( str -- ) COUNT TYPE CLEARSSP ; \ writestring : !STR ( Str1,Str2 -- ) \ string store operator 2DUP MAXLEN SWAP LEN < \ Str2 too short ? IF 8 ERROR ENDIF MOVESTR CLEARSSP ; : TEXTSTR ( delimiter -- | addr ) \ ASCII , TEXTSTR WORD HERE PAD DUP C/L ERASE MOVESTR ; : :=" ( str -- ) \ example: Name$ :=" Peter" ASCII " TEXTSTR PAD SWAP !STR ; --> ( STRING FUNCTIONS: RIGHTSTR SUBSTR 27MAR89 FOX ) : :="" ( str -- ) DUP MAXLEN ERASE ; \ str is made null : TRIM ( str -- str ) >STRBUF STRBUF COUNT -TRAILING OVER 1- C! 1- ; : SUBSTR ( Str,Pos,Length -- address ) +SSP ( Length) >R \ Length to return stack ( Pos) 1- + \ add pos-1 to str address STRBUF R 1+ CMOVE \ move len+1 bytes to STRBUF R> STRBUF !LEN ; \ store the new length byte : RIGHTSTR ( Str,n -- address ) OVER LEN SWAP - \ calc. start position OVER LEN 1+ OVER - \ calc. remaining length SUBSTR ; \ SUBSTR makes the new string --> ( STRING FUNCTIONS: LEFTSTR CONCAT FOX ) : LEFTSTR ( Str,n -- address ) SWAP >STRBUF \ move Str to string stack STRBUF !LEN ; \ store new length : CONCAT ( str1,str2, -- address ) 2DUP SWAP >STRBUF \ str1 to STRBUF COUNT \ get addr & length of STR2 STRBUF COUNT + \ calc end of STR1 IN STRBUF SWAP CMOVE \ move STR2 to STRBUF+COUNT LEN SWAP LEN + \ sum lengths of str1 & str2 STRBUF !LEN ; \ store new len in STRBUF --> ( STRING FUNCTIONS: -MATCH -SAME machine code 02JAN86 BJF ) HEX \ SOURCE on block 124 CODE -MATCH ( str1,n,str2 -- not? ) \ compares NEQ, LT, GT C079 , C039 , C099 , 04C3 , D131 , D172 , 7144 , 1308 , 1501 , 1003 , 0583 , 04C0 , 1002 , 0603 , 04C0 , 1001 , 0600 , C000 , 15F1 , C643 , 045F , \ SOURCE on block 125 CODE -SAME ( str1,n,str2 -- not? ) \ compares not equal C079 , C039 , C099 , 04C3 , 9C72 , 1602 , 0600 , 1002 , 0583 , 04C0 , C000 , 15F8 , C643 , 045F , DECIMAL --> ( STRING COMPARISONS: SEEK, INSTR FOX ) : SEEK ( adr,n,str -- ? ) \ Find str at adr within n bytes >STRBUF \ push str onto string stack >R DUP DUP R> \ make 2 copies of adr under n OVER + SWAP \ set up to index adr DO I STRBUF COUNT SWAP \ set up parameters for -MATCH -SAME NOT \ do comparison, negate the flag IF \ if match found at that address DROP I LEAVE \ place I on stack, LEAVE loop ENDIF LOOP SWAP - ; \ subtract the addresses left : INSTR ( str1,str2 -- n ) \ find str2 within str1 OVER LEN SWAP SEEK ; \ n = 0 if no match is found --> ( STRING FUNCTIONS: DELIMITED, &" FOX ) : DELIMITED ( str,c -- addr ) \ str is delimited by char "c" ENCLOSE \ find 1st delimiter character DROP >R DROP \ get the position onto R >STRBUF \ move HERE onto string stack R> DUP \ bring back position & DUP STRBUF LEN > \ is pos. GT strbuf len IF DROP 0 \ if so replace with a zero THEN STRBUF !LEN ; \ store the new length byte : &" ( str -- ) \ join text to string variable 34 WORD HERE CONCAT ; \ example: SURNAME$ &" Johanne" ( STRING FUNCTIONS: UPPER, LOWER, CHARSUM FOX ) HEX : UPPER ( str, -- address ) \ set str to upper case >STRBUF STRBUF DUP COUNT OVER + SWAP DO I C@ DUP 61 7A WITHIN? IF 5F AND I C! ELSE DROP ENDIF LOOP ; : LOWER ( str -- address ) >STRBUF STRBUF DUP COUNT OVER + SWAP DO I C@ DUP 41 5A WITHIN? IF 20 + I C! ELSE DROP ENDIF LOOP ; : CHARSUM ( str -- sum-of-Ascii-values-in-string ) 0 SWAP COUNT OVER + SWAP DO I C@ + LOOP ; DECIMAL ( DATA-TYPES : ARRAY 15JUL86 B.FOX ) \ ARRAY defines a block of the dictionary from address \ "0" to the size given. It uses the "}" operator to compile \ the size into the dictionary.It is preceded by the cell size \ in bytes, or the constants: BYTE, INTEGER,32BIT or FLOAT \ Use: 1000 INTEGER ARRAY X{ 200 REAL ARRAY WAGES{ \ 999 X{ 1 } ! ... stores 999 at cell #1. \ By convention all array names should end with "{" ie. X{ 1 CONSTANT BYTE 4 CONSTANT 32BIT 2 CONSTANT INTEGER 8 CONSTANT FLOAT : ARRAY ( cell-size -- name) 4 + ; \ skip cell size & dimension --> ( DATA-TYPES : array operator "}" 15JUL86 B.FOX ) : } ( adr,index -- adr) \ no range checking. can cause crash OVER 4 - @ * + ; : MAX} ( addr -- addr,byte-cnt ) DUP 4 - @ OVER 2- @ * ; \ Use: NAMES{ MAX} ERASE : }E ( adr,index -- adr) \ HAS ERROR CHECKING 2DUP SWAP \ ( adr,indx,ad10) 2- @ \ get max no. of bytes U< NOT \ compare to index asked for IF ( INDX > MAXIMUM ) 5 ERROR \ error 5 = "subscript error THEN } ; \ calculcate the address ( INTEGER SWAP and comparisons operators 4JUL96 BJF ) HEX CODE EXCHANGE ( adr1,adr2 -- ) C079 , C0B9 , C0D2 , C491 , C443 , 045F , DECIMAL : 2VAL ( adr1,adr2 -- val1,val2 ) 2DUP @ >R @ R> ; : GT ( adr1,adr2 -- ? ) 2VAL > ; : LT 2VAL < ; : EQ 2VAL = ; ( ALTERNATE TERMINAL SUPPORT FOR RS232 30OCT87 BJF) BASE->R DECIMAL 68 R->BASE CLOAD STAT BASE->R HEX : OUTPORT PABS @ 2DF + DUP PAB-ADDR ! 1- PAB-VBUF ! ; : INPORT PABS @ 2FF + DUP PAB-ADDR ! 1- PAB-VBUF ! ; : TTYPORT OUTPORT AS: OUTPUT DEV= RS232.BA=9600 OPEN >ALTOUT INPORT AS: INPUT DISPLAY SEQUENTIAL FIXED 1 REC-LEN DEV= RS232.BA=9600.EC OPEN >ALTIN ; : TTY CR 22 MESSAGE TTYPORT ( switch to TTY ) C EMIT 21 MESSAGE CR CR 23 MESSAGE CR ABORT ; : BYE CR 22 MESSAGE 28 SCRN_WIDTH ! (CON) 0 0 GOTOXY CLS MENU ABORT ; R->BASE ( BLOCK TO FILE MOVE: WRITEBLK, WRITEBLKS 13MAR87 BJF ) \ 68 CLOAD STAT \ 168 CLOAD DSK3.DIR : SECS 0 DO I DROP LOOP ; : WRITEBLK ( BLK# --- ) \ writes entire block to TI file BLOCK B/BUF \ get block address & bytes/buff OVER + SWAP \ calc. addresses DO I C/L -TRAILING \ 64 chars - trailing blanks 1 MAX WRITE C/L +LOOP ; \ increment block address by 64 : WRITEBLKS ( from,to -- ) \ send multiple blocks to file 1+ SWAP DO I WRITEBLK LOOP ; ( FILE TO BLOCK : READBLK 16AUG86 BJF ) : NOT-EOF STAT 4 = ; : READBLK ( BLK# --- ) BLOCK PAB-BUF ! 16 0 DO NOT-EOF IF PAB-BUF @ READ 64 PAB-BUF +! ELSE #1 CLOSE LEAVE ENDIF LOOP ; : FILE->BLK ( form to --- ) 1+ SWAP DO I READBLK LOOP ; ( VOLKER CRAIG TERMINAL PERSONALITY 8MAR86 BJF) BASE->R DECIMAL CR ." Loading Volker/Craig terminal personality" 155 CLOAD HLIST \ hi-speed serial port stuff 178 CLOAD Y/N? \ handy stuff too : ?TERMINAL KEY 3 = ; \ check for ^C : PAGE 12 EMIT ; \ form feed : LF 10 EMIT ; \ line feed : HTAB 9 EMIT ; \ horizontal tab : HOME 11 EMIT ; \ vertical tab : BSPACE 8 EMIT ; \ back space : VTAB 14 EMIT ; \ shift out : GOTOXY ( col,row -- ) 15 EMIT SWAP EMIT EMIT ; : BEEP 7 EMIT ; R->BASE --> ( PRINT TEXT PAGES 20AUG87 FOX ) : PRINTING ; 66 VARIABLE PAGELENGTH 0 VARIABLE LINECNT 60 VARIABLE LINES/PG 64 VARIABLE COLUMNS 6 VARIABLE MARGIN 0 VARIABLE PAGE# 0 VARIABLE PAGE#COL 0 VARIABLE HEADER-LENGTH : PAGECOLUMN ( -- N) COLUMNS @ MARGIN @ + 2+ ; : INDENT ( -- ) MARGIN @ SPACES ; : LINESLEFT ( -- N) PAGELENGTH @ LINECNT @ - ; : CR'S ( -- ) 6 - 0 DO CR LOOP ; : .PAGE# ( -- ) LINESLEFT CR'S PAGECOLUMN SPACES PAGE# @ 3 .R ; : +PAGE# 1 PAGE# +! ; : FORM 12 EMIT ; --> ( PRINT TEXT PAGES 20AUG87 FOX ) : LINES/PAGE ( n -- ) PAGELENGTH @ 1- MIN LINES/PG ! ; : HEADER ( n -- ) LINES/PG @ MIN HEADER-LENGTH ! ; : .HEADER HEADER-LENGTH @ 0 DO CR 1 LINECNT +! LOOP ; : .FOOTER LINESLEFT IF +PAGE# .PAGE# FORM 0 LINECNT ! ENDIF ; --> ( PRINT TEXT PAGES 20AUG87 FOX ) DECIMAL : +LINECNT 1 LINECNT +! LINECNT @ LINES/PG @ > IF .FOOTER ENDIF ; : TYPELINE ( n -- ) SCR @ .LINE CR +LINECNT ; : .BLOCK ( blk# -- ) DUP BLOCK B/BUF ?ASCII NOT IF . 26 ERROR ENDIF SCR ! 16 0 DO PAUSE IF QUIT CON ENDIF INDENT I TYPELINE LOOP ; --> ( PRINT TEXT PAGES 20AUG87 FOX ) DECIMAL : PRINT ( start-page,end-page -- ) 0 PAGE# ! 0 LINECNT ! .HEADER 1+ SWAP DO I .BLOCK LOOP .FOOTER CON ; ( EPSON RX-80 CONTROL LEXICON 26AUG87 FOX ) 104 CLOAD PRINT : EPSON ; CR ." Loading Epson RX-80 control words" : LPT! LPT EMIT (CON) ; : ESC 27 LPT! ; : VT 11 LPT! ; : EMPHASIZE ESC ASCII E LPT! ; : DE-EMPHASIZE ESC ASCII F LPT! ; : DOUBLE-STRK ESC ASCII G LPT! ; : SINGLE-STRK ESC ASCII H LPT! ; : RESET ESC ASCII @ LPT! ; : PICA ESC ASCII P LPT! ; : ELITE ESC ASCII M LPT! ; : ENLARGED 14 LPT! ; : CONDENSED 15 LPT! ; --> ( EPSON RX-80 CONTROL LEXICON 26AUG87 FOX ) : INCH-FORM ( n --) ESC 0 LPT! LPT! ; : LINE-FORM ( n --) DUP PAGELENGTH ! ESC ASCII C LPT! LPT! ; : LEFT-MARGIN ( n --) ESC ASCII l LPT! LPT! ; : RIGHT-MARGIN ( n --) ESC ASCII Q LPT! LPT! ; ( LABEL MAKER LEXICON: 28AUG87 FOX) : LABELING ; 104 CLOAD PRINT 108 CLOAD INCH-FORM \ LABEL gets text from last edited block stored in SCR variable : LABEL ( -- ) PAGELENGTH @ 1 \ start at line 1 not line 0 DO I TYPELINE \ print the Ith line of SCR LOOP FORM ; \ form feed : LABELS ( count -- ) 0 MARGIN ! 0 DO LABEL PAUSE IF LEAVE ENDIF LOOP CON ; (----5----0----5----0----5 LABEL TEXT BLOCK 02SEP87 FOX ) LONDON P.U.C BOX 3060 LONDON ONTARIO N6A 4J8 ( BACKROUND PROCESSOR 27SEP87 FOX ) DECIMAL 122 CLOAD ISR? HEX 0 VARIABLE REGS2 20 ALLOT \ tms9900 registers 0 VARIABLE USER2 80 ALLOT \ new user variable list 0 VARIABLE S2 100 ALLOT \ new parameter stack 0 VARIABLE R2 100 ALLOT \ new return stack 8300 CONSTANT WORKSPACE1 REGS2 CONSTANT WORKSPACE2 DECIMAL : InitRegs ( -- ) WORKSPACE1 WORKSPACE2 16 MOVE \ copy old regs to new ( USER2 OVER 16 + ! \ new user list to R8 S2 OVER 18 + ! \ new stack to R9 R2 OVER 28 + ! ) ; \ return stack to R14 ( BACKROUND PROCESSOR 27SEP87 FOX ) HEX : InitUsers 3980 USER2 40 MOVE ; \ move user table to USER2 DECIMAL ( BACKROUND PROCESSOR 27SEP87 FOX ) HEX CODE TASK1 WORKSPACE1 LWPI, NEXT, CODE TASK2 WORKSPACE2 LWPI, NEXT, CODE SWITCHER 1 STWP, WORKSPACE1 1 CI, EQ IF, WORKSPACE2 LWPI, ELSE, WORKSPACE1 LWPI, ENDIF, NEXT, : NEWJOB InitUsers InitRegs ISR= SWITCHER RUNISR ; ( DOUBLE PRECISION WORD SET 05JUL85 GED ) BASE->R DECIMAL 74 R->BASE CLOAD ;CODE BASE->R HEX CODE 2! C039 , CC39 , CC39 , 045F , CODE 2@ C019 , C070 , C650 , 0649 , C641 , 045F , CODE 2DROP 8E79 , 045F , CODE 2DUP 0229 , -4 , CA69 , 6 , 2 , C669 , 4 , 045F , CODE 20VER 0229 , -4 , CA69 , A , 2 , C669 , 8 , 045F , CODE 2SWAP C029 , 2 , C059 , C669 , 4 , CA69 , 6 , 2 , CA40 , 6 , CA41 , 4 , 045F , CODE 2ROT C029 , A , C069 , 8 , C089 , 0222 , 6 , C892 , 4 , 0642 , B242 , 16FB , CA40 , 2 , C641 , 045F , R->BASE --> ( DOUBLE PRECISION WORD SET .... 05JUL85 GED ) BASE->R DECIMAL : 2CONSTANT 2@ ; : 2VARIABLE ; : D- DMINUS D+ ; : D= D- 0= SWAP 0= AND ; : D0= 0. D= ; : D< D- SWAP DROP 0< ; : DU< ROT SWAP 2DUP U< IF 2DROP 2DROP ELSE = IF U< ELSE 2DROP 0 ENDIF ENDIF ; : DMAX 20VER 20VER D- SWAP DROP 0< IF 2SWAP ENDIF 2DROP ; : DMIN 20VER 20VER 2SWAP D- SWAP DROP 0< IF 2SWAP ENDIF 2DROP ; R->BASE ( DOER/MAKE "Thinking Forth" LPB 12MAY86 ) : NOTHING ; : DOES-PFA ( pfa -- pfa of child of ) 2+ ; : DOER @ >R ; 0 VARIABLE MARKER : (MAKE) R> DUP 2+ DUP 2+ SWAP @ 2+ DOES-PFA ! @ -DUP IF >R ENDIF ; : MAKE STATE @ IF ( compiling ) COMPILE (MAKE) HERE MARKER ! 0 , ELSE HERE [COMPILE] ' DOES-PFA ! SMUDGE [COMPILE] ] ENDIF ; IMMEDIATE : ;AND COMPILE ;S HERE MARKER @ ! ; IMMEDIATE : UNDO ' NOTHING [COMPILE] ' DOES-PFA ! ; ( SCREEN DUMP TO PRINTER /TEXT ONLY ) -PRINT ( LIB routines ) : SCRDUMP 72 CLOAD TRIADS LPT ( activate line printer ) SCRN_END @ SCRN_START @ DO I VSBR EMIT I 1+ SCRN_WIDTH @ MOD 0= IF CR ?TERMINAL IF LEAVE ENDIF ENDIF LOOP RETURN ; ( return to previous terminal ) ( PRIME NUMBER TEST 29 APR 86 BJF ) : PRIMES ( n ___ ) DUP 1 DO 2 / 2 DO I J MOD 0= ( NO REMAINDER ) IF ( True ) DROP LEAVE ELSE I ENDIF LOOP -DUP IF ( I ) . ENDIF LOOP ; ( TRANSLATOR EXPERIMENT 30APR BJF ) : TRANSLATOR ; VOCABULARY ENGLISH/DUTCH IMMEDIATE ENGLISH/DUTCH DEFINITIONS : I ." IK " ; : WHERE ." WAAR "; : ME ." MIJ " ; : IS ." IS " ; : YOU ." JOU " ; : THE ." DE " ; : SPEAK ." SPREKEN " ; : WASHROOM ." TOILETTE " ; : TALK SPEAK ; : WHAT ." WAT " ; : DUTCH ." NEDERLANDS " ; : HIS ." ZIJN " ; : CAN ." KAN " ; : WITH ." MET " ; : VERY ." ZEER " ; : TIME ." TIJD " ; : GOOD ." GOED " ; : THAT ." DAT " ; : NOT ." NIET " ; : ARE HIS ; ( INTERUPT SERVICE ROUTINE SUPPORT LEXICON 17SEP87 FOX ) HEX : STOPISR 0 83C4 ! ; : RUNISR INTLNK @ 83C4 ! ; : ISR= ( -- ) -FIND DROP DROP CFA ISR ! ; : ISR? ( returns status of ISR. Active or not ) 83C4 @ 0 > IF 1B MESSAGE ELSE 1C MESSAGE ENDIF ; DECIMAL ( TIMER: SET RESET TIME CLKON CLKOFF 18 MIN. MAX 20JUN86 BJF ) BASE->R HEX 0 VARIABLE T 4 ALLOT : SEXTAL 6 BASE ! ; : RESET 0 T ! ; : SET T ! ; : T++ 1 T +! ; : :00 # SEXTAL # DECIMAL 3A HOLD ; : .TIME <# :00 :00 #S #> TYPE ; : TIME T @ 0 .TIME ; R->BASE ( ASSEMBLER STRING COMPARE OPERATOR : COMPSTR 01JAN87 BJF ) CODE COMPSTR ( str1,n,str2 ) \ 0:SAME, 1:GT, -1:LT *SP+ 1 MOV, *SP+ 0 MOV, *SP 2 MOV, 3 CLR, BEGIN, 1 *?+ 4 MOVB, 2 *?+ 5 MOVB, \ bytes moved into R4,R5 4 5 SB, \ sub R4,R5 , DECR counter NE IF, \ comp R4 R5 NOT EQ GT IF, 3 INC, 0 CLR, \ if R4>R5, R3= 1, exit ELSE, 3 DEC, 0 CLR, \ else R3=-1, exit ENDIF, ELSE, 0 DEC, ENDIF, 0 0 MOV, LTE \ R0 <= 0 ? ( HI OR = 0 ) UNTIL, \ loop until above is TRUE 3 *SP MOV, \ push R1 to stack NEXT, ( ASSEMBLER STRING EQUATING OPERATOR : -SAME 01JAN87 BJF ) CODE -SAME ( str1,n,str2 ) \ "NOT-SAME" *SP+ 1 MOV, \ str2 -> R1, pop stack *SP+ 0 MOV, \ count-> R0, pop stack *SP 2 MOV, \ str1 -> R2 3 CLR, \ reset R3 BEGIN, 2 *?+ 1 *?+ CB, \ compare bytes,auto-incr EQ IF, 0 DEC, \ if .EQ. dec byte counter ELSE, 3 INC, 0 CLR, \ else set R3 , clr R0 ENDIF, 0 0 MOV, LTE \ R0 <=0 ? (byte counter ) UNTIL, \ loop until above is TRUE 3 *SP MOV, \ push R3 to stack NEXT, \ end definition ( STRING SEARCH OPERATOR : SEEK 01FEB87 BJF ) \ finds position of string in a block of ram N bytes long CODE SEEK ( adr,n,str1 -- f ) \ f=0 if str1 not found *SP+ 4 MOV, \ R4:= adr of str1 *SP+ 5 MOV, \ R5:= # of bytes to seek in 5 INC, \ + one more for good measure *SP 6 MOV, \ R6:= start of ram block 6 5 A, \ R5 now is end of ram block 4 *? 7 MOVB, \ Len(str1)-> R7 7 8 SRL, \ shift to the low order byte 7 5 S, \ EndOfRam=EndOfRam-R7 4 INC, \ inc R4 to get past byte cnt 3 CLR, \ clear found flag --> ( SEEK LOOP STRUCTURES ... ) BEGIN, 7 0 MOV, \ count-> r0 4 2 MOV, 6 1 MOV, \ str1-> r2 , ramblock-> r1 BEGIN, \ inner string equate routine 2 *?+ 1 *?+ CB, EQ IF, 0 DEC, ELSE, 3 INC, 0 CLR, ENDIF, LTE UNTIL, 3 3 MOV, NE IF, 6 INC, 3 CLR, \ if R3<>0 keep going ELSE, 6 3 MOV, 6 5 MOV, \ force exit ENDIF, 6 5 C, EQ \ if start=end exit loop UNTIL, 3 *SP MOV, \ move address to stack NEXT, ( TTY Line Editor:TED good for most terminals 30oct87 FOX ) DECIMAL VOCABULARY TED IMMEDIATE TED DEFINITIONS : PAGE 12 EMIT ; \ clears most terminals : CLEARPAD PAD 64 32 FILL ; : TEXT> CLEARPAD WORD HERE COUNT PAD SWAP CMOVE ; : P ( line# -- ) \ put a line into block 1 TEXT> SCR @ (LINE) PAD ROT ROT CMOVE UPDATE ; : T ( line# -- ) \ type a line SCR @ .LINE ; : EDIT ( n -- ) PAGE LIST ." Line editor ready.." CR ; : ED ( -- ) SCR @ EDIT ; \ ed current block : >> ( -- ) 1 SCR +! ED ; \ next block : << ( -- ) -1 SCR +! ED ; \ previous block ( BACKUPS: STRING STORE 12JUL82 LCT) DECIMAL 41 CLOAD SMOVE \ Load screen scopy routines 178 CLOAD Y/N? \ Handy stuff HEX : (!") R COUNT DUP 1+ =CELLS R> + >R >R SWAP R> CMOVE ; : !" 22 STATE @ ( STORE STRING AT ADDR ) IF COMPILE (!") WORD HERE C@ 1+ =CELLS ALLOT ELSE WORD HERE COUNT >R SWAP R> CMOVE ENDIF ; IMMEDIATE --> ( BACKUPS : DISK-HEAD COMPATIBLE WITH TI-BASIC 12JUL82 LCT) BASE->R HEX : DISK-HEAD 0 CLEAR 0 BLOCK ( START SECTOR 0) DUP !" FORTH " DUP A + 168 SWAP ! DUP C + 944 SWAP ! DUP E + 534B SWAP ! DUP 10 + 2000 SWAP ! DUP 12 + 26 0 FILL DUP 38 + C8 FF FILL 100 + ( START SECTOR 1) DUP 2 SWAP ! DUP 2+ FE 00 FILL 100 + ( START SECTOR 2) DUP !" SCREENS " DUP A + 0 SWAP ! DUP C + 2 SWAP ! DUP E + 165 SWAP ! DUP 10 + 80 SWAP ! DUP 12 + CA02 SWAP ! DUP 14 + 8 0 FILL DUP 1C + 2250 SWAP ! DUP 1E + 1403 SWAP ! DUP 20 + 4016 SWAP ! 22 + 0DE 0 FILL FLUSH ; R->BASE --> ( BACKUP : COMPLETE BACKUP 16MAR87 BJF ) DECIMAL 41 CLOAD SMOVE : COMPLETE 0 DISK_SIZE @ 1- ; \ set-up for full backup : BACKUP ( start-blk,end-blk -- ) CR ." * Insert MASTER disk in drive 1" CR ." * Insert COPY disk in drive 2" CR CR ." * Press any key to continue" CR ." * Press FCTN CLEAR to halt process" CR KEY DROP 1+ SWAP DO ?TERMINAL IF CR CR ." *Job ended early*" ABORT ELSE I DUP DUP ." Copying.. " . CR DISK_SIZE @ + SCOPY ENDIF LOOP CR CR ." * Disk Backup complete" ABORT ; ( EDITOR SEARCH STRING : BJF 03FEB87 ) 64 CHAR.STRING SEARCH-STRING 0 VARIABLE SEARCH-LENGTH 0 VARIABLE SEARCH-START : GET.STRING PAGE ." Search string:" BEEP SEARCH-STRING ACCEPTSTR ; : HOWMANY ( ) CR ." How many blocks:" ACCEPT# 0 DISK_HI @ LIMITS SEARCH-LENGTH ! ; : FOUND? ( -- ? ) SEARCH-START @ ; : VERIFIED? ( -- ? ) FOUND? DUP IF !CUR REDRAW CURSON PAGE ." This one ? " BEEP Y/N? ELSE NOT ENDIF ; : SCRN.SEARCH ( -- ) SCR @ BLOCK SEARCH-START + B/BUF SEARCH-START - SEARCH-STRING SEEK ; --> ( EDITOR BLOCK SEARCH : LOCATE BJF 15FEB87 ) : LOCATE ( -- blk#, cnt ) GET.STRING HOWMANY 0 SEARCH-START ! SEARCH-LENGTH SCR @ DO I SCR ! SCRNO \ change blocks & display # BEGIN SCRN.SEARCH SEARCH-START ! VERIFIED? UNTIL 0 SEARCH-START ! ?TERMINAL IF LEAVE ENDIF LOOP ; ( INTEGER SWAP FOR SORTS OF ALL KINDS 4JUL96 BJF ) : SWAPINT ( ADR1, ADR2 ___ ) 2DUP ( dup the addresses ) >R @ SWAP ( push adr2 & get val/adr1 ) R> @ ( pop adr2 & get val/adr2 ) >R ! ( push val2 & store to adr2) R> ( get val/adr2 & ) SWAP ! ; ( swap & store to adr1 ) : GT ( ADR1,ADR2 ___ FLAG ) ( flag=true if adr1>adr2 ) 2DUP @ >R @ R> > ; : LT 2DUP @ >R @ R> < ; ( IMPROVED BUBBLE SORT : sorts array called A{ n } BJF ) 0 VARIABLE N : BUBSORT ( N -- ) N ! 0 \ store n, place false flag BEGIN SET FLAG ! N @ 1 DO A{ I } A{ I 1+ } GT IF SWAPINT NOT \ swap the ints, NOT flag ELSE 2DROP ENDIF LOOP -1 N +! \ decr. N to shorten loop UNTIL ( FLAG=TRUE ) ; \ go until flag=true ( SHELLSORT PRIMITIVES: 24JUL86 BJF ) 0 VARIABLE GAP 0 VARIABLE j 0 VARIABLE k : N@ N @ ; : j@ j @ ; : k@ k @ ; : GAP@ GAP @ ; : *1.5 15 10 */ ; : CALC_GAP ( N ___ ) *1.5 2 / ; --> ( SHELLSORT : sorts array called A{ n } BJF ) : SHELLSORT CALC_GAP GAP ! BEGIN GAP@ 2 / DUP GAP ! 0 > WHILE ( GAP>0 ) N@ GAP@ - 1 \ from N-GAP to 1 DO I j ! BEGIN j@ DUP GAP@ + k ! 0 > WHILE ( j > 0 ) A{ j@ } A{ k@ } GT IF SWAPINT GAP@ MINUS j +! ELSE 2DROP 0 j ! ENDIF REPEAT LOOP REPEAT ; ( RS232 TEST WORDS ) XINIT : RXTEST BEGIN CKEY DUP EMIT 3 = UNTIL ; ( ^C to stop) ( HI-SPEED RS232 EMIT USING DIRECT CRU COMMUNICATION 21JAN87 ) \ based on words from Forth dimensions VI/2 ) BASE->R DECIMAL 88 R->BASE CLOAD STCR BASE->R HEX 034 CONSTANT RATE \ 34=9600 bps 1A1=1200 00A3 CONSTANT PROTOCOL \ 8 BITS EVEN Par. 1 STP 1300 2 / CONSTANT CARD \ address of Rs232 card CARD 07 + CONSTANT LED \ led on card CARD 020 + CONSTANT PORT \ 20=RS232/1 40=RS232/2 DECIMAL PORT 13 + CONSTANT LDIR \ Load interval register PORT 16 + CONSTANT RTS \ request to send PORT 18 + CONSTANT RXI \ recieve interrupt bit PORT 21 + CONSTANT RBRL \ Receive buffer reg loaded PORT 22 + CONSTANT TXBE \ Transmit buffer reg empty PORT 31 + CONSTANT RESET \ Reset TMS 9902 R->BASE --> ( HI-SPEED RS232 EMIT USING DIRECT CRU COMMUNICATION 21JAN87 ) BASE->R HEX : XINIT LED SBO RESET SBO RXI SBZ PROTOCOL 08 PORT LDCR LDIR SBZ RATE 0C PORT LDCR LED SBZ ; \ set to 9600 BAUD : CEMIT ( char -- ) RTS SBO LED SBO BEGIN TXBE TB UNTIL ( wait for Tx buffer) 08 PORT LDCR LED SBZ 1 OUT +! RTS SBZ ; : CKEY? ( -- char ) \ scans keys only RBRL TB IF 08 PORT STCR ELSE 0 ENDIF RXI SBZ ; R->BASE --> ( HI-SPEED TTY WORDS: HTYPE KEY CR 27JUN86 BJF ) : CKEY ( -- n ) BEGIN RBRL TB UNTIL LED SBO 8 PORT STCR RXI SBO LED SBZ ; DECIMAL : CRLF 13 CEMIT 10 CEMIT ; : CTYPE ( adr,n --) \ hi-speed TYPE OVER + SWAP DO I C@ CEMIT LOOP ; XINIT : RXTEST BEGIN CKEY DUP EMIT 3 = UNTIL ; ( ^C to stop) ( HI-SPEED TTY LIST 15JUN86 BJF ) DECIMAL : COMLIST ( blk# -- ) \ hi-speed LIST DUP DUP SCR ! CRLF ." SCR #" 3 .R CRLF BLOCK B/BUF OVER + SWAP DO 4 0 DO BL CEMIT LOOP \ send 4 spaces I 64 -TRAILING CTYPE CRLF \ type the line 64 +LOOP ; \ increment address by 64 : LIST232 ( start end --) SWAP DO I COMLIST LOOP ; BASE->R HEX ( F0F0 F0F0 F0F0 F0F0 7 CHAR BELL FEFE FEFE FEFE FEFE 8 CHAR BACK SPACE FCFC FCFC FCFC FCFC 9 CHAR HOR TAB FFFD FDFD FDFD FDFD A CHAR LINE FEED AFAD AFAD AFAD AFAD B CHAR VERT TAB ) FF83 DF87 DFDF FF00 C CHAR ( FORM FEED ) ( FFFF FFFF FFFF FFFF X CHAR FFFF FFFF FFFF FFFF X CHAR FFFF FFFF FFFF FFFF X CHAR ) R->BASE ( RS232 TEST ) 101 CLOAD WRITEBLKS 168 CLOAD #2 #1 AS: TEXTFILE DEV= RS232.BA=1200.PA=E.DA=7 OPEN : DELAY 0 DO I DROP LOOP ; : TEST BEGIN 163 WRITEBLK TYPE CR \ to TI-99 Screen 10 DELAY PAUSE UNTIL ; : SENDIT WRITEBLKS ; ( EPSON RX-80 BIT-MAP CONTROLS 14APR86 BJF ) : BIT-MAP ESC 75 EMIT ; : HIRES ESC 76 EMIT ; : IMAGE ( cnt -- n1,n2 ) DUP 256 /MOD SWAP EMIT8 EMIT8 ; : ?EOL OUT @ 512 > IF CR 0 OUT ! ENDIF ; : SENDSCREEN ( adr,cnt -- ) LPT BIT-MAP IMAGE \ set to bit map mode OVER + SWAP \ set up to index adresses DO DUP I + VSBR EMIT8 LOOP CON ; ( Lists.... 05APR87 BJF ) ( LIST STRUCTURE: When called a list leaves an address on the stack that is the activation record for that "List". The activat ion record contains: 1st block #, no. of blocks, and maximum size of an atom : LALLOC >R OVER OVER OVER + SWAP DO I BLOCK B/BUF -TRAILING IF I 13 MESSAGE ABORT ENDIF LOOP ; : List ( start-blk, blk-cnt, atom-size -- text-name ) , , , \ compile the nos. to memory DOES> @ BLOCK ; ( PAB INITIALIZATION FOR 3 FILES & I/O DEVICES 7MAY86 BJF ) 68 CLOAD STAT BASE->R HEX 0 VARIABLE FILEBUF FF ALLOT ( forth ram buffer ) PABS @ 7F + FILEBUF 35D8 FILE #1 PABS @ BF + FILEBUF 37D8 FILE #2 : TEXTFILE SEQUENTIAL VARIABL ; \ text file definintion : PORT1 #1 AS: TEXTFILE ; : PORT2 #2 AS: TEXTFILE ; R->BASE --> ( DIRECTORY DISPLAY 19/2/86 B. FOX ) : (DIR) AS: INPUT INTERNAL RELATIVE FIXED 128 REC-LEN DEV= DSK1. ; : DIR (DIR) OPEN 0 REC# FILEBUF READ CR ." DSK." FILEBUF COUNT TYPE CR CR ( volume name ) 126 1 DO I REC# FILEBUF DUP READ ( begin loop ) COUNT -DUP ( read name cnt ) IF TYPE CR ( type it out ) PAUSE ( F ) ELSE IF ( F=TRUE) LEAVE ENDIF ENDIF DROP I 1- ( total # of files on S ) LOOP (DIR) CLOSE CR . ." files" ; --> ( DIRECTORY DISPLAY 19/2/86 B. FOX ) : DSK1.DIR (DIR) DEV= DSK1. DIR ; : DSK2.DIR (DIR) DEV= DSK2. DIR ; : DSK3.DIR (DIR) DEV= DSK3. DIR ; ( DISPLAY A TEXT FILE IN ENTIRETY ) : NOT-EOF STAT 4 = ; : CLRPAD ( N ___ ) PAD 80 BLANKS ; : .PAD PAD 80 -TRAILING TYPE ; : PRINTFILE BEGIN NOT-EOF ( false flag ) WHILE CLRPAD PAD READ .PAD CR REPEAT ; ( VIEW: A WAY TO FIND STUFF IN A SERIES OF BLOCKS 13AUG88 FOX) DECIMAL : FIND 1 TEXTSTR PAD TRIM ; : GO ( blk1, blk2 -- | offset blk# ) 0 ROT ROT CR 1+ SWAP DO I DUP DUP SCR ! . BLOCK B/BUF PAD SEEK DUP IF LEAVE ELSE DROP THEN PAUSE IF CR 36 ERROR THEN LOOP DUP 0= 43 ?ERROR \ "string not found" 2+ SCR @ ; ( RELATIVE FILES : FIELD JAN86 BJF ) : FIELD ( addr, fieldno. ___ fieldaddr, byte count ) SWAP ( push field no. onto RS ) 1+ DUP 1- C@ ROT ( field no. on top ) DUP 1 > IF 1 DO + 1+ DUP 1- C@ LOOP ENDIF DROP ;