\ ******************* 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!)