fs2fb
Descripción del contenido de la página
Conversor de ficheros fuente de Forth en ficheros de bloques o ficheros TAP para ZX Spectrum.
Etiquetas:
Esta utilidad permite convertir ficheros de código fuente de Forth del formato de texto estándar (cuya extensión en Gforth es «.fs», por «Forth stream») al formato clásico de bloques («.fb», «Forth blocks»). También crea una variante de los ficheros de bloque: un fichero de cinta virtual («.tap») preparado para el sistema Abersoft Forth de ZX Spectrum.
El programa, una vez cargado en Gforth, muestra la sintaxis de los comandos disponibles.
Este programa está superado por dos herramientas más potentes y versátiles: fsb y fsb2.
Código fuente
#! /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