level0/urforth0_w_tib.asm

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;;
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;;
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, version 3 of the License ONLY.
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;; GNU General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU General Public License
  15 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 urword_value "(DEFAULT-#TIB)",par_default_tib_size,1024
  20 urword_hidden
  21
  22 ;; this will be patched by the startup code
  23 urword_value "(DEFAULT-TIB)",par_default_tib,0
  24 urword_hidden
  25
  26
  27 urword_var "TIB",      tib,      0  ;fdata_tib
  28 urword_var "#TIB",     tibsize,  0  ;fdata_tib_end-fdata_tib
  29 urword_var ">IN",      inptr,    0
  30 urword_var "TIB-LINE#",tiblineno,0
  31
  32 ;; "TIB-GETCH" will set this if last read char is not EOL
  33 ;; parsing words will set this too, as if they're using "TIB-GETCH"
  34 urword_var "(TIB-LAST-READ-CHAR)",par_last_read_char,0
  35
  36 urword_value "(LAST-TLOAD-PATH-ADDR)",par_last_tload_path,0
  37
  38 ;; size of TIB save buffer
  39 urword_const "#TIB-SAVE-BUFFER",tib_save_buffer_size,4+4+4+4+4
  40
  41 ;; current file we are interpreting
  42 urword_const "(#TIB-CURR-FNAME)",par_tib_curr_fname_size,4096
  43 urword_hidden
  44 ;; c4str
  45 urword_value "(TIB-CURR-FNAME)",par_tib_curr_fname,0
  46 urword_hidden
  47
  48
  49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50 urword_code "TIBSTATE>R",par_tibstate_rpush
  51   rpushmem [fvar_tib_data]
  52   rpushmem [fvar_tibsize_data]
  53   rpushmem [fvar_inptr_data]
  54   rpushmem [fvar_tiblineno_data]
  55   rpushmem [fvar_par_last_read_char_data]
  56   urnext
  57 urword_end
  58
  59 urword_code "R>TIBSTATE",par_tibstate_rpop
  60   rpopmem  [fvar_par_last_read_char_data]
  61   rpopmem  [fvar_tiblineno_data]
  62   rpopmem  [fvar_inptr_data]
  63   rpopmem  [fvar_tibsize_data]
  64   rpopmem  [fvar_tib_data]
  65   urnext
  66 urword_end
  67
  68 urword_code "RDROP-TIBSTATE",par_tibstate_rdrop
  69   add   ERP,4+4+4+4+4
  70   urnext
  71 urword_end
  72
  73
  74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75 urword_forth "TIB-DEFAULT?",tib_is_default
  76   UF tib @ par_default_tib equal
  77 urword_end
  78
  79 urword_forth "TIB-RESET",tib_reset
  80   ; reset TIB
  81   UF par_default_tib tib !
  82   UF par_default_tib_size tibsize !
  83   UF inptr 0poke
  84   UF tiblineno 0poke
  85   UF 0
  86   urto par_last_tload_path
  87 urword_end
  88
  89
  90 if 0
  91 urword_forth "TIB-PEEKCH",tib_peekch
  92 ;; ( -- ch-or-0 )
  93   UF inptr @ tibsize @ uless
  94   ur_if
  95     UF tib @ inptr @ + cpeek
  96     UF qdup
  97     ur_ifnot
  98       UF 32
  99     ur_endif
 100   ur_else
 101     UF 0
 102   ur_endif
 103 urword_end
 104
 105 urword_forth "TIB-GETCH",tib_getch
 106 ;; ( -- ch-or-0 )
 107   UF tib_peekch dup
 108   ur_if
 109     UF 1 inptr addpoke
 110     UF dup 10 equal
 111     ur_if
 112       UF tiblineno @
 113       ur_if
 114         UF 1 tiblineno addpoke
 115       ur_endif
 116     ur_endif
 117     UF dup par_last_read_char !
 118   ur_endif
 119 urword_end
 120
 121 else
 122
 123 urword_code "TIB-PEEKCH",tib_peekch
 124 ;; ( -- ch-or-0 )
 125 ;; will never be negative
 126   push  TOS
 127   xor   TOS,TOS
 128   ld    eax,[fvar_inptr_data]
 129   cp    eax,dword [fvar_tibsize_data]
 130   jr    nc,@f
 131   add   eax,[fvar_tib_data]
 132   movzx TOS,byte [eax]
 133   ; convert zero to 32
 134   ld    eax,32
 135   or    cl,cl
 136   cmovz ecx,eax
 137 @@:
 138   urnext
 139 urword_end
 140
 141 urword_code "TIB-GETCH",tib_getch
 142 ;; ( -- ch-or-0 )
 143 ;; will never be negative
 144   push  TOS
 145   xor   TOS,TOS
 146   ld    eax,[fvar_inptr_data]
 147   cp    eax,dword [fvar_tibsize_data]
 148   jr    nc,@f
 149   add   eax,[fvar_tib_data]
 150   movzx TOS,byte [eax]
 151   ; convert zero to 32
 152   ld    eax,32
 153   or    cl,cl
 154   cmovz ecx,eax
 155   ; update last read char
 156   ld    [fvar_par_last_read_char_data],TOS
 157   ; update position
 158   inc   dword [fvar_inptr_data]
 159   ; update current line
 160   cp    cl,10
 161   jr    nz,@f
 162   cp    dword [fvar_tiblineno_data],0
 163   jr    z,@f
 164   inc   dword [fvar_tiblineno_data]
 165 @@:
 166   urnext
 167 urword_end
 168 end if
 169
 170
 171 if 0
 172 urword_forth "TIB-CALC-CURRLINE",tib_calc_currline
 173 ;; ( -- linenum-1 )
 174 ;; returns line number for the current TIB position
 175   UF 0
 176   UF inptr @
 177   ur_if
 178     UF inptr @ tib @ +  tib @
 179     ur_do
 180       UF i cpeek 10 equal
 181       ur_if
 182         UF 1inc
 183       ur_endif
 184     ur_loop
 185   ur_endif
 186 else
 187 urword_code "TIB-CALC-CURRLINE",tib_calc_currline
 188 ;; ( -- linenum-1 )
 189 ;; returns line number for the current TIB position
 190   push  TOS
 191   ld    edi,[fvar_tib_data]
 192   ld    ecx,[fvar_inptr_data]
 193   ld    al,10
 194   xor   edx,edx   ; line counter
 195 @@:
 196   cp    ecx,1
 197   jr    l,@f
 198   repne scasb
 199   jr    nz,@f
 200   inc   edx
 201   jr    @b
 202 @@:
 203   ld    TOS,edx
 204   urnext
 205 end if
 206 urword_end
 207
 208
 209 urword_forth "ACCEPT",accept
 210 ;; ( addr maxlen -- readlen // -1 )
 211   UF dup 0 lessequ errid_input_too_long qerror
 212   UF 0
 213   ;; ( addr maxlen currcount )
 214   ur_begin
 215     UF key
 216     ; eof or cr or lf?
 217     UF dup 0xffffffff equal
 218     UF over 10 equal or
 219     UF over 13 equal or
 220     UF not
 221   ur_while
 222     ;; ( addr maxlen currcount char )
 223     UF rpush
 224     ;; can we put it?
 225     UF 2dup great
 226     ur_if
 227       ;; yep, store
 228       ;; ( addr maxlen currcount | char )
 229       UF rot rpop over cpoke 1inc nrot 1inc
 230     ur_else
 231       ;; nope
 232       UF rdrop  ;; drop char, we have no room for it
 233       ;; need a bell?
 234       UF 2dup equal
 235       ur_if
 236         UF bell
 237         UF 1inc
 238       ur_endif
 239     ur_endif
 240   ur_repeat
 241   ;; ( addr maxlen currcount char )
 242   UF 0xffffffff nequ
 243   ur_if
 244     UF par_reset_emitcol  ;; because OS did cr (i hope)
 245   ur_endif
 246   ;; check for overflow
 247   UF 2dup less
 248   ur_if
 249     ;; oops, overflow
 250     UF 2drop drop 0xffffffff
 251   ur_else
 252     UF nrot 2drop
 253   ur_endif
 254 urword_end
 255
 256
 257 urword_forth "REFILL",refill
 258 ;; ( -- flag )
 259 ;; either refills TIB and sets flag to true, or does nothing and sets flag to false
 260   UF tib_is_default
 261   ur_if
 262     ur_begin
 263       UF tib @ tibsize @ 1dec accept
 264       UF dup 0less
 265     ur_while
 266       UF drop
 267       UF endcr pardottype "ERROR: ACCEPT buffer overflow" cr
 268     ur_repeat
 269       ;UF tib @ over type 124 emit dup . cr
 270     ;; put trailing zero
 271     UF tib @ + 0poke
 272     UF inptr 0poke
 273     UF 1
 274   ur_else
 275     UF 0
 276   ur_endif
 277 urword_end