level0/urforth0_w_countstr.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_code "ZCOUNT",zcount
  20 ;; ( addr -- addr count )
  21 ;; length of asciiz string
  22   push  TOS
  23   mov   edi,TOS
  24   xor   al,al
  25   cp    [edi],al
  26   jr    nz,@f
  27   xor   TOS,TOS
  28   urnext
  29 @@:
  30   mov   edx,-1
  31   mov   ecx,edx
  32   repnz scasb
  33   sub   edx,ecx
  34   mov   ecx,edx
  35   dec   ecx
  36   urnext
  37 urword_end
  38
  39
  40 urword_alias "COUNT-ONLY",count_only,peek
  41 ;; ( addr -- count )
  42
  43 urword_code "COUNT",count
  44 ;; ( addr -- addr+4 count )
  45   ;UF dup count_only swap cellinc swap exit
  46   ld    eax,[TOS]
  47   add   TOS,4
  48   push  TOS
  49   ld    TOS,eax
  50   urnext
  51 urword_end
  52
  53
  54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55 urword_code "S=",strequ
  56 ;; ( addr0 count0 addr1 count1 -- flag )
  57   ; compare lengthes
  58   cp    TOS,[esp+4]
  59   jr    nz,.lenfail
  60   or    ecx,ecx
  61   jr    z,.lenzero
  62   ; perform memcmp
  63   pop   edi
  64   pop   eax
  65   xchg  esi,[esp]
  66   ; now EIP is saved on the stack
  67   repz  cmpsb
  68   ; restore EIP
  69   pop   esi
  70   jcxz  .success_check
  71   xor   TOS,TOS
  72   urnext
  73
  74 .success_check:
  75   jz    .success
  76   xor   TOS,TOS
  77   urnext
  78
  79 .lenfail:
  80   ; early failure
  81   add   esp,4*3
  82   xor   TOS,TOS
  83   urnext
  84
  85 .lenzero:
  86   ; early success
  87   add   esp,4*3
  88 .success:
  89   ld    TOS,1
  90   urnext
  91 urword_end
  92
  93 ; ascii case-insensitive compare
  94 urword_code "S=CI",strequ_ci
  95 ;; ( addr0 count0 addr1 count1 -- flag )
  96   ; compare lengthes
  97   cp    TOS,[esp+4]
  98   jr    nz,.lenfail
  99   or    ecx,ecx
 100   jr    z,.lenzero
 101   ; perform memcmp
 102   pop   edi
 103   pop   eax
 104   xchg  esi,[esp]
 105   ; now EIP is saved on the stack
 106 .cmploop:
 107   lodsb
 108   ld    ah,[edi]
 109   inc   edi
 110   ; it may work
 111   cp    al,ah
 112   jr    nz,.trycase
 113 .caseequ:
 114   loop  .cmploop
 115   ; success
 116   ; restore EIP
 117   pop   esi
 118   ld    TOS,1
 119   urnext
 120
 121 .trycase:
 122   cp    al,'a'
 123   jr    c,@f
 124   cp    al,'z'+1
 125   jr    nc,@f
 126   sub   al,32
 127 @@:
 128   cp    ah,'a'
 129   jr    c,@f
 130   cp    ah,'z'+1
 131   jr    nc,@f
 132   sub   ah,32
 133 @@:
 134   cmp   al,ah
 135   jr    z,.caseequ
 136   ; failure
 137   ; restore EIP
 138   pop   esi
 139   xor   TOS,TOS
 140   urnext
 141
 142 .lenfail:
 143   ; early failure
 144   add   esp,4*3
 145   xor   TOS,TOS
 146   urnext
 147
 148 .lenzero:
 149   ; early success
 150   add   esp,4*3
 151   ld    TOS,1
 152   urnext
 153 urword_end
 154
 155
 156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 157 urword_code "UPCASE-CHAR",upcase_char
 158 ;; ( ch -- ch )
 159   and   TOS,0xff
 160   cp    cl,'a'
 161   jr    c,@f
 162   cp    cl,'z'+1
 163   jr    nc,@f
 164   sub   cl,32
 165 @@:
 166   urnext
 167 urword_end
 168
 169 urword_code "UPCASE-STR",upcase_str
 170 ;; ( addr count -- )
 171   pop   edi
 172   test  TOS,0x80000000
 173   jr    nz,fword_upcase_str_done
 174   or    TOS,TOS
 175   jr    z,fword_upcase_str_done
 176 fword_upcase_str_loop:
 177   ld    al,[edi]
 178   cp    al,'a'
 179   jr    c,@f
 180   cp    al,'z'+1
 181   jr    nc,@f
 182   sub   byte [edi],32
 183 @@:
 184   inc   edi
 185   loop  fword_upcase_str_loop
 186 fword_upcase_str_done:
 187   pop   TOS
 188   urnext
 189 urword_end
 190
 191
 192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 193 ;; converts some escape codes in-place
 194 ;; used for `."` and `"`
 195 ;; the resulting string is never bigger that the source one
 196 ;; this will not preserve the trailing zero byte
 197 urword_code "STR-UNESCAPE",str_unescape
 198 ;; ( addr count -- addr count )
 199   ;call  .dbg
 200   jecxz .quit
 201   ld    edi,[esp]
 202   push  ecx
 203
 204 .scanloop:
 205   ld    al,92
 206   repnz scasb
 207   jecxz .done  ; nope
 208   jr    nz,.done
 209   ; edi is after backslash
 210   ; ecx is number of chars left after backslash
 211   ; found backslash, check next char
 212   ld    al,[edi]
 213   ; '\r'?
 214   cp    al,'r'
 215   jr    nz,@f
 216   ld    al,13
 217   jr    .replace_one
 218 @@:
 219   ; '\n'?
 220   cp    al,'n'
 221   jr    nz,@f
 222   ld    al,10
 223   jr    .replace_one
 224 @@:
 225   ; '\t'?
 226   cp    al,'t'
 227   jr    nz,@f
 228   ld    al,9
 229   jr    .replace_one
 230 @@:
 231   ; '\b'? (bell)
 232   cp    al,'b'
 233   jr    nz,@f
 234   ld    al,7
 235   jr    .replace_one
 236 @@:
 237   ; '\e'? (escape)
 238   cp    al,'e'
 239   jr    nz,@f
 240   ld    al,27
 241   jr    .replace_one
 242 @@:
 243   ; '\z'? (zero)
 244   cp    al,'z'
 245   jr    nz,@f
 246   xor   al,al
 247   jr    .replace_one
 248 @@:
 249   ; '\`'? (double quote)
 250   cp    al,'`'
 251   jr    nz,@f
 252   ld    al,'"'
 253   jr    .replace_one
 254 @@:
 255   ; 'xHH'?
 256   cp    al,'x'
 257   jr    z,.esc_hex
 258   cp    al,'X'
 259   jr    z,.esc_hex
 260   jr    .replace_one
 261 .loop_cont:
 262   loop  .scanloop
 263
 264 .done:
 265   pop   ecx
 266 .quit:
 267   urnext
 268
 269 .esc_hex:
 270   cp    ecx,2
 271   jr    c,.loop_cont
 272   ld    al,[edi+1]
 273   call  .hexdigit
 274   jr    c,.loop_cont
 275   ; save original string position
 276   push  esi
 277   ld    esi,edi
 278   ; skip 'x'
 279   inc   edi   ; skip 'x'
 280   dec   ecx
 281   dec   dword [esp+4]
 282   ; skip first digit
 283   inc   edi
 284   dec   ecx
 285   dec   dword [esp+4]
 286   jecxz .esc_hex_done
 287   ld    ah,al
 288   ld    al,[edi]
 289   call  .hexdigit
 290   jr    nc,@f
 291   ld    al,ah
 292   jr    .esc_hex_done
 293 @@:
 294   ; combine two hex digits
 295   shl   ah,4
 296   or    al,ah
 297   ; skip second digit
 298   inc   edi
 299   dec   ecx
 300   dec   dword [esp+4]
 301 .esc_hex_done:
 302   ld    [esi-1],al
 303   jecxz .esc_hex_quit
 304   ; remove leftover chars
 305   ; ECX: chars left
 306   ; ESI: position after backslash
 307   ; EDI: rest position
 308   ; old ESI is on the stack
 309   push  esi   ; to be restored in EDI
 310   push  ecx
 311   xchg  esi,edi
 312   rep movsb
 313   pop   ecx
 314   pop   edi   ; get back to backslash
 315   pop   esi   ; restore old ESI
 316   jr    .scanloop
 317
 318 .esc_hex_quit:
 319   pop   esi
 320   jr    .done
 321
 322 .replace_one:
 323   ld    [edi-1],al
 324   dec   dword [esp]
 325   dec   ecx
 326   jecxz .done
 327   ; move
 328   push  esi
 329   push  edi
 330   push  ecx
 331   ld    esi,edi
 332   inc   edi
 333 .domove:
 334   xchg  esi,edi
 335   rep movsb
 336   pop   ecx
 337   pop   edi
 338   pop   esi
 339   jr    .scanloop
 340
 341 .hexdigit:
 342   sub   al,'0'
 343   jr    c,.hexdigit_done
 344   cp    al,10
 345   ccf
 346   jr    nc,.hexdigit_done
 347   sub   al,7
 348   jr    c,.hexdigit_done
 349   cp    al,16
 350   ccf
 351   jr    nc,.hexdigit_done
 352   ; maybe its lowercase?
 353   cp    al,42
 354   jr    c,.hexdigit_done
 355   sub   al,32
 356   cp    al,16
 357   ccf
 358 .hexdigit_done:
 359   ret
 360
 361 .dbg:
 362   dprint_hex_al
 363   dprint_char ' '
 364   dprint_hex ecx
 365   dprint_cr
 366   ret
 367 urword_end
 368
 369
 370 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 371 urword_code "STR-TRIM-AFTER-LAST-CHAR",str_trim_after_last_char
 372 ;; ( addr count char -- addr count )
 373 ;; `count` will be 0 if there is no char
 374 ;; `count` will include char
 375 ;; `addr` is not changed in any case
 376   ; i can do it faster, but meh...
 377   ld    eax,TOS
 378   pop   TOS
 379   ld    edi,[esp]
 380   jecxz .notfound
 381   test  TOS,0x80000000
 382   jr    nz,.notfound
 383   add   edi,TOS
 384 .scanloop:
 385   dec   edi
 386   cp    byte [edi],al
 387   jr    z,.done
 388   loop  .scanloop
 389 .notfound:
 390   xor   TOS,TOS
 391   urnext
 392 .done:
 393   jecxz .notfound
 394   urnext
 395 urword_end
 396
 397
 398 urword_code "STR-TRIM-AFTER-CHAR",str_trim_after_char
 399 ;; ( addr count char -- addr count )
 400 ;; `count` will be 0 if there is no char
 401 ;; `count` will not include a colon
 402 ;; `addr` is not changed in any case
 403   ; i can do it faster, but meh...
 404   ld    eax,TOS
 405   pop   TOS
 406   ld    edi,[esp]
 407   jecxz .notfound
 408   test  TOS,0x80000000
 409   jr    nz,.notfound
 410   xor   edx,edx
 411 .scanloop:
 412   cp    byte [edi],al
 413   jr    z,.done
 414   inc   edi
 415   inc   edx
 416   loop  .scanloop
 417 .notfound:
 418   xor   TOS,TOS
 419   urnext
 420 .done:
 421   inc   edx
 422   ld    TOS,edx
 423   urnext
 424 urword_end
 425
 426
 427 urword_forth "STR-SKIP-AFTER-LAST-CHAR",str_skip_after_last_char
 428 ;; ( addr count char -- addr count )
 429 ;; `count` will be 0 if there is no char (and `addr` will be unchanged)
 430 ;; `addr` will not include char
 431   UF rpush 2dup rpop str_trim_after_last_char
 432   UF nip dup rpush
 433   UF - swap rpop + swap
 434 urword_end
 435
 436 urword_forth "STR-SKIP-AFTER-CHAR",str_skip_after_char
 437 ;; ( addr count char -- addr count )
 438 ;; `count` will be 0 if there is no char (and `addr` will be unchanged)
 439 ;; `addr` will not include char
 440   UF rpush 2dup rpop str_trim_after_char
 441   UF nip dup rpush
 442   UF - swap rpop + swap
 443 urword_end
 444
 445
 446 urword_forth "STR-TRIM-AT-LAST-CHAR",str_trim_at_last_char
 447 ;; ( addr count char -- addr count )
 448 ;; `count` will be 0 if there is no char
 449 ;; `count` will not include char
 450 ;; `addr` is not changed in any case
 451   UF str_trim_after_last_char dup
 452   ur_if
 453     UF 1dec
 454   ur_endif
 455 urword_end
 456
 457 urword_forth "STR-TRIM-AT-CHAR",str_trim_at_char
 458 ;; ( addr count char -- addr count )
 459 ;; `count` will be 0 if there is no char
 460 ;; `count` will not include char
 461 ;; `addr` is not changed in any case
 462   UF str_trim_after_char dup
 463   ur_if
 464     UF 1dec
 465   ur_endif
 466 urword_end
 467
 468
 469 urword_forth "STR-SKIP-AT-LAST-CHAR",str_skip_at_last_char
 470 ;; ( addr count char -- addr count )
 471 ;; `count` will be 0 if there is no char (and `addr` will be unchanged)
 472 ;; `addr` will not include char
 473   UF rpush 2dup rpop str_trim_at_last_char
 474   UF nip dup rpush
 475   UF - swap rpop + swap
 476 urword_end
 477
 478 urword_forth "STR-SKIP-AT-CHAR",str_skip_at_char
 479 ;; ( addr count char -- addr count )
 480 ;; `count` will be 0 if there is no char (and `addr` will be unchanged)
 481 ;; `addr` will not include char
 482   UF rpush 2dup rpop str_trim_at_char
 483   UF nip dup rpush
 484   UF - swap rpop + swap
 485 urword_end
 486
 487
 488 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 489 urword_forth "STR-EXTRACT-PATH",str_extract_path
 490 ;; ( addr count -- addr count )
 491 ;; count can be 0 if no path there
 492 ;; trailing '/' is included
 493   UF 47 str_trim_after_last_char
 494 urword_end
 495
 496 urword_forth "STR-EXTRACT-NAME",str_extract_name
 497 ;; ( addr count -- addr count )
 498 ;; count can be 0 if no name there (and `addr` is not changed)
 499   UF 47 str_skip_after_last_char
 500 urword_end
 501
 502 urword_forth "STR-EXTRACT-EXT",str_extract_ext
 503 ;; ( addr count -- addr count )
 504 ;; count can be 0 if no extension there (and `addr` is not changed)
 505 ;; dot is included
 506   UF 2dup str_extract_name qdup
 507   ur_ifnot
 508     ;; ( addr count dummyaddr )
 509     UF 2drop 0 exit
 510   ur_endif
 511   ;; ( addr count naddr ncount )
 512   UF 46 str_skip_at_last_char qdup
 513   ur_ifnot
 514     ;; ( addr count dummyaddr )
 515     UF 2drop 0
 516   ur_else
 517     ;; ( addr count extaddr extcount )
 518     UF 2swap 2drop
 519   ur_endif
 520 urword_end
 521
 522 urword_forth "STR-EXTRACT-BASE-NAME",str_extract_base_name
 523 ;; ( addr count -- addr count )
 524 ;; count can be 0 if no base name there (and `addr` is not changed)
 525   ;; get base name
 526   UF 2dup str_extract_name qdup
 527   ur_ifnot
 528     ;; no file name, nothing to extract
 529     UF 2drop 0 exit
 530   ur_endif
 531   ;; trim at extension
 532   ;; ( addr count nameaddr namecount )
 533   UF 2dup 46 str_trim_at_last_char
 534   ;; ( addr count nameaddr namecount bnaddr bncount )
 535   UF qdup
 536   ur_ifnot
 537     ;; ( addr count nameaddr namecount dummyaddr )
 538     UF drop 2rpush 2drop 2rpop exit
 539   ur_endif
 540   ;; ( addr count nameaddr namecount bnaddr bncount )
 541   UF 2rpush 2drop 2drop 2rpop
 542 urword_end
 543
 544
 545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 546 urword_forth "C4S-ZTERM",c4s_zterm
 547 ;; ( addr -- )
 548   UF count + 0poke
 549 urword_end
 550
 551 urword_forth "C4S-COPY",c4s_copy
 552 ;; ( addrsrc addrdest -- )
 553   UF rpush dup count_only cellinc rpop swap cmove
 554 urword_end
 555
 556 urword_forth "C4S-COPY-A-C",c4s_copy_ac
 557 ;; ( addrsrc count addrdest -- )
 558   UF 2dup poke
 559   UF cellinc swap cmove
 560 urword_end
 561 urword_alias "C4S-COPY-COUNTED",c4s_copy_counted,c4s_copy_ac
 562
 563 urword_forth "C4S-CAT-A-C",c4s_cat_ac
 564 ;; ( addr count addrdest -- )
 565   UF over 0great
 566   ur_if
 567     UF dup rpush count + swap dup rpush cmove
 568     UF rpop rpop addpoke
 569   ur_else
 570     UF 2drop drop
 571   ur_endif
 572 urword_end
 573 urword_alias "C4S-CAT-COUNTED",c4s_cat_counted,c4s_cat_ac