FigForth 1.0d#

An old Forth Version for ATARI 800. Uses traditional Forth blocks for storage.

Screens Disk 1#




SCR # 1 
  0 ( basic functions )
  1 HEX : BELL FD EMIT ;
  2 DECIMAL
  3 : FREE ( amount of memory left)
  4  MEMTOP @ PAD 256 + - ;
  5 : U. 0 D. ; ( unsigned . )
  6 : NEW-ABORT ( auto-reset )
  7  HERE 2 - ' ABORT DUP @ , ! ;
  8  IMMEDIATE
  9 512 VARIABLE *$* ( $STK size)
 10 
 11 
 12 
 13 
 14 
 15 -->





SCR # 2 
  0 ( printer routines ) HEX
  1 CREATE (P:) 50 C, 3A C, 9B C,
  2 SMUDGE ' (P:) CONSTANT P:
  3 : PR-ON 70 CLOSE 70 8 0 P: OPEN
  4  1 PRFLAG ! ;
  5 : PR-OFF 70 CLOSE 0 PRFLAG ! ;
  6 : PLIST ( strt end --> )
  7  1+ SWAP C EMIT ( form-feed) CR
  8  DO CR I LIST CR CR CR
  9  ?TERMINAL IF LEAVE ENDIF LOOP
 10  C EMIT CR ;
 11 
 12 
 13 
 14 
 15                              -->





SCR # 3 
  0 HEX : :SELECT ( code --> ? )
  1  <BUILDS HERE 1 ALLOT 0
  2  BEGIN BL WORD
  3   HERE 1+ C@ 3B - WHILE
  4   1+ HERE NUMBER DROP C,
  5   -FIND IF DROP CFA , ELSE
  6    HERE COUNT TYPE
  7    ." UNDEFINED" QUIT ENDIF
  8  REPEAT SWAP C! DOES>
  9  DUP DUP C@ 3 * + 1+ SWAP 1+
 10  DO I C@ DUP 0= IF DROP
 11    I 1+ @ EXECUTE LEAVE ELSE
 12    OVER = IF I 1+ @
 13     EXECUTE LEAVE ENDIF
 14   ENDIF 3 +LOOP ;
 15                           6 LOAD





SCR # 4 
  0 ( ERROR MESSAGES )
  1 EMPTY STACK
  2 DICTIONARY FULL
  3 HAS INCORRECT ADDRESS MODE
  4 ISN'T UNIQUE
  5 
  6 DISK RANGE ?
  7 FULL STACK
  8 DISK ERROR !
  9 
 10 
 11 
 12 
 13 
 14 
 15 FORTH INTEREST GROUP





SCR # 5 
  0 ( ERROR MESSAGES )
  1 COMPILATION ONLY, USE IN DEFN
  2 EXECUTION ONLY
  3 CONDITIONALS NOT PAIRED
  4 DEFINITION NOT FINISHED
  5 IN PROTECTED DICTIONARY
  6 USE ONLY WHEN LOADING
  7 OFF CURRENT EDITING SCREEN
  8 DECLARE VOCABULARY
  9 
 10 
 11 
 12 
 13 
 14 
 15 





SCR # 6 
  0 : DUMP ( from number --> )
  1  BASE @ >R HEX ( save base)
  2  0 DO  CR DUP I + DUP 0 4 D.R
  3   ." :"  8 0 DO ( 8 byte values)
  4    DUP I + C@ 2 .R SPACE LOOP
  5   1 2FE C! ( display controls)
  6   8 0 DO ( print ASCII)
  7    DUP I + C@ EMIT LOOP
  8   ?TERMINAL IF LEAVE ENDIF
  9   0 2FE C!  DROP  8 +LOOP
 10  DROP CR R> BASE ! ;
 11 : <CMOVE ( from to n -->,hi-lo)
 12  -DUP IF  1 - -1 SWAP DO
 13   OVER I + C@ OVER I + C!
 14   -1 +LOOP  ENDIF  DROP DROP ;
 15                              -->





SCR # 7 
  0 ( I/O definitions )
  1 00 CONSTANT #0   30 CONSTANT #3
  2 40 CONSTANT #4   50 CONSTANT #5
  3 60 CONSTANT #6
  4 2FB CONSTANT ATACHR
  5 54 CONSTANT ROWCRS ( 1 byte)
  6 55 CONSTANT COLCRS ( 2 bytes)
  7 
  8 
  9 
 10 
 11 
 12 
 13 
 14 
 15 0 VARIABLE (COLOR)           -->





