csb2

Description of the page content

Circular string buffer in Forth.

Tags:

csb2 is my customized version of a circular string buffer written by Wil Baden in 1996.

Source code

The original version by Wil Baden, with some little changes of mine:

\ Circular string buffer

\ (c) 1996 Wil Baden
\ Forth Dimensions, volume XVIII, number 2 (July/August 1996), page 6
\ http://forth.org/FD/

\ Modified by Marcos Cruz (programandala.net)
\ 2008-04-27

200000 CONSTANT /csb  \ size of the buffer

/csb CELL+ ALLOCATE  [IF]
  \ ALLOCATE error
  DROP CREATE csb 0 , /csb CHARS ALLOT
[ELSE]
  CONSTANT csb  0 csb !
[THEN]

\ : (>csb)  ( u -- c-addr )
: +sbuffer  ( u -- c-addr )

  \ Take a number and return
  \ a character address in the buffer
  \ to store a string of that lenght.

  DUP csb @ >
  IF  /csb csb !  THEN
  NEGATE csb +!
  csb CELL+ csb @ CHARS +

  ;

\ : >csb  ( c-addr1 u -- c-addr2 u )
: >sbuffer  ( c-addr1 u -- c-addr2 u )

  \ Find room for a string in the buffer,
  \ copy it there and return its address and length.

\ DUP (>csb) SWAP
  DUP +sbuffer SWAP
  2DUP >R >R
  CHARS MOVE
  R> R>

  ;

: str+  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ Concatenate two strings and move the
  \ result into the buffer.

  2 PICK OVER + >R  ( R: u1+u2 )
\ R@ (>csb) >R  ( R: u1+u2 c-addr3 )
  R@ +sbuffer >R  ( R: u1+u2 c-addr3 )
  2 PICK CHARS R@ + ( . . c-addr2 u2 c-addr3+u1)
  SWAP CHARS CMOVE  ( c-addr1 u1 )
  R@ SWAP  ( c-addr1 c-addr3 u1 )
  CHARS CMOVE  ( )
  R> R>

  ;

\ ' s+ alias str+

csb2

The improved version I rewrote to suit my needs:

\ csb2
\ ("Circular String Buffer 2")
\ ("Almacén Circular de Textos 2")

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

\ http://programandala.net/es.programa.csb2.html

\ Basado en parte en el código publicado por Wil Baden
\ en Forth Dimensions en julio-agosto de 1996
\ (volumen 18, número 2, página 6).

\ Probado con: Gforth, SP-Forth y lina. 

\ Historial:
\ 2011-06-14: Primera versión.
\ 2011-07-24: Cambiado MOVE por CMOVE en SMOVE .
\ 2011-12-08: Añadido CHARS en varios cálculos.
\   Falta confirmar si debería estar en todos,
\   aunque en la práctica CHARS no hace nada
\   en la mayoría de sistemas Forth.
\ 2011-12-24: Versión opcional para sistemas
\   Forth que no tienen las palabras ALLOCATE ,
\   RESIZE y FREE . Creada la palabra >BYTES/CSB .
\ 2012-02-05: Unificado el formato de los comentarios.
\ 2012-02-05: Los comandos principales pasan a ser vectores,
\   y nuevas palabras permiten reasignarlos a una de las dos
\   versiones: memoria y diccionario. Esto facilita cambiar
\   de modalidad.
\ 2012-04-07: Corrección de la puntuación de los comentarios.
\ 2015-01-29: Sustitución de los tabuladores por espacios.

: >bytes/csb  ( u1 -- u2 )
  \ Convierte un número de caracteres en el número de octetos necesarios.
  \ u1 = Caracteres
  \ u2 = Octetos necesarios para guardarlos,
  \      más una celda para guardar el puntero
  chars cell+
  ;
\ Número máximo predeterminado de caracteres en el almacén:
1024 >bytes/csb value /csb
\ Dirección del almacén (cero hasta que se cree el almacén):
0 value csb

: csb_set  ( u a -- )
  \ Guarda la dirección y longitud de la zona a usar como almacén.
  2dup !  \ Guardar en la primera celda del almacén
          \ el número de caracteres libres.
  to csb  to /csb
  ;

\ Vectores de los comandos principales

defer free_csb
defer allocate_csb
defer resize_csb

\ Versión para usar la memoria como almacenamiento

: heap_free_csb
  \ Libera la zona de memoria del almacén.
  csb free throw
  ;
: heap_allocate_csb  ( u -- )
  \ Crea un almacén para u caracteres.
  csb  if  free_csb  then  \ Si ya existe un almacén creado, borrarlo.
  dup >bytes/csb allocate throw
  csb_set
  ;
: heap_resize_csb  ( u -- )
  \ Cambia el tamaño del almacén para u caracteres.
  dup >bytes/csb csb swap resize throw
  csb_set
  ;

\ Versión limitada, que utiliza el espacio del diccionario

: dictionary_free_csb  ;
: dictionary_allocate_csb  ( u -- )  here over >bytes/csb allot csb_set  ;
: dictionary_resize_csb  ( u -- )  allocate_csb   ;

\ Asignación de los vectores

: heap_csb  ( -- )
  \ Activa la versión que utiliza la memoria.
  ['] heap_resize_csb is resize_csb
  ['] heap_free_csb is free_csb
  ['] heap_allocate_csb is allocate_csb
  ;
: dictionary_csb  ( -- )
  \ Activa la versión que utiliza el diccionario.
  ['] dictionary_resize_csb is resize_csb
  ['] dictionary_free_csb is free_csb
  ['] dictionary_allocate_csb is allocate_csb
  ;

[defined] allocate [defined] resize [defined] free and and
[IF]    heap_csb
[ELSE]  dictionary_csb
[THEN]

/csb allocate_csb  \ Crear el almacén con el tamaño predeterminado.

: csb_check  ( u -- )
  \ Si no queda espacio libre para u caracteres en el almacén,
  \ reinicia el puntero.
  chars csb @ >  if  /csb csb !  then
  ;
: csb-  ( u -- )
  \ Reduce el espacio disponible en el almacén en u caracteres.
  chars negate csb +!
  ;
: 'csb  ( u -- a )
  \ Devuelve una dirección libre en el almacén para almacenar u caracteres.
  chars dup csb_check  csb-  \ Comprobar y preparar el almacén.
  csb cell+ csb @ chars +  \ Calcular la dirección libre.
  ;
: >csb  ( a1 u -- a2 u )
  \ Guarda una cadena en el almacén y la devuelve con su nueva dirección.
  dup 'csb swap  \ Calcular la dirección y disponer parámetros para MOVE .
  2dup >r >r  \ Preservar la cadena en la pila de retornos.
  chars move  \ Copiar la cadena en el almacén.
  r> r>  \ Recuperar la cadena.
  ;
: (s)  ( a u -- | a2 u )
  \ Almacena una cadena en el sistema.
  state @
  if  postpone sliteral  \ En modo de compilación, en el diccionario.
  else  >csb  \ En modo de interpretación, al almacén.
  then
  ;
: s|  ( "ccc<|>" -- a u )
  \ Interpreta una cadena de forma análoga a la palabra S"
  \ pero usando la barra vertical como separador,
  \ lo que permite usar comillas dobles en las cadenas.
  [char] | parse  \ Buscar siguiente barra vertical en flujo de entrada.
  (s)  \ Almacenar la cadena.
  ; immediate
: s"  ( "ccc<doublequote>" -- a u )
  \ Interpreta una cadena de forma análoga a la palabra S" .
  \ Esta palabra sustituye a la homónima estándar;
  \ hace la misma función pero devuelve el resultado en el almacén.
  [char] " parse  \ Buscar siguiente comilla doble en flujo de entrada.
  (s)  \ Almacenar la cadena.
  ; immediate
: lengths  ( a1 u1 a2 u2 -- a1 u1 a2 u2 u1 u2 )
  \ Duplica en la pila las longitudes de dos cadenas.
  2 pick over
  ;
: smove ( a1 u a2 -- )
  \ Copia una cadena a una dirección.
  swap chars cmove
  ;
: s+  ( a1 u1 a2 u2 -- a3 u3 )
  \ Concatena dos cadenas y devuelve el resultado en el almacén.
  \ Calcular y preservar la longitud total:
  lengths + >r  ( a1 u2 a2 u2 ) ( R: u3 )
  \ Calcular y preservar la dirección en el almacén:
  r@ 'csb >r  ( R: u3 a3 )
  \ Calcular la dirección de la segunda cadena
  \ dentro de la cadena final (u1+a3):
  2 pick chars r@ +  ( a1 u1 a2 u2 u1+a3 )
  smove  ( a1 u1 )  \ Copiar la segunda cadena al almacén.
  r@ smove  \ Copiar la primera cadena al almacén.
  r> r>  \ Recuperar de la pila de retornos los datos de la cadena final.
  ;
: c!++  ( a1 c -- a2 )
  \ Guarda un caracter en una dirección de memoria
  \ y devuelve la dirección incrementada.
  over c! char+
  ;
: (s&)  ( a1 u1 a2 u2 -- a3 u3 )
  \ Concatena dos cadenas con un espacio intermedio
  \ y devuelve el resultado en el almacén.
  \ Calcular y preservar la longitud total:
  lengths + 1+ >r  ( a1 u2 a2 u2 ) ( R: u3 )
  \ Calcular y preservar la dirección en el almacén:
  r@ 'csb >r  ( R: u3 a3 )
  \ Calcular la dirección de la segunda cadena
  \ dentro de la cadena final (u1+a3):
  2 pick chars r@ +  ( a1 u1 a2 u2 u1+a3 )
  bl c!++  \ Guardar un espacio en esa posición y la incrementa.
  smove  ( a1 u1 )  \ Copiar la segunda cadena al almacén.
  r@ smove  \ Copiar la primera cadena al almacén.
  r> r>  \ Recuperar de la pila de retornos los datos de la cadena final.
  ;
: any_empty_string?  ( a1 u1 a2 u2  -- a1 u1 a2 u2 f )
  \ ¿Alguna de las dos cadenas está vacía?
  lengths 0= swap 0= or
  ;
: s&  ( a1 u1 a2 u2 -- a3 u3 )
  \ Concatena dos cadenas (con un espacio intermedio si ninguna está vacía)
  \ y devuelve el resultado en el almacén.
  any_empty_string?  if  s+  else  (s&)  then
  ;
: count  ( a -- a2 u )
  \ Sustituye a la palabra homónima estándar;
  \ hace la misma función pero devuelve el resultado en el almacén.
  count >csb
  ;

Downloads

Related pages

sbuffer
Circular string buffer in Forth.
csb8
Model of circular string buffer for an 8-bit Forth.