level1/42_tib.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 ;; "TIB" and "#TIB" will be set by the startup code
   8 $uservar "TIB"       ua_ofs_tib 0
   9 $uservar "#TIB"      ua_ofs_tib_size 0
  10 $uservar ">IN"       ua_ofs_in 0
  11 $uservar "TIB-LINE#" ua_ofs_tibline  0
  12
  13 ;; "TIB-GETCH" will set this if last read char is not EOL
  14 ;; parsing words will set this too, as if they're using "TIB-GETCH"
  15 $uservar "(TIB-LAST-READ-CHAR)" ua_ofs_tiblastchar 0
  16
  17 ;; $uservar "(TIB-ERROR-LINE-C4S)" ua_ofa_tib_errline_c4s 0
  18 $variable "(TIB-ERROR-LINE-C4S)" 0
  19 $variable "(TIB-ERROR-LINE->IN)" 0
  20
  21 ;; current file we are interpreting
  22 ;; c4str
  23 $value "(TIB-CURR-FNAME)" 0
  24 (hidden)
  25
  26 $value "(TIB-ERROR-FNAME)" 0
  27 (hidden)
  28 $value "(TIB-ERROR-LINE#)" 0
  29 (hidden)
  30
  31 $value "(TIB-CURR-FNAME-DEFAULT)" 0
  32 (hidden)
  33
  34 $constant "(#TIB-CURR-FNAME)" 260
  35 (hidden)
  36
  37 ;; size of TIB save buffer
  38 $constant "#TIB-SAVE-BUFFER" 5*4
  39
  40
  41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42 : TIB-CURR-LINE  ( -- linenum )
  43   tib-line# @ (tib-last-read-char@) nl = -  \ FIXME: WARNING! assumes that `true` is `1`!
  44 ;
  45
  46
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ..: (startup-init)  ( -- )
  49   (#tib-curr-fname) brk-alloc dup to (tib-curr-fname) to (tib-curr-fname-default)
  50   (#tib-curr-fname) brk-alloc dup to (tib-error-fname) 0! (tib-curr-fname) 0!
  51 ;..
  52
  53
  54 : (tib-free-errline)  ( -- )
  55   (tib-error-line-c4s) @ ?dup if
  56     4096 os:munmap drop (tib-error-line-c4s) 0!
  57     (tib-error-line->in) 0!
  58   endif
  59 ;
  60
  61 : (tib-clear-error)  ( -- )
  62   (tib-error-fname) 0! 0 to (tib-error-line#)
  63   (tib-free-errline)
  64 ;
  65
  66 : (tib-set-fname)  ( addr count -- )
  67   0 (#tib-curr-fname) clamp (tib-curr-fname) c4s:copy-counted
  68   (tib-clear-error)
  69 ; (hidden)
  70
  71 : (tib-pos>bol)  ( pos -- pos )
  72   0 max
  73   begin dup while
  74   dup 1- tib @ + c@ nl <> while
  75   1- repeat
  76 ;
  77
  78 : (tib-pos>eol)  ( pos -- pos )
  79   0 max
  80   begin dup #tib @ < while
  81   dup tib @ + c@ dup nl <> swap 0<> and while
  82   1+ repeat
  83 ;
  84
  85 ;; copy current TIB line to error buffer
  86 : (tib-line>errline)  ( -- )
  87   tib @ if
  88     >in @ (tib-last-read-char@) nl = if 1- endif 0 #tib @ clamp
  89     dup (tib-pos>bol) >in @ over - (tib-error-line->in) !
  90     swap (tib-pos>eol) over - 0 4090 clamp
  91     (tib-error-line-c4s) @ ?dup ifnot
  92       4096 os:prot-r/w os:mmap ifnot drop exit endif
  93       dup (tib-error-line-c4s) !
  94     endif
  95     rot tib @ + nrot c4s:copy-counted
  96   else
  97     ;; tib is sempty
  98     (tib-free-errline)
  99   endif
 100 ;
 101
 102 : (tib-fname>error-fname)  ( -- )
 103   (tib-line>errline)
 104   (tib-curr-fname) ?dup ifnot (tib-error-fname) ?dup if 0! endif exit endif
 105   (tib-error-fname) ?dup ifnot drop exit endif
 106   c4s:copy
 107   tib-line# @ dup if (tib-last-read-char@) nl = if 1- 1 max endif endif
 108   to (tib-error-line#)
 109 ; (hidden)
 110
 111
 112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 113 : (tib-type-highlighted-line)  ( addr count hipos -- )
 114   over +if
 115     ." \x1b[4m<"
 116     >r over r> + nrot bounds do
 117       dup i = if ." \x1b[7m" endif
 118       i c@ safe-emit-printable
 119       dup i = if ." \x1b[27m" endif
 120     loop
 121     ." >\x1b[24m"
 122   else
 123     2drop
 124   endif
 125   drop
 126 ; (hidden)
 127
 128 : (tib-type-error-line)  ( -- )
 129   (tib-error-line-c4s) @ ?dup if count (tib-error-line->in) @ (tib-type-highlighted-line) endif
 130 ; (hidden)
 131
 132 : (tib-type-curr-line)  ( -- )
 133   #tib @ ifnot exit endif
 134   >in @ (tib-last-read-char@) nl = if 1- endif
 135   0 #tib @ clamp
 136   dup (tib-pos>bol) >in @ over - >r
 137   swap (tib-pos>eol) over - 0 4090 clamp
 138   swap tib @ + swap r> (tib-type-highlighted-line)
 139 ; (hidden)
 140
 141
 142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 143 ;; by default, threads has no allocated tib
 144 ;; call this to ensure that the tib is allocated
 145 : tib-allocate-default  ( -- )
 146   (default-tib) @ ifnot
 147     (default-#tib) cell+ brk-alloc (default-tib) !
 148     tib @ ifnot (default-#tib) #tib ! (default-tib) @ tib ! endif
 149     tib @ dup 0! (default-#tib) + 0!
 150   endif
 151 ;
 152
 153 ;; this doesn't reset line
 154 : (tib-set-to)  ( addr count -- )
 155   #tib ! tib ! >in 0! bl (tib-last-read-char) !
 156 ;
 157
 158 ;; this resets line
 159 : tib-set-to  ( addr count -- )
 160   (tib-set-to) tib-line# 0!
 161 ;
 162
 163 : TIBSTATE-SAVE  ( bufaddr -- )
 164   tib @ over ! cell+
 165   #tib @ over ! cell+
 166   >in @ over ! cell+
 167   tib-line# @ over ! cell+
 168   (tib-last-read-char@) swap !
 169 ;
 170
 171 : TIBSTATE-RESTORE  ( bufaddr -- )
 172   dup @ tib ! cell+
 173   dup @ #tib ! cell+
 174   dup @ >in ! cell+
 175   dup @ tib-line# ! cell+
 176   @ (tib-last-read-char) !
 177 ;
 178
 179
 180 : TIBSTATE>R  ( -- | -- savedtibstate )
 181   r> #tib-save-buffer ralloca tibstate-save >r
 182 ;
 183
 184 : R>TIBSTATE  ( -- | savedtibstate -- )
 185   r> rp@ tibstate-restore #tib-save-buffer rdealloca >r
 186 ;
 187
 188 : RDROP-TIBSTATE  ( -- | savedtibstate -- )
 189   r> #tib-save-buffer rdealloca >r
 190 ;
 191
 192 : SAVE-INPUT  ( -- ... n )
 193   tib @ #tib @ >in @ tib-line# @ (tib-last-read-char@) 5
 194 ;
 195
 196 : RESTORE-INPUT  ( ... 5 -- )
 197   5 <> ERR-INVALID-INPUT-SIZE ?error
 198   (tib-last-read-char) ! tib-line# ! >in ! #tib ! tib !
 199 ;
 200
 201 : DROP-SAVED-INPUT  ( ... 5 -- )
 202   5 <> ERR-INVALID-INPUT-SIZE ?error
 203   2drop 2drop drop
 204 ;
 205
 206
 207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 208 : TIB-DEFAULT?  ( -- bool )
 209   tib @ (default-tib) @ =
 210 ;
 211
 212 ;; reset TIB to the default one
 213 : TIB-RESET ( -- )
 214   (default-tib) @ dup tib !
 215   if (default-#tib) else 0 endif #tib !
 216   >in 0!
 217   tib-line# 0!
 218   bl (tib-last-read-char) !
 219   ;;k8: no, don't clear it; it will be cleared by tloader in abort sequence
 220   ;; 0 to tloader:last-include-dir-c4s
 221   (tib-curr-fname-default) to (tib-curr-fname)
 222 ;
 223
 224
 225 code: tib-in^  ( -- addr )
 226   push  TOS
 227   ld    TOS,ts:[ua_ofs_tib]
 228   add   TOS,ts:[ua_ofs_in]
 229   urnext
 230 endcode
 231
 232
 233 code: (tib-last-read-char@)  ( -- ch )
 234   push  TOS
 235   ld    TOS,ts:[ua_ofs_tiblastchar]
 236   urnext
 237 endcode
 238
 239 ;; will never be negative
 240 ;; 0 means "END-OF-TIB"
 241 code: TIB-PEEKCH  ( -- ch-or-0 )
 242   push  TOS
 243   xor   TOS,TOS
 244   ld    eax,ts:[ua_ofs_in]
 245   cp    eax,ts:[ua_ofs_tib_size]
 246   jr    nc,.done
 247   add   eax,ts:[ua_ofs_tib]
 248   movzx TOS,byte [eax]
 249 .done:
 250   urnext
 251 endcode
 252
 253 ;; will never be negative
 254 ;; 0 means "END-OF-TIB"
 255 code: TIB-PEEKCH-N  ( chofs -- ch-or-0 )
 256   ld    eax,TOS
 257   xor   TOS,TOS
 258   add   eax,ts:[ua_ofs_in]
 259   jr    s,.done
 260   cp    eax,ts:[ua_ofs_tib_size]
 261   jr    nc,.done
 262   add   eax,ts:[ua_ofs_tib]
 263   movzx TOS,byte [eax]
 264 .done:
 265   urnext
 266 endcode
 267
 268 ;; will never be negative
 269 ;; 0 means "END-OF-TIB" (and doesn't advance >IN)
 270 code: TIB-GETCH  ( -- ch-or-0 )
 271   push  TOS
 272   xor   TOS,TOS
 273   ld    eax,ts:[ua_ofs_in]
 274   cp    eax,ts:[ua_ofs_tib_size]
 275   jr    nc,.done
 276   ld    edx,eax
 277   inc   edx
 278   add   eax,ts:[ua_ofs_tib]
 279   movzx TOS,byte [eax]
 280   ;; zero always ends the input
 281   jecxz .done
 282   ld    ts:[ua_ofs_tiblastchar],TOS
 283   ld    ts:[ua_ofs_in],edx
 284   ;; update current line
 285   cp    cl,10
 286   jr    nz,.done
 287   ld    eax,ts:[ua_ofs_tibline]
 288   test  eax,eax
 289   jr    z,.done
 290   inc   eax
 291   ld    ts:[ua_ofs_tibline],eax
 292 .done:
 293   urnext
 294 endcode
 295
 296 : tib-skipch  ( -- )  tib-getch drop ;
 297
 298 ;; -1 means "buffer overflow"
 299 : (STD-ACCEPT)  ( addr maxlen fromrefill -- readlen // -1 )
 300   drop  ;; we can't do anything with "fromrefill" flag here
 301   0  ;; ( addr maxlen currcount )
 302   begin
 303     key
 304     ;; eof or cr or lf?
 305     dup -1 = over 10 = or over 13 = or
 306   not-while
 307     ;; ( addr maxlen currcount char )
 308     >r
 309     ;; can we put it?
 310     2dup > if
 311       ;; yep, store -- ( addr maxlen currcount | char )
 312       rot r> over c! 1+ nrot 1+
 313     else
 314       ;; nope
 315       rdrop  ;; drop char, we have no room for it
 316       ;; need a bell?
 317       2dup = if bell 1+ ( no more bells ) endif
 318     endif
 319   repeat
 320   ;; ( addr maxlen currcount char )
 321   -1 <> if reset-emitcol ( because OS did cr -- i hope ) endif
 322   ;; check for overflow
 323   2dup < if 2drop drop -1 ( oops, overflow ) else nrot 2drop endif
 324 ; (hidden)
 325
 326 ;; -1 means "buffer overflow"
 327 ( addr maxlen fromrefill -- readlen // -1 )
 328 $defer "(ACCEPT)"  cfa "(STD-ACCEPT)"
 329
 330
 331 ;; -1 means "buffer overflow"
 332 : ACCEPT  ( addr maxlen -- readlen // -1 )
 333   dup 0 <= err-input-too-long ?error
 334   false (accept)
 335 ;
 336
 337 ;; either refills TIB and sets flag to true, or does nothing and sets flag to false
 338 : REFILL  ( -- flag )
 339   tib-default? ifnot
 340     false
 341   else
 342     begin
 343       tib @ #tib @ 1- true (accept)
 344       dup 0<
 345     while
 346       drop
 347       endcr ." ERROR: ACCEPT buffer overflow\n"
 348     repeat
 349       ;;tib @ over type 124 emit dup . cr
 350     ;; put trailing zero
 351     tib @ + 0c!
 352     >in 0!
 353     true
 354   endif
 355 ;