Ftaper

Descripción del contenido de la página

Utilidad escrita Forth para convertir ficheros fuente de Forth en ficheros de cinta virtual para ZX Spectrum.

Proyecto abandonado. Iniciado en 2010-06-02. 20% completado.

Etiquetas:

Esta utilidad fue un proyecto para convertir ficheros de código fuente de Forth del formato de texto estándar (cuya extensión en Gforth es «.fs», por «Forth stream») en un fichero de cinta virtual («.tap») que pueda ser leído directamente por los sistemas Abersoft Forth o Spectrum Forth-83 de ZX Spectrum.

El proyecto fue abandonado porque el desarrollo de fsb y fsb2, más potentes y versátiles, lo hizo innecesario. También fue desarrollada una herramienta similar aunque más sencilla: fs2fb.

Código fuente

La última versión del código es la siguiente:

#! /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  ;

Páginas relacionadas

fs2fb
Conversor de ficheros fuente de Forth en ficheros de bloques o ficheros TAP para ZX Spectrum.
fsb
Convertidor de fuentes de Forth.
fsb2
Convertidor de fuentes de Forth.