version 1.1, 2005/01/06 21:31:51
|
version 1.6, 2007/05/05 17:26:03
|
Line 1
|
Line 1
|
\ extended characters (either 8bit or UTF-8, possibly other encodings) |
\ extended characters (either 8bit or UTF-8, possibly other encodings) |
\ and their fixed-size variant |
\ 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. |
\ This file is part of Gforth. |
|
|
Line 27 DEFER XEMIT ( xc -- )
|
Line 27 DEFER XEMIT ( xc -- )
|
DEFER XKEY ( -- xc ) |
DEFER XKEY ( -- xc ) |
DEFER XCHAR+ ( xc-addr1 -- xc-addr2 ) |
DEFER XCHAR+ ( xc-addr1 -- xc-addr2 ) |
DEFER XCHAR- ( xc-addr1 -- xc-addr2 ) |
DEFER XCHAR- ( xc-addr1 -- xc-addr2 ) |
DEFER +X/STRING ( xc-addr1 u1 -- xc-addr2 u2 ) |
DEFER +XSTRING ( 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-addr1 u2 ) |
|
DEFER XSTRING- ( xc-addr1 u1 -- xc-addr1 u2 ) |
DEFER XC@ ( xc-addr -- xc ) |
DEFER XC@ ( xc-addr -- xc ) |
DEFER XC!+? ( xc xc-addr1 u1 -- xc-addr2 u2 f ) \ f if operation succeeded |
DEFER XC!+? ( xc xc-addr1 u1 -- xc-addr2 u2 f ) \ f if operation succeeded |
DEFER XC@+ ( xc-addr1 -- xc-addr2 xc ) |
DEFER XC@+ ( xc-addr1 -- xc-addr2 xc ) |
DEFER XC-SIZE ( xc -- u ) \ size in cs |
DEFER XC-SIZE ( xc -- u ) \ size in cs |
|
DEFER X-WIDTH ( addr u -- n ) \ size in fixed chars |
DEFER -TRAILING-GARBAGE ( addr u1 -- addr u2 ) \ remove trailing incomplete xc |
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 ) |
|
\ !! check for errors? |
|
over >r +xstring |
|
r> xc@ ; |
|
|
\ fixed-size versions of these words |
\ fixed-size versions of these words |
|
|
: char- ( c-addr1 -- c-addr2 ) |
: char- ( c-addr1 -- c-addr2 ) |
[ 1 chars ] literal - ; |
[ 1 chars ] literal - ; |
|
|
: 1/string ( c-addr1 u1 -- c-addr2 u2 ) |
: +string ( c-addr1 u1 -- c-addr2 u2 ) |
1 /string ; |
1 /string ; |
|
: -string ( c-addr1 u1 -- c-addr2 u2 ) |
: -1/string ( c-addr1 u1 -- c-addr2 u2 ) |
|
-1 /string ; |
-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 ) |
: c!+? ( c c-addr1 u1 -- c-addr2 u2 f ) |
1 chars u< if \ or use < ? |
dup 1 chars u< if \ or use < ? |
>r dup >r c! |
|
1 r> r> /string true |
|
else |
|
rot drop false |
rot drop false |
|
else |
|
>r dup >r c! |
|
r> r> 1 /string true |
then ; |
then ; |
|
|
: c-size ( c -- 1 ) |
: c-size ( c -- 1 ) |
Line 62 DEFER -TRAILING-GARBAGE ( addr u1 -- add
|
Line 76 DEFER -TRAILING-GARBAGE ( addr u1 -- add
|
['] key is xkey |
['] key is xkey |
['] char+ is xchar+ |
['] char+ is xchar+ |
['] char- is xchar- |
['] char- is xchar- |
['] 1/string is +x/string |
['] +string is +xstring |
['] -1/string is -x/string |
['] -string is -xstring |
|
['] string+ is xstring+ |
|
['] string- is xstring- |
['] c@ is xc@ |
['] c@ is xc@ |
['] c!+? is xc!+? |
['] c!+? is xc!+? |
['] count is xc@+ |
['] count is xc@+ |
['] c-size is xc-size |
['] c-size is xc-size |
|
['] nip IS x-width |
['] noop is -trailing-garbage |
['] noop is -trailing-garbage |
; |
; |