libs/tty/tty-ekey-names.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; THIS IS NOT MULTITHREAD-SAFE!
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 also tty definitions
   9
  10
  11 : (k-find-name)  ( code -- addr count true // false )
  12   0xffff and vocid: tty [:  ( nfa -- stopflag )
  13     dup nfa->cfa word-type? word-type-const = if
  14       2dup nfa->cfa cfa->pfa @ = if
  15         id-count over w@ 0x2d4b = over 2 > and  ;; is this a "K-*" const?
  16         dup ifnot nrot 2drop else >r rot drop 2 /string r> endif
  17         exit
  18       endif
  19     endif
  20     drop false
  21   ;] foreach-word
  22   dup ifnot nip endif
  23 ;
  24
  25 ;; uses PAD
  26 : ekey>name  ( code -- addr count )
  27   pad 0!
  28   dup K-CTRL-MASK and if " C-" pad c4s:cat-counted endif
  29   dup K-ALT-MASK and if " M-" pad c4s:cat-counted endif
  30   dup K-SHIFT-MASK and if " S-" pad c4s:cat-counted endif
  31   dup K-HYPER-MASK and if " H-" pad c4s:cat-counted endif
  32   dup (k-find-name) ifnot
  33     dup 0xffff and bl 128 within over 0xffff and 129 256 within or if
  34       dup [ K-ALT-MASK K-CTRL-MASK or ] literal and ifnot
  35         dup locase-char over 0xffff and <> if dup K-SHIFT-MASK and ifnot " S-" pad c4s:cat-counted endif endif
  36       endif
  37       upcase-char pad c4s:cat-char pad count exit
  38     else " 0x" pad c4s:cat-counted base @ >r hex <#u # # # # #> r> base !
  39     endif
  40   else rot drop
  41   endif
  42   pad c4s:cat-counted pad count
  43 ;
  44
  45
  46 previous definitions