Author: wmb Date: 2008-12-04 10:18:10 +0100 (Thu, 04 Dec 2008) New Revision: 1018
Added: forth/lib/printf.fth Modified: forth/lib/loadcomm.fth Log: All platforms - added simple "printf" and "sprintf" functions.
Modified: forth/lib/loadcomm.fth =================================================================== --- forth/lib/loadcomm.fth 2008-12-04 09:18:06 UTC (rev 1017) +++ forth/lib/loadcomm.fth 2008-12-04 09:18:10 UTC (rev 1018) @@ -70,6 +70,7 @@ fload ${BP}/forth/lib/linklist.fth \ Linked list routines
fload ${BP}/forth/lib/lex.fth +fload ${BP}/forth/lib/printf.fth
fload ${BP}/forth/lib/autold.fth \ Autoload mechanism
Added: forth/lib/printf.fth =================================================================== --- forth/lib/printf.fth (rev 0) +++ forth/lib/printf.fth 2008-12-04 09:18:10 UTC (rev 1018) @@ -0,0 +1,88 @@ +purpose: printf and sprintf +\ See license at end of file + +d# 1024 buffer: spbuf +0 value splen +: +spbuf ( adr len -- ) + dup splen + d# 1024 > abort" sprintf buffer overflow" + tuck spbuf splen + swap move ( len ) + splen + is splen +; +: +spchar ( char -- ) + splen d# 1023 > abort" sprintf buffer overflow" + spbuf splen + c! + splen 1+ is splen +; + +: 1/string ( adr len -- adr' len' char ) + dup if ( adr len ) + over c@ >r 1 /string r> ( adr' len' char ) + else ( adr len ) + -1 ( adr len -1 ) + then +; + +: handle% ( ... tail$ -- ... tail$' ) \ Handle % escapes + 1/string ( ... tail$ char ) + case + [char] d of push-decimal rot <# u#s u#> +spbuf pop-base endof + [char] x of push-hex rot <# u#s u#> +spbuf pop-base endof + [char] s of 2swap +spbuf endof + [char] o of push-octal rot <# u#s u#> +spbuf pop-base endof + -1 of endof + ( default ) dup +spchar + endcase +; + +: handle\ ( ... tail$ -- ... tail$' ) \ Handle backslash escapes + 1/string ( ... tail$ char ) + case + [char] n of newline +spchar then + [char] r of carret +spchar then + [char] t of control i +spchar then + [char] f of control l +spchar then + [char] l of linefeed +spchar then + [char] b of control h +spchar then + [char] ! of bell +spchar then + ( default ) +spchar + endcase +; + +: sprintf ( ... adr len -- adr' len' ) + 0 is splen + + begin dup while ( ... adr len ) + " %" lex if ( ... tail$ head$ delim ) + -rot +spbuf ( ... tail$ delim ) + [char] % = if handle% else handle\ then ( ... tail$ ) + else ( ... tail$ ) + +spbuf 0 0 ( ... 0 0 ) + then ( ... tail$ ) + repeat ( tail$ ) + 2drop spbuf splen +; +: printf ( ... adr len -- ) sprintf type ; + +\ LICENSE_BEGIN +\ Copyright (c) 2008 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END