[gforth] / gforth / utf-8.fs  

gforth: gforth/utf-8.fs

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help