Annotation of gforth/utf-8.fs, revision 1.12
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.10 pazsan 25: $80 Value maxascii
26:
1.4 pazsan 27: : u8len ( u8 -- n )
1.10 pazsan 28: dup maxascii u< IF drop 1 EXIT THEN \ special case ASCII
1.1 pazsan 29: $800 2 >r
30: BEGIN 2dup u>= WHILE 5 lshift r> 1+ >r REPEAT
31: 2drop r> ;
32:
33: : u8@+ ( u8addr -- u8addr' u )
1.10 pazsan 34: count dup maxascii u< ?EXIT \ special case ASCII
1.1 pazsan 35: $7F and $40 >r
36: BEGIN dup r@ and WHILE r@ xor
37: 6 lshift r> 5 lshift >r >r count
1.7 pazsan 38: dup $C0 and $80 <> IF UTF-8-err throw THEN
1.1 pazsan 39: $3F and r> or
40: REPEAT rdrop ;
41:
42: : u8!+ ( u u8addr -- u8addr' )
1.10 pazsan 43: over maxascii u< IF tuck c! 1+ EXIT THEN \ special case ASCII
1.1 pazsan 44: >r 0 swap $3F
45: BEGIN 2dup u> WHILE
46: 2/ >r dup $3F and $80 or swap 6 rshift r>
47: REPEAT $7F xor 2* or r>
48: BEGIN over $80 u>= WHILE tuck c! 1+ REPEAT nip ;
49:
1.8 pazsan 50: \ plug-in so that char and '<char> work for UTF-8
51:
1.9 anton 52: [ifundef] char@ \ !! bootstrapping help
53: Defer char@ ( addr u -- char addr' u' )
54: :noname over c@ -rot 1 /string ; IS char@
55: [then]
56:
1.8 pazsan 57: :noname ( addr u -- char addr' u' )
1.9 anton 58: \ !! the if here seems to work around some breakage, but not
59: \ entirely; e.g., try 'ç' with LANG=C.
60: dup 1 u<= IF defers char@ EXIT THEN
1.8 pazsan 61: over + >r u8@+ swap r> over - ; IS char@
62:
1.1 pazsan 63: \ scan to next/previous character
64:
1.12 ! pazsan 65: : u8>> ( u8addr -- u8addr' ) u8@+ drop ;
1.1 pazsan 66: : u8<< ( u8addr -- u8addr' )
1.10 pazsan 67: BEGIN 1- dup c@ $C0 and maxascii <> UNTIL ;
1.1 pazsan 68:
69: \ utf key and emit
70:
71: : u8key ( -- u )
1.10 pazsan 72: defers key dup maxascii u< ?EXIT \ special case ASCII
1.1 pazsan 73: $7F and $40 >r
74: BEGIN dup r@ and WHILE r@ xor
75: 6 lshift r> 5 lshift >r >r defers key
1.7 pazsan 76: dup $C0 and $80 <> IF UTF-8-err throw THEN
1.1 pazsan 77: $3F and r> or
78: REPEAT rdrop ;
79:
80: : u8emit ( u -- )
1.10 pazsan 81: dup maxascii u< IF defers emit EXIT THEN \ special case ASCII
1.1 pazsan 82: 0 swap $3F
83: BEGIN 2dup u> WHILE
84: 2/ >r dup $3F and $80 or swap 6 rshift r>
85: REPEAT $7F xor 2* or
86: BEGIN dup $80 u>= WHILE defers emit REPEAT drop ;
87:
88: \ input editor
89:
1.7 pazsan 90: [IFUNDEF] #esc 27 Constant #esc [THEN]
91:
92: : save-cursor ( -- ) #esc emit '7 emit ;
93: : restore-cursor ( -- ) #esc emit '8 emit ;
1.1 pazsan 94: : .rest ( addr pos1 -- addr pos1 )
95: restore-cursor 2dup type ;
96: : .all ( span addr pos1 -- span addr pos1 )
97: restore-cursor >r 2dup swap type r> ;
98:
1.3 pazsan 99: : <u8ins> ( max span addr pos1 u8char -- max span addr pos2 )
1.6 pazsan 100: >r 2over r@ u8len + u< IF rdrop bell EXIT THEN
101: >string over r@ u8len + swap move 2dup chars + r@ swap u8!+ drop
1.3 pazsan 102: r> u8len >r rot r@ chars + -rot r> chars + ;
1.1 pazsan 103: : (u8ins) ( max span addr pos1 u8char -- max span addr pos2 )
1.3 pazsan 104: <u8ins> .all .rest ;
1.1 pazsan 105: : u8back ( max span addr pos1 -- max span addr pos2 f )
1.2 pazsan 106: dup IF over + u8<< over - 0 max .all .rest
1.6 pazsan 107: ELSE bell THEN 0 ;
1.1 pazsan 108: : u8forw ( max span addr pos1 -- max span addr pos2 f )
1.6 pazsan 109: 2 pick over <> IF over + u8@+ u8emit over - ELSE bell THEN 0 ;
1.1 pazsan 110: : (u8del) ( max span addr pos1 -- max span addr pos2 )
111: over + dup u8<< tuck - >r over -
112: >string over r@ + -rot move
1.3 pazsan 113: rot r> - -rot ;
1.1 pazsan 114: : ?u8del ( max span addr pos1 -- max span addr pos2 0 )
1.3 pazsan 115: dup IF (u8del) .all 2 spaces .rest THEN 0 ;
1.1 pazsan 116: : <u8del> ( max span addr pos1 -- max span addr pos2 0 )
117: 2 pick over <>
1.3 pazsan 118: IF u8forw drop (u8del) .all 2 spaces .rest
1.6 pazsan 119: ELSE bell THEN 0 ;
1.1 pazsan 120: : u8eof 2 pick over or 0= IF bye ELSE <u8del> THEN ;
121:
1.3 pazsan 122: : u8first-pos ( max span addr pos1 -- max span addr 0 0 )
123: drop 0 .all .rest 0 ;
124: : u8end-pos ( max span addr pos1 -- max span addr span 0 )
125: drop over .all 0 ;
126:
127:
128: : u8clear-line ( max span addr pos1 -- max addr )
129: drop restore-cursor swap spaces restore-cursor ;
130: : u8clear-tib ( max span addr pos -- max 0 addr 0 false )
131: u8clear-line 0 tuck dup ;
132:
133: : (u8enter) ( max span addr pos1 -- max span addr pos2 true )
134: >r end^ 2@ hist-setpos
135: 2dup swap history write-line drop ( throw ) \ don't worry about errors
136: hist-pos 2dup backward^ 2! end^ 2!
137: r> .all space true ;
138:
139: : u8kill-expand ( max span addr pos1 -- max span addr pos2 )
140: prefix-found cell+ @ ?dup IF >r
141: r@ - >string over r@ + -rot move
142: rot r@ - -rot .all r> spaces .rest THEN ;
143:
144: : insert ( string length buffer size -- )
145: rot over min >r r@ - ( left over )
146: over dup r@ + rot move r> move ;
147:
148: : u8tab-expand ( max span addr pos1 -- max span addr pos2 0 )
149: key? IF #tab (u8ins) 0 EXIT THEN
150: u8kill-expand 2dup extract-word dup 0= IF nip EXIT THEN
1.5 pazsan 151: search-prefix tib-full?
152: IF 7 emit 2drop prefix-off
1.3 pazsan 153: ELSE dup >r
154: 2>r >string r@ + 2r> 2swap insert
155: r@ + rot r> + -rot
156: THEN
1.5 pazsan 157: prefix-found @ IF bl (u8ins) ELSE .all .rest THEN 0 ;
1.3 pazsan 158:
1.4 pazsan 159: : utf-8-io ( -- )
160: ['] u8forw ctrl F bindkey
161: ['] u8back ctrl B bindkey
162: ['] ?u8del ctrl H bindkey
163: ['] u8eof ctrl D bindkey
164: ['] <u8del> ctrl X bindkey
165: ['] u8clear-tib ctrl K bindkey
166: ['] u8first-pos ctrl A bindkey
167: ['] u8end-pos ctrl E bindkey
168: ['] (u8enter) #lf bindkey
169: ['] (u8enter) #cr bindkey
170: ['] u8tab-expand #tab bindkey
171: ['] (u8ins) IS insert-char
1.5 pazsan 172: ['] kill-prefix IS everychar
1.4 pazsan 173: ['] save-cursor IS everyline
174: ['] u8key IS key
175: ['] u8emit IS emit ;
176:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>