--- gforth/kernel/xchars.fs 2006/02/19 17:27:13 1.4 +++ gforth/kernel/xchars.fs 2007/07/14 19:57:16 1.7 @@ -1,7 +1,7 @@ \ extended characters (either 8bit or UTF-8, possibly other encodings) \ and their fixed-size variant -\ Copyright (C) 2005 Free Software Foundation, Inc. +\ Copyright (C) 2005,2006 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -27,20 +27,23 @@ DEFER XEMIT ( xc -- ) DEFER XKEY ( -- xc ) DEFER XCHAR+ ( xc-addr1 -- xc-addr2 ) DEFER XCHAR- ( xc-addr1 -- xc-addr2 ) -DEFER +X/STRING ( xc-addr1 u1 -- xc-addr2 u2 ) -DEFER -X/STRING ( xc-addr1 u1 -- xc-addr2 u2 ) +DEFER +XSTRING ( xc-addr1 u1 -- xc-addr2 u2 ) +DEFER -XSTRING ( xc-addr1 u1 -- xc-addr2 u2 ) +DEFER XSTRING+ ( xc-addr1 u1 -- xc-addr1 u2 ) +DEFER XSTRING- ( xc-addr1 u1 -- xc-addr1 u2 ) DEFER XC@ ( xc-addr -- xc ) DEFER XC!+? ( xc xc-addr1 u1 -- xc-addr2 u2 f ) \ f if operation succeeded DEFER XC@+ ( xc-addr1 -- xc-addr2 xc ) DEFER XC-SIZE ( xc -- u ) \ size in cs +DEFER X-SIZE ( xc-addr u1 -- u2 ) \ size in cs DEFER X-WIDTH ( addr u -- n ) \ size in fixed chars DEFER -TRAILING-GARBAGE ( addr u1 -- addr u2 ) \ remove trailing incomplete xc \ derived words, faster implementations are probably possible -: X@+/string ( xc-addr1 u1 -- xc-addr2 u2 xc ) +: x@+/string ( xc-addr1 u1 -- xc-addr2 u2 xc ) \ !! check for errors? - over >r +x/string + over >r +xstring r> xc@ ; \ fixed-size versions of these words @@ -48,12 +51,16 @@ DEFER -TRAILING-GARBAGE ( addr u1 -- add : char- ( c-addr1 -- c-addr2 ) [ 1 chars ] literal - ; -: 1/string ( c-addr1 u1 -- c-addr2 u2 ) +: +string ( c-addr1 u1 -- c-addr2 u2 ) 1 /string ; - -: -1/string ( c-addr1 u1 -- c-addr2 u2 ) +: -string ( c-addr1 u1 -- c-addr2 u2 ) -1 /string ; +: string+ ( c-addr1 u1 -- c-addr1 u2 ) + 1+ ; +: string- ( c-addr1 u1 -- c-addr1 u2 ) + 1- ; + : c!+? ( c c-addr1 u1 -- c-addr2 u2 f ) dup 1 chars u< if \ or use < ? rot drop false @@ -70,12 +77,15 @@ DEFER -TRAILING-GARBAGE ( addr u1 -- add ['] key is xkey ['] char+ is xchar+ ['] char- is xchar- - ['] 1/string is +x/string - ['] -1/string is -x/string + ['] +string is +xstring + ['] -string is -xstring + ['] string+ is xstring+ + ['] string- is xstring- ['] c@ is xc@ ['] c!+? is xc!+? ['] count is xc@+ ['] c-size is xc-size + ['] c-size is x-size ['] nip IS x-width ['] noop is -trailing-garbage ;