fs2fb
Description of the page content
Converter of Forth source files to blocks files or ZX Spectrum TAP files.
This tool converts Forth source files to blocks files or ZX Spectrum TAP files, ready to be used by Abersoft Forth. When the program is loaded into Gforth it shows its commands.
fs2fb was superseded by fsb and fsb2, more powerful and versatile tools.
Source code
#! /usr/bin/env gforth
\ --------------------------------------------------------
\ fs2fb
\ Copyright (C) 2009,2011,2014 Marcos Cruz (programandala.net)
\ License: http://programandala.net/license
\ This program converts a Forth stream file (.fs)
\ to a Forth blocks file (.fb),
\ or to a ZX Spectrum TAP file
\ containing an Abersofth Forth's RAM-disc file.
\ This program is written in Forth with Gforth.
\ (http://gnu.org/software/gforth)
\ --------------------------------------------------------
\ History
\ 2009-06-04: First draft.
\ 2009-06-14: First working version.
\ 2011-12-23: The format of the source code was modifed.
\ 2014-10-26: Little changes.
\ 2014-11-02: Strange things happened during some tests. Bugs.
\ --------------------------------------------------------
forth definitions
marker fs2fb
base @ hex
\ Files
variable fs_fid
variable tap_fid
: open_fb ( ca u -- )
open-blocks
;
: open_fs ( ca u -- )
r/o open-file abort" open stream file error"
fs_fid !
;
: open_tap ( ca u -- )
w/o create-file abort" create tap file error"
tap_fid !
;
: close ( fid -- )
close-file abort" close file error"
;
: close_fs ( -- )
fs_fid @ close
;
: close_fb ( -- )
get-block-fid close
;
: close_tap ( -- )
tap_fid @ close
;
\ Text lines
ff constant /line
create 'line /line 2 + chars allot
9 constant tab
: valid-char? ( c -- f )
dup tab <> swap bl <> and
;
: next-char ( ca1 -- ca2 c )
char+ dup c@
;
: -leading_init ( ca u -- ca u ca1 )
over 1 chars -
;
: -leading_result ( ca u ca2 -- ca2 u2 )
dup >r rot - - r> swap
;
: -leading ( ca u -- ca1 u1 )
-leading_init
begin next-char valid-char? until
-leading_result
;
: +space ( ca u1 -- ca u2 )
2dup + bl swap c! 1+
;
: no_\ ( ca u1 -- ca u2 )
2dup s" \ " search
if nip - else 2drop then
;
: no_() ( ca u1 -- ca u2 )
;
: -comments ( ca u1 -- ca u2 )
no_\ no_()
;
: trim ( ca u -- ca1 u1 )
-trailing -leading +space
;
: clean_line ( ca u -- ca1 u1 )
trim -comments
;
: >line ( -- ca u f )
\ u = bytes read
\ f = end of file?
'line dup /line fs_fid @
read-line abort" stream read error"
;
\ Blocks file
1 block-offset ! \ start counting at block 1...
\ ...otherwise Gforth 0.6.2 doesn't update the first block...
\ ...(but fills it with zeroes) (bug?)
2 constant first_block#
400 constant /block
variable block# \ number of the current block
variable >block \ address of the current position into the current block
: 'block ( -- ca )
block# @ block
;
: chars_left ( -- u )
/block >block @ 'block - -
;
: too_long? ( u -- f )
4 + chars_left >
;
: to_block ( ca u -- )
>block @ swap chars move
;
: (line>) ( ca u -- )
dup >r to_block r> >block +! update
;
: .--> ( -- ca u )
s" -->" (line>)
;
: clean_buffer ( u -- )
block /block blank
;
: is_block ( u -- )
dup clean_buffer dup block# ! buffer >block !
;
: next_block ( -- )
block# @ 1+ is_block
;
: line> ( ca u -- )
clean_line 2dup cr type dup too_long?
if .--> next_block then (line>)
;
: first_block ( -- )
1 is_block update 2 is_block
;
: .debug ( -- )
cr ." block# = " block# ?
." 'block = " 'block .
." >block = " >block ?
." chars_left " chars_left .
cr .s cr block# @ list
;
: wait ( -- )
key drop
;
: (fs>fb) ( -- )
first_block
begin .debug >line while line> repeat
2drop flush
;
\ File extensions
create "fb" char f c, char b c,
create "tap" char t c, char a c, char p c,
create filename 255 chars allot
: >filename ( ca u -- ca1 u )
dup rot filename rot cmove filename swap
;
: >"fb" ( ca u -- ca1 u )
>filename 2dup 2 - + "fb" swap 2 cmove
;
: >"tap" ( ca u -- ca1 u1 )
>filename 2dup 2 - + "tap" swap 3 cmove 1+
;
\ TAP file
18 constant /tap_header
create 'tap_header
13 c, 00 c, 00 c, 03 c,
char D c, char I c, char S c, char C c, bl c, bl c, bl c, bl c, bl c, bl c,
ff c, 2b c, 00 c, d0 c, 20 c, 20 c, 1a c, 01 c, 2c c, ff c,
: tap_write ( ca u -- )
tap_fid @ write-file abort" tap write error"
;
: checksum ( ca u -- x )
0 rot rot bounds do i c@ xor loop
;
: header_checksum ( -- )
'tap_header dup /tap_header checksum
;
: block_checksum ( x1 u -- x2 )
\ x1 = current checksum
\ u = block
block /block checksum xor
;
: tap_header ( -- )
header_checksum
;
: block>tap ( x1 u -- x2 )
\ x1 = current checksum
\ u = block
swap over block_checksum block /block tap_write
;
: byte>tap ( b -- )
pad c! pad 1 tap_write
;
: (fb>tap) ( ca1 u1 ca2 u2 -- )
tap_header 0 12 1 do i block>tap loop byte>tap
;
\ User interface
: fs>fb ( ca u -- )
2dup >"fb" open_fb open_fs (fs>fb)
close_fb close_fs
;
: fb>tap ( ca u -- )
2dup >"tap" open_tap open_fb (fb>tap)
close_tap close_fb
;
: fs>tap ( ca u -- )
2dup fs>fb >"fb" fb>tap
;
\ End
base !
\ debug
: s2b fs2fb s" /home/marcos/forth/fs2fb.fs" included ;
: test s" /home/marcos/forth/test.fs" fs>fb ;
cr
cr .( Usage: )
cr .( s" program.fs" fs>fb)
cr .( s" program.fb" fb>tap)
cr .( s" program.fs" fs>tap)
cr cr