| \ Input 13feb93py |
\ Input 13feb93py |
| |
|
| \ Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1999,2003 Free Software Foundation, Inc. |
| |
|
| \ This file is part of Gforth. |
\ This file is part of Gforth. |
| |
|
| |
|
| \ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
| \ along with this program; if not, write to the Free Software |
\ along with this program; if not, write to the Free Software |
| \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
| |
|
| : (ins) ( max span addr pos1 key -- max span addr pos2 ) |
: (ins) ( max span addr pos1 key -- max span addr pos2 ) |
| >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ; |
>r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ; |
| : (bs) ( max span addr pos1 -- max span addr pos2 flag ) |
: (bs) ( max span addr pos1 -- max span addr pos2 flag ) |
| dup IF |
dup IF |
| #bs emit bl emit #bs emit 1- rot 1- -rot |
#bs emit space #bs emit 1- rot 1- -rot |
| THEN false ; |
THEN false ; |
| : (ret) true bl emit ; |
: (ret) ( max span addr pos1 -- max span addr pos2 flag ) |
| |
true space ; |
| |
|
| Create ctrlkeys |
Create ctrlkeys |
| ] false false false false false false false false |
' false a, ' false a, ' false a, ' false a, |
| (bs) false (ret) false false (ret) false false |
' false a, ' false a, ' false a, ' false a, |
| false false false false false false false false |
|
| false false false false false false false false [ |
' (bs) a, ' false a, ' (ret) a, ' false a, |
| |
' false a, ' (ret) a, ' false a, ' false a, |
| |
|
| |
' false a, ' false a, ' false a, ' false a, |
| |
' false a, ' false a, ' false a, ' false a, |
| |
|
| |
' false a, ' false a, ' false a, ' false a, |
| |
' false a, ' false a, ' false a, ' false a, |
| |
|
| defer insert-char |
defer insert-char |
| ' (ins) IS insert-char |
' (ins) IS insert-char |
| |
|
| : decode ( max span addr pos1 key -- max span addr pos2 flag ) |
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
| everychar |
everychar |
| |
dup -1 = IF drop 4 THEN \ -1 is EOF |
| dup #del = IF drop #bs THEN \ del is rubout |
dup #del = IF drop #bs THEN \ del is rubout |
| dup bl < IF cells ctrlkeys + perform EXIT THEN |
dup bl u< IF cells ctrlkeys + perform EXIT THEN |
| |
\ check for end reached |
| >r 2over = IF rdrop bell 0 EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
| r> insert-char 0 ; |
r> insert-char 0 ; |
| |
|
| : accept ( addr len -- len ) \ core |
: edit-line ( c-addr n1 n2 -- n3 ) \ gforth |
| dup 0< IF abs over dup 1 chars - c@ tuck type |
\G edit the string with length @var{n2} in the buffer @var{c-addr |
| \ this allows to edit given strings |
\G n1}, like @code{accept}. |
| ELSE 0 THEN rot over |
rot over |
| |
2dup type |
| BEGIN key decode UNTIL |
BEGIN key decode UNTIL |
| 2drop nip ; |
2drop nip ; |
| |
|
| |
: accept ( c-addr +n1 -- +n2 ) \ core |
| |
\G Get a string of up to @var{n1} characters from the user input |
| |
\G device and store it at @var{c-addr}. @var{n2} is the length of |
| |
\G the received string. The user indicates the end by pressing |
| |
\G @key{RET}. Gforth supports all the editing functions available |
| |
\G on the Forth command line (including history and word |
| |
\G completion) in @code{accept}. |
| |
dup 0< -&24 and throw \ use edit-line to edit given strings |
| |
0 edit-line ; |
