1: \ Input 13feb93py
2:
3: \ Copyright (C) 1995,1996,1997 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., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21: : (ins) ( max span addr pos1 key -- max span addr pos2 )
22: >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
23: : (bs) ( max span addr pos1 -- max span addr pos2 flag )
24: dup IF
25: #bs emit bl emit #bs emit 1- rot 1- -rot
26: THEN false ;
27: : (ret) true bl emit ;
28:
29: Create ctrlkeys
30: ] false false false false false false false false
31: (bs) false (ret) false false (ret) false false
32: false false false false false false false false
33: false false false false false false false false [
34:
35: defer insert-char
36: ' (ins) IS insert-char
37: defer everychar
38: ' noop IS everychar
39:
40: : decode ( max span addr pos1 key -- max span addr pos2 flag )
41: everychar
42: dup #del = IF drop #bs THEN \ del is rubout
43: dup bl < IF cells ctrlkeys + perform EXIT THEN
44: >r 2over = IF rdrop bell 0 EXIT THEN
45: r> insert-char 0 ;
46:
47: : accept ( addr len -- len ) \ core
48: dup 0< IF abs over dup 1 chars - c@ tuck type
49: \ this allows to edit given strings
50: ELSE 0 THEN rot over
51: BEGIN key decode UNTIL
52: 2drop nip ;
53:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>