SCR # 8 
  0 : ?IOERR (STAT) @ 7F > IF
  1  BASE @ HEX HERE COUNT TYPE
  2  ."  ? I/O ERROR " (STAT) @ .
  3  BASE ! SP! IN @ BLK @ QUIT
  4  ENDIF ;
  5 CREATE (S:) 53 C, 3A C, 9B C,
  6 SMUDGE ' (S:) CONSTANT S:
  7 CREATE (E:) 45 C, 3A C, 9B C,
  8 SMUDGE ' (E:) CONSTANT E:
  9 : GR. ( mode --> )
 10  ( mode+16=split,mode+32=no clr)
 11  #6 CLOSE   #0 CLOSE
 12  #0 C 0 E: OPEN
 13  #6 SWAP DUP 30 AND C OR ( aux1)
 14   SWAP  S:  OPEN  ?IOERR
 15  ;                           -->





SCR # 9 
  0 : POS. ( x y --> )
  1  ROWCRS C!  COLCRS ! ;
  2 : COLOR ( col --> )
  3  (COLOR) C! ;
  4 : DR. ( x y --> )
  5  (COLOR) C@ ATACHR C!
  6  POS. #6 11 JSRCIO ;
  7 : LOC. ( x y --> val )
  8  OVER OVER POS.  #6 GET >R
  9  POS. #6 R PUT R> ;
 10 : PL. ( x y --> )
 11  POS. #6 (COLOR) C@ PUT ;
 12 : SE. ( reg hue lum --> )
 13  SWAP 10 * + SWAP 2C4 + C! ;
 14 : STICK ( port --> value)
 15  278 ( STICK0) + C@ ;        -->





SCR # 10 
  0 CREATE (CVTSTK) 4 C, 2 C, 3 C,
  1  FF C, 6 C, 8 C, 7 C, FF C, 5 C,
  2  1 C, 0 C, SMUDGE
  3 : CVTSTK ( value --> 0=nothing,
  4  1=up, 3=right, 5=down, 7=left)
  5  5 - ' (CVTSTK) + C@ ;
  6 : STRIG ( port --> TF,T=not psh)
  7  284 ( STRIG0) + C@ ;
  8 : SO. ( voice pitch dist vol ->)
  9  3 D20F C! 3 232 C! 0 D208 C!
 10  SWAP 10 * + 3 PICK DUP +
 11  D201 ( AUDC1) + C!
 12  SWAP DUP + D200 ( AUDF1) + C!
 13  ;
 14 
 15                              -->





SCR # 11 
  0 : SPEMIT  ( char -->,special ch)
  1  1 2FE C!  EMIT  0 2FE C! ;
  2 : XIO ( cmd iocb aux1 aux2
  3         nameaddr --> )
  4  4 PICK >R ( iocb --> ret stk)
  5  R 344 + ! ( store name addr)
  6  R 34B + C! ( store aux2)
  7  R> 34A + C! ( store aux1)
  8  SWAP JSRCIO ( do cmd) ;
  9 
 10 
 11 
 12 
 13 
 14 
 15 DECIMAL                      -->





SCR # 12 
  0 ( string definitions) HEX
  1 *$* @ ALLOT ( allocate $STK)
  2 HERE CONSTANT $0 ( $STK base)
  3 $0 VARIABLE $P ( $STK pointer)
  4 : $P! ( --> , reset $STK)
  5  $0 $P ! ;
  6 : $P@ ( --> $P value)
  7  $P @ ;
  8 : $DROP ( $ -$> )
  9  $P@ DUP C@ + 1+ $P ! ;
 10 : $LEN ( --> len of top $ )
 11  $P@ C@ ;
 12 : $FETCH ( addr len --> , -$> $)
 13  $P@ OVER 1+ - DUP $P ! ( upd$P)
 14  OVER OVER C! ( store len)
 15  1+ SWAP CMOVE ( move str) ; -->





