*********** THE UNIFORTH SAMPLER ************** FORTH.FTH is the default file, and contains the segment utility as well as the sysgen program. There are empty blocks at the end of the file for your own use. Copyright (c) 1985 Unified Software Systems P.O. Box 2644, New Carrollton, MD 20784 (301) 552-9590 \ Notes on clock words 042885aah --> \ just in case you try to load this block CLKADR is 6-byte array in order: se mi hr yr da mo Four vectored words control data movement from clkadr to your particular clock: SDATE, GDATE set date from, get date into, clkadr STIME, GTIME set time from, get time into, clkadr These guys are variables, which nominally contain the code field addresses of NOOP. Store the CFA of your interface routine into the appropriate variable. See following blocks. ( Z80 CTC clock -- 1 042685AAH) 2VARIABLE TICS ( count the number of tics) SUBROUTINE $INCTIM ( Interrupt handler) HL PUSH, AF PUSH, ( we need these registers/flags) TICS HL LD, ( the 32-bit tick counter) (HL) INC, CY RIF, ( 32-bit increment, byte 0) HL INC, (HL) INC, CY RIF, ( byte 1) HL INC, (HL) INC, CY RIF, ( byte 2) HL INC, (HL) INC, ( byte 3) RTHEN, RTHEN, RTHEN, ( exit conditionals) AF POP, HL POP, ( restore registers) EI, RETI, END-CODE CODE XDI ( disable interrupts) DI, NEXT, END-CODE CODE XEI ( enable interrupts) EI, NEXT, END-CODE DECIMAL --> ( Z80 CTC clock -- 2 042685AAH) : START-CLOCK ( store $INCTIM into CTC's vector) XDI $INCTIM H' FF1C ! XEI ; : SET-TIME ( set time assuming 1 second interrupts) CLKADR C@ S>D CLKADR 1+ C@ 60 SS*D D+ CLKADR 2+ C@ 3600 SS*D D+ TICS 2! ; : GET-TIME ( read from TICS into CLKADR) TICS 2@ 60 UM/MOD SWAP CLKADR C! 60 /MOD CLKADR 2+ C! CLKADR 1+ C! ; ' SET-TIME STIME ! ( set time execution vector) ' GET-TIME GTIME ! ( get time execution vector) DECIMAL ;S ;S ( UNIFORTH SYSGEN load block 090584AAH) FORTH DEFINITIONS DECIMAL ( RETURN VOCABULARY TO FORTH) ' FORTH >BODY 12 +ORIGIN 10 CMOVE ( store state of vocab) HERE 36 +ORIGIN ! ( FENCE) HERE 38 +ORIGIN ! ( D.P.) VOC-LINK @ 40 +ORIGIN ! ( VOC-LINK) : GETVALS ( input number routine for reallocate) CR ." Number of blocks (2 to n):" GETNUM CR ." New memory size in Kbytes (24-60):" GETNUM CR ; : ENDALL ( print terminating messages for reallocate) ." End reallocate. SYSGEN or COLD to use new limits" CR ; : REALLOCATE ( change init memory size and #buffers) GETVALS 1024 * LIMIT @ - OVER #BUFF @ - B/BUF 8 + * - 32 24 DO DUP I +ORIGIN +! 2 +LOOP 42 +ORIGIN +! 44 +ORIGIN ! ENDALL ; --> ( UNIFORTH SYSGEN -- 2 030584 aah) 21 ARRAY FCB$ ( temporary fcb) : !FCB ( adr --- ...fill fcb from string adr) FCB @ 1+ 11 BLANKS FCB @ 12 + 22 ERASE DUP DUP FINDCOLON FINDDOT >IN @ TIB @ ROT TIB ! 1 >IN ! !DEV !NAM !TYP TIB ! >IN ! ; : FILL-BLOCKS ( fill in task image) 38 +ORIGIN @ 0 +ORIGIN - US>D 1024 UM/MOD SWAP IF 1+ THEN 0 DO I 1024 * +ORIGIN I BUFFER 1024 CMOVE UPDATE LOOP ; : CRTASK ( create new .COM file for task) SAVE-BUFFERS EMPTY-BUFFERS FCB$ FCB ! CR ." Enter new task name, like B:FTH.COM " PAD 1+ 40 EXPECTBL SPAN @ PAD C! PAD !FCB FCB @ (MAKE) DROP ; --> ( UNIFORTH SYSGEN -- 3 081683 aah) : CORRECT-FCB ( modify new file for correct def fcb) FCB 0 +ORIGIN - US>D 1024 UM/MOD BLOCK + 92 SWAP ! UPDATE ; : SYSGEN ( main word for writing new task file) CRTASK FILL-BLOCKS CORRECT-FCB SAVE-BUFFERS EMPTY-BUFFERS CLOSE CHANA ; --> ( UNIFORTH SYSGEN -- 4 081484AAH) : (SCRAMBLE) ( perform the actual scramble) 14 +ORIGIN PAD 40 + 8 CMOVE BEGIN PAD 40 + (LATEST) SWAP ?DUP WHILE NAME> >LINK DUP @ ROT ! 0 SWAP ! REPEAT DROP ; : SCRAMBLE ( OEM development tool...wipes out links) ( use this word on your sysgen, and no royalties) ( are required) CR ." SCRAMBLE...Are you sure? " Y/N 0> IF CR ." Have you set TURNKEY? " Y/N 0> IF (SCRAMBLE) SYSGEN CR ." Finished scrambling...now rebooting!" BYE THEN THEN ; ;S ;S ( The game of STARS) ( Courtesy of W. Ragsdale) VARIABLE TRIES VARIABLE RANDOM 60 RANDOM ! : -STARS 0 DO ." *" LOOP ; : AWARD 4 SPACE 32 -STARS CR ." That's it !!! You guessed my cosmic number in " TRIES @ . ." tries " ; : HINT 4 SPACES 64 SWAP / 2/ 1+ DUP RANDOM +! -STARS CR ; : WIN? OVER - DUP 0< IF NEGATE THEN DUP IF HINT FALSE ELSE DROP AWARD TRUE THEN ; : MORE? CR ." Do you want to play again?? " Y/N ; --> ( The game of STARS -- 2 ) : GUESS ( -- num ..take care of user input) BEGIN GETNUM PRECIS @ 0< IF CR DROP ." Give me a real number! " FALSE ELSE DUP RANDOM +! 1 TRIES +! TRUE THEN UNTIL ; : SELECT RANDOM @ 101 MOD 0 TRIES ! ; : SHORT CR ." I have a number. What is your guess?? " CR ; : INSTRUCTIONS CR CR ." I will select a number from 1 to 100 " CR ." Type in your guess and hit <return>. " CR ." If you are close I'll tell you by showing stars. " 8 -STARS CR ; --> ( The game of stars -- 3) : STARS 0 BLK ! 0 TRIES ! DECIMAL INSTRUCTIONS BEGIN SHORT SELECT BEGIN GUESS WIN? UNTIL MORE? NOT UNTIL CR CR ." Thanks, see you later " CR CR 10 SPACES ; --> ;S ( *** EXTENSIONS TO MAKE SYSTEM TRUE FORTH-83 *** ) : UM* USS*D ; : .( A' ) WORD COUNT TYPE ; : FORTH-83 ; : .NAME dup @ >name id. 2+ ; : .OFFSET .name dup @ . 2+ ; : .WORD dup @ case ' lit =: 2+ dup @ . 2+ ;; ' (.") =: 2+ a' . emit a' " emit space count 2dup type + a' " emit space ;; ' 0branch =: .offset ;; ' branch =: .offset ;; ' $case =: .offset ;; ' $=: =: .offset ;; ' (do) =: .offset ;; ' (loop) =: .offset ;; ' (+loop) =: .offset ;; ' compile =: .name .name ;; nocase =: .name ;; casend ; --> : WORD_LIST ( cfa - ) >body begin dup @ ' ;s <> while .word repeat ." ; " ; : SEE [compile] ' dup @ 2dup - -2 = if ." Code " else case ' words @ =: ." : " dup >name id. word_list ;; ' dp @ =: ." Variable " ;; ' 1 @ =: ." Constant " ;; ' forth @ =: ." Vocabulary " ;; casend then ; ;S ;S ;S ;S
