[openfirmware] r1018 - forth/lib
svn at openfirmware.info
svn at openfirmware.info
Thu Dec 4 10:18:11 CET 2008
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
More information about the openfirmware
mailing list