fth/flkkern.fs

   1 \  FLK kernel words (core word set)
   2 \
   3 \  Copyright (C) 1998 Lars Krueger
   4 \
   5 \  This file is part of FLK.
   6 \
   7 \  FLK is free software; you can redistribute it and/or
   8 \  modify it under the terms of the GNU General Public License
   9 \  as published by the Free Software Foundation; either version 2
  10 \  of the License, or (at your option) any later version.
  11 \
  12 \  This program is distributed in the hope that it will be useful,
  13 \  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 \  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 \  GNU General Public License for more details.
  16 \
  17 \  You should have received a copy of the GNU General Public License
  18 \  along with this program; if not, write to the Free Software
  19 \  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \ $Id: flkkern.fs,v 1.15 1998/09/13 15:42:04 root Exp $
  22 \ $Log: flkkern.fs,v $
  23 \ Revision 1.15  1998/09/13 15:42:04  root
  24 \ introduced separate control flow stack
  25 \
  26 \ Revision 1.14  1998/08/30 10:50:59  root
  27 \ new optimizing algorithm
  28 \
  29 \ Revision 1.13  1998/07/13 18:08:54  root
  30 \ various optimizations
  31 \
  32 \ Revision 1.12  1998/07/03 09:09:28  root
  33 \ support for level 2 optimizer
  34 \
  35 \ Revision 1.11  1998/06/01 17:51:42  root
  36 \ SEE shows the sourcefile using VIEW
  37 \
  38 \ Revision 1.10  1998/05/27 18:52:12  root
  39 \ \: commants added for SEE and HELP
  40 \
  41 \ Revision 1.9  1998/05/16 16:19:24  root
  42 \ direct terminfo access
  43 \
  44 \ Revision 1.8  1998/05/09 21:47:05  root
  45 \ moved some words to flktools.fs
  46 \
  47 \ Revision 1.7  1998/05/03 12:06:37  root
  48 \ added macro support
  49 \
  50 \ Revision 1.6  1998/05/01 18:11:25  root
  51 \ GNU license text added
  52 \ comments checked
  53 \
  54 \ Revision 1.5  1998/04/30 09:42:25  root
  55 \ Comments added.
  56 \
  57 \ Revision 1.4  1998/04/24 20:23:34  root
  58 \ cleaning up
  59 \ char>digit case insensitiv
  60 \
  61 \ Revision 1.3  1998/04/24 16:47:39  root
  62 \ bug fixes
  63 \
  64 \ Revision 1.2  1998/04/09 11:35:03  root
  65 \ FM/REM, */MOD etc. fixed
  66 \
  67 \ Revision 1.1  1998/04/07 20:10:33  root
  68 \ Initial revision
  69 \
  70
  71 \ See standard.
  72 VARIABLE >IN
  73
  74 \ See standard.
  75 VARIABLE BASE
  76
  77 \ See standard.
  78 0  VALUE HERE
  79
  80 \ HERE for code area
  81 0  VALUE CHERE
  82
  83 \ See standard.
  84 VARIABLE STATE
  85
  86 \ See standard.
  87 VARIABLE #TIB
  88
  89 \ See standard.
  90 VARIABLE SPAN
  91
  92 \ Floating point stack pointer.
  93 0  VALUE FSP
  94
  95 \ See standard.
  96 32  CONSTANT BL
  97
  98 \ See standard.
  99 0 CONSTANT FALSE
 100
 101 \ See standard.
 102 -1  CONSTANT TRUE
 103
 104 \ See standard.
 105 1 CONSTANT R/O
 106
 107 \ See standard.
 108 2 CONSTANT R/W
 109
 110 \ See standard.
 111 4 CONSTANT BIN
 112
 113 \ See standard.
 114 8 CONSTANT W/O
 115
 116 \ LEAVE handling
 117 0 VALUE last-leave
 118 \ Contains the allocator state of the current DO or ?DO.
 119 CREATE do-state 11 ALLOT
 120
 121 \ See standard.
 122 : ERASE 0 FILL ;
 123 ( OK )
 124
 125 \ See standard.
 126 : DABS
 127 ( OK )
 128   2DUP D0< IF DNEGATE THEN ;
 129
 130 \ See standard.
 131 : ?DUP
 132 ( OK )
 133   DUP IF DUP THEN ;
 134
 135 \ See standard.
 136 : HEX 16 BASE ! ;
 137 ( OK )
 138
 139 \ See standard.
 140 : DECIMAL 10 BASE ! ;
 141 ( OK )
 142
 143 \ See standard.
 144 : MOVE          ( from to len -- )
 145 ( OK )
 146   -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ;
 147
 148 \ See standard.
 149 : -TRAILING         ( c-addr u1 -- c-addr u2 )
 150 ( OK )
 151   BEGIN
 152     DUP 0<>
 153   WHILE
 154     1- 2DUP CHARS + C@
 155     BL > IF         \ c-addr u1-1
 156       1+ EXIT
 157     THEN
 158   REPEAT ;
 159
 160 \ See standard.
 161 : BLANK BL FILL ;
 162 ( OK )
 163
 164 \ See standard.
 165 : /STRING         ( a1 n1 n2 -- a2 n3 )
 166 ( OK )
 167   DUP 0> IF         \ a1 n1 n2
 168     2DUP > INVERT IF
 169       DROP DUP
 170     THEN
 171   THEN
 172   ROT           \ n1 n2 a1
 173   OVER +        \ n1 n2 a2
 174   -ROT          \ a2 n1 n2
 175   - ;
 176
 177 \ See standard.  Taken from gforth without inspection.
 178 : M*/           ( d1 n2 u3 -- dqout )
 179 ( OK )
 180   >R S>D >R ABS -ROT
 181   S>D R> XOR R> SWAP >R >R DABS ROT TUCK UM* 2SWAP UM*
 182   SWAP >R 0 D+ R> -ROT R@ UM/MOD -ROT R> UM/MOD NIP SWAP
 183   R> IF DNEGATE THEN ;
 184
 185 \ See standard. Taken from FPC with little inspection.
 186 : FM/MOD        ( d1 n1 -- n2 n3 )
 187 ( OK )
 188   DUP >R ABS        \ Save n1 and make it +ve.
 189   ROT ROT DUP >R DABS       \ Save d1 and make it +ve.
 190   ROT UM/MOD        \ -- n2 n3 )
 191   R> R@ SignsDiffer? IF     \ If the signs of d1 & n1 differ ...
 192     OVER IF         \ if the remainder n2 <> 0 ...
 193       1+        \ increment the quotient n3.
 194       R@ ABS ROT - SWAP     \ n2 = n2 - n1
 195     THEN
 196     NEGATE        \ n3 = -n3
 197   THEN
 198   R> 0< IF        \ If n1 -ve ...
 199     SWAP NEGATE SWAP      \ n2 = -n2
 200   THEN
 201 ;
 202
 203 \ See standard.
 204 : */MOD ( n1 n2 n3 -- n4 n5)  -ROT M* ROT SM/REM ;
 205 ( OK )
 206
 207 \ See standard.
 208 : */  ( n1 n2 n3 -- n4 )   */MOD SWAP DROP ;
 209 ( OK )
 210
 211 \ See standard.
 212 : /MOD ( n1 n2 -- n3 n4)  SWAP S>D ROT SM/REM ;
 213 ( OK )
 214
 215 \ See standard.
 216 : WITHIN        ( x lo hi -- flag )
 217 ( OK )
 218   2DUP < INVERT IF SWAP THEN    \ x lo hi
 219   ROT           \ lo hi x
 220   TUCK          \ lo x hi x
 221   >           \ lo x f1
 222   -ROT          \ f1 lo x
 223   > INVERT AND ;
 224
 225 \ Convert a lower case letter to upper case.
 226 : >UPPER        ( char -- char2)
 227 ( OK )
 228   DUP 97 123 WITHIN IF
 229     32 XOR
 230   THEN ;
 231
 232 \ Case insensitive compare.
 233 : CAPS-COMPARE        ( c-addr1 u1 c-addr2 u2 -- n )
 234 ( OK )
 235   ROT 2DUP MIN        \ c1 c2 u2 u1 um
 236   -ROT 2>R        \ c1 c2 um
 237   0 ?DO         \ c1 c2
 238     2DUP C@ >UPPER SWAP C@ >UPPER   \ c1 c2 ch2 ch1
 239     2DUP > IF
 240        UNLOOP 2R> 2DROP 2DROP
 241        2DROP -1 EXIT
 242     ELSE        \ c1 c2 ch2 ch1
 243        < IF
 244    UNLOOP 2R> 2DROP 2DROP 1 EXIT
 245        THEN
 246     THEN        \ c1 c2
 247     SWAP 1+ SWAP 1+
 248   LOOP          \ c1 c2
 249   2DROP 2R>         \ u2 u1
 250   2DUP > IF         \ u2 u1
 251     -1
 252   ELSE
 253     2DUP < IF
 254       1
 255     ELSE
 256       0
 257     THEN
 258   THEN          \ u2 u1 n
 259   NIP NIP ;
 260
 261 \ See standard.
 262 : COMPARE         ( c-addr1 u1 c-addr2 u2 -- n )
 263 ( OK )
 264   ROT 2DUP MIN        \ c1 c2 u2 u1 um
 265   -ROT 2>R        \ c1 c2 um
 266   0 ?DO         \ c1 c2
 267     2DUP C@ SWAP C@       \ c1 c2 ch2 ch1
 268     2DUP > IF
 269        UNLOOP 2R> 2DROP 2DROP
 270        2DROP -1 EXIT
 271     ELSE        \ c1 c2 ch2 ch1
 272        < IF
 273    UNLOOP 2R> 2DROP 2DROP 1 EXIT
 274        THEN
 275     THEN        \ c1 c2
 276     SWAP 1+ SWAP 1+
 277   LOOP          \ c1 c2
 278   2DROP 2R>         \ u2 u1
 279   2DUP > IF         \ u2 u1
 280     -1
 281   ELSE
 282     2DUP < IF
 283       1
 284     ELSE
 285       0
 286     THEN
 287   THEN          \ u2 u1 n
 288   NIP NIP ;
 289
 290 \ Multiply a double by a single returning a double. The unused third cell is
 291 \ assumed to be zero.
 292 : UMD*          ( ud1l ud1h u -- ud2 )
 293 ( OK )
 294   TUCK          \ ud1l u ud1h u
 295   UM*           \ ud1l u ud2hl ud2hh
 296   DROP          \ ud1l u ud2hl
 297   -ROT          \ ud2hl ud1l u
 298   UM*           \ ud2hl ud2lh ud2ll
 299   ROT +         \ ud2l ud2h
 300 ;
 301
 302 \ Convert a character using the given base and return a failure flag.
 303 : (char>digit)        ( char base -- digit FALSE | TRUE )
 304 ( OK )
 305   DUP 10 > IF ( hex etc . )     \ char base
 306     OVER 48 58 WITHIN IF    \ char base
 307       DROP 48 - FALSE
 308     ELSE        \ char base
 309       OVER 65 55      \ c b c 65 55
 310       FLOCK + WITHIN IF         \ c b
 311   DROP 55 - FALSE
 312       ELSE        \ char base
 313         OVER 97 87 FLOCK + WITHIN IF  \ char base
 314     DROP 87 - FALSE
 315   ELSE          \ char base
 316       2DROP TRUE
 317   THEN
 318       THEN
 319     THEN
 320   ELSE ( decimal or less )    \ char base
 321     OVER 48 DUP       \ c b c 48 48
 322     FLOCK + WITHIN IF       \ c b
 323       DROP 48 - FALSE
 324     ELSE
 325       2DROP TRUE
 326     THEN
 327   THEN ;
 328
 329 \ Convert a character with the current base.
 330 : char>digit BASE @ (char>digit) ;
 331
 332 \ See standard.
 333 : >NUMBER         ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
 334 ( OK )
 335   BEGIN         \ ud1 c1 u1
 336     DUP
 337   WHILE         \ ud1 c1 u1
 338     OVER C@         \ ud1 c1 u1 char
 339     DUP 48 >= IF
 340       char>digit ?EXIT      \ ud1 c1 u1 digit
 341       -ROT        \ ud1 digit c1 u1
 342       2>R >R        \ ud1
 343       BASE @        \ ud1 base
 344       UMD* R> M+
 345       2R> 1 /STRING
 346     ELSE
 347       DROP EXIT
 348     THEN
 349   REPEAT ;
 350
 351 \ See standard.
 352 : CONVERT
 353 ( OK )
 354   0 0 2SWAP >NUMBER DROP ;
 355
 356 \ See standard.
 357 : UNUSED        ( -- n )
 358 ( OK )
 359   HERE-LIMIT HERE - ;
 360
 361 \ Same as UNUSED but for code area.
 362 : CUNUSED         ( -- n )
 363 ( OK )
 364   CHERE-LIMIT CHERE - ;
 365
 366 #PAD-LEN CONSTANT #PAD-LEN
 367
 368 \ See standard.
 369 : PAD HERE-LIMIT #PAD-LEN - ;
 370 ( OK )
 371
 372 CREATE (SEARCH-RESET-TABLE) 256 CELLS ALLOT
 373
 374 \ Initialize the string search table from the given string.
 375 : (setup-search-table)      ( caddr u -- )
 376 ( OK )
 377   (SEARCH-RESET-TABLE) 256 CELLS -1 FILL ( fill reset table with -1 )
 378   0 DO          \ c2
 379     DUP C@        \ c2 char
 380     CELLS (SEARCH-RESET-TABLE) +  \ c2 addr
 381     DUP @ -1 = IF       \ c2 addr
 382       I SWAP !        \ c2
 383     ELSE        \ c2 addr
 384       DROP
 385     THEN        \ c2
 386     CHAR+
 387   LOOP DROP ;
 388
 389 0 VALUE (search-addr)
 390 0 VALUE (search-len)
 391
 392 \ Boyer/Moore search comparator word
 393 : (search-comp)       ( pa pl sa -- offs char FALSE / TRUE )
 394 ( OK )
 395   OVER          \ pa pl sa pl
 396   1- +          \ pa pl sae
 397   -ROT TUCK         \ sae pl pa pl
 398   1- + SWAP         \ sae pae pl
 399   BEGIN         \ sae pae pl
 400     1-
 401     -ROT 2DUP C@ SWAP C@    \ pl sae pae pc sc
 402     TUCK <> IF        \ pl sae pae sc
 403       NIP NIP FALSE EXIT
 404     THEN        \ pl sae pae sc
 405     DROP CHAR- SWAP CHAR- SWAP    \ pl sae+1 pae+1
 406     ROT
 407     DUP 0=
 408   UNTIL 2DROP DROP TRUE
 409   ;
 410
 411 \ See standard.
 412 : SEARCH        ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
 413 ( OK )
 414   PLUCK OVER OR 0=      \ c1 u1 c2 u2 empty?
 415   IF 2DROP FALSE EXIT THEN
 416   2DUP (setup-search-table)
 417   2OVER TO (search-len)
 418   TO (search-addr) 2SWAP    \ c2 u2 c1 u1
 419   BEGIN         \ c2 u2 c1 u1
 420     PLUCK OVER        \ c2 u2 c1 u1 u2 u1
 421     <
 422   WHILE         \ c2 u2 c1 u1
 423     2OVER FLOCK       \ c2 u2 c1 u1 c2 u2 c1
 424     (search-comp)       \ c2 u2 c1 u1 ( offs char FALSE / TRUE )
 425     IF          \ c2 u2 c1 u1
 426       2SWAP 2DROP TRUE EXIT
 427     THEN        \ c2 u2 c1 u1 offs char
 428     CELLS (SEARCH-RESET-TABLE) + @
 429     -
 430     /STRING
 431   REPEAT
 432   2DROP 2DROP
 433   (search-addr) (search-len) FALSE ;
 434
 435 \ Transfer n items and n itself to the return stack. An inlined version must
 436 \ not save the top of return stack.
 437 : n>R           ( ... n -- ) ( r: -- ... n )
 438 ( OK )
 439   R>          \ ... n ret
 440   OVER BEGIN        \ ... n ret cnt
 441     DUP
 442   WHILE         \ ... x n ret cnt
 443     TURN >R
 444     1-
 445   REPEAT        \ n ret 0
 446   DROP SWAP >R >R
 447   ;
 448
 449 \ Transfer n items from the return to the data stack. An inlined version must
 450 \ not save the top of return stack.
 451 : nR>           ( -- ... n ) ( r: ... n -- )
 452 ( OK )
 453   R>          \ ret
 454   R> DUP        \ ret n cnt
 455   BEGIN
 456     DUP
 457   WHILE         \ ret n cnt
 458     R> -TURN        \ x ret n cnt
 459     1-
 460   REPEAT        \ ... ret n 0
 461   DROP SWAP >R ;
 462
 463 \ The xt of the last defined word
 464 0 VALUE lastheader