obp/obp/fm/lib/editcmd.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: editcmd.fth
\
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\
\  - Do no alter or remove copyright notices
\
\  - Redistribution and use of this software in source and binary forms, with
\    or without modification, are permitted provided that the following
\    conditions are met:
\
\  - Redistribution of source code must retain the above copyright notice,
\    this list of conditions and the following disclaimer.
\
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\    Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\
\     This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility.
\
\ ========== Copyright Header End ============================================
\ editcmd.fth 2.17 06/12/15
\ Copyright 1985-1994 Bradley Forthware
\ Copyright 2006 Sun Microsystems, Inc.  All Rights Reserved
\ Copyright Use is subject to license terms.

headers
forth definitions
vocabulary keys-forth
defer skey  ' key is skey  \ Perhaps override with an ekey-based word later

hidden definitions

headerless
tuser keys  ' keys-forth keys token!

d# 32 buffer: name-buf

: add-char-to-string  ( str char -- )
   over ( str char str )
   count dup >r ( str char addr len )
   + c!  ( str )
   r> 1+ swap c!
;
: add-char-to-name  ( str char -- )

   dup bl u<  if    ( str char )  \ control character so translate to ^ form
      over ascii ^ add-char-to-string  ( str char )
      ascii a 1- +  ( str char' )  add-char-to-string
   else
      \ Map the Delete key to the string "del"
      dup d# 127 =  if   drop  " del" rot $cat  exit  then

      \ Map the Unicode Control Sequence Identifier to the string "ESC["
      dup h# 9b =  if   drop  " esc-[" rot $cat  exit  then

      \ Map the ISO 6429 (and ISO-8849-1) CS1 character
      \ "Private Use 1" (PU1==0x91) to the ask-layout command
      dup h# 91 = if drop " ask-layout" rot $cat exit then

      \ Map the out-of-band character into the string "ext"
      dup -1 =   if   drop  " ext" rot $cat  exit  then

      add-char-to-string
   then
;
defer not-found

nuser lastchar          \ most-recently-typed character
: do-command  ( prefix-string -- )
   name-buf "copy
   name-buf lastchar @  add-char-to-name
   name-buf count  keys token@ search-wordlist  ( false | cfa true )
   if  execute  else  not-found  then
;

defer printable-char
nuser finished          \ is the line complete yet?

: start-edit  ( bufadr buflen bufmax line# position display? -- )
   is display?
   >r
   line# !
   is bufmax  buflen !  is buf-start-adr
   buf-start-adr r> +  is line-start-adr

   0 is #before
   set-linelen
;
: finish-edit  ( -- length )  buflen @  ;
: edit-command-loop  ( -- )
   finished off
   begin
      skey lastchar !
      lastchar @
      dup  bl     h# 7e  between
      swap h# a0  h# fe  between  or
      if  lastchar @ printable-char  else  nullstring  do-command  then
   finished @  until
   cr
;
headerless

: edit-buffer  (s bufadr buflen bufmax line# position -- newlen )
   true start-edit

   0 display-line

   edit-command-loop

   finish-edit
;
: edit-file  (s addr len maxlen -- newlen )  0 0 edit-buffer  ;

d# 512  /tib 2* max  value hbufmax
hbufmax buffer: hbuf-adr
0 value hbuflen
: ensure-line-end  ( -- )
   \ Put a newline at the end of the last line if necessary
   hbuflen  if
      hbuf-adr hbuflen +  1-  c@  newline  <> if
         newline  hbuf-adr hbuflen +  c!
         hbuflen 1+  is hbuflen
      then
   then
;
: make-room  ( needed -- )
   1+  hbufmax  hbuflen -  -  ( shortfall )
   dup  0>  if                ( shortfall )   \ Too little room at the end
      dup hbuf-adr +  hbuf-adr  hbuflen 3 pick -  move  ( shortfall )
      hbuflen swap - is hbuflen
   else
      drop
   then
\      hbuf-adr over +  hbufmax  rot -    ( adr remaining )
\      hbufmax -rot  bounds  ?do          ( next-line-adr )
\         i c@  newline =  if
\           drop i 1+  hbuf-adr - leave
\         then
\      loop                               ( shortfall next-line-adr )
\      dup hbuf-adr
   ensure-line-end
;
: open-history  ( needed -- buf len maxlen line# position )
   make-room   ( )
   hbuf-adr  hbuflen  hbufmax  0  hbuflen
;
: xaccept  (s adr len -- actual )
   (interactive? 0=  if  sys-accept exit  then
   tuck dup hbufmax 1-  >  if    ( len adr len )
      0 swap  0 0                ( len adr 0 len 0 0 )
   else                          ( adr len )
      open-history               ( len adr  hbuf hlen hmax line# position )
   then

   true is accepting?
   edit-buffer  is hbuflen       ( len adr )
   false is accepting?

   swap linelen @ min  tuck      ( len' adr len' )
   line-start-adr  -rot move     ( len' )
;
: new-line-or-done  ( -- )
   accepting?  if
      finished on
      line# @ -1 < if  ?copyline  then
   else
      new-line
   then
;

: self-insert  ( -- )  lastchar @ insert-character  ;

headers
forth definitions

defer (ask-layout ['] noop is (ask-layout       ( -- )

keys-forth also definitions

: ^f  forward-character  ;
: ^b  backward-character  ;
: ^a  beginning-of-line  ;
\ : ^c  finished on  ;
: ^e  end-of-line  ;
: ^d  erase-next-character  ;
: ^h  erase-previous-character  ;
: ^i  bl insert-character  ;
: ^j  new-line-or-done  ;
: ^k  kill-to-end-of-line  ;
: ^l  list-file  ;
: ^m  new-line-or-done  ;
: ^n  next-line  ;
: ^o  split-line  ;
: ^p  previous-line  ;
: ^q  quote-next-character  ;
: ^x  finished on  ;            \ XXX for testing
: ^y  yank  ;
: esc-y  yank  ;                \ XXX for testing

: ^{  key lastchar !  [""] esc- do-command  ;
: esc-o  only forth also definitions  beep beep beep  ;
: esc-h  erase-previous-word  ;
: esc-d  erase-next-word  ;
: esc-f  forward-word  ;
: esc-b  backward-word  ;
: esc-^h  erase-previous-word  ;
: esc-^d  erase-next-word  ;
: esc-^f  forward-word  ;
: esc-^b  backward-word  ;
: esc-del  erase-next-word  ;

\ ANSI cursor keys
: esc-[  key lastchar !  [""] esc-[ do-command  ;
: esc-[A previous-line  ;
: esc-[B next-line  ;
: esc-[C forward-character  ;
: esc-[D backward-character  ;
: esc-[P erase-previous-character  ;

: ask-layout                    ( -- )
  \ Use defer word to reach (ask-layout) in ui-cvars.fth
  (ask-layout
  \ Keep just-typed number from becoming a command line
  beginning-of-line  kill-to-end-of-line
;

hidden definitions
headerless
: emacs-edit
   ['] beep             is  not-found
   ['] insert-character is  printable-char
   ['] xaccept          is  accept
;
emacs-edit

[ifexist] xref-find-hook
' keys-forth ' lose ' $find-word (patch
[then]
forth definitions
chain: init  ( -- )  emacs-edit  ;
headers