Annotation of gforth/utf-8.fs, revision 1.1
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:
! 23: : u8len ( u -- n )
! 24: dup $80 u< IF drop 1 EXIT THEN \ special case ASCII
! 25: $800 2 >r
! 26: BEGIN 2dup u>= WHILE 5 lshift r> 1+ >r REPEAT
! 27: 2drop r> ;
! 28:
! 29: : u8@+ ( u8addr -- u8addr' u )
! 30: count dup $80 and 0= ?EXIT \ special case ASCII
! 31: $7F and $40 >r
! 32: BEGIN dup r@ and WHILE r@ xor
! 33: 6 lshift r> 5 lshift >r >r count
! 34: \ dup $C0 and $80 <> abort" malformed character"
! 35: $3F and r> or
! 36: REPEAT rdrop ;
! 37:
! 38: : u8!+ ( u u8addr -- u8addr' )
! 39: over $80 < IF tuck c! 1+ EXIT THEN \ special case ASCII
! 40: >r 0 swap $3F
! 41: BEGIN 2dup u> WHILE
! 42: 2/ >r dup $3F and $80 or swap 6 rshift r>
! 43: REPEAT $7F xor 2* or r>
! 44: BEGIN over $80 u>= WHILE tuck c! 1+ REPEAT nip ;
! 45:
! 46: \ scan to next/previous character
! 47:
! 48: : u8>> ( u8addr -- u8addr' )
! 49: BEGIN count $C0 and $80 <> UNTIL ;
! 50: : u8<< ( u8addr -- u8addr' )
! 51: BEGIN 1- dup c@ $C0 and $80 <> UNTIL ;
! 52:
! 53: \ utf key and emit
! 54:
! 55: : u8key ( -- u )
! 56: defers key dup $80 and 0= ?EXIT \ special case ASCII
! 57: $7F and $40 >r
! 58: BEGIN dup r@ and WHILE r@ xor
! 59: 6 lshift r> 5 lshift >r >r defers key
! 60: \ dup $C0 and $80 <> abort" malformed character"
! 61: $3F and r> or
! 62: REPEAT rdrop ;
! 63:
! 64: : u8emit ( u -- )
! 65: dup $80 < IF defers emit EXIT THEN \ special case ASCII
! 66: 0 swap $3F
! 67: BEGIN 2dup u> WHILE
! 68: 2/ >r dup $3F and $80 or swap 6 rshift r>
! 69: REPEAT $7F xor 2* or
! 70: BEGIN dup $80 u>= WHILE defers emit REPEAT drop ;
! 71:
! 72: \ input editor
! 73:
! 74: : save-cursor ( -- ) 27 emit '7 emit ;
! 75: : restore-cursor ( -- ) 27 emit '8 emit ;
! 76: : .rest ( addr pos1 -- addr pos1 )
! 77: restore-cursor 2dup type ;
! 78: : .all ( span addr pos1 -- span addr pos1 )
! 79: restore-cursor >r 2dup swap type r> ;
! 80:
! 81: : (u8ins) ( max span addr pos1 u8char -- max span addr pos2 )
! 82: >r >string over r@ u8len + swap move 2dup chars + r@ swap u8!+ drop
! 83: r> u8len >r rot r@ chars + -rot r> chars + .all .rest ;
! 84: : u8back ( max span addr pos1 -- max span addr pos2 f )
! 85: dup IF over + u8<< over - 0 max
! 86: ELSE #bell emit THEN .rest 0 ;
! 87: : u8forw ( max span addr pos1 -- max span addr pos2 f )
! 88: 2 pick over <> IF over + u8@+ u8emit over - ELSE #bell emit THEN 0 ;
! 89: : (u8del) ( max span addr pos1 -- max span addr pos2 )
! 90: over + dup u8<< tuck - >r over -
! 91: >string over r@ + -rot move
! 92: rot r> - -rot .all 2 spaces .rest ;
! 93: : ?u8del ( max span addr pos1 -- max span addr pos2 0 )
! 94: dup IF (u8del) THEN 0 ;
! 95: : <u8del> ( max span addr pos1 -- max span addr pos2 0 )
! 96: 2 pick over <>
! 97: IF u8forw drop (u8del) ELSE #bell emit THEN 0 ;
! 98: : u8eof 2 pick over or 0= IF bye ELSE <u8del> THEN ;
! 99:
! 100: ' u8forw ctrl F bindkey
! 101: ' u8back ctrl B bindkey
! 102: ' ?u8del ctrl H bindkey
! 103: ' u8eof ctrl D bindkey
! 104: ' <u8del> ctrl X bindkey
! 105: ' (u8ins) IS insert-char
! 106: ' noop IS everychar
! 107: ' save-cursor IS everyline
! 108: ' u8key IS key
! 109: ' u8emit IS emit
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>