level1/40_termio_high.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
   7 ;;$uservar "XEMIT" ua_ofs_xemit 0
   8 ;; ( ch -- )
   9
  10 $uservar "(EMIT)" ua_ofs_emit cfa "(STDTTY-EMIT)"
  11 ;; ( ch -- )
  12
  13 ;; this doesn't count columns
  14 $uservar "(XEMIT)" ua_ofs_xemit cfa "(STDTTY-XEMIT)"
  15 ;; ( ch -- )
  16
  17 $uservar "(TYPE)" ua_ofs_emit_type cfa "(STDTTY-TYPE)"
  18 ;; ( addr count -- )
  19
  20 ;; this doesn't count columns
  21 $uservar "(XTYPE)" ua_ofs_emit_xtype cfa "(STDTTY-XTYPE)"
  22 ;; ( addr count -- )
  23
  24 $uservar "(CR)" ua_ofs_emit_cr cfa "(STDTTY-CR)"
  25  ( -- )
  26
  27 $uservar "(BELL)" ua_ofs_emit_bell cfa "(STDTTY-BELL)"
  28 ;; ( -- )
  29
  30 $uservar "(ENDCR)" ua_ofs_emit_endcr cfa "(STDTTY-ENDCR)"
  31 ;; ( -- )
  32
  33 ;; should "ENDCR" do "CR"?
  34 $uservar "(?ENDCR)" ua_ofs_emit_isendcr cfa "(STDTTY-?ENDCR)"
  35 ;; ( -- flag )
  36
  37 $uservar "(RESET-EMIT-COL)" ua_ofs_emit_resetcol cfa "(STDTTY-RESET-EMIT-COL)"
  38 ;; ( -- )
  39
  40 $uservar "(KEY)" ua_ofs_emit_key cfa "(STDTTY-GETCH)"
  41 ;; ( -- ch )
  42
  43 $uservar "(KEY?)" ua_ofs_emit_iskey cfa "(STDTTY-KEY?)"
  44 ;; ( -- flag )
  45
  46 $uservar "(EKEY)" ua_ofs_emit_ekey 0
  47 ;; ( -- ch )
  48
  49 $uservar "(EKEY?)" ua_ofs_emit_isekey 0
  50 ;; ( -- flag )
  51
  52
  53 : emit  ( ch -- ) (emit) @execute-tail ;
  54 : xemit  ( ch -- ) (xemit) @execute-tail ;
  55 : type  ( addr count -- ) (type) @execute-tail ;
  56 : xtype  ( addr count -- ) (xtype) @execute-tail ;
  57 : cr  (  -- ) (cr) @execute-tail ;
  58 : bell  ( -- ) (bell) @execute-tail ;
  59 : endcr  ( -- ) (endcr) @execute-tail ;
  60 : ?endcr  ( -- flag ) (?endcr) @execute-tail ;
  61 : reset-emitcol  ( -- ) (reset-emit-col) @execute-tail ;
  62 : key  ( -- key ) (key) @execute-tail ;
  63 : key?  ( -- flag ) (key?) @ dup if execute-tail endif ;
  64 : ekey  ( -- key ) (ekey) @ ?dup if execute-tail else key endif ;
  65 : ekey?  ( -- flag ) (ekey?) @ ?dup if execute-tail else key? endif ;
  66
  67
  68 $uservar "(SAFE-EMIT-HIGH-ASCII?)" ua_ofs_safe_emit_highascii 1
  69
  70 : (safe-for-emit)  ( ch -- ch true // 63 false )
  71   0xff and
  72   dup bl < if  ;; < 32: allow tab, cr, lf
  73     dup 9 = over nl = or over 13 = or ?dup ifnot drop [char] ? false endif
  74   else
  75     dup (safe-emit-high-ascii?) @ if 127 0xa0 within else 127 >= endif
  76     if drop [char] ? false else true endif
  77   endif
  78 ; (hidden)
  79
  80 : safe-emit  ( ch -- )  (safe-for-emit) drop emit ;
  81 : safe-emit-printable  ( ch -- )  (safe-for-emit) drop dup bl < if drop [char] ? endif emit ;
  82 : safe-emit-xdump  ( ch -- )  (safe-for-emit) if dup bl <= if drop [char] . endif else drop [char] . endif emit ;
  83
  84
  85 : type-with  ( addr length emitcfa -- )  over +if nrot bounds do i c@ over execute loop else 2drop endif drop ;
  86
  87 \ : type  ( addr length -- )  ['] emit type-with ;
  88
  89 : safe-type  ( addr length -- )  ['] safe-emit type-with ;
  90 : safe-type-printable  ( addr length -- )  ['] safe-emit-printable type-with ;
  91
  92 : space  ( -- )  bl emit ;
  93 : spaces  ( n -- )  for space endfor ;
  94
  95 ;; type asciiz string
  96 : type-asciiz  ( addr -- )  zcount type ;
  97 : safe-type-asciiz  ( addr -- )  zcount safe-type ;
  98 : safe-type-printable-asciiz  ( addr -- )  zcount safe-type-printable ;
  99
 100
 101 : dump  ( addr count -- )
 102   endcr begin dup +while
 103     over .hex8 [char] : emit
 104     2dup 8 for space dup +if over c@ .hex2 else 2 spaces endif /char endfor space
 105     8 for space dup +if over c@ .hex2 else 2 spaces endif /char endfor 2 spaces
 106     2drop 2dup 8 for dup +if over c@ safe-emit-xdump else space endif /char endfor space
 107     8 for dup +if over c@ safe-emit-xdump else space endif /char endfor
 108     2drop 16 /string cr
 109   repeat 2drop
 110 ;
 111
 112
 113 : (.")  ( -- )
 114   r@ ccount type r> ccount + 3 or 1+ >r
 115 ; (hidden) (arg-c1strz)