level1/08_termio_low.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 $value "STDIN-FD"  0
   8 $value "STDOUT-FD" 1
   9 $value "STDERR-FD" 2
  10
  11 $variable "(STDTTY-EMIT-COL)" 0
  12 (hidden)
  13
  14
  15 code: (STDTTY-XEMIT)  ( ch -- )
  16   push  EIP
  17   push  TOS
  18 .again:
  19   ld    eax,4    ;; function
  20   ld    ebx,[pfa "stdout-fd"]
  21   ld    ecx,esp  ;; address
  22   ld    edx,1    ;; length
  23   syscall
  24   cp    eax,-4
  25   jr    z,.again
  26   pop   TOS
  27   pop   EIP
  28 .done:
  29   pop   TOS
  30   urnext
  31 endcode
  32 (hidden)
  33
  34 code: (STDTTY-XTYPE)  ( addr length -- )
  35   ;; positive length is guaranteed by the caller, but...
  36   ld    edx,TOS
  37   pop   ecx
  38   push  EIP
  39   cp    edx,0
  40   jr    le,.done
  41 .again:
  42   push  ecx
  43   push  edx
  44   ld    ebx,[pfa "stdout-fd"]
  45   ld    eax,4
  46   syscall
  47   pop   edx
  48   pop   ecx
  49   cp    eax,-4
  50   jr    z,.again
  51   or    eax,eax
  52   jr    s,.done
  53   sub   edx,eax
  54   jr    be,.done
  55   add   ecx,eax
  56   jr    .again
  57 .done:
  58   pop   EIP
  59   pop   TOS
  60   urnext
  61 endcode
  62
  63 ;; returns -1 on EOF, or [0..255]
  64 code: (STDTTY-GETCH)  ( -- ch )
  65   push  TOS
  66   xor   eax,eax
  67   push  EIP
  68   push  eax
  69 .again:
  70   ld    eax,3     ;; read
  71   ld    ebx,[pfa "stdin-fd"]
  72   ld    ecx,esp   ;; address
  73   ld    edx,1     ;; length
  74   syscall
  75   cp    eax,-4
  76   jr    z,.again
  77   pop   TOS       ;; read char
  78   pop   EIP
  79   cp    eax,1
  80   ld    ebx,-1
  81   cmovnz TOS,ebx
  82   urnext
  83 endcode
  84 (hidden)
  85
  86
  87 : (STDTTY-RESET-EMIT-COL)  ( -- )  (stdtty-emit-col) 0! ;
  88
  89 : (STDTTY-EMIT-FIX-COL)  ( ch -- ch )
  90   dup case
  91     8 of (stdtty-emit-col) @ 1- 0 max (stdtty-emit-col) ! endof
  92     9 of (stdtty-emit-col) @ 7 or 1+ (stdtty-emit-col) ! endof
  93     10 of (stdtty-reset-emit-col) endof
  94     13 of (stdtty-reset-emit-col) endof
  95     127 of endof
  96     otherwise bl >= (stdtty-emit-col) +!  ;; FIXME: assumes that `true` is 1
  97   endcase
  98 ; (hidden)
  99
 100 : (STDTTY-BELL)    ( -- )       7 (stdtty-xemit) ; (hidden)
 101 : (STDTTY-EMIT)    ( ch -- )    (stdtty-emit-fix-col) (stdtty-xemit) ; (hidden)
 102 : (STDTTY-CR)      ( -- )       (stdtty-reset-emit-col) nl (stdtty-xemit) ; (hidden)
 103 : (STDTTY-ENDCR)   ( -- )       (stdtty-emit-col) @ if (stdtty-cr) endif ; (hidden)
 104 : (STDTTY-?ENDCR)  ( -- flag )  (stdtty-emit-col) @ 0<> ; (hidden)
 105
 106 : (STDTTY-TYPE)  ( addr length -- )
 107   ;; positive length is guaranteed by the caller, but...
 108   dup +if
 109     2dup bounds do i c@ (stdtty-emit-fix-col) drop loop
 110     (stdtty-xtype)
 111   else 2drop endif
 112 ; (hidden)
 113
 114
 115 : (STDTTY-KEY?)  ( -- flag )
 116   os:#pollfd alloca >r 0
 117   begin
 118     drop stdin-fd r@ os:pollfd.fd !
 119     os:poll-in r@ os:pollfd.events !  ;; this also clears revents
 120     r@ 1 0 os:poll dup -4 <>
 121   until
 122   0> rdrop >r os:#pollfd dealloca r>
 123 ; (hidden)