fs2fb

Descripción del contenido de esta página

Utilidad Forth para convertir ficheros fuente de formato de texto a formato de bloques.

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.

Listado


\ --------------------------------------------------------
\ fs2fb

\ Copyright (C) 2009,2011 Marcos Cruz (programandala.net)
\ License: http://programandala.net/license

\ This program converts a Forth stream file (.fs)
\ into a Forth block file (.fb),
\ or into an Abersofth Forth block file
\ saved in a ZX Spectrum's TAP file.

\ This program has been written and tested in Gforth.

\ --------------------------------------------------------

\ History

\ 2009-06-04 First draft.
\ 2009-06-14 First working version.
\ 2011-12-23 The format of the source code was modifed.

\ --------------------------------------------------------

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)

Descarga

Páginas relacionadas