SCR # 13 
  0 : $STORE ( addr max --> actual,
  1            $ -$> )
  2  $LEN MIN >R ( actual length)
  3  $P@ 1+ SWAP R CMOVE
  4  R> $DROP ;
  5 : $VARLEN ( vaddr --> len )
  6  1 - C@ ;
  7 : $VARMAX ( vaddr --> max len )
  8  2 - C@ ;
  9 : $@ ( vaddr -->, -$> $ )
 10  DUP $VARLEN $FETCH ;
 11 : $! ( vaddr -->, $ -$> )
 12  DUP DUP $VARMAX $STORE
 13  SWAP 1 - C! ;
 14 : $. ( $ -$> , print string)
 15  $P@ 1+ $LEN TYPE $DROP ;    -->





SCR # 14 
  0 : $DUP ( $ -$> $ $ )
  1  $P@ 1+ $LEN $FETCH ;
  2 : $P2@ ( 2nd$P) $P@ $LEN + 1+ ;
  3 : $LEN2 ( 2ndlen) $P2@ C@ ;
  4 : $OVER ( $1 $2 -$> $1 $2 $1 )
  5  $P2@ 1+ $LEN2 $FETCH ;
  6 : $SWAP ( $1 $2 -$> $2 $1 )
  7  $P@ >R $LEN ( $2 length)
  8  $OVER $LEN + 2+ ( $1$2$1, len)
  9 $P@ SWAP R SWAP <CMOVE ( $2$1$1)
 10  R> $P ! ; ( pop extra $1)
 11 : $+ ( $1 $2 -$> $1+$2 )
 12  $SWAP  $LEN2 $LEN +
 13  $P@ 1+ DUP 1+ $LEN <CMOVE
 14  ( remove embedded length)
 15  1 $P +! $P@ C! ; ( $P,len)  -->





SCR # 15 
  0 : $FILL ( n b -->, -$> n b's )
  1  OVER 1+ $P@ SWAP - DUP $P !
  2  ( alloc space )
  3  3 PICK OVER C! ( store length)
  4  1+ ROT ROT FILL ;
  5 : $VARFILL ( vaddr b --> )
  6  OVER DUP $VARMAX SWAP $VARLEN -
  7  -DUP IF ( any left to fill?)
  8   >R OVER $@
  9   R> SWAP $FILL $+ $!
 10  ELSE DROP DROP ENDIF ;
 11 : $VARIABLE ( len -->)
 12  <BUILDS DUP C, 0 C, ALLOT
 13  DOES> 2+ ;
 14 : (") ( move inline str to $STK)
 15  R 1+ $@  R C@ R> + 1+ >R ;  -->





SCR # 16 
  0 : " ( if comp, put inline str on
  1  $STK in exec, else put now)
  2  STATE @ IF COMPILE (") 22 WORD
  3   HERE C@ 1+ ALLOT
  4  ELSE  22 WORD  HERE 1+ $@
  5  ENDIF ; IMMEDIATE
  6 1 $VARIABLE $EOL ( EOL string)
  7  $EOL 9B $VARFILL
  8 : $FILE ( --> addr, $ -$> $+EOL)
  9  $EOL $@ $+  $P@ 1+ ;
 10 : $SETDR0 ( --> , $ -$> )
 11  FLUSH CLOSE-DR0 $FILE DROP
 12  DR0NAME 10 $STORE DROP ;
 13 : $SETDR1 ( --> , $ -$> )
 14  FLUSH CLOSE-DR1 $FILE DROP
 15  DR1NAME 10 $STORE DROP ;    -->





SCR # 17 
  0 0 VARIABLE $TR ( temp result)
  1 : ($COMPARE) ( addr1 addr2 len
  2  --> 1,0,-1 )
  3  0 $TR !  -DUP IF ( len>0?)
  4   0 DO  OVER I + C@ OVER I + C@
  5    - -DUP IF ( no match?)
  6     0< IF -1 ELSE 1 ENDIF $TR !
  7  LEAVE ENDIF LOOP ENDIF
  8  DROP DROP $TR @ ;
  9 : ($BLCOMPARE) ( addr len -->
 10  1,0,-1  compare to blanks)
 11  0 $TR !  -DUP IF ( len>0?)
 12   0 DO  DUP I + C@ BL - -DUP IF
 13    0< IF -1 ELSE 1 ENDIF $TR !
 14  LEAVE ENDIF LOOP ENDIF
 15  DROP $TR @ ;                -->





SCR # 18 
  0 : $COMPARE ( --> 1,0,-1
  1  $1 $2 -$>  , compare two str)
  2  $P2@ 1+ $P@ 1+ $LEN $LEN2 MIN
  3  ($COMPARE) DUP 0= ( match?)
  4  IF ( ck rest of str)
  5   $LEN $LEN2 < IF ( $1 longer?)
  6    DROP $P2@ 1+ $LEN +
  7    $LEN2 $LEN - ($BLCOMPARE)
  8   ELSE DROP $P@ 1+ $LEN2 +  $LEN
  9    $LEN2 - ($BLCOMPARE) MINUS
 10  ENDIF ENDIF $DROP $DROP ;
 11 : $= ( --> tf, $1 $2 -$> )
 12  $COMPARE 0= ;
 13 : $< ( --> tf, $1 $2 -$> )
 14  $COMPARE 0< ;
 15 DECIMAL                      -->





SCR # 19 
  0 : "" ( push empty str on $STK)
  1  -1 $P +!  0 $P@ C! ;
  2 0 VARIABLE $TO ( offset)
  3 0 VARIABLE $TL ( length)
  4 : $EXTRACT ( varaddr off char
  5   --> t offset      -$> word
  6   --> f  [when no word left] )
  7  $TR ! ( store char)
  8  -1 $TO ! 0 $TL ! ( clr off,len)
  9  OVER $VARLEN OVER OVER <
 10  IF ( still room left in var)
 11   SWAP DO ( find 1st non-separ)
 12    DUP I + C@ $TR @ = 0=
 13    IF ( non-separator char)
 14     I $TO ! ( starting offset)
 15                              -->





SCR # 20 
  0     I 1+ OVER $VARLEN OVER OVER
  1     < IF ( not at end of var)
  2      SWAP DO ( find next separ)
  3       DUP I + C@ $TR @ =
  4       IF ( found end of word)
  5        I $TO @ - $TL ! ( length)
  6       LEAVE ENDIF
  7      LOOP  $TL @ 0=
  8      IF ( assume end of line)
  9       DUP $VARLEN $TO @ -
 10       $TL ! ( length to end)
 11      ENDIF
 12     ELSE ( 1 char at end of var)
 13      1 $TL !  DROP DROP
 14     ENDIF  LEAVE
 15                              -->





SCR # 21 
  0    ENDIF
  1   LOOP
  2  ELSE  DROP DROP
  3  ENDIF
  4  $TO @ 0< IF ( word not found)
  5   DROP 0 ( return FALSE)
  6  ELSE ( word was found)
  7   $TO @ + $TL @ $FETCH ( get wd)
  8   $TO @ $TL @ + ( new offset)
  9   1 ( return TRUE)
 10  ENDIF ;
 11 
 12 
 13 
 14 
 15                              -->





SCR # 22 
  0 : $+! ( var --> , $ -$>, add str
  1  to variable ) ( comp. new len)
  2  >R R $VARLEN R + ( start addr)
  3  R $VARMAX R $VARLEN - ( ch lft)
  4  $STORE ( concat, ret len added)
  5  R $VARLEN + R> 1 - C!
  6  ( store new length) ;
  7 : $RESET ( auto-$STK reset)
  8  NEW-ABORT $P! DECIMAL ;
  9 
 10 
 11 
 12 
 13 
 14 
 15                              -->





SCR # 23 
  0 : $LOAD ( filename -$> )
  1  $SETDR1 DR1 1 LOAD ;
  2 : LOAD-ED
  3  " D:EDITOR.4TH" $LOAD ;
  4 : LOAD-BED ( boot editor)
  5  " D:BOOTEDIT.4TH" $LOAD ;
  6 : LOAD-DOS
  7  " D:DOS.4TH" $LOAD ;
  8 : LOAD-TURN
  9  " D:TURNKEY.4TH" $LOAD ;
 10 
 11 
 12 
 13 
 14 
 15 





SCR # 24 
  0 
  1 
  2 
  3 
  4 
  5 
  6 
  7 
  8 
  9 
 10 
 11 
 12 
 13 
 14 
 15 




OK
PR-OFF 

Add new attachment

Only authorized users are allowed to upload new attachments.

List of attachments

Kind Attachment Name Size Version Date Modified Author Change note
atr
FigForth1.0dA.atr 92.2 kB 1 05-Apr-2010 22:41 Carsten Strotmann
atr
FigForth1.0dB.atr 92.2 kB 1 05-Apr-2010 22:41 Carsten Strotmann
« This page (revision-3) was last changed on 05-Apr-2010 23:36 by Carsten Strotmann