csb2
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
;