sbuffer
I wrote this circular string buffer implementation in 2001, based on the code of a similar code for kForth I rewrote it also in OPL+ as part of Forth 5mx. Finally I wrote csb2, an improved implementation.
Source code
\ *******************
CR .( sbuffer )
\ *******************
\ Copyright (C) 2001,2005,2008 Marcos Cruz (programandala.net)
\ License: http://programandala.net/license
\ Programa escrito en ANS Forth.
\ Programo verkita en ANS-Fortho.
\ Program written in ANS Forth.
\ Búfer circular para cadenas de texto.
\ Cirkla tekstochena bufro.
\ Circular text string buffer.
\ ***************************************************************
\ Algunas de las palabras están tomadas y adaptadas de:
\ Iuj el la vortoj estas adapte prenitaj el:
\ Some of the words are taken and adapted from:
\ strings.4th (String utility words for kForth, 1999)
\ ***************************************************************
\ Por hacer / Farenda / To do :
\ Comprobar la longitud máxima de las cadenas del sistema antes de almacenar una en el búfer.
\ Probar si se aprovecha hasta el último octeto.
\ ***************************************************************
\ Historial / Historio / History :
\ 2015-01-29:
\ Tabs changed to spaces in the source.
\ 2012-02-12:
\ 2- removed; 2 - used instead. It was a rest from Forth 5mx.
\ 2009-09-18:
\ SBUFFER# had to be increased from 500000 to 690000 because of a special operation needed
\ in my app alinome-bici-cua.fs.
\ 2008-04-27:
\ In >SBUFFER : CHARS added; CHAR+ used instead of 1+ .
\ In >CSBUFFER : 1 CHARS - used instead of 1- .
\ In +SBUFFER : CHAR+ used instead of 1+ .
\ 2008-01-20:
\ Bugs fixed in +BUFFER .
\ They were not discovered until this code was used in gforth
\ (Win32Forth suffered from the same bugs, but its error messages
\ are less verbose and the problem coud not be found).
\ Forth 5mx worked right because this app is written as a primitive in the system.
\ 2005-10-19:
\ +SBUFFER improved to avoid lengths greater than the buffer.
\ 2005-10-18:
\ Espacio en el búfer reservado con ALLOT si ALLOCATE da error.
\ Bufrospaco rezerivita per ALLOT se ALLOCATE fiaskas.
\ If ALLOCATE returns an error, the buffer space is reserved with ALLOT.
\ Todos los comentarios en los tres idiomas.
\ Chiuj notoj en la tri lingvoj.
\ All comments in the three languages.
\ Todas las palabras renombradas en inglés.
\ Chiuj vortoj angle renomitaj.
\ All words renamed into English.
\ Mejorados las palabras del interfaz y el funcionamiento interno general.
\ Plibonigitaj la interfacvortoj kaj la ena funkciado.
\ Interface words and inner working improved.
\ Se almacena también la longitud del texto en el búfer.
\ Ankaw la tekstolongo enmetitas en la bufron.
\ The text lenght is stored in the buffer too.
\ Nueva palabra >CSBUFFER .
\ Nova vorto >CSBUFFER .
\ New wod >CSBUFFER .
\ 2005-03-13:
\ Espacio en el búfer reservado con ALLOCATE en lugar de ALLOT .
\ Bufrospaco rezervita per ALLOCATE anstataw ALLOT .
\ Buffer space reserved with ALLOCATE instead of ALLOT .
\ 2001:
\ Primera versión.
\ Unua versio.
\ First version.
\ ***************************************************************
800000 CONSTANT sbuffer#
sbuffer# ALLOCATE [IF]
\ ALLOCATE error
DROP CREATE 'sbuffer sbuffer# CHARS ALLOT
[ELSE]
CONSTANT 'sbuffer
[THEN]
'sbuffer sbuffer# 1- + CONSTANT 'sbuffer;
\ Variable que apuntará al espacio libre del búfer:
\ Variablo celumonta la bufran liberan spacon:
\ Variable that will point to the buffer free space:
VARIABLE (sbuffer) 'sbuffer (sbuffer) !
VARIABLE /sbuffer
: sbuffer ( -- addr )
\ Devuelve la dirección actual del espacio libre del búfer.
\ Redonu la nuna adreson de la libera bufrospaco.
\ Return the current address of the free buffer space.
(sbuffer) @
;
: sbuffer-free ( -- u )
\ Return the free bytes in the buffer.
\ 2008-01-21
'sbuffer; sbuffer - 1-
;
: +sbuffer ( u -- c-addr )
\ Apunta a un espacio libre del búfer para una cadena de texto de u caracteres.
\ Celumigu al libera bufra spaco por tekstocheno u bitokojn longa.
\ Point to a free buffer space for a text string u bytes long.
[ FALSE ] [IF]
\ First buggy version.
sbuffer# 1- MIN
DUP 1+ /sbuffer !
'sbuffer; 'sbuffer - >
IF
\ Espacio insuficiente; mueve el puntero al comienzo del búfer.
\ Nesuficha spaco; movu la celumilon bufrokomencen.
\ Not enough space; move the pointer to the buffer start.
'sbuffer (sbuffer) !
THEN
sbuffer
[THEN]
\ 2008-01-20 Bugs fixed.
\ 2008-01-21 Factored with SBUFFER-FREE .
sbuffer# 2 - MIN
CHAR+ DUP /sbuffer !
sbuffer-free >
IF
\ Espacio insuficiente; mueve el puntero al comienzo del búfer.
\ Nesuficha spaco; movu la celumilon bufrokomencen.
\ Not enough space; move the pointer to the buffer start.
'sbuffer (sbuffer) !
THEN
sbuffer
;
: sbuffer+! ( u -- )
\ Suma u octetos al puntero del búfer.
\ Sumu u bitokojn al la bufro-celumilo.
\ Add u bytes to the buffer pointer.
(sbuffer) +!
;
: sbuffer+ ( -- )
\ Suma al puntero del búfer los octetos reservados por +sbuffer .
\ Sumu al la bufro-celumilo la bitokojn rezervitajn de +sbuffer .
\ Add to the buffer pointer the bytes reserved by +sbuffer .
/sbuffer @ sbuffer+!
;
: >sbuffer ( c-addr1 u -- c-addr2 u )
\ Copia una cadena de texto en el búfer.
\ Kopiu tekstochenon bufren.
\ Copy a text string into the buffer.
DUP +sbuffer
2DUP C! CHAR+
SWAP 2DUP 2>R CHARS CMOVE 2R>
sbuffer+
;
: >csbuffer ( c-addr1 u -- c-addr2 )
\ Copia una cadena de texto en el búfer.
\ Kopiu tekstochenon bufren.
\ Copy a text string into the buffer.
>sbuffer DROP 1 CHARS -
;
.( sbuffer ok!)