Annotation of gforth/utf-8.fs, revision 1.9
1.1 pazsan 1: \ UTF-8 handling 12dec04py
2:
3: \ Copyright (C) 2004 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: \ short: u8 means utf-8 encoded address
22:
1.7 pazsan 23: s" malformed UTF-8 character" exception Constant UTF-8-err
24:
1.4 pazsan 25: : u8len ( u8 -- n )
1.1 pazsan 26: dup $80 u< IF drop 1 EXIT THEN \ special case ASCII
27: $800 2 >r
28: BEGIN 2dup u>= WHILE 5 lshift r> 1+ >r REPEAT
29: 2drop r> ;
30:
31: : u8@+ ( u8addr -- u8addr' u )
32: count dup $80 and 0= ?EXIT \ special case ASCII
33: $7F and $40 >r
34: BEGIN dup r@ and WHILE r@ xor
35: 6 lshift r> 5 lshift >r >r count
1.7 pazsan 36: dup $C0 and $80 <> IF UTF-8-err throw THEN
1.1 pazsan 37: $3F and r> or
38: REPEAT rdrop ;
39:
40: : u8!+ ( u u8addr -- u8addr' )
41: over $80 < IF tuck c! 1+ EXIT THEN \ special case ASCII
42: >r 0 swap $3F
43: BEGIN 2dup u> WHILE
44: 2/ >r dup $3F and $80 or swap 6 rshift r>
45: REPEAT $7F xor 2* or r>
46: BEGIN over $80 u>= WHILE tuck c! 1+ REPEAT nip ;
47:
1.8 pazsan 48: \ plug-in so that char and '<char> work for UTF-8
49:
1.9 ! anton 50: [ifundef] char@ \ !! bootstrapping help
! 51: Defer char@ ( addr u -- char addr' u' )
! 52: :noname over c@ -rot 1 /string ; IS char@
! 53: [then]
! 54:
1.8 pazsan 55: :noname ( addr u -- char addr' u' )
1.9 ! anton 56: \ !! the if here seems to work around some breakage, but not
! 57: \ entirely; e.g., try 'ç' with LANG=C.
! 58: dup 1 u<= IF defers char@ EXIT THEN
1.8 pazsan 59: over + >r u8@+ swap r> over - ; IS char@
60:
1.1 pazsan 61: \ scan to next/previous character
62:
63: : u8>> ( u8addr -- u8addr' )
64: BEGIN count $C0 and $80 <> UNTIL ;
65: : u8<< ( u8addr -- u8addr' )
66: BEGIN 1- dup c@ $C0 and $80 <> UNTIL ;
67:
68: \ utf key and emit
69:
70: : u8key ( -- u )
71: defers key dup $80 and 0= ?EXIT \ special case ASCII
72: $7F and $40 >r
73: BEGIN dup r@ and WHILE r@ xor
74: 6 lshift r> 5 lshift >r >r defers key
1.7 pazsan 75: dup $C0 and $80 <> IF UTF-8-err throw THEN
1.1 pazsan 76: $3F and r> or
77: REPEAT rdrop ;
78:
79: : u8emit ( u -- )
80: dup $80 < IF defers emit EXIT THEN \ special case ASCII
81: 0 swap $3F
82: BEGIN 2dup u> WHILE
83: 2/ >r dup $3F and $80 or swap 6 rshift r>
84: REPEAT $7F xor 2* or
85: BEGIN dup $80 u>= WHILE defers emit REPEAT drop ;
86:
87: \ input editor
88:
1.7 pazsan 89: [IFUNDEF] #esc 27 Constant #esc [THEN]
90:
91: : save-cursor ( -- ) #esc emit '7 emit ;
92: : restore-cursor ( -- ) #esc emit '8 emit ;
1.1 pazsan 93: : .rest ( addr pos1 -- addr pos1 )
94: restore-cursor 2dup type ;
95: : .all ( span addr pos1 -- span addr pos1 )
96: restore-cursor >r 2dup swap type r> ;
97:
1.3 pazsan 98: : <u8ins> ( max span addr pos1 u8char -- max span addr pos2 )
1.6 pazsan 99: >r 2over r@ u8len + u< IF rdrop bell EXIT THEN
100: >string over r@ u8len + swap move 2dup chars + r@ swap u8!+ drop
1.3 pazsan 101: r> u8len >r rot r@ chars + -rot r> chars + ;
1.1 pazsan 102: : (u8ins) ( max span addr pos1 u8char -- max span addr pos2 )
1.3 pazsan 103: <u8ins> .all .rest ;
1.1 pazsan 104: : u8back ( max span addr pos1 -- max span addr pos2 f )
1.2 pazsan 105: dup IF over + u8<< over - 0 max .all .rest
1.6 pazsan 106: ELSE bell THEN 0 ;
1.1 pazsan 107: : u8forw ( max span addr pos1 -- max span addr pos2 f )
1.6 pazsan 108: 2 pick over <> IF over + u8@+ u8emit over - ELSE bell THEN 0 ;
1.1 pazsan 109: : (u8del) ( max span addr pos1 -- max span addr pos2 )
110: over + dup u8<< tuck - >r over -
111: >string over r@ + -rot move
1.3 pazsan 112: rot r> - -rot ;
1.1 pazsan 113: : ?u8del ( max span addr pos1 -- max span addr pos2 0 )
1.3 pazsan 114: dup IF (u8del) .all 2 spaces .rest THEN 0 ;
1.1 pazsan 115: : <u8del> ( max span addr pos1 -- max span addr pos2 0 )
116: 2 pick over <>
1.3 pazsan 117: IF u8forw drop (u8del) .all 2 spaces .rest
1.6 pazsan 118: ELSE bell THEN 0 ;
1.1 pazsan 119: : u8eof 2 pick over or 0= IF bye ELSE <u8del> THEN ;
120:
1.3 pazsan 121: : u8first-pos ( max span addr pos1 -- max span addr 0 0 )
122: drop 0 .all .rest 0 ;
123: : u8end-pos ( max span addr pos1 -- max span addr span 0 )
124: drop over .all 0 ;
125:
126:
127: : u8clear-line ( max span addr pos1 -- max addr )
128: drop restore-cursor swap spaces restore-cursor ;
129: : u8clear-tib ( max span addr pos -- max 0 addr 0 false )
130: u8clear-line 0 tuck dup ;
131:
132: : (u8enter) ( max span addr pos1 -- max span addr pos2 true )
133: >r end^ 2@ hist-setpos
134: 2dup swap history write-line drop ( throw ) \ don't worry about errors
135: hist-pos 2dup backward^ 2! end^ 2!
136: r> .all space true ;
137:
138: : u8kill-expand ( max span addr pos1 -- max span addr pos2 )
139: prefix-found cell+ @ ?dup IF >r
140: r@ - >string over r@ + -rot move
141: rot r@ - -rot .all r> spaces .rest THEN ;
142:
143: : insert ( string length buffer size -- )
144: rot over min >r r@ - ( left over )
145: over dup r@ + rot move r> move ;
146:
147: : u8tab-expand ( max span addr pos1 -- max span addr pos2 0 )
148: key? IF #tab (u8ins) 0 EXIT THEN
149: u8kill-expand 2dup extract-word dup 0= IF nip EXIT THEN
1.5 pazsan 150: search-prefix tib-full?
151: IF 7 emit 2drop prefix-off
1.3 pazsan 152: ELSE dup >r
153: 2>r >string r@ + 2r> 2swap insert
154: r@ + rot r> + -rot
155: THEN
1.5 pazsan 156: prefix-found @ IF bl (u8ins) ELSE .all .rest THEN 0 ;
1.3 pazsan 157:
1.4 pazsan 158: : utf-8-io ( -- )
159: ['] u8forw ctrl F bindkey
160: ['] u8back ctrl B bindkey
161: ['] ?u8del ctrl H bindkey
162: ['] u8eof ctrl D bindkey
163: ['] <u8del> ctrl X bindkey
164: ['] u8clear-tib ctrl K bindkey
165: ['] u8first-pos ctrl A bindkey
166: ['] u8end-pos ctrl E bindkey
167: ['] (u8enter) #lf bindkey
168: ['] (u8enter) #cr bindkey
169: ['] u8tab-expand #tab bindkey
170: ['] (u8ins) IS insert-char
1.5 pazsan 171: ['] kill-prefix IS everychar
1.4 pazsan 172: ['] save-cursor IS everyline
173: ['] u8key IS key
174: ['] u8emit IS emit ;
175:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>