Ftaper
Description of the page content
Forth tool to convert Forth source files to ZX Spectrum virtual tape files.
Abandoned project. Started on 2010-06-02. 20% completed.
The goal of this tool was to convert Forth source text files to ZX Spectrum TAP files, ready to be used by Abersoft Forth or Spectrum Forth-83.
The project was abandoned because first fs2fb (a simple similar tool), and finally fsb and fsb2 (more powerful and versatile) made ftaper unnecessary.
Source code
The most recent version of the code is the following:
#! /usr/bin/env gforth
\ --------------------------------------------------------
\ Ftaper
\ Version A-01-20141026
\ ** UNFINISHED **
\ ** UNDER DEVELOPMENT **
\ This program creates,
\ from a Forth source text file, a TAP file
\ suitable for the following ZX Spectrum's Forth Systems:
\ - Abersoft Forth (by John Jones-Steele, 1983)
\ - Forth-83 Standard System (by Lennart Benschop, 1988)
\ Copyright (C) 2010,2011,2014 Marcos Cruz (programandala.net)
\ License/Licencia/Permesilo: http://programandala.net/license
\ This program is written in Forth with Gforth.
\ --------------------------------------------------------
\ Planned features
\ * Wrap long source lines.
\ * Configurable block lines and columns (16x64, 32x32...)
\ * Configurable position of the --> word: alone in its own line, the last of every block, or at the end of the block code.
\ * Convert tabs into spaces.
\ * Configurable layout: respect the original or remove spaces.
\ * Configurable minimum and maximun number of blocks per TAP file.
\ --------------------------------------------------------
\ Changelog
\ 2010-06-02: First draft.
\ 2010-11-20: Bug fixed: "-->" was printed also into the first line of the next block, because the line buffer was not blanked after omitting the first line.
\ 2011-02-08: Some changes.
\ 2011-02-09: Variables and constants for the tape addresses has been reorganized. New variables for options.
\ 2011-02-09: The tape header and the TAP metadata are ready. The TAP file is created.
\ 2011-02-09: New words to show the blocks info.
\ 2014-07-25:
\ Change: Updated the stack notation of strings and zones,
\ and the notation of metacomments.
\ New: Shebang.
\ Fix: code typo in 'blank_line'.
\ Fix: error messages.
\ 2014-10-26: Experimental changes for version A-01.
\ --------------------------------------------------------
\ Technical info
\ TAP file format (from the "Z80" Spectrum emulator's documentation):
\ The .TAP files contain blocks of tape-saved data. All blocks start with two
\ bytes specifying how many bytes will follow (not counting the two length
\ bytes). Then raw tape data follows, including the flag and checksum bytes. The
\ checksum is the bitwise XOR of all bytes including the flag byte. For example,
\ when you execute the line SAVE "ROM" CODE 0,2 this will result:
\
\ |------ Spectrum-generated data -------| |---------|
\
\ 13 00 00 03 52 4f 4d 7x20 02 00 00 00 00 80 f1 04 00 ff f3 af a3
\
\ ^^^^^...... first block is 19 bytes (17 bytes+flag+checksum)
\ ^^... flag byte (A reg, 00 for headers, ff for data blocks)
\ ^^ first byte of header, indicating a code block
\
\ file name ..^^^^^^^^^^^^^
\ header info ..............^^^^^^^^^^^^^^^^^
\ checksum of header .........................^^
\ length of second block ........................^^^^^
\ flag byte ............................................^^
\ first two bytes of rom .................................^^^^^
\ checksum (checkbittoggle would be a better name!).............^^
\
\ A tape header always consists of 17 bytes:
\
\ Byte Length Description
\ ---------------------------
\ 0 1 Type (0,1,2 or 3)
\ 1 10 Filename (padded with blanks)
\ 11 2 Length of data block
\ 13 2 Parameter 1
\ 15 2 Parameter 2
\
\ The type is 0,1,2 or 3 for a Program, Number array, Character array or Code
\ file. A SCREEN$ file is regarded as a Code file with start address 16384 and
\ length 6912 decimal. If the file is a Program file, parameter 1 holds the
\ autostart line number (or a number >=32768 if no LINE parameter was given) and
\ parameter 2 holds the start of the variable area relative to the start of the
\ program. If it's a Code file, parameter 1 holds the start of the code block
\ when saved, and parameter 2 holds 32768. For data files finally, the byte at
\ position 14 decimal holds the variable name.
\ --------------------------------------------------------
forth definitions decimal
[defined] --ftaper-- [if] --ftaper-- [then]
marker --ftaper--
include string.fs
include ffl/str.fs
\ --------------------------------------------------------
\ Stock words
[undefined] bounds [if]
: bounds ( a len -- a' a ) over + swap ;
[then]
[undefined] true [if]
-1 constant true
[then]
[undefined] false [if]
0 constant false
[then]
[undefined] on [if]
: on ( a -- ) true swap ! ;
[then]
[undefined] off [if]
: on ( a -- ) false swap ! ;
[then]
[undefined] 2+ [if]
: 2+ ( n1 -- n2 ) 2 + ;
[then]
: !z80 ( u a -- )
\ Store a 16-bit value, big-endian, like the Z80.
swap 2dup 256 mod swap c! 256 / swap 1+ c!
;
: @z80 ( a -- )
\ Fetch a 16-bit value, big-endian, like the Z80.
\ First version:
dup c@ swap 1+ c@ 256 * +
\ Second version (can not work in all platforms):
\ @ 0xFFFF and
;
\ --------------------------------------------------------
\ Debug
: halt ( -- ) cr ." Press any key" key drop ;
\ --------------------------------------------------------
\ Constants
9 constant tab-char
\ --------------------------------------------------------
\ Options
variable -tabs? -tabs? on
variable -spaces? -spaces? on
variable remove_empty_lines? remove_empty_lines? on
variable -comments? -comments? on \ XXX not used yet
variable show_output? show_output? on
variable show_info? show_info? on
variable preserve_first_line? preserve_first_line? on
variable compact_format? compact_format? on \ XXX not used yet
\ --------------------------------------------------------
\ Text file constants and variables
1024 constant //txt_line \ max txt line length
create txt_line //txt_line chars allot \ buffer for the text line to be translated
variable txt_line# \ source line counter
\ --------------------------------------------------------
\ TAP file constants and variables
1024 16 * constant //data \ actual data maximum length in bytes
17 constant /header \ actual header length in bytes
/header 2+ constant /header_block \ header block length
//data 2+ constant //data_block \ max data block length
/header_block 2+ //data_block 2+ + constant //tap \ TAP file maximum length in bytes
create tap //tap chars allot \ buffer for the TAP file
tap 2+ constant header_block \ TAP header block address
header_block 1+ constant header \ actual header address
header_block /header_block + 2+ constant data_block \ data block address
data_block 1+ constant data \ actual data address
variable >data \ pointer to the current write position
10 constant /filename \ length of the ZX Spectrum file name
64 constant //block_line
create block_line //block_line chars allot \ tap line buffer
variable /block_line 64 /block_line ! \ block line lenght
variable last_block_line 15 last_block_line !
: lines/block ( -- u ) last_block_line @ 1+ ;
variable block_line# \ block line counter
variable block# \ block counter
\ --------------------------------------------------------
\ Files
variable txt_fileid
variable tap_fileid
: open_txt ( ca len -- )
\ ca len = txt file name
r/o open-file abort" Error while opening the text file."
txt_fileid !
;
: open_tap ( ca len -- )
\ ca len = tap file name
r/w create-file abort" Error while creating the TAP file."
tap_fileid !
;
: write_tap ( ca len -- )
\ ca len = content
tap_fileid @ write-file abort" Error while writing to the TAP file."
;
: open_files ( ca1 len1 ca2 len2 -- )
\ ca1 len1 = text file name
\ ca2 len2 = TAP file name
open_tap open_txt
;
: close_txt ( -- )
txt_fileid @ close-file abort" Error while closing the text."
;
: close_tap ( -- )
tap_fileid @ close-file abort" Error while closing the TAP file."
;
: close_files ( -- )
close_tap close_txt
;
\ --------------------------------------------------------
\ TAP file meta data
\ Addresses related to the header block or the data block:
: >block_length ( a1 -- a2 ) 2 - ;
: >block_flag ( a -- a ) ;
: >block_checksum ( a1 -- a2 ) dup >block_length @z80 + 1- ;
\ Addresses related to the header block only:
: header_type ( -- a ) header_block 1+ ;
: header_filename ( -- a ) header_block 2+ ;
: header_data_length ( -- a ) header_filename /filename + ;
: header_parameter1 ( -- a ) header_data_length 2+ ;
: header_parameter2 ( -- a ) header_parameter1 2+ ;
: checksum ( a len -- b )
\ a len = memory zone
\ b = checksum ("checkbittoggle") of the memory zone
\ 2dup swap cr ." checksum " u. u. \ XXX INFORMER
1- over c@ rot rot bounds
do i c@ xor loop
;
: /tap ( -- u )
\ u = length of the whole TAP file
>data @ tap - 2+
;
: /data ( -- u )
\ u = length of the actual data
>data @ data - 1+
;
: /data_block ( -- u )
\ u = length of the data block
/data 2+
;
: filename! ( ca len -- )
\ ca len = filename
\ Store the given ZX Spectrum file name into the TAP header
/filename min
header_filename dup /filename blank
swap cmove
;
: finish_header_block ( -- )
0 header_block >block_flag c! \ ZX Spectrum header block id
3 header_type c! \ ZX Spectrum CODE content type id
/header_block header_block >block_length !z80
s" DISC" filename!
/data header_data_length !z80
65535 /data - header_parameter1 !z80 \ start of the code when saved
32768 header_parameter2 !z80
header /header checksum header_block >block_checksum c!
;
: finish_data_block ( -- )
255 data_block >block_flag c! \ ZX Spectrum data block id
/data_block data_block >block_length !z80
data /data checksum data_block >block_checksum c!
;
: finish_tap ( ca len -- )
\ ca len = tap file name
\ cr ." In finish_tap " .s cr type \ XXX INFORMER
finish_header_block
finish_data_block
tap /tap write_tap
;
\ --------------------------------------------------------
\ Text line formatting
: (tab>bl) ( ca -- )
\ ca = address whose content has to be modified
dup c@ tab-char = if bl swap c! else drop then
;
: (tabs>blanks) ( ca len -- )
\ ca len = text line
bounds do i (tab>bl) loop
;
: tabs>blanks ( ca len -- )
\ ca len = text line
?dup if (tabs>blanks) else drop then
;
: -tabs ( ca len -- )
\ ca len = text line
-tabs? @ if tabs>blanks then
;
: (-spaces) ( ca len -- ) \ XXX TODO
\ ca len = text line
;
: -spaces ( ca len -- )
\ ca len = text line
-spaces? @ if (-spaces) then
;
: (-comments) ( ca len -- ) \ XXX TODO
\ ca len = text line
;
: -comments ( ca len -- )
\ ca len = text line
-comments? @ if (-comments) then
;
: blank_line ( -- )
block_line /block_line @ blank
;
: right_pad ( ca len -- )
\ Clear the block line buffer with blanks and copy the block line into it
\ ca len = text line
blank_line block_line swap cmove
;
: format_txt_line ( ca len -- )
\ ca len = text line
right_pad
;
\ --------------------------------------------------------
\ Data translation
: +block_line# ( -- )
\ Update the line and block numbers
\ cr ." block_line# at the start of +block_line# is " block_line# ? \ XXX INFORMER
block_line# @ 1+ dup lines/block < and dup block_line# !
0= 1 and block# +!
\ cr ." block_line# at the end of +block_line# is " block_line# ? \ XXX INFORMER
;
: +>data ( -- )
\ Update the TAP data block pointer
/block_line @ >data +!
;
: next_line ( -- )
blank_line +>data +block_line#
;
: (.block#) ( -- )
cr ." Block #" block# @ .
;
: .block# ( -- )
show_output? @ if (.block#) then
;
: (.block_line#) ( -- )
hex cr block_line# @ s>d <# # #S bl hold #> type decimal
;
: .block_line# ( -- )
show_output? @ if (.block_line#) then
;
: .margin ( -- ) [char] | emit ;
: line@ ( -- ca len ) block_line /block_line @ ;
: (.line) ( -- )
block_line# @ 0= if .block# then
.block_line# .margin line@ type .margin
;
: .line ( -- )
show_output? @ if (.line) then
;
: line>data ( ca len -- )
\ XXX TODO
drop /block_line >data @ /block_line @ cmove
;
: new_line ( -- )
.line next_line
;
: >line ( ca len -- )
\ ca len = text to be copied into a block line
\ XXX TODO
\ cr ." In >line block_line# is " block_line# ? 2dup cr type \ XXX INFORMER
format_txt_line line>data new_line
;
: check_first_line ( -- )
\ cr ." block_line# at the start of check_first_line is " block_line# ? \ XXX INFORMER
block_line# @ 0= preserve_first_line? @ and if
\ cr ." preserving line 0" \ XXX INFORMER
new_line then
;
: .--> ( -- )
\ cr ." block_line# in .--> is " block_line# ? \ XXX INFORMER
s" -->" >line
;
: last_block_line? ( -- f )
block_line# @ last_block_line @ =
;
: (>tap) ( len -- )
/block_line @ min
last_block_line? if .--> then
check_first_line
cr ." ----> In (>tap) 1 " .s \ XXX INFORMER
txt_line swap >line
cr ." ----> In (>tap) 2 " .s \ XXX INFORMER
;
: >tap ( len -- )
cr ." In >tap " .s \ dup txt_line swap cr type \ XXX INFORMER
\ cr ." block_line# at the start of >tap is " block_line# ? \ XXX INFORMER
txt_line swap
2dup -tabs -spaces -comments
cr ." after cleaning " .s \ dup txt_line swap cr type \ XXX INFORMER
key drop
nip dup 0= remove_empty_lines? @ and
if drop else (>tap) then
\ cr ." block_line# at the end of >tap is " block_line# ? \ XXX INFORMER
;
: <txt ( -- len flag )
\ cr ." In <txt 1 " .s \ XXX INFORMER
txt_line //txt_line txt_fileid @ read-line
abort" Error while reading the source file."
\ cr ." In <txt 2 " .s \ XXX INFORMER
;
: init ( -- )
1 txt_line# ! 0 block_line# ! 0 block# ! \ counters
tap //tap erase data //data blank \ buffer
data >data ! \ pointer
;
\ --------------------------------------------------------
\ Info
: "(" [char] ( hold ;
: ")" [char] ) hold ;
: 0x [char] x hold [char] 0 hold ;
: .(0x) ( u -- )
base @ hex swap s>d
<# ")" over 255 > if # # then # # 0x "(" #> type
base !
;
: .field ( u -- )
dup u. .(0x)
;
: .header_block_info ( -- )
cr ." Header block:"
cr ." block length = " header_block >block_length @z80 .field
cr ." black flag = " header_block >block_flag c@ .field
cr ." type = " header_type c@ .field
cr ." filename = " [char] " emit header_filename /filename type [char] " emit
cr ." data length = " header_data_length @z80 .field
cr ." data start = " header_parameter1 @z80 .field
cr ." parameter 2 = " header_parameter2 @z80 .field
cr ." block checksum = " header_block >block_checksum c@ .field
;
: .data_block_info ( -- )
cr ." Data block:"
cr ." block length = " data_block >block_length @z80 .field
cr ." block flag = " data_block >block_flag c@ .field
cr ." block checksum = " data_block >block_checksum c@ .field
;
: (.info) ( -- )
.header_block_info .data_block_info
;
: .info ( -- )
show_info? @ if (.info) then
;
\ --------------------------------------------------------
\ Main
0 [if] \ XXX new, experimental
: .block ( ca len -- )
~~
." «" type ." »" cr
;
: .blocks ( ca1 len1 ... ca-n len-n n -- )
~~
0 do .block loop
;
: unline ( ca len -- ca' len' )
;
: (ftaper) ( ca len -- )
~~
unline 1024 str+columns .blocks
~~
;
variable filename$
: ftaper ( ca1 len1 -- )
\ ca1 len1 = text file name
2dup filename$ $! slurp-file (ftaper)
;
[then]
: (ftaper) ( -- )
init
\ cr ." In (ftaper) " .s \ XXX INFORMER
begin <txt
\ cr ." In (taper) loop " .s \ XXX INFORMER
while
\ cr ." In (taper) loop " .s \ XXX INFORMER
>tap
\ halt \ XXX INFORMER
repeat drop
finish_tap
.info
\ cr ." (ftaper) END " .s \ XXX INFORMER
;
: ftaper ( ca1 len1 ca2 len2 -- )
\ ca1 len1 = text file name
\ ca2 len2 = TAP file name
open_files (ftaper) close_files
\ cr ." ftaper END " .s \ XXX INFORMER
;
cr .( Ftaper )
cr .( Usage: )
cr .( s" path/program.fs" ftaper)
cr
: test s" ~/forth/ftaper/ftapertest.fs" ftaper ;