--- gforth/kernel/xchars.fs 2005/01/06 21:54:18 1.2 +++ gforth/kernel/xchars.fs 2007/09/15 20:11:44 1.8 @@ -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. @@ -28,16 +28,18 @@ 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 X\STRING- ( 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 r> xc@ ; @@ -47,18 +49,17 @@ 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 ) - -1 /string ; +: string- ( c-addr1 u1 -- c-addr1 u2 ) + 1- ; : c!+? ( c c-addr1 u1 -- c-addr2 u2 f ) - 1 chars u< if \ or use < ? - >r dup >r c! - 1 r> r> /string true - else + dup 1 chars u< if \ or use < ? rot drop false + else + >r dup >r c! + r> r> 1 /string true then ; : c-size ( c -- 1 ) @@ -69,11 +70,13 @@ 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 +x/string + ['] string- is x\string- ['] 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 ;