Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ Gforth primitives |
| 2 : | |||
| 3 : | anton | 1.16 | \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. |
| 4 : | anton | 1.1 | |
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth 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 : | |||
| 22 : | \ WARNING: This file is processed by m4. Make sure your identifiers | ||
| 23 : | \ don't collide with m4's (e.g. by undefining them). | ||
| 24 : | \ | ||
| 25 : | \ | ||
| 26 : | \ | ||
| 27 : | \ This file contains primitive specifications in the following format: | ||
| 28 : | \ | ||
| 29 : | \ forth name stack effect category [pronunciation] | ||
| 30 : | \ [""glossary entry""] | ||
| 31 : | \ C code | ||
| 32 : | \ [: | ||
| 33 : | \ Forth code] | ||
| 34 : | \ | ||
| 35 : | \ prims2x is pedantic about tabs vs. blanks. The fields of the first | ||
| 36 : | \ line of a primitive are separated by tabs, the stack items in a | ||
| 37 : | \ stack effect by blanks. | ||
| 38 : | \ | ||
| 39 : | \ Both pronounciation and stack items (in the stack effect) must | ||
| 40 : | \ conform to the C name syntax or the C compiler will complain. | ||
| 41 : | \ | ||
| 42 : | \ | ||
| 43 : | \ These specifications are automatically translated into C-code for the | ||
| 44 : | \ interpreter and into some other files. I hope that your C compiler has | ||
| 45 : | \ decent optimization, otherwise the automatically generated code will | ||
| 46 : | \ be somewhat slow. The Forth version of the code is included for manual | ||
| 47 : | \ compilers, so they will need to compile only the important words. | ||
| 48 : | \ | ||
| 49 : | \ Note that stack pointer adjustment is performed according to stack | ||
| 50 : | \ effect by automatically generated code and NEXT is automatically | ||
| 51 : | \ appended to the C code. Also, you can use the names in the stack | ||
| 52 : | \ effect in the C code. Stack access is automatic. One exception: if | ||
| 53 : | \ your code does not fall through, the results are not stored into the | ||
| 54 : | \ stack. Use different names on both sides of the '--', if you change a | ||
| 55 : | \ value (some stores to the stack are optimized away). | ||
| 56 : | \ | ||
| 57 : | \ | ||
| 58 : | \ | ||
| 59 : | \ The stack variables have the following types: | ||
| 60 : | \ | ||
| 61 : | \ name matches type | ||
| 62 : | \ f.* Bool | ||
| 63 : | \ c.* Char | ||
| 64 : | \ [nw].* Cell | ||
| 65 : | \ u.* UCell | ||
| 66 : | \ d.* DCell | ||
| 67 : | \ ud.* UDCell | ||
| 68 : | \ r.* Float | ||
| 69 : | \ a_.* Cell * | ||
| 70 : | \ c_.* Char * | ||
| 71 : | \ f_.* Float * | ||
| 72 : | \ df_.* DFloat * | ||
| 73 : | \ sf_.* SFloat * | ||
| 74 : | \ xt.* XT | ||
| 75 : | \ wid.* WID | ||
| 76 : | \ f83name.* F83Name * | ||
| 77 : | \ | ||
| 78 : | \ | ||
| 79 : | \ | ||
| 80 : | \ In addition the following names can be used: | ||
| 81 : | \ ip the instruction pointer | ||
| 82 : | \ sp the data stack pointer | ||
| 83 : | \ rp the parameter stack pointer | ||
| 84 : | \ lp the locals stack pointer | ||
| 85 : | \ NEXT executes NEXT | ||
| 86 : | \ cfa | ||
| 87 : | \ NEXT1 executes NEXT1 | ||
| 88 : | \ FLAG(x) makes a Forth flag from a C flag | ||
| 89 : | \ | ||
| 90 : | \ | ||
| 91 : | \ | ||
| 92 : | \ Percentages in comments are from Koopmans book: average/maximum use | ||
| 93 : | \ (taken from four, not very representative benchmarks) | ||
| 94 : | \ | ||
| 95 : | \ | ||
| 96 : | \ | ||
| 97 : | \ To do: | ||
| 98 : | \ | ||
| 99 : | \ throw execute, cfa and NEXT1 out? | ||
| 100 : | \ macroize *ip, ip++, *ip++ (pipelining)? | ||
| 101 : | |||
| 102 : | \ these m4 macros would collide with identifiers | ||
| 103 : | undefine(`index') | ||
| 104 : | undefine(`shift') | ||
| 105 : | |||
| 106 : | noop -- gforth | ||
| 107 : | ; | ||
| 108 : | : | ||
| 109 : | ; | ||
| 110 : | |||
| 111 : | lit -- w gforth | ||
| 112 : | w = (Cell)NEXT_INST; | ||
| 113 : | INC_IP(1); | ||
| 114 : | : | ||
| 115 : | r> dup @ swap cell+ >r ; | ||
| 116 : | |||
| 117 : | execute xt -- core | ||
| 118 : | crook | 1.26 | ""Perform the semantics represented by the execution token, @var{xt}."" |
| 119 : | anton | 1.1 | ip=IP; |
| 120 : | IF_TOS(TOS = sp[0]); | ||
| 121 : | EXEC(xt); | ||
| 122 : | |||
| 123 : | perform a_addr -- gforth | ||
| 124 : | crook | 1.22 | ""Equivalent to @code{@ execute}."" |
| 125 : | anton | 1.1 | /* and pfe */ |
| 126 : | ip=IP; | ||
| 127 : | IF_TOS(TOS = sp[0]); | ||
| 128 : | EXEC(*(Xt *)a_addr); | ||
| 129 : | : | ||
| 130 : | @ execute ; | ||
| 131 : | |||
| 132 : | pazsan | 1.15 | \+glocals |
| 133 : | anton | 1.1 | |
| 134 : | branch-lp+!# -- gforth branch_lp_plus_store_number | ||
| 135 : | /* this will probably not be used */ | ||
| 136 : | branch_adjust_lp: | ||
| 137 : | lp += (Cell)(IP[1]); | ||
| 138 : | goto branch; | ||
| 139 : | |||
| 140 : | pazsan | 1.15 | \+ |
| 141 : | anton | 1.1 | |
| 142 : | branch -- gforth | ||
| 143 : | branch: | ||
| 144 : | anton | 1.23 | SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
| 145 : | anton | 1.1 | : |
| 146 : | r> dup @ + >r ; | ||
| 147 : | |||
| 148 : | \ condbranch(forthname,restline,code,forthcode) | ||
| 149 : | \ this is non-syntactical: code must open a brace that is closed by the macro | ||
| 150 : | define(condbranch, | ||
| 151 : | $1 $2 | ||
| 152 : | anton | 1.23 | $3 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
| 153 : | anton | 1.1 | NEXT; |
| 154 : | } | ||
| 155 : | else | ||
| 156 : | INC_IP(1); | ||
| 157 : | $4 | ||
| 158 : | |||
| 159 : | pazsan | 1.15 | \+glocals |
| 160 : | anton | 1.1 | |
| 161 : | $1-lp+!# $2_lp_plus_store_number | ||
| 162 : | $3 goto branch_adjust_lp; | ||
| 163 : | } | ||
| 164 : | else | ||
| 165 : | INC_IP(2); | ||
| 166 : | |||
| 167 : | pazsan | 1.15 | \+ |
| 168 : | anton | 1.1 | ) |
| 169 : | |||
| 170 : | condbranch(?branch,f -- f83 question_branch, | ||
| 171 : | if (f==0) { | ||
| 172 : | IF_TOS(TOS = sp[0]); | ||
| 173 : | jwilke | 1.5 | ,: |
| 174 : | 0= dup \ !f !f | ||
| 175 : | r> dup @ \ !f !f IP branchoffset | ||
| 176 : | rot and + \ !f IP|IP+branchoffset | ||
| 177 : | swap 0= cell and + \ IP'' | ||
| 178 : | >r ;) | ||
| 179 : | anton | 1.1 | |
| 180 : | \ we don't need an lp_plus_store version of the ?dup-stuff, because it | ||
| 181 : | \ is only used in if's (yet) | ||
| 182 : | |||
| 183 : | pazsan | 1.15 | \+xconds |
| 184 : | anton | 1.1 | |
| 185 : | ?dup-?branch f -- f new question_dupe_question_branch | ||
| 186 : | ""The run-time procedure compiled by @code{?DUP-IF}."" | ||
| 187 : | if (f==0) { | ||
| 188 : | sp++; | ||
| 189 : | IF_TOS(TOS = sp[0]); | ||
| 190 : | anton | 1.23 | SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
| 191 : | anton | 1.1 | NEXT; |
| 192 : | } | ||
| 193 : | else | ||
| 194 : | INC_IP(1); | ||
| 195 : | |||
| 196 : | ?dup-0=-?branch f -- new question_dupe_zero_equals_question_branch | ||
| 197 : | ""The run-time procedure compiled by @code{?DUP-0=-IF}."" | ||
| 198 : | /* the approach taken here of declaring the word as having the stack | ||
| 199 : | effect ( f -- ) and correcting for it in the branch-taken case costs a | ||
| 200 : | few cycles in that case, but is easy to convert to a CONDBRANCH | ||
| 201 : | invocation */ | ||
| 202 : | if (f!=0) { | ||
| 203 : | sp--; | ||
| 204 : | anton | 1.23 | SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST)); |
| 205 : | anton | 1.1 | NEXT; |
| 206 : | } | ||
| 207 : | else | ||
| 208 : | INC_IP(1); | ||
| 209 : | |||
| 210 : | pazsan | 1.15 | \+ |
| 211 : | anton | 1.1 | |
| 212 : | condbranch((next),-- cmFORTH paren_next, | ||
| 213 : | if ((*rp)--) { | ||
| 214 : | ,: | ||
| 215 : | r> r> dup 1- >r | ||
| 216 : | IF dup @ + >r ELSE cell+ >r THEN ;) | ||
| 217 : | |||
| 218 : | condbranch((loop),-- gforth paren_loop, | ||
| 219 : | Cell index = *rp+1; | ||
| 220 : | Cell limit = rp[1]; | ||
| 221 : | if (index != limit) { | ||
| 222 : | *rp = index; | ||
| 223 : | ,: | ||
| 224 : | r> r> 1+ r> 2dup = | ||
| 225 : | IF >r 1- >r cell+ >r | ||
| 226 : | ELSE >r >r dup @ + >r THEN ;) | ||
| 227 : | |||
| 228 : | condbranch((+loop),n -- gforth paren_plus_loop, | ||
| 229 : | /* !! check this thoroughly */ | ||
| 230 : | Cell index = *rp; | ||
| 231 : | /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ | ||
| 232 : | /* dependent upon two's complement arithmetic */ | ||
| 233 : | Cell olddiff = index-rp[1]; | ||
| 234 : | if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ | ||
| 235 : | || (olddiff^n)>=0 /* it is a wrap-around effect */) { | ||
| 236 : | #ifdef i386 | ||
| 237 : | *rp += n; | ||
| 238 : | #else | ||
| 239 : | *rp = index + n; | ||
| 240 : | #endif | ||
| 241 : | IF_TOS(TOS = sp[0]); | ||
| 242 : | ,: | ||
| 243 : | r> swap | ||
| 244 : | r> r> 2dup - >r | ||
| 245 : | 2 pick r@ + r@ xor 0< 0= | ||
| 246 : | 3 pick r> xor 0< 0= or | ||
| 247 : | IF >r + >r dup @ + >r | ||
| 248 : | ELSE >r >r drop cell+ >r THEN ;) | ||
| 249 : | |||
| 250 : | pazsan | 1.15 | \+xconds |
| 251 : | anton | 1.1 | |
| 252 : | condbranch((-loop),u -- gforth paren_minus_loop, | ||
| 253 : | /* !! check this thoroughly */ | ||
| 254 : | Cell index = *rp; | ||
| 255 : | UCell olddiff = index-rp[1]; | ||
| 256 : | if (olddiff>u) { | ||
| 257 : | #ifdef i386 | ||
| 258 : | *rp -= u; | ||
| 259 : | #else | ||
| 260 : | *rp = index - u; | ||
| 261 : | #endif | ||
| 262 : | IF_TOS(TOS = sp[0]); | ||
| 263 : | ,) | ||
| 264 : | |||
| 265 : | condbranch((s+loop),n -- gforth paren_symmetric_plus_loop, | ||
| 266 : | ""The run-time procedure compiled by S+LOOP. It loops until the index | ||
| 267 : | crosses the boundary between limit and limit-sign(n). I.e. a symmetric | ||
| 268 : | version of (+LOOP)."" | ||
| 269 : | /* !! check this thoroughly */ | ||
| 270 : | Cell index = *rp; | ||
| 271 : | Cell diff = index-rp[1]; | ||
| 272 : | Cell newdiff = diff+n; | ||
| 273 : | if (n<0) { | ||
| 274 : | diff = -diff; | ||
| 275 : | newdiff = -newdiff; | ||
| 276 : | } | ||
| 277 : | if (diff>=0 || newdiff<0) { | ||
| 278 : | #ifdef i386 | ||
| 279 : | *rp += n; | ||
| 280 : | #else | ||
| 281 : | *rp = index + n; | ||
| 282 : | #endif | ||
| 283 : | IF_TOS(TOS = sp[0]); | ||
| 284 : | ,) | ||
| 285 : | |||
| 286 : | pazsan | 1.15 | \+ |
| 287 : | anton | 1.1 | |
| 288 : | unloop -- core | ||
| 289 : | rp += 2; | ||
| 290 : | : | ||
| 291 : | r> rdrop rdrop >r ; | ||
| 292 : | |||
| 293 : | (for) ncount -- cmFORTH paren_for | ||
| 294 : | /* or (for) = >r -- collides with unloop! */ | ||
| 295 : | *--rp = 0; | ||
| 296 : | *--rp = ncount; | ||
| 297 : | : | ||
| 298 : | r> swap 0 >r >r >r ; | ||
| 299 : | |||
| 300 : | (do) nlimit nstart -- gforth paren_do | ||
| 301 : | /* or do it in high-level? 0.09/0.23% */ | ||
| 302 : | *--rp = nlimit; | ||
| 303 : | *--rp = nstart; | ||
| 304 : | : | ||
| 305 : | r> swap rot >r >r >r ; | ||
| 306 : | |||
| 307 : | (?do) nlimit nstart -- gforth paren_question_do | ||
| 308 : | *--rp = nlimit; | ||
| 309 : | *--rp = nstart; | ||
| 310 : | if (nstart == nlimit) { | ||
| 311 : | IF_TOS(TOS = sp[0]); | ||
| 312 : | goto branch; | ||
| 313 : | } | ||
| 314 : | else { | ||
| 315 : | INC_IP(1); | ||
| 316 : | } | ||
| 317 : | : | ||
| 318 : | 2dup = | ||
| 319 : | IF r> swap rot >r >r | ||
| 320 : | dup @ + >r | ||
| 321 : | ELSE r> swap rot >r >r | ||
| 322 : | cell+ >r | ||
| 323 : | THEN ; \ --> CORE-EXT | ||
| 324 : | |||
| 325 : | pazsan | 1.15 | \+xconds |
| 326 : | anton | 1.1 | |
| 327 : | (+do) nlimit nstart -- gforth paren_plus_do | ||
| 328 : | *--rp = nlimit; | ||
| 329 : | *--rp = nstart; | ||
| 330 : | if (nstart >= nlimit) { | ||
| 331 : | IF_TOS(TOS = sp[0]); | ||
| 332 : | goto branch; | ||
| 333 : | } | ||
| 334 : | else { | ||
| 335 : | INC_IP(1); | ||
| 336 : | } | ||
| 337 : | : | ||
| 338 : | swap 2dup | ||
| 339 : | r> swap >r swap >r | ||
| 340 : | >= | ||
| 341 : | IF | ||
| 342 : | dup @ + | ||
| 343 : | ELSE | ||
| 344 : | cell+ | ||
| 345 : | THEN >r ; | ||
| 346 : | |||
| 347 : | (u+do) ulimit ustart -- gforth paren_u_plus_do | ||
| 348 : | *--rp = ulimit; | ||
| 349 : | *--rp = ustart; | ||
| 350 : | if (ustart >= ulimit) { | ||
| 351 : | IF_TOS(TOS = sp[0]); | ||
| 352 : | goto branch; | ||
| 353 : | } | ||
| 354 : | else { | ||
| 355 : | INC_IP(1); | ||
| 356 : | } | ||
| 357 : | : | ||
| 358 : | swap 2dup | ||
| 359 : | r> swap >r swap >r | ||
| 360 : | u>= | ||
| 361 : | IF | ||
| 362 : | dup @ + | ||
| 363 : | ELSE | ||
| 364 : | cell+ | ||
| 365 : | THEN >r ; | ||
| 366 : | |||
| 367 : | (-do) nlimit nstart -- gforth paren_minus_do | ||
| 368 : | *--rp = nlimit; | ||
| 369 : | *--rp = nstart; | ||
| 370 : | if (nstart <= nlimit) { | ||
| 371 : | IF_TOS(TOS = sp[0]); | ||
| 372 : | goto branch; | ||
| 373 : | } | ||
| 374 : | else { | ||
| 375 : | INC_IP(1); | ||
| 376 : | } | ||
| 377 : | : | ||
| 378 : | swap 2dup | ||
| 379 : | r> swap >r swap >r | ||
| 380 : | <= | ||
| 381 : | IF | ||
| 382 : | dup @ + | ||
| 383 : | ELSE | ||
| 384 : | cell+ | ||
| 385 : | THEN >r ; | ||
| 386 : | |||
| 387 : | (u-do) ulimit ustart -- gforth paren_u_minus_do | ||
| 388 : | *--rp = ulimit; | ||
| 389 : | *--rp = ustart; | ||
| 390 : | if (ustart <= ulimit) { | ||
| 391 : | IF_TOS(TOS = sp[0]); | ||
| 392 : | goto branch; | ||
| 393 : | } | ||
| 394 : | else { | ||
| 395 : | INC_IP(1); | ||
| 396 : | } | ||
| 397 : | : | ||
| 398 : | swap 2dup | ||
| 399 : | r> swap >r swap >r | ||
| 400 : | u<= | ||
| 401 : | IF | ||
| 402 : | dup @ + | ||
| 403 : | ELSE | ||
| 404 : | cell+ | ||
| 405 : | THEN >r ; | ||
| 406 : | |||
| 407 : | pazsan | 1.15 | \+ |
| 408 : | anton | 1.1 | |
| 409 : | jwilke | 1.5 | \ don't make any assumptions where the return stack is!! |
| 410 : | \ implement this in machine code if it should run quickly! | ||
| 411 : | |||
| 412 : | anton | 1.1 | i -- n core |
| 413 : | n = *rp; | ||
| 414 : | : | ||
| 415 : | jwilke | 1.5 | \ rp@ cell+ @ ; |
| 416 : | r> r> tuck >r >r ; | ||
| 417 : | anton | 1.1 | |
| 418 : | i' -- w gforth i_tick | ||
| 419 : | ""loop end value"" | ||
| 420 : | w = rp[1]; | ||
| 421 : | : | ||
| 422 : | jwilke | 1.5 | \ rp@ cell+ cell+ @ ; |
| 423 : | r> r> r> dup itmp ! >r >r >r itmp @ ; | ||
| 424 : | variable itmp | ||
| 425 : | anton | 1.1 | |
| 426 : | j -- n core | ||
| 427 : | n = rp[2]; | ||
| 428 : | : | ||
| 429 : | jwilke | 1.5 | \ rp@ cell+ cell+ cell+ @ ; |
| 430 : | r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; | ||
| 431 : | [IFUNDEF] itmp variable itmp [THEN] | ||
| 432 : | anton | 1.1 | |
| 433 : | k -- n gforth | ||
| 434 : | n = rp[4]; | ||
| 435 : | : | ||
| 436 : | jwilke | 1.5 | \ rp@ [ 5 cells ] Literal + @ ; |
| 437 : | r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; | ||
| 438 : | [IFUNDEF] itmp variable itmp [THEN] | ||
| 439 : | anton | 1.1 | |
| 440 : | \ digit is high-level: 0/0% | ||
| 441 : | |||
| 442 : | move c_from c_to ucount -- core | ||
| 443 : | crook | 1.26 | "" If @var{ucount}>0, copy the contents of @var{ucount} address units |
| 444 : | at @var{c-from} to @var{c-to}. @code{move} chooses its copy direction | ||
| 445 : | to avoid problems when @var{c-from}, @var{c-to} overlap."" | ||
| 446 : | anton | 1.1 | memmove(c_to,c_from,ucount); |
| 447 : | /* make an Ifdef for bsd and others? */ | ||
| 448 : | : | ||
| 449 : | >r 2dup u< IF r> cmove> ELSE r> cmove THEN ; | ||
| 450 : | |||
| 451 : | cmove c_from c_to u -- string | ||
| 452 : | crook | 1.26 | "" If @var{u}>0, copy the contents of @var{ucount} characters from |
| 453 : | data space at @var{c-from} to @var{c-to}. The copy proceeds @code{char}-by-@code{char} | ||
| 454 : | crook | 1.22 | from low address to high address."" |
| 455 : | anton | 1.1 | while (u-- > 0) |
| 456 : | *c_to++ = *c_from++; | ||
| 457 : | : | ||
| 458 : | bounds ?DO dup c@ I c! 1+ LOOP drop ; | ||
| 459 : | |||
| 460 : | cmove> c_from c_to u -- string c_move_up | ||
| 461 : | crook | 1.26 | "" If @var{u}>0, copy the contents of @var{ucount} characters from |
| 462 : | data space at @var{c-from} to @var{c-to}. The copy proceeds @code{char}-by-@code{char} | ||
| 463 : | crook | 1.22 | from high address to low address."" |
| 464 : | anton | 1.1 | while (u-- > 0) |
| 465 : | c_to[u] = c_from[u]; | ||
| 466 : | : | ||
| 467 : | dup 0= IF drop 2drop exit THEN | ||
| 468 : | rot over + -rot bounds swap 1- | ||
| 469 : | DO 1- dup c@ I c! -1 +LOOP drop ; | ||
| 470 : | |||
| 471 : | fill c_addr u c -- core | ||
| 472 : | crook | 1.26 | "" If @var{u}>0, store character @var{c} in each of @var{u} consecutive |
| 473 : | @code{char} addresses in memory, starting at address @var{c-addr}."" | ||
| 474 : | anton | 1.1 | memset(c_addr,c,u); |
| 475 : | : | ||
| 476 : | -rot bounds | ||
| 477 : | ?DO dup I c! LOOP drop ; | ||
| 478 : | |||
| 479 : | compare c_addr1 u1 c_addr2 u2 -- n string | ||
| 480 : | crook | 1.26 | ""Compare two strings lexicographically. If they are equal, @var{n} is 0; if |
| 481 : | the first string is smaller, @var{n} is -1; if the first string is larger, @var{n} | ||
| 482 : | anton | 1.1 | is 1. Currently this is based on the machine's character |
| 483 : | crook | 1.26 | comparison. In the future, this may change to consider the current |
| 484 : | anton | 1.1 | locale and its collation order."" |
| 485 : | n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); | ||
| 486 : | if (n==0) | ||
| 487 : | n = u1-u2; | ||
| 488 : | if (n<0) | ||
| 489 : | n = -1; | ||
| 490 : | else if (n>0) | ||
| 491 : | n = 1; | ||
| 492 : | : | ||
| 493 : | rot 2dup - >r min swap -text dup | ||
| 494 : | IF rdrop | ||
| 495 : | ELSE drop r@ 0> | ||
| 496 : | IF rdrop -1 | ||
| 497 : | ELSE r> 1 and | ||
| 498 : | THEN | ||
| 499 : | THEN ; | ||
| 500 : | |||
| 501 : | -text c_addr1 u c_addr2 -- n new dash_text | ||
| 502 : | n = memcmp(c_addr1, c_addr2, u); | ||
| 503 : | if (n<0) | ||
| 504 : | n = -1; | ||
| 505 : | else if (n>0) | ||
| 506 : | n = 1; | ||
| 507 : | : | ||
| 508 : | swap bounds | ||
| 509 : | ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 | ||
| 510 : | ELSE c@ I c@ - unloop THEN -text-flag ; | ||
| 511 : | : -text-flag ( n -- -1/0/1 ) | ||
| 512 : | dup 0< IF drop -1 ELSE 0> 1 and THEN ; | ||
| 513 : | |||
| 514 : | toupper c1 -- c2 gforth | ||
| 515 : | anton | 1.25 | ""If @var{c1} is a lower-case character (in the current locale), @var{c2} |
| 516 : | is the equivalent upper-case character. All other characters are unchanged."" | ||
| 517 : | anton | 1.1 | c2 = toupper(c1); |
| 518 : | : | ||
| 519 : | dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; | ||
| 520 : | |||
| 521 : | capscomp c_addr1 u c_addr2 -- n new | ||
| 522 : | n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */ | ||
| 523 : | if (n<0) | ||
| 524 : | n = -1; | ||
| 525 : | else if (n>0) | ||
| 526 : | n = 1; | ||
| 527 : | : | ||
| 528 : | swap bounds | ||
| 529 : | ?DO dup c@ I c@ <> | ||
| 530 : | IF dup c@ toupper I c@ toupper = | ||
| 531 : | ELSE true THEN WHILE 1+ LOOP drop 0 | ||
| 532 : | ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ; | ||
| 533 : | |||
| 534 : | -trailing c_addr u1 -- c_addr u2 string dash_trailing | ||
| 535 : | crook | 1.27 | ""Adjust the string specified by @var{c-addr, u1} to remove all trailing |
| 536 : | spaces. @var{u2} is the length of the modified string."" | ||
| 537 : | anton | 1.1 | u2 = u1; |
| 538 : | anton | 1.4 | while (u2>0 && c_addr[u2-1] == ' ') |
| 539 : | anton | 1.1 | u2--; |
| 540 : | : | ||
| 541 : | BEGIN 1- 2dup + c@ bl = WHILE | ||
| 542 : | dup 0= UNTIL ELSE 1+ THEN ; | ||
| 543 : | |||
| 544 : | /string c_addr1 u1 n -- c_addr2 u2 string slash_string | ||
| 545 : | crook | 1.27 | ""Adjust the string specified by @var{c-addr1, u1} to remove @var{n} |
| 546 : | characters from the start of the string."" | ||
| 547 : | anton | 1.1 | c_addr2 = c_addr1+n; |
| 548 : | u2 = u1-n; | ||
| 549 : | : | ||
| 550 : | tuck - >r + r> dup 0< IF - 0 THEN ; | ||
| 551 : | |||
| 552 : | + n1 n2 -- n core plus | ||
| 553 : | n = n1+n2; | ||
| 554 : | |||
| 555 : | \ PFE-0.9.14 has it differently, but the next release will have it as follows | ||
| 556 : | under+ n1 n2 n3 -- n n2 gforth under_plus | ||
| 557 : | ""add @var{n3} to @var{n1} (giving @var{n})"" | ||
| 558 : | n = n1+n3; | ||
| 559 : | : | ||
| 560 : | rot + swap ; | ||
| 561 : | |||
| 562 : | - n1 n2 -- n core minus | ||
| 563 : | n = n1-n2; | ||
| 564 : | : | ||
| 565 : | negate + ; | ||
| 566 : | |||
| 567 : | negate n1 -- n2 core | ||
| 568 : | /* use minus as alias */ | ||
| 569 : | n2 = -n1; | ||
| 570 : | : | ||
| 571 : | invert 1+ ; | ||
| 572 : | |||
| 573 : | 1+ n1 -- n2 core one_plus | ||
| 574 : | n2 = n1+1; | ||
| 575 : | : | ||
| 576 : | 1 + ; | ||
| 577 : | |||
| 578 : | 1- n1 -- n2 core one_minus | ||
| 579 : | n2 = n1-1; | ||
| 580 : | : | ||
| 581 : | 1 - ; | ||
| 582 : | |||
| 583 : | max n1 n2 -- n core | ||
| 584 : | if (n1<n2) | ||
| 585 : | n = n2; | ||
| 586 : | else | ||
| 587 : | n = n1; | ||
| 588 : | : | ||
| 589 : | 2dup < IF swap THEN drop ; | ||
| 590 : | |||
| 591 : | min n1 n2 -- n core | ||
| 592 : | if (n1<n2) | ||
| 593 : | n = n1; | ||
| 594 : | else | ||
| 595 : | n = n2; | ||
| 596 : | : | ||
| 597 : | 2dup > IF swap THEN drop ; | ||
| 598 : | |||
| 599 : | abs n1 -- n2 core | ||
| 600 : | if (n1<0) | ||
| 601 : | n2 = -n1; | ||
| 602 : | else | ||
| 603 : | n2 = n1; | ||
| 604 : | : | ||
| 605 : | dup 0< IF negate THEN ; | ||
| 606 : | |||
| 607 : | * n1 n2 -- n core star | ||
| 608 : | n = n1*n2; | ||
| 609 : | : | ||
| 610 : | um* drop ; | ||
| 611 : | |||
| 612 : | / n1 n2 -- n core slash | ||
| 613 : | n = n1/n2; | ||
| 614 : | : | ||
| 615 : | /mod nip ; | ||
| 616 : | |||
| 617 : | mod n1 n2 -- n core | ||
| 618 : | n = n1%n2; | ||
| 619 : | : | ||
| 620 : | /mod drop ; | ||
| 621 : | |||
| 622 : | /mod n1 n2 -- n3 n4 core slash_mod | ||
| 623 : | n4 = n1/n2; | ||
| 624 : | n3 = n1%n2; /* !! is this correct? look into C standard! */ | ||
| 625 : | : | ||
| 626 : | >r s>d r> fm/mod ; | ||
| 627 : | |||
| 628 : | 2* n1 -- n2 core two_star | ||
| 629 : | n2 = 2*n1; | ||
| 630 : | : | ||
| 631 : | dup + ; | ||
| 632 : | |||
| 633 : | 2/ n1 -- n2 core two_slash | ||
| 634 : | /* !! is this still correct? */ | ||
| 635 : | n2 = n1>>1; | ||
| 636 : | : | ||
| 637 : | dup MINI and IF 1 ELSE 0 THEN | ||
| 638 : | [ bits/byte cell * 1- ] literal | ||
| 639 : | jwilke | 1.5 | 0 DO 2* swap dup 2* >r MINI and |
| 640 : | anton | 1.1 | IF 1 ELSE 0 THEN or r> swap |
| 641 : | LOOP nip ; | ||
| 642 : | |||
| 643 : | fm/mod d1 n1 -- n2 n3 core f_m_slash_mod | ||
| 644 : | crook | 1.26 | ""Floored division: @var{d1} = @var{n3}*@var{n1}+@var{n2}, @var{n1}>@var{n2}>=0 or 0>=@var{n2}>@var{n1}."" |
| 645 : | anton | 1.1 | #ifdef BUGGY_LONG_LONG |
| 646 : | DCell r = fmdiv(d1,n1); | ||
| 647 : | n2=r.hi; | ||
| 648 : | n3=r.lo; | ||
| 649 : | #else | ||
| 650 : | /* assumes that the processor uses either floored or symmetric division */ | ||
| 651 : | n3 = d1/n1; | ||
| 652 : | n2 = d1%n1; | ||
| 653 : | /* note that this 1%-3>0 is optimized by the compiler */ | ||
| 654 : | if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) { | ||
| 655 : | n3--; | ||
| 656 : | n2+=n1; | ||
| 657 : | } | ||
| 658 : | #endif | ||
| 659 : | : | ||
| 660 : | dup >r dup 0< IF negate >r dnegate r> THEN | ||
| 661 : | over 0< IF tuck + swap THEN | ||
| 662 : | um/mod | ||
| 663 : | r> 0< IF swap negate swap THEN ; | ||
| 664 : | |||
| 665 : | sm/rem d1 n1 -- n2 n3 core s_m_slash_rem | ||
| 666 : | crook | 1.26 | ""Symmetric division: @var{d1} = @var{n3}*@var{n1}+@var{n2}, sign(@var{n2})=sign(@var{d1}) or 0."" |
| 667 : | anton | 1.1 | #ifdef BUGGY_LONG_LONG |
| 668 : | DCell r = smdiv(d1,n1); | ||
| 669 : | n2=r.hi; | ||
| 670 : | n3=r.lo; | ||
| 671 : | #else | ||
| 672 : | /* assumes that the processor uses either floored or symmetric division */ | ||
| 673 : | n3 = d1/n1; | ||
| 674 : | n2 = d1%n1; | ||
| 675 : | /* note that this 1%-3<0 is optimized by the compiler */ | ||
| 676 : | if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) { | ||
| 677 : | n3++; | ||
| 678 : | n2-=n1; | ||
| 679 : | } | ||
| 680 : | #endif | ||
| 681 : | : | ||
| 682 : | over >r dup >r abs -rot | ||
| 683 : | dabs rot um/mod | ||
| 684 : | r> r@ xor 0< IF negate THEN | ||
| 685 : | r> 0< IF swap negate swap THEN ; | ||
| 686 : | |||
| 687 : | m* n1 n2 -- d core m_star | ||
| 688 : | #ifdef BUGGY_LONG_LONG | ||
| 689 : | d = mmul(n1,n2); | ||
| 690 : | #else | ||
| 691 : | d = (DCell)n1 * (DCell)n2; | ||
| 692 : | #endif | ||
| 693 : | : | ||
| 694 : | 2dup 0< and >r | ||
| 695 : | 2dup swap 0< and >r | ||
| 696 : | um* r> - r> - ; | ||
| 697 : | |||
| 698 : | um* u1 u2 -- ud core u_m_star | ||
| 699 : | /* use u* as alias */ | ||
| 700 : | #ifdef BUGGY_LONG_LONG | ||
| 701 : | ud = ummul(u1,u2); | ||
| 702 : | #else | ||
| 703 : | ud = (UDCell)u1 * (UDCell)u2; | ||
| 704 : | #endif | ||
| 705 : | : | ||
| 706 : | >r >r 0 0 r> r> [ 8 cells ] literal 0 | ||
| 707 : | DO | ||
| 708 : | over >r dup >r 0< and d2*+ drop | ||
| 709 : | r> 2* r> swap | ||
| 710 : | LOOP 2drop ; | ||
| 711 : | : d2*+ ( ud n -- ud+n c ) | ||
| 712 : | over MINI | ||
| 713 : | and >r >r 2dup d+ swap r> + swap r> ; | ||
| 714 : | |||
| 715 : | um/mod ud u1 -- u2 u3 core u_m_slash_mod | ||
| 716 : | #ifdef BUGGY_LONG_LONG | ||
| 717 : | UDCell r = umdiv(ud,u1); | ||
| 718 : | u2=r.hi; | ||
| 719 : | u3=r.lo; | ||
| 720 : | #else | ||
| 721 : | u3 = ud/u1; | ||
| 722 : | u2 = ud%u1; | ||
| 723 : | #endif | ||
| 724 : | : | ||
| 725 : | 0 swap [ 8 cells 1 + ] literal 0 | ||
| 726 : | jwilke | 1.5 | ?DO /modstep |
| 727 : | anton | 1.1 | LOOP drop swap 1 rshift or swap ; |
| 728 : | : /modstep ( ud c R: u -- ud-?u c R: u ) | ||
| 729 : | jwilke | 1.5 | >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ; |
| 730 : | anton | 1.1 | : d2*+ ( ud n -- ud+n c ) |
| 731 : | over MINI | ||
| 732 : | and >r >r 2dup d+ swap r> + swap r> ; | ||
| 733 : | |||
| 734 : | m+ d1 n -- d2 double m_plus | ||
| 735 : | #ifdef BUGGY_LONG_LONG | ||
| 736 : | d2.lo = d1.lo+n; | ||
| 737 : | d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo); | ||
| 738 : | #else | ||
| 739 : | d2 = d1+n; | ||
| 740 : | #endif | ||
| 741 : | : | ||
| 742 : | s>d d+ ; | ||
| 743 : | |||
| 744 : | d+ d1 d2 -- d double d_plus | ||
| 745 : | #ifdef BUGGY_LONG_LONG | ||
| 746 : | d.lo = d1.lo+d2.lo; | ||
| 747 : | d.hi = d1.hi + d2.hi + (d.lo<d1.lo); | ||
| 748 : | #else | ||
| 749 : | d = d1+d2; | ||
| 750 : | #endif | ||
| 751 : | : | ||
| 752 : | rot + >r tuck + swap over u> r> swap - ; | ||
| 753 : | |||
| 754 : | d- d1 d2 -- d double d_minus | ||
| 755 : | #ifdef BUGGY_LONG_LONG | ||
| 756 : | d.lo = d1.lo - d2.lo; | ||
| 757 : | d.hi = d1.hi-d2.hi-(d1.lo<d2.lo); | ||
| 758 : | #else | ||
| 759 : | d = d1-d2; | ||
| 760 : | #endif | ||
| 761 : | : | ||
| 762 : | dnegate d+ ; | ||
| 763 : | |||
| 764 : | dnegate d1 -- d2 double | ||
| 765 : | /* use dminus as alias */ | ||
| 766 : | #ifdef BUGGY_LONG_LONG | ||
| 767 : | d2 = dnegate(d1); | ||
| 768 : | #else | ||
| 769 : | d2 = -d1; | ||
| 770 : | #endif | ||
| 771 : | : | ||
| 772 : | invert swap negate tuck 0= - ; | ||
| 773 : | |||
| 774 : | d2* d1 -- d2 double d_two_star | ||
| 775 : | #ifdef BUGGY_LONG_LONG | ||
| 776 : | d2.lo = d1.lo<<1; | ||
| 777 : | d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1)); | ||
| 778 : | #else | ||
| 779 : | d2 = 2*d1; | ||
| 780 : | #endif | ||
| 781 : | : | ||
| 782 : | 2dup d+ ; | ||
| 783 : | |||
| 784 : | d2/ d1 -- d2 double d_two_slash | ||
| 785 : | #ifdef BUGGY_LONG_LONG | ||
| 786 : | d2.hi = d1.hi>>1; | ||
| 787 : | d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1)); | ||
| 788 : | #else | ||
| 789 : | d2 = d1>>1; | ||
| 790 : | #endif | ||
| 791 : | : | ||
| 792 : | dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and | ||
| 793 : | r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ; | ||
| 794 : | |||
| 795 : | and w1 w2 -- w core | ||
| 796 : | w = w1&w2; | ||
| 797 : | |||
| 798 : | or w1 w2 -- w core | ||
| 799 : | w = w1|w2; | ||
| 800 : | : | ||
| 801 : | invert swap invert and invert ; | ||
| 802 : | |||
| 803 : | xor w1 w2 -- w core | ||
| 804 : | w = w1^w2; | ||
| 805 : | |||
| 806 : | invert w1 -- w2 core | ||
| 807 : | w2 = ~w1; | ||
| 808 : | : | ||
| 809 : | MAXU xor ; | ||
| 810 : | |||
| 811 : | rshift u1 n -- u2 core | ||
| 812 : | u2 = u1>>n; | ||
| 813 : | : | ||
| 814 : | 0 ?DO 2/ MAXI and LOOP ; | ||
| 815 : | |||
| 816 : | lshift u1 n -- u2 core | ||
| 817 : | u2 = u1<<n; | ||
| 818 : | : | ||
| 819 : | 0 ?DO 2* LOOP ; | ||
| 820 : | |||
| 821 : | \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) | ||
| 822 : | define(comparisons, | ||
| 823 : | $1= $2 -- f $6 $3equals | ||
| 824 : | f = FLAG($4==$5); | ||
| 825 : | : | ||
| 826 : | [ char $1x char 0 = [IF] | ||
| 827 : | ] IF false ELSE true THEN [ | ||
| 828 : | [ELSE] | ||
| 829 : | ] xor 0= [ | ||
| 830 : | [THEN] ] ; | ||
| 831 : | |||
| 832 : | $1<> $2 -- f $7 $3different | ||
| 833 : | f = FLAG($4!=$5); | ||
| 834 : | : | ||
| 835 : | [ char $1x char 0 = [IF] | ||
| 836 : | ] IF true ELSE false THEN [ | ||
| 837 : | [ELSE] | ||
| 838 : | ] xor 0<> [ | ||
| 839 : | [THEN] ] ; | ||
| 840 : | |||
| 841 : | $1< $2 -- f $8 $3less | ||
| 842 : | f = FLAG($4<$5); | ||
| 843 : | : | ||
| 844 : | [ char $1x char 0 = [IF] | ||
| 845 : | ] MINI and 0<> [ | ||
| 846 : | [ELSE] char $1x char u = [IF] | ||
| 847 : | ] 2dup xor 0< IF nip ELSE - THEN 0< [ | ||
| 848 : | [ELSE] | ||
| 849 : | ] MINI xor >r MINI xor r> u< [ | ||
| 850 : | [THEN] | ||
| 851 : | [THEN] ] ; | ||
| 852 : | |||
| 853 : | $1> $2 -- f $9 $3greater | ||
| 854 : | f = FLAG($4>$5); | ||
| 855 : | : | ||
| 856 : | [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] | ||
| 857 : | $1< ; | ||
| 858 : | |||
| 859 : | $1<= $2 -- f gforth $3less_or_equal | ||
| 860 : | f = FLAG($4<=$5); | ||
| 861 : | : | ||
| 862 : | $1> 0= ; | ||
| 863 : | |||
| 864 : | $1>= $2 -- f gforth $3greater_or_equal | ||
| 865 : | f = FLAG($4>=$5); | ||
| 866 : | : | ||
| 867 : | [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] | ||
| 868 : | $1<= ; | ||
| 869 : | |||
| 870 : | ) | ||
| 871 : | |||
| 872 : | comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext) | ||
| 873 : | comparisons(, n1 n2, , n1, n2, core, core-ext, core, core) | ||
| 874 : | comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext) | ||
| 875 : | |||
| 876 : | \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...) | ||
| 877 : | define(dcomparisons, | ||
| 878 : | $1= $2 -- f $6 $3equals | ||
| 879 : | #ifdef BUGGY_LONG_LONG | ||
| 880 : | f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); | ||
| 881 : | #else | ||
| 882 : | f = FLAG($4==$5); | ||
| 883 : | #endif | ||
| 884 : | |||
| 885 : | $1<> $2 -- f $7 $3different | ||
| 886 : | #ifdef BUGGY_LONG_LONG | ||
| 887 : | f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); | ||
| 888 : | #else | ||
| 889 : | f = FLAG($4!=$5); | ||
| 890 : | #endif | ||
| 891 : | |||
| 892 : | $1< $2 -- f $8 $3less | ||
| 893 : | #ifdef BUGGY_LONG_LONG | ||
| 894 : | f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); | ||
| 895 : | #else | ||
| 896 : | f = FLAG($4<$5); | ||
| 897 : | #endif | ||
| 898 : | |||
| 899 : | $1> $2 -- f $9 $3greater | ||
| 900 : | #ifdef BUGGY_LONG_LONG | ||
| 901 : | f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); | ||
| 902 : | #else | ||
| 903 : | f = FLAG($4>$5); | ||
| 904 : | #endif | ||
| 905 : | |||
| 906 : | $1<= $2 -- f gforth $3less_or_equal | ||
| 907 : | #ifdef BUGGY_LONG_LONG | ||
| 908 : | f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi); | ||
| 909 : | #else | ||
| 910 : | f = FLAG($4<=$5); | ||
| 911 : | #endif | ||
| 912 : | |||
| 913 : | $1>= $2 -- f gforth $3greater_or_equal | ||
| 914 : | #ifdef BUGGY_LONG_LONG | ||
| 915 : | f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi); | ||
| 916 : | #else | ||
| 917 : | f = FLAG($4>=$5); | ||
| 918 : | #endif | ||
| 919 : | |||
| 920 : | ) | ||
| 921 : | |||
| 922 : | pazsan | 1.15 | \+dcomps |
| 923 : | anton | 1.1 | |
| 924 : | dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth) | ||
| 925 : | dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth) | ||
| 926 : | dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth) | ||
| 927 : | |||
| 928 : | pazsan | 1.15 | \+ |
| 929 : | anton | 1.1 | |
| 930 : | within u1 u2 u3 -- f core-ext | ||
| 931 : | f = FLAG(u1-u2 < u3-u2); | ||
| 932 : | : | ||
| 933 : | over - >r - r> u< ; | ||
| 934 : | |||
| 935 : | crook | 1.26 | sp@ -- a_addr gforth sp_fetch |
| 936 : | anton | 1.1 | a_addr = sp+1; |
| 937 : | |||
| 938 : | crook | 1.26 | sp! a_addr -- gforth sp_store |
| 939 : | anton | 1.1 | sp = a_addr; |
| 940 : | /* works with and without TOS caching */ | ||
| 941 : | |||
| 942 : | crook | 1.26 | rp@ -- a_addr gforth rp_fetch |
| 943 : | anton | 1.1 | a_addr = rp; |
| 944 : | |||
| 945 : | crook | 1.26 | rp! a_addr -- gforth rp_store |
| 946 : | anton | 1.1 | rp = a_addr; |
| 947 : | |||
| 948 : | pazsan | 1.15 | \+floating |
| 949 : | anton | 1.1 | |
| 950 : | fp@ -- f_addr gforth fp_fetch | ||
| 951 : | f_addr = fp; | ||
| 952 : | |||
| 953 : | fp! f_addr -- gforth fp_store | ||
| 954 : | fp = f_addr; | ||
| 955 : | |||
| 956 : | pazsan | 1.15 | \+ |
| 957 : | anton | 1.1 | |
| 958 : | ;s -- gforth semis | ||
| 959 : | crook | 1.22 | ""The primitive compiled by @code{EXIT}."" |
| 960 : | anton | 1.23 | SET_IP((Xt *)(*rp++)); |
| 961 : | anton | 1.1 | |
| 962 : | >r w -- core to_r | ||
| 963 : | *--rp = w; | ||
| 964 : | : | ||
| 965 : | (>r) ; | ||
| 966 : | : (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ; | ||
| 967 : | |||
| 968 : | r> -- w core r_from | ||
| 969 : | w = *rp++; | ||
| 970 : | : | ||
| 971 : | rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ; | ||
| 972 : | Create (rdrop) ' ;s A, | ||
| 973 : | |||
| 974 : | rdrop -- gforth | ||
| 975 : | rp++; | ||
| 976 : | : | ||
| 977 : | r> r> drop >r ; | ||
| 978 : | |||
| 979 : | 2>r w1 w2 -- core-ext two_to_r | ||
| 980 : | *--rp = w1; | ||
| 981 : | *--rp = w2; | ||
| 982 : | : | ||
| 983 : | swap r> swap >r swap >r >r ; | ||
| 984 : | |||
| 985 : | 2r> -- w1 w2 core-ext two_r_from | ||
| 986 : | w2 = *rp++; | ||
| 987 : | w1 = *rp++; | ||
| 988 : | : | ||
| 989 : | r> r> swap r> swap >r swap ; | ||
| 990 : | |||
| 991 : | 2r@ -- w1 w2 core-ext two_r_fetch | ||
| 992 : | w2 = rp[0]; | ||
| 993 : | w1 = rp[1]; | ||
| 994 : | : | ||
| 995 : | i' j ; | ||
| 996 : | |||
| 997 : | 2rdrop -- gforth two_r_drop | ||
| 998 : | rp+=2; | ||
| 999 : | : | ||
| 1000 : | r> r> drop r> drop >r ; | ||
| 1001 : | |||
| 1002 : | over w1 w2 -- w1 w2 w1 core | ||
| 1003 : | : | ||
| 1004 : | sp@ cell+ @ ; | ||
| 1005 : | |||
| 1006 : | drop w -- core | ||
| 1007 : | : | ||
| 1008 : | IF THEN ; | ||
| 1009 : | |||
| 1010 : | swap w1 w2 -- w2 w1 core | ||
| 1011 : | : | ||
| 1012 : | >r (swap) ! r> (swap) @ ; | ||
| 1013 : | Variable (swap) | ||
| 1014 : | |||
| 1015 : | dup w -- w w core | ||
| 1016 : | : | ||
| 1017 : | sp@ @ ; | ||
| 1018 : | |||
| 1019 : | rot w1 w2 w3 -- w2 w3 w1 core rote | ||
| 1020 : | : | ||
| 1021 : | [ defined? (swap) [IF] ] | ||
| 1022 : | (swap) ! (rot) ! >r (rot) @ (swap) @ r> ; | ||
| 1023 : | Variable (rot) | ||
| 1024 : | [ELSE] ] | ||
| 1025 : | >r swap r> swap ; | ||
| 1026 : | [THEN] | ||
| 1027 : | |||
| 1028 : | -rot w1 w2 w3 -- w3 w1 w2 gforth not_rote | ||
| 1029 : | : | ||
| 1030 : | rot rot ; | ||
| 1031 : | |||
| 1032 : | nip w1 w2 -- w2 core-ext | ||
| 1033 : | : | ||
| 1034 : | jwilke | 1.6 | swap drop ; |
| 1035 : | anton | 1.1 | |
| 1036 : | tuck w1 w2 -- w2 w1 w2 core-ext | ||
| 1037 : | : | ||
| 1038 : | swap over ; | ||
| 1039 : | |||
| 1040 : | ?dup w -- w core question_dupe | ||
| 1041 : | if (w!=0) { | ||
| 1042 : | IF_TOS(*sp-- = w;) | ||
| 1043 : | #ifndef USE_TOS | ||
| 1044 : | *--sp = w; | ||
| 1045 : | #endif | ||
| 1046 : | } | ||
| 1047 : | : | ||
| 1048 : | dup IF dup THEN ; | ||
| 1049 : | |||
| 1050 : | pick u -- w core-ext | ||
| 1051 : | w = sp[u+1]; | ||
| 1052 : | : | ||
| 1053 : | 1+ cells sp@ + @ ; | ||
| 1054 : | |||
| 1055 : | 2drop w1 w2 -- core two_drop | ||
| 1056 : | : | ||
| 1057 : | drop drop ; | ||
| 1058 : | |||
| 1059 : | 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe | ||
| 1060 : | : | ||
| 1061 : | over over ; | ||
| 1062 : | |||
| 1063 : | 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over | ||
| 1064 : | : | ||
| 1065 : | 3 pick 3 pick ; | ||
| 1066 : | |||
| 1067 : | 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap | ||
| 1068 : | : | ||
| 1069 : | rot >r rot r> ; | ||
| 1070 : | |||
| 1071 : | 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double-ext two_rote | ||
| 1072 : | : | ||
| 1073 : | >r >r 2swap r> r> 2swap ; | ||
| 1074 : | |||
| 1075 : | 2nip w1 w2 w3 w4 -- w3 w4 gforth two_nip | ||
| 1076 : | : | ||
| 1077 : | 2swap 2drop ; | ||
| 1078 : | |||
| 1079 : | 2tuck w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 gforth two_tuck | ||
| 1080 : | : | ||
| 1081 : | 2swap 2over ; | ||
| 1082 : | |||
| 1083 : | \ toggle is high-level: 0.11/0.42% | ||
| 1084 : | |||
| 1085 : | @ a_addr -- w core fetch | ||
| 1086 : | w = *a_addr; | ||
| 1087 : | |||
| 1088 : | ! w a_addr -- core store | ||
| 1089 : | *a_addr = w; | ||
| 1090 : | |||
| 1091 : | +! n a_addr -- core plus_store | ||
| 1092 : | *a_addr += n; | ||
| 1093 : | : | ||
| 1094 : | tuck @ + swap ! ; | ||
| 1095 : | |||
| 1096 : | crook | 1.26 | c@ c_addr -- c core c_fetch |
| 1097 : | anton | 1.1 | c = *c_addr; |
| 1098 : | : | ||
| 1099 : | [ bigendian [IF] ] | ||
| 1100 : | [ cell>bit 4 = [IF] ] | ||
| 1101 : | dup [ 0 cell - ] Literal and @ swap 1 and | ||
| 1102 : | IF $FF and ELSE 8>> THEN ; | ||
| 1103 : | [ [ELSE] ] | ||
| 1104 : | dup [ cell 1- ] literal and | ||
| 1105 : | tuck - @ swap [ cell 1- ] literal xor | ||
| 1106 : | 0 ?DO 8>> LOOP $FF and | ||
| 1107 : | [ [THEN] ] | ||
| 1108 : | [ [ELSE] ] | ||
| 1109 : | [ cell>bit 4 = [IF] ] | ||
| 1110 : | dup [ 0 cell - ] Literal and @ swap 1 and | ||
| 1111 : | IF 8>> ELSE $FF and THEN | ||
| 1112 : | [ [ELSE] ] | ||
| 1113 : | dup [ cell 1- ] literal and | ||
| 1114 : | tuck - @ swap | ||
| 1115 : | 0 ?DO 8>> LOOP 255 and | ||
| 1116 : | [ [THEN] ] | ||
| 1117 : | [ [THEN] ] | ||
| 1118 : | ; | ||
| 1119 : | : 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; | ||
| 1120 : | |||
| 1121 : | crook | 1.26 | c! c c_addr -- core c_store |
| 1122 : | anton | 1.1 | *c_addr = c; |
| 1123 : | : | ||
| 1124 : | [ bigendian [IF] ] | ||
| 1125 : | [ cell>bit 4 = [IF] ] | ||
| 1126 : | tuck 1 and IF $FF and ELSE 8<< THEN >r | ||
| 1127 : | dup -2 and @ over 1 and cells masks + @ and | ||
| 1128 : | r> or swap -2 and ! ; | ||
| 1129 : | Create masks $00FF , $FF00 , | ||
| 1130 : | [ELSE] ] | ||
| 1131 : | dup [ cell 1- ] literal and dup | ||
| 1132 : | [ cell 1- ] literal xor >r | ||
| 1133 : | - dup @ $FF r@ 0 ?DO 8<< LOOP invert and | ||
| 1134 : | rot $FF and r> 0 ?DO 8<< LOOP or swap ! ; | ||
| 1135 : | [THEN] | ||
| 1136 : | [ELSE] ] | ||
| 1137 : | [ cell>bit 4 = [IF] ] | ||
| 1138 : | tuck 1 and IF 8<< ELSE $FF and THEN >r | ||
| 1139 : | dup -2 and @ over 1 and cells masks + @ and | ||
| 1140 : | r> or swap -2 and ! ; | ||
| 1141 : | Create masks $FF00 , $00FF , | ||
| 1142 : | [ELSE] ] | ||
| 1143 : | dup [ cell 1- ] literal and dup >r | ||
| 1144 : | - dup @ $FF r@ 0 ?DO 8<< LOOP invert and | ||
| 1145 : | rot $FF and r> 0 ?DO 8<< LOOP or swap ! ; | ||
| 1146 : | [THEN] | ||
| 1147 : | [THEN] | ||
| 1148 : | : 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; | ||
| 1149 : | |||
| 1150 : | 2! w1 w2 a_addr -- core two_store | ||
| 1151 : | a_addr[0] = w2; | ||
| 1152 : | a_addr[1] = w1; | ||
| 1153 : | : | ||
| 1154 : | tuck ! cell+ ! ; | ||
| 1155 : | |||
| 1156 : | 2@ a_addr -- w1 w2 core two_fetch | ||
| 1157 : | w2 = a_addr[0]; | ||
| 1158 : | w1 = a_addr[1]; | ||
| 1159 : | : | ||
| 1160 : | dup cell+ @ swap @ ; | ||
| 1161 : | |||
| 1162 : | cell+ a_addr1 -- a_addr2 core cell_plus | ||
| 1163 : | a_addr2 = a_addr1+1; | ||
| 1164 : | : | ||
| 1165 : | cell + ; | ||
| 1166 : | |||
| 1167 : | cells n1 -- n2 core | ||
| 1168 : | n2 = n1 * sizeof(Cell); | ||
| 1169 : | : | ||
| 1170 : | [ cell | ||
| 1171 : | 2/ dup [IF] ] 2* [ [THEN] | ||
| 1172 : | 2/ dup [IF] ] 2* [ [THEN] | ||
| 1173 : | 2/ dup [IF] ] 2* [ [THEN] | ||
| 1174 : | 2/ dup [IF] ] 2* [ [THEN] | ||
| 1175 : | drop ] ; | ||
| 1176 : | |||
| 1177 : | char+ c_addr1 -- c_addr2 core care_plus | ||
| 1178 : | c_addr2 = c_addr1 + 1; | ||
| 1179 : | : | ||
| 1180 : | 1+ ; | ||
| 1181 : | |||
| 1182 : | (chars) n1 -- n2 gforth paren_cares | ||
| 1183 : | n2 = n1 * sizeof(Char); | ||
| 1184 : | : | ||
| 1185 : | ; | ||
| 1186 : | |||
| 1187 : | count c_addr1 -- c_addr2 u core | ||
| 1188 : | crook | 1.26 | "" If @var{c-add1} is the address of a counted string return the length of |
| 1189 : | the string, @var{u}, and the address of its first character, @var{c-addr2}."" | ||
| 1190 : | anton | 1.1 | u = *c_addr1; |
| 1191 : | c_addr2 = c_addr1+1; | ||
| 1192 : | : | ||
| 1193 : | dup 1+ swap c@ ; | ||
| 1194 : | |||
| 1195 : | (f83find) c_addr u f83name1 -- f83name2 new paren_f83find | ||
| 1196 : | pazsan | 1.13 | for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) |
| 1197 : | anton | 1.1 | if ((UCell)F83NAME_COUNT(f83name1)==u && |
| 1198 : | memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) | ||
| 1199 : | break; | ||
| 1200 : | f83name2=f83name1; | ||
| 1201 : | : | ||
| 1202 : | BEGIN dup WHILE (find-samelen) dup WHILE | ||
| 1203 : | >r 2dup r@ cell+ char+ capscomp 0= | ||
| 1204 : | IF 2drop r> EXIT THEN | ||
| 1205 : | r> @ | ||
| 1206 : | REPEAT THEN nip nip ; | ||
| 1207 : | : (find-samelen) ( u f83name1 -- u f83name2/0 ) | ||
| 1208 : | BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; | ||
| 1209 : | |||
| 1210 : | pazsan | 1.15 | \+hash |
| 1211 : | anton | 1.1 | |
| 1212 : | (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind | ||
| 1213 : | pazsan | 1.13 | struct F83Name *f83name1; |
| 1214 : | anton | 1.1 | f83name2=NULL; |
| 1215 : | while(a_addr != NULL) | ||
| 1216 : | { | ||
| 1217 : | pazsan | 1.13 | f83name1=(struct F83Name *)(a_addr[1]); |
| 1218 : | anton | 1.1 | a_addr=(Cell *)(a_addr[0]); |
| 1219 : | if ((UCell)F83NAME_COUNT(f83name1)==u && | ||
| 1220 : | memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) | ||
| 1221 : | { | ||
| 1222 : | f83name2=f83name1; | ||
| 1223 : | break; | ||
| 1224 : | } | ||
| 1225 : | } | ||
| 1226 : | : | ||
| 1227 : | BEGIN dup WHILE | ||
| 1228 : | 2@ >r >r dup r@ cell+ c@ $1F and = | ||
| 1229 : | IF 2dup r@ cell+ char+ capscomp 0= | ||
| 1230 : | IF 2drop r> rdrop EXIT THEN THEN | ||
| 1231 : | rdrop r> | ||
| 1232 : | REPEAT nip nip ; | ||
| 1233 : | |||
| 1234 : | (tablefind) c_addr u a_addr -- f83name2 new paren_tablefind | ||
| 1235 : | ""A case-sensitive variant of @code{(hashfind)}"" | ||
| 1236 : | pazsan | 1.13 | struct F83Name *f83name1; |
| 1237 : | anton | 1.1 | f83name2=NULL; |
| 1238 : | while(a_addr != NULL) | ||
| 1239 : | { | ||
| 1240 : | pazsan | 1.13 | f83name1=(struct F83Name *)(a_addr[1]); |
| 1241 : | anton | 1.1 | a_addr=(Cell *)(a_addr[0]); |
| 1242 : | if ((UCell)F83NAME_COUNT(f83name1)==u && | ||
| 1243 : | memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */) | ||
| 1244 : | { | ||
| 1245 : | f83name2=f83name1; | ||
| 1246 : | break; | ||
| 1247 : | } | ||
| 1248 : | } | ||
| 1249 : | : | ||
| 1250 : | BEGIN dup WHILE | ||
| 1251 : | 2@ >r >r dup r@ cell+ c@ $1F and = | ||
| 1252 : | IF 2dup r@ cell+ char+ -text 0= | ||
| 1253 : | IF 2drop r> rdrop EXIT THEN THEN | ||
| 1254 : | rdrop r> | ||
| 1255 : | REPEAT nip nip ; | ||
| 1256 : | |||
| 1257 : | (hashkey) c_addr u1 -- u2 gforth paren_hashkey | ||
| 1258 : | u2=0; | ||
| 1259 : | while(u1--) | ||
| 1260 : | u2+=(Cell)toupper(*c_addr++); | ||
| 1261 : | : | ||
| 1262 : | 0 -rot bounds ?DO I c@ toupper + LOOP ; | ||
| 1263 : | |||
| 1264 : | (hashkey1) c_addr u ubits -- ukey gforth paren_hashkey1 | ||
| 1265 : | ""ukey is the hash key for the string c_addr u fitting in ubits bits"" | ||
| 1266 : | /* this hash function rotates the key at every step by rot bits within | ||
| 1267 : | ubits bits and xors it with the character. This function does ok in | ||
| 1268 : | the chi-sqare-test. Rot should be <=7 (preferably <=5) for | ||
| 1269 : | ASCII strings (larger if ubits is large), and should share no | ||
| 1270 : | divisors with ubits. | ||
| 1271 : | */ | ||
| 1272 : | unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits]; | ||
| 1273 : | Char *cp = c_addr; | ||
| 1274 : | for (ukey=0; cp<c_addr+u; cp++) | ||
| 1275 : | ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) | ||
| 1276 : | ^ toupper(*cp)) | ||
| 1277 : | & ((1<<ubits)-1)); | ||
| 1278 : | : | ||
| 1279 : | dup rot-values + c@ over 1 swap lshift 1- >r | ||
| 1280 : | tuck - 2swap r> 0 2swap bounds | ||
| 1281 : | ?DO dup 4 pick lshift swap 3 pick rshift or | ||
| 1282 : | I c@ toupper xor | ||
| 1283 : | over and LOOP | ||
| 1284 : | nip nip nip ; | ||
| 1285 : | Create rot-values | ||
| 1286 : | 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c, | ||
| 1287 : | 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c, | ||
| 1288 : | 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, | ||
| 1289 : | 7 c, 5 c, 5 c, | ||
| 1290 : | |||
| 1291 : | pazsan | 1.15 | \+ |
| 1292 : | anton | 1.1 | |
| 1293 : | (parse-white) c_addr1 u1 -- c_addr2 u2 gforth paren_parse_white | ||
| 1294 : | /* use !isgraph instead of isspace? */ | ||
| 1295 : | Char *endp = c_addr1+u1; | ||
| 1296 : | while (c_addr1<endp && isspace(*c_addr1)) | ||
| 1297 : | c_addr1++; | ||
| 1298 : | if (c_addr1<endp) { | ||
| 1299 : | for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++) | ||
| 1300 : | ; | ||
| 1301 : | u2 = c_addr1-c_addr2; | ||
| 1302 : | } | ||
| 1303 : | else { | ||
| 1304 : | c_addr2 = c_addr1; | ||
| 1305 : | u2 = 0; | ||
| 1306 : | } | ||
| 1307 : | : | ||
| 1308 : | BEGIN dup WHILE over c@ bl <= WHILE 1 /string | ||
| 1309 : | REPEAT THEN 2dup | ||
| 1310 : | BEGIN dup WHILE over c@ bl > WHILE 1 /string | ||
| 1311 : | REPEAT THEN nip - ; | ||
| 1312 : | |||
| 1313 : | aligned c_addr -- a_addr core | ||
| 1314 : | a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); | ||
| 1315 : | : | ||
| 1316 : | [ cell 1- ] Literal + [ -1 cells ] Literal and ; | ||
| 1317 : | |||
| 1318 : | faligned c_addr -- f_addr float f_aligned | ||
| 1319 : | f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); | ||
| 1320 : | : | ||
| 1321 : | [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; | ||
| 1322 : | |||
| 1323 : | >body xt -- a_addr core to_body | ||
| 1324 : | a_addr = PFA(xt); | ||
| 1325 : | : | ||
| 1326 : | 2 cells + ; | ||
| 1327 : | |||
| 1328 : | jwilke | 1.28 | \+standardthreading |
| 1329 : | |||
| 1330 : | anton | 1.1 | >code-address xt -- c_addr gforth to_code_address |
| 1331 : | crook | 1.26 | ""@var{c-addr} is the code address of the word @var{xt}."" |
| 1332 : | anton | 1.1 | /* !! This behaves installation-dependently for DOES-words */ |
| 1333 : | c_addr = (Address)CODE_ADDRESS(xt); | ||
| 1334 : | : | ||
| 1335 : | @ ; | ||
| 1336 : | |||
| 1337 : | >does-code xt -- a_addr gforth to_does_code | ||
| 1338 : | crook | 1.26 | ""If @var{xt} is the execution token of a defining-word-defined word, |
| 1339 : | @var{a-addr} is the start of the Forth code after the @code{DOES>}; | ||
| 1340 : | Otherwise @var{a-addr} is 0."" | ||
| 1341 : | anton | 1.1 | a_addr = (Cell *)DOES_CODE(xt); |
| 1342 : | : | ||
| 1343 : | cell+ @ ; | ||
| 1344 : | |||
| 1345 : | code-address! c_addr xt -- gforth code_address_store | ||
| 1346 : | crook | 1.26 | ""Create a code field with code address @var{c-addr} at @var{xt}."" |
| 1347 : | anton | 1.1 | MAKE_CF(xt, c_addr); |
| 1348 : | anton | 1.10 | CACHE_FLUSH(xt,(size_t)PFA(0)); |
| 1349 : | anton | 1.1 | : |
| 1350 : | ! ; | ||
| 1351 : | |||
| 1352 : | does-code! a_addr xt -- gforth does_code_store | ||
| 1353 : | crook | 1.26 | ""Create a code field at @var{xt} for a defining-word-defined word; @var{a-addr} |
| 1354 : | is the start of the Forth code after @code{DOES>}."" | ||
| 1355 : | anton | 1.1 | MAKE_DOES_CF(xt, a_addr); |
| 1356 : | anton | 1.10 | CACHE_FLUSH(xt,(size_t)PFA(0)); |
| 1357 : | anton | 1.1 | : |
| 1358 : | dodoes: over ! cell+ ! ; | ||
| 1359 : | |||
| 1360 : | does-handler! a_addr -- gforth does_handler_store | ||
| 1361 : | crook | 1.26 | ""Create a @code{DOES>}-handler at address @var{a-addr}. Usually, @var{a-addr} points |
| 1362 : | just behind a @code{DOES>}."" | ||
| 1363 : | anton | 1.1 | MAKE_DOES_HANDLER(a_addr); |
| 1364 : | anton | 1.10 | CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); |
| 1365 : | anton | 1.1 | : |
| 1366 : | drop ; | ||
| 1367 : | |||
| 1368 : | /does-handler -- n gforth slash_does_handler | ||
| 1369 : | crook | 1.26 | ""The size of a @code{DOES>}-handler (includes possible padding)."" |
| 1370 : | anton | 1.1 | /* !! a constant or environmental query might be better */ |
| 1371 : | n = DOES_HANDLER_SIZE; | ||
| 1372 : | : | ||
| 1373 : | 2 cells ; | ||
| 1374 : | |||
| 1375 : | threading-method -- n gforth threading_method | ||
| 1376 : | ""0 if the engine is direct threaded. Note that this may change during | ||
| 1377 : | the lifetime of an image."" | ||
| 1378 : | #if defined(DOUBLY_INDIRECT) | ||
| 1379 : | n=2; | ||
| 1380 : | #else | ||
| 1381 : | # if defined(DIRECT_THREADED) | ||
| 1382 : | n=0; | ||
| 1383 : | # else | ||
| 1384 : | n=1; | ||
| 1385 : | # endif | ||
| 1386 : | #endif | ||
| 1387 : | : | ||
| 1388 : | 1 ; | ||
| 1389 : | jwilke | 1.28 | |
| 1390 : | \+ | ||
| 1391 : | anton | 1.1 | |
| 1392 : | pazsan | 1.12 | key-file wfileid -- n gforth paren_key_file |
| 1393 : | pazsan | 1.17 | #ifdef HAS_FILE |
| 1394 : | anton | 1.1 | fflush(stdout); |
| 1395 : | pazsan | 1.12 | n = key((FILE*)wfileid); |
| 1396 : | pazsan | 1.17 | #else |
| 1397 : | n = key(stdin); | ||
| 1398 : | #endif | ||
| 1399 : | anton | 1.1 | |
| 1400 : | pazsan | 1.12 | key?-file wfileid -- n facility key_q_file |
| 1401 : | pazsan | 1.17 | #ifdef HAS_FILE |
| 1402 : | anton | 1.1 | fflush(stdout); |
| 1403 : | pazsan | 1.12 | n = key_query((FILE*)wfileid); |
| 1404 : | pazsan | 1.17 | #else |
| 1405 : | n = key_query(stdin); | ||
| 1406 : | #endif | ||
| 1407 : | |||
| 1408 : | \+os | ||
| 1409 : | pazsan | 1.12 | |
| 1410 : | stdin -- wfileid gforth | ||
| 1411 : | wfileid = (Cell)stdin; | ||
| 1412 : | anton | 1.1 | |
| 1413 : | stdout -- wfileid gforth | ||
| 1414 : | wfileid = (Cell)stdout; | ||
| 1415 : | |||
| 1416 : | stderr -- wfileid gforth | ||
| 1417 : | wfileid = (Cell)stderr; | ||
| 1418 : | |||
| 1419 : | form -- urows ucols gforth | ||
| 1420 : | ""The number of lines and columns in the terminal. These numbers may change | ||
| 1421 : | with the window size."" | ||
| 1422 : | /* we could block SIGWINCH here to get a consistent size, but I don't | ||
| 1423 : | think this is necessary or always beneficial */ | ||
| 1424 : | urows=rows; | ||
| 1425 : | ucols=cols; | ||
| 1426 : | |||
| 1427 : | flush-icache c_addr u -- gforth flush_icache | ||
| 1428 : | ""Make sure that the instruction cache of the processor (if there is | ||
| 1429 : | crook | 1.26 | one) does not contain stale data at @var{c-addr} and @var{u} bytes |
| 1430 : | anton | 1.1 | afterwards. @code{END-CODE} performs a @code{flush-icache} |
| 1431 : | automatically. Caveat: @code{flush-icache} might not work on your | ||
| 1432 : | installation; this is usually the case if direct threading is not | ||
| 1433 : | supported on your machine (take a look at your @file{machine.h}) and | ||
| 1434 : | your machine has a separate instruction cache. In such cases, | ||
| 1435 : | @code{flush-icache} does nothing instead of flushing the instruction | ||
| 1436 : | cache."" | ||
| 1437 : | FLUSH_ICACHE(c_addr,u); | ||
| 1438 : | |||
| 1439 : | (bye) n -- gforth paren_bye | ||
| 1440 : | return (Label *)n; | ||
| 1441 : | |||
| 1442 : | (system) c_addr u -- wretval wior gforth peren_system | ||
| 1443 : | pazsan | 1.20 | #ifndef MSDOS |
| 1444 : | anton | 1.1 | int old_tp=terminal_prepped; |
| 1445 : | deprep_terminal(); | ||
| 1446 : | pazsan | 1.20 | #endif |
| 1447 : | anton | 1.1 | wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ |
| 1448 : | wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); | ||
| 1449 : | pazsan | 1.20 | #ifndef MSDOS |
| 1450 : | anton | 1.1 | if (old_tp) |
| 1451 : | prep_terminal(); | ||
| 1452 : | pazsan | 1.20 | #endif |
| 1453 : | anton | 1.1 | |
| 1454 : | getenv c_addr1 u1 -- c_addr2 u2 gforth | ||
| 1455 : | crook | 1.26 | ""The string @var{c-addr1 u1} specifies an environment variable. The string @var{c-addr2 u2} |
| 1456 : | crook | 1.24 | is the host operating system's expansion of that environment variable. If the |
| 1457 : | crook | 1.26 | environment variable does not exist, @var{c-addr2 u2} specifies a string 0 characters |
| 1458 : | crook | 1.24 | in length."" |
| 1459 : | anton | 1.1 | c_addr2 = getenv(cstr(c_addr1,u1,1)); |
| 1460 : | u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); | ||
| 1461 : | |||
| 1462 : | open-pipe c_addr u ntype -- wfileid wior gforth open_pipe | ||
| 1463 : | wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */ | ||
| 1464 : | wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ | ||
| 1465 : | |||
| 1466 : | close-pipe wfileid -- wretval wior gforth close_pipe | ||
| 1467 : | wretval = pclose((FILE *)wfileid); | ||
| 1468 : | wior = IOR(wretval==-1); | ||
| 1469 : | |||
| 1470 : | time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date | ||
| 1471 : | struct timeval time1; | ||
| 1472 : | struct timezone zone1; | ||
| 1473 : | struct tm *ltime; | ||
| 1474 : | gettimeofday(&time1,&zone1); | ||
| 1475 : | ltime=localtime((time_t *)&time1.tv_sec); | ||
| 1476 : | nyear =ltime->tm_year+1900; | ||
| 1477 : | nmonth=ltime->tm_mon+1; | ||
| 1478 : | nday =ltime->tm_mday; | ||
| 1479 : | nhour =ltime->tm_hour; | ||
| 1480 : | nmin =ltime->tm_min; | ||
| 1481 : | nsec =ltime->tm_sec; | ||
| 1482 : | |||
| 1483 : | ms n -- facility-ext | ||
| 1484 : | struct timeval timeout; | ||
| 1485 : | timeout.tv_sec=n/1000; | ||
| 1486 : | timeout.tv_usec=1000*(n%1000); | ||
| 1487 : | (void)select(0,0,0,0,&timeout); | ||
| 1488 : | |||
| 1489 : | allocate u -- a_addr wior memory | ||
| 1490 : | crook | 1.27 | ""Allocate @var{u} address units of contiguous data space. The initial |
| 1491 : | contents of the data space is undefined. If the allocation is successful, | ||
| 1492 : | @var{a-addr} is the start address of the allocated region and @var{wior} | ||
| 1493 : | is 0. If the allocation fails, @var{a-addr} is undefined and @var{wior} | ||
| 1494 : | is an implementation-defined I/O result code."" | ||
| 1495 : | anton | 1.1 | a_addr = (Cell *)malloc(u?u:1); |
| 1496 : | wior = IOR(a_addr==NULL); | ||
| 1497 : | |||
| 1498 : | free a_addr -- wior memory | ||
| 1499 : | crook | 1.27 | ""Return the region of data space starting at @var{a-addr} to the system. |
| 1500 : | The regon must originally have been obtained using @code{allocate} or | ||
| 1501 : | @code{resize}. If the operational is successful, @var{wior} is 0. | ||
| 1502 : | If the operation fails, @var{wior} is an implementation-defined | ||
| 1503 : | I/O result code."" | ||
| 1504 : | anton | 1.1 | free(a_addr); |
| 1505 : | wior = 0; | ||
| 1506 : | |||
| 1507 : | resize a_addr1 u -- a_addr2 wior memory | ||
| 1508 : | crook | 1.26 | ""Change the size of the allocated area at @i{a-addr1} to @i{u} |
| 1509 : | anton | 1.1 | address units, possibly moving the contents to a different |
| 1510 : | crook | 1.27 | area. @i{a-addr2} is the address of the resulting area. |
| 1511 : | If the operational is successful, @var{wior} is 0. | ||
| 1512 : | If the operation fails, @var{wior} is an implementation-defined | ||
| 1513 : | I/O result code. If @i{a-addr1} is 0, Gforth's (but not the standard) | ||
| 1514 : | @code{resize} @code{allocate}s @i{u} address units."" | ||
| 1515 : | anton | 1.1 | /* the following check is not necessary on most OSs, but it is needed |
| 1516 : | on SunOS 4.1.2. */ | ||
| 1517 : | if (a_addr1==NULL) | ||
| 1518 : | a_addr2 = (Cell *)malloc(u); | ||
| 1519 : | else | ||
| 1520 : | a_addr2 = (Cell *)realloc(a_addr1, u); | ||
| 1521 : | wior = IOR(a_addr2==NULL); /* !! Define a return code */ | ||
| 1522 : | |||
| 1523 : | strerror n -- c_addr u gforth | ||
| 1524 : | c_addr = strerror(n); | ||
| 1525 : | u = strlen(c_addr); | ||
| 1526 : | |||
| 1527 : | strsignal n -- c_addr u gforth | ||
| 1528 : | c_addr = strsignal(n); | ||
| 1529 : | u = strlen(c_addr); | ||
| 1530 : | |||
| 1531 : | call-c w -- gforth call_c | ||
| 1532 : | ""Call the C function pointed to by @i{w}. The C function has to | ||
| 1533 : | access the stack itself. The stack pointers are exported in the global | ||
| 1534 : | variables @code{SP} and @code{FP}."" | ||
| 1535 : | /* This is a first attempt at support for calls to C. This may change in | ||
| 1536 : | the future */ | ||
| 1537 : | IF_FTOS(fp[0]=FTOS); | ||
| 1538 : | FP=fp; | ||
| 1539 : | SP=sp; | ||
| 1540 : | ((void (*)())w)(); | ||
| 1541 : | sp=SP; | ||
| 1542 : | fp=FP; | ||
| 1543 : | IF_TOS(TOS=sp[0]); | ||
| 1544 : | IF_FTOS(FTOS=fp[0]); | ||
| 1545 : | |||
| 1546 : | pazsan | 1.15 | \+ |
| 1547 : | \+file | ||
| 1548 : | anton | 1.1 | |
| 1549 : | close-file wfileid -- wior file close_file | ||
| 1550 : | wior = IOR(fclose((FILE *)wfileid)==EOF); | ||
| 1551 : | |||
| 1552 : | crook | 1.22 | open-file c_addr u ntype -- wfileid wior file open_file |
| 1553 : | wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); | ||
| 1554 : | pazsan | 1.14 | #if defined(GO32) && defined(MSDOS) |
| 1555 : | crook | 1.22 | if(wfileid && !(ntype & 1)) |
| 1556 : | setbuf((FILE*)wfileid, NULL); | ||
| 1557 : | pazsan | 1.14 | #endif |
| 1558 : | crook | 1.22 | wior = IOR(wfileid == 0); |
| 1559 : | anton | 1.1 | |
| 1560 : | crook | 1.22 | create-file c_addr u ntype -- wfileid wior file create_file |
| 1561 : | anton | 1.1 | Cell fd; |
| 1562 : | fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666); | ||
| 1563 : | if (fd != -1) { | ||
| 1564 : | crook | 1.22 | wfileid = (Cell)fdopen(fd, fileattr[ntype]); |
| 1565 : | pazsan | 1.14 | #if defined(GO32) && defined(MSDOS) |
| 1566 : | crook | 1.22 | if(wfileid && !(ntype & 1)) |
| 1567 : | setbuf((FILE*)wfileid, NULL); | ||
| 1568 : | pazsan | 1.14 | #endif |
| 1569 : | crook | 1.22 | wior = IOR(wfileid == 0); |
| 1570 : | anton | 1.1 | } else { |
| 1571 : | crook | 1.22 | wfileid = 0; |
| 1572 : | anton | 1.1 | wior = IOR(1); |
| 1573 : | } | ||
| 1574 : | |||
| 1575 : | delete-file c_addr u -- wior file delete_file | ||
| 1576 : | wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); | ||
| 1577 : | |||
| 1578 : | rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file | ||
| 1579 : | crook | 1.26 | ""Rename file @var{c_addr1 u1} to new name @var{c_addr2 u2}"" |
| 1580 : | anton | 1.1 | char *s1=tilde_cstr(c_addr2, u2, 1); |
| 1581 : | wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); | ||
| 1582 : | |||
| 1583 : | file-position wfileid -- ud wior file file_position | ||
| 1584 : | /* !! use tell and lseek? */ | ||
| 1585 : | ud = LONG2UD(ftell((FILE *)wfileid)); | ||
| 1586 : | wior = IOR(UD2LONG(ud)==-1); | ||
| 1587 : | |||
| 1588 : | reposition-file ud wfileid -- wior file reposition_file | ||
| 1589 : | wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); | ||
| 1590 : | |||
| 1591 : | file-size wfileid -- ud wior file file_size | ||
| 1592 : | struct stat buf; | ||
| 1593 : | wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); | ||
| 1594 : | ud = LONG2UD(buf.st_size); | ||
| 1595 : | |||
| 1596 : | resize-file ud wfileid -- wior file resize_file | ||
| 1597 : | wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1); | ||
| 1598 : | |||
| 1599 : | read-file c_addr u1 wfileid -- u2 wior file read_file | ||
| 1600 : | /* !! fread does not guarantee enough */ | ||
| 1601 : | u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); | ||
| 1602 : | wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); | ||
| 1603 : | /* !! is the value of ferror errno-compatible? */ | ||
| 1604 : | if (wior) | ||
| 1605 : | clearerr((FILE *)wfileid); | ||
| 1606 : | |||
| 1607 : | read-line c_addr u1 wfileid -- u2 flag wior file read_line | ||
| 1608 : | /* | ||
| 1609 : | Cell c; | ||
| 1610 : | flag=-1; | ||
| 1611 : | for(u2=0; u2<u1; u2++) | ||
| 1612 : | { | ||
| 1613 : | *c_addr++ = (Char)(c = getc((FILE *)wfileid)); | ||
| 1614 : | if(c=='\n') break; | ||
| 1615 : | if(c==EOF) | ||
| 1616 : | { | ||
| 1617 : | flag=FLAG(u2!=0); | ||
| 1618 : | break; | ||
| 1619 : | } | ||
| 1620 : | } | ||
| 1621 : | wior=FILEIO(ferror((FILE *)wfileid)); | ||
| 1622 : | */ | ||
| 1623 : | if ((flag=FLAG(!feof((FILE *)wfileid) && | ||
| 1624 : | fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { | ||
| 1625 : | wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */ | ||
| 1626 : | if (wior) | ||
| 1627 : | clearerr((FILE *)wfileid); | ||
| 1628 : | u2 = strlen(c_addr); | ||
| 1629 : | u2-=((u2>0) && (c_addr[u2-1]==NEWLINE)); | ||
| 1630 : | } | ||
| 1631 : | else { | ||
| 1632 : | wior=0; | ||
| 1633 : | u2=0; | ||
| 1634 : | } | ||
| 1635 : | |||
| 1636 : | pazsan | 1.15 | \+ |
| 1637 : | \+file | ||
| 1638 : | anton | 1.1 | |
| 1639 : | write-file c_addr u1 wfileid -- wior file write_file | ||
| 1640 : | /* !! fwrite does not guarantee enough */ | ||
| 1641 : | { | ||
| 1642 : | UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); | ||
| 1643 : | wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); | ||
| 1644 : | if (wior) | ||
| 1645 : | clearerr((FILE *)wfileid); | ||
| 1646 : | } | ||
| 1647 : | |||
| 1648 : | pazsan | 1.17 | \+ |
| 1649 : | |||
| 1650 : | anton | 1.1 | emit-file c wfileid -- wior gforth emit_file |
| 1651 : | pazsan | 1.17 | #ifdef HAS_FILE |
| 1652 : | anton | 1.1 | wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); |
| 1653 : | if (wior) | ||
| 1654 : | clearerr((FILE *)wfileid); | ||
| 1655 : | pazsan | 1.17 | #else |
| 1656 : | putc(c, stdout); | ||
| 1657 : | #endif | ||
| 1658 : | anton | 1.1 | |
| 1659 : | pazsan | 1.15 | \+file |
| 1660 : | anton | 1.1 | |
| 1661 : | flush-file wfileid -- wior file-ext flush_file | ||
| 1662 : | wior = IOR(fflush((FILE *) wfileid)==EOF); | ||
| 1663 : | |||
| 1664 : | file-status c_addr u -- ntype wior file-ext file_status | ||
| 1665 : | char *filename=tilde_cstr(c_addr, u, 1); | ||
| 1666 : | if (access (filename, F_OK) != 0) { | ||
| 1667 : | ntype=0; | ||
| 1668 : | wior=IOR(1); | ||
| 1669 : | } | ||
| 1670 : | else if (access (filename, R_OK | W_OK) == 0) { | ||
| 1671 : | ntype=2; /* r/w */ | ||
| 1672 : | wior=0; | ||
| 1673 : | } | ||
| 1674 : | else if (access (filename, R_OK) == 0) { | ||
| 1675 : | ntype=0; /* r/o */ | ||
| 1676 : | wior=0; | ||
| 1677 : | } | ||
| 1678 : | else if (access (filename, W_OK) == 0) { | ||
| 1679 : | ntype=4; /* w/o */ | ||
| 1680 : | wior=0; | ||
| 1681 : | } | ||
| 1682 : | else { | ||
| 1683 : | ntype=1; /* well, we cannot access the file, but better deliver a legal | ||
| 1684 : | access mode (r/o bin), so we get a decent error later upon open. */ | ||
| 1685 : | wior=0; | ||
| 1686 : | } | ||
| 1687 : | |||
| 1688 : | pazsan | 1.15 | \+ |
| 1689 : | \+floating | ||
| 1690 : | anton | 1.1 | |
| 1691 : | comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) | ||
| 1692 : | comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) | ||
| 1693 : | |||
| 1694 : | d>f d -- r float d_to_f | ||
| 1695 : | #ifdef BUGGY_LONG_LONG | ||
| 1696 : | extern double ldexp(double x, int exp); | ||
| 1697 : | r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo; | ||
| 1698 : | #else | ||
| 1699 : | r = d; | ||
| 1700 : | #endif | ||
| 1701 : | |||
| 1702 : | f>d r -- d float f_to_d | ||
| 1703 : | #ifdef BUGGY_LONG_LONG | ||
| 1704 : | anton | 1.21 | d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0); |
| 1705 : | anton | 1.1 | d.lo = r-ldexp((Float)d.hi,CELL_BITS); |
| 1706 : | #else | ||
| 1707 : | d = r; | ||
| 1708 : | #endif | ||
| 1709 : | |||
| 1710 : | f! r f_addr -- float f_store | ||
| 1711 : | *f_addr = r; | ||
| 1712 : | |||
| 1713 : | f@ f_addr -- r float f_fetch | ||
| 1714 : | r = *f_addr; | ||
| 1715 : | |||
| 1716 : | df@ df_addr -- r float-ext d_f_fetch | ||
| 1717 : | #ifdef IEEE_FP | ||
| 1718 : | r = *df_addr; | ||
| 1719 : | #else | ||
| 1720 : | !! df@ | ||
| 1721 : | #endif | ||
| 1722 : | |||
| 1723 : | df! r df_addr -- float-ext d_f_store | ||
| 1724 : | #ifdef IEEE_FP | ||
| 1725 : | *df_addr = r; | ||
| 1726 : | #else | ||
| 1727 : | !! df! | ||
| 1728 : | #endif | ||
| 1729 : | |||
| 1730 : | sf@ sf_addr -- r float-ext s_f_fetch | ||
| 1731 : | #ifdef IEEE_FP | ||
| 1732 : | r = *sf_addr; | ||
| 1733 : | #else | ||
| 1734 : | !! sf@ | ||
| 1735 : | #endif | ||
| 1736 : | |||
| 1737 : | sf! r sf_addr -- float-ext s_f_store | ||
| 1738 : | #ifdef IEEE_FP | ||
| 1739 : | *sf_addr = r; | ||
| 1740 : | #else | ||
| 1741 : | !! sf! | ||
| 1742 : | #endif | ||
| 1743 : | |||
| 1744 : | f+ r1 r2 -- r3 float f_plus | ||
| 1745 : | r3 = r1+r2; | ||
| 1746 : | |||
| 1747 : | f- r1 r2 -- r3 float f_minus | ||
| 1748 : | r3 = r1-r2; | ||
| 1749 : | |||
| 1750 : | f* r1 r2 -- r3 float f_star | ||
| 1751 : | r3 = r1*r2; | ||
| 1752 : | |||
| 1753 : | f/ r1 r2 -- r3 float f_slash | ||
| 1754 : | r3 = r1/r2; | ||
| 1755 : | |||
| 1756 : | f** r1 r2 -- r3 float-ext f_star_star | ||
| 1757 : | crook | 1.26 | ""@i{r3} is @i{r1} raised to the @i{r2}th power."" |
| 1758 : | anton | 1.1 | r3 = pow(r1,r2); |
| 1759 : | |||
| 1760 : | fnegate r1 -- r2 float | ||
| 1761 : | r2 = - r1; | ||
| 1762 : | |||
| 1763 : | fdrop r -- float | ||
| 1764 : | |||
| 1765 : | fdup r -- r r float | ||
| 1766 : | |||
| 1767 : | fswap r1 r2 -- r2 r1 float | ||
| 1768 : | |||
| 1769 : | fover r1 r2 -- r1 r2 r1 float | ||
| 1770 : | |||
| 1771 : | frot r1 r2 r3 -- r2 r3 r1 float | ||
| 1772 : | |||
| 1773 : | fnip r1 r2 -- r2 gforth | ||
| 1774 : | |||
| 1775 : | ftuck r1 r2 -- r2 r1 r2 gforth | ||
| 1776 : | |||
| 1777 : | float+ f_addr1 -- f_addr2 float float_plus | ||
| 1778 : | f_addr2 = f_addr1+1; | ||
| 1779 : | |||
| 1780 : | floats n1 -- n2 float | ||
| 1781 : | n2 = n1*sizeof(Float); | ||
| 1782 : | |||
| 1783 : | floor r1 -- r2 float | ||
| 1784 : | crook | 1.26 | ""Round towards the next smaller integral value, i.e., round toward negative infinity."" |
| 1785 : | anton | 1.1 | /* !! unclear wording */ |
| 1786 : | r2 = floor(r1); | ||
| 1787 : | |||
| 1788 : | fround r1 -- r2 float | ||
| 1789 : | crook | 1.26 | ""Round to the nearest integral value."" |
| 1790 : | anton | 1.1 | /* !! unclear wording */ |
| 1791 : | #ifdef HAVE_RINT | ||
| 1792 : | r2 = rint(r1); | ||
| 1793 : | #else | ||
| 1794 : | r2 = floor(r1+0.5); | ||
| 1795 : | /* !! This is not quite true to the rounding rules given in the standard */ | ||
| 1796 : | #endif | ||
| 1797 : | |||
| 1798 : | fmax r1 r2 -- r3 float | ||
| 1799 : | if (r1<r2) | ||
| 1800 : | r3 = r2; | ||
| 1801 : | else | ||
| 1802 : | r3 = r1; | ||
| 1803 : | |||
| 1804 : | fmin r1 r2 -- r3 float | ||
| 1805 : | if (r1<r2) | ||
| 1806 : | r3 = r1; | ||
| 1807 : | else | ||
| 1808 : | r3 = r2; | ||
| 1809 : | |||
| 1810 : | represent r c_addr u -- n f1 f2 float | ||
| 1811 : | char *sig; | ||
| 1812 : | int flag; | ||
| 1813 : | int decpt; | ||
| 1814 : | sig=ecvt(r, u, &decpt, &flag); | ||
| 1815 : | n=(r==0 ? 1 : decpt); | ||
| 1816 : | f1=FLAG(flag!=0); | ||
| 1817 : | anton | 1.21 | f2=FLAG(isdigit((unsigned)(sig[0]))!=0); |
| 1818 : | anton | 1.1 | memmove(c_addr,sig,u); |
| 1819 : | |||
| 1820 : | >float c_addr u -- flag float to_float | ||
| 1821 : | crook | 1.27 | ""Attempt to convert the character string @var{c-addr u} to |
| 1822 : | internal floating-point representation. If the string | ||
| 1823 : | represents a valid floating-point number @var{r} is placed | ||
| 1824 : | on the floating-point stack and @var{flag} is true. Otherwise, | ||
| 1825 : | @var{flag} is false. A string of blanks is a special case | ||
| 1826 : | and represents the flotaing-point number 0."" | ||
| 1827 : | anton | 1.1 | /* real signature: c_addr u -- r t / f */ |
| 1828 : | Float r; | ||
| 1829 : | char *number=cstr(c_addr, u, 1); | ||
| 1830 : | char *endconv; | ||
| 1831 : | anton | 1.21 | while(isspace((unsigned)(number[--u])) && u>0); |
| 1832 : | anton | 1.1 | switch(number[u]) |
| 1833 : | { | ||
| 1834 : | case 'd': | ||
| 1835 : | case 'D': | ||
| 1836 : | case 'e': | ||
| 1837 : | case 'E': break; | ||
| 1838 : | default : u++; break; | ||
| 1839 : | } | ||
| 1840 : | number[u]='\0'; | ||
| 1841 : | r=strtod(number,&endconv); | ||
| 1842 : | if((flag=FLAG(!(Cell)*endconv))) | ||
| 1843 : | { | ||
| 1844 : | IF_FTOS(fp[0] = FTOS); | ||
| 1845 : | fp += -1; | ||
| 1846 : | FTOS = r; | ||
| 1847 : | } | ||
| 1848 : | else if(*endconv=='d' || *endconv=='D') | ||
| 1849 : | { | ||
| 1850 : | *endconv='E'; | ||
| 1851 : | r=strtod(number,&endconv); | ||
| 1852 : | if((flag=FLAG(!(Cell)*endconv))) | ||
| 1853 : | { | ||
| 1854 : | IF_FTOS(fp[0] = FTOS); | ||
| 1855 : | fp += -1; | ||
| 1856 : | FTOS = r; | ||
| 1857 : | } | ||
| 1858 : | } | ||
| 1859 : | |||
| 1860 : | fabs r1 -- r2 float-ext | ||
| 1861 : | r2 = fabs(r1); | ||
| 1862 : | |||
| 1863 : | facos r1 -- r2 float-ext | ||
| 1864 : | r2 = acos(r1); | ||
| 1865 : | |||
| 1866 : | fasin r1 -- r2 float-ext | ||
| 1867 : | r2 = asin(r1); | ||
| 1868 : | |||
| 1869 : | fatan r1 -- r2 float-ext | ||
| 1870 : | r2 = atan(r1); | ||
| 1871 : | |||
| 1872 : | fatan2 r1 r2 -- r3 float-ext | ||
| 1873 : | crook | 1.26 | ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably |
| 1874 : | anton | 1.1 | intends this to be the inverse of @code{fsincos}. In gforth it is."" |
| 1875 : | r3 = atan2(r1,r2); | ||
| 1876 : | |||
| 1877 : | fcos r1 -- r2 float-ext | ||
| 1878 : | r2 = cos(r1); | ||
| 1879 : | |||
| 1880 : | fexp r1 -- r2 float-ext | ||
| 1881 : | r2 = exp(r1); | ||
| 1882 : | |||
| 1883 : | fexpm1 r1 -- r2 float-ext | ||
| 1884 : | ""@i{r2}=@i{e}**@i{r1}@minus{}1"" | ||
| 1885 : | #ifdef HAVE_EXPM1 | ||
| 1886 : | pazsan | 1.3 | extern double |
| 1887 : | #ifdef NeXT | ||
| 1888 : | const | ||
| 1889 : | #endif | ||
| 1890 : | expm1(double); | ||
| 1891 : | anton | 1.1 | r2 = expm1(r1); |
| 1892 : | #else | ||
| 1893 : | r2 = exp(r1)-1.; | ||
| 1894 : | #endif | ||
| 1895 : | |||
| 1896 : | fln r1 -- r2 float-ext | ||
| 1897 : | r2 = log(r1); | ||
| 1898 : | |||
| 1899 : | flnp1 r1 -- r2 float-ext | ||
| 1900 : | ""@i{r2}=ln(@i{r1}+1)"" | ||
| 1901 : | #ifdef HAVE_LOG1P | ||
| 1902 : | pazsan | 1.3 | extern double |
| 1903 : | #ifdef NeXT | ||
| 1904 : | const | ||
| 1905 : | #endif | ||
| 1906 : | log1p(double); | ||
| 1907 : | anton | 1.1 | r2 = log1p(r1); |
| 1908 : | #else | ||
| 1909 : | r2 = log(r1+1.); | ||
| 1910 : | #endif | ||
| 1911 : | |||
| 1912 : | flog r1 -- r2 float-ext | ||
| 1913 : | crook | 1.26 | ""The decimal logarithm."" |
| 1914 : | anton | 1.1 | r2 = log10(r1); |
| 1915 : | |||
| 1916 : | falog r1 -- r2 float-ext | ||
| 1917 : | ""@i{r2}=10**@i{r1}"" | ||
| 1918 : | extern double pow10(double); | ||
| 1919 : | r2 = pow10(r1); | ||
| 1920 : | |||
| 1921 : | fsin r1 -- r2 float-ext | ||
| 1922 : | r2 = sin(r1); | ||
| 1923 : | |||
| 1924 : | fsincos r1 -- r2 r3 float-ext | ||
| 1925 : | ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" | ||
| 1926 : | r2 = sin(r1); | ||
| 1927 : | r3 = cos(r1); | ||
| 1928 : | |||
| 1929 : | fsqrt r1 -- r2 float-ext | ||
| 1930 : | r2 = sqrt(r1); | ||
| 1931 : | |||
| 1932 : | ftan r1 -- r2 float-ext | ||
| 1933 : | r2 = tan(r1); | ||
| 1934 : | : | ||
| 1935 : | fsincos f/ ; | ||
| 1936 : | |||
| 1937 : | fsinh r1 -- r2 float-ext | ||
| 1938 : | r2 = sinh(r1); | ||
| 1939 : | : | ||
| 1940 : | fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; | ||
| 1941 : | |||
| 1942 : | fcosh r1 -- r2 float-ext | ||
| 1943 : | r2 = cosh(r1); | ||
| 1944 : | : | ||
| 1945 : | fexp fdup 1/f f+ f2/ ; | ||
| 1946 : | |||
| 1947 : | ftanh r1 -- r2 float-ext | ||
| 1948 : | r2 = tanh(r1); | ||
| 1949 : | : | ||
| 1950 : | f2* fexpm1 fdup 2. d>f f+ f/ ; | ||
| 1951 : | |||
| 1952 : | fasinh r1 -- r2 float-ext | ||
| 1953 : | r2 = asinh(r1); | ||
| 1954 : | : | ||
| 1955 : | fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; | ||
| 1956 : | |||
| 1957 : | facosh r1 -- r2 float-ext | ||
| 1958 : | r2 = acosh(r1); | ||
| 1959 : | : | ||
| 1960 : | fdup fdup f* 1. d>f f- fsqrt f+ fln ; | ||
| 1961 : | |||
| 1962 : | fatanh r1 -- r2 float-ext | ||
| 1963 : | r2 = atanh(r1); | ||
| 1964 : | : | ||
| 1965 : | fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ | ||
| 1966 : | r> IF fnegate THEN ; | ||
| 1967 : | |||
| 1968 : | sfloats n1 -- n2 float-ext s_floats | ||
| 1969 : | n2 = n1*sizeof(SFloat); | ||
| 1970 : | |||
| 1971 : | dfloats n1 -- n2 float-ext d_floats | ||
| 1972 : | n2 = n1*sizeof(DFloat); | ||
| 1973 : | |||
| 1974 : | sfaligned c_addr -- sf_addr float-ext s_f_aligned | ||
| 1975 : | sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); | ||
| 1976 : | : | ||
| 1977 : | [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; | ||
| 1978 : | |||
| 1979 : | dfaligned c_addr -- df_addr float-ext d_f_aligned | ||
| 1980 : | df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); | ||
| 1981 : | : | ||
| 1982 : | [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; | ||
| 1983 : | |||
| 1984 : | \ The following words access machine/OS/installation-dependent | ||
| 1985 : | \ Gforth internals | ||
| 1986 : | \ !! how about environmental queries DIRECT-THREADED, | ||
| 1987 : | \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ | ||
| 1988 : | |||
| 1989 : | \ local variable implementation primitives | ||
| 1990 : | pazsan | 1.15 | \+ |
| 1991 : | \+glocals | ||
| 1992 : | anton | 1.1 | |
| 1993 : | @local# -- w gforth fetch_local_number | ||
| 1994 : | w = *(Cell *)(lp+(Cell)NEXT_INST); | ||
| 1995 : | INC_IP(1); | ||
| 1996 : | |||
| 1997 : | @local0 -- w new fetch_local_zero | ||
| 1998 : | w = *(Cell *)(lp+0*sizeof(Cell)); | ||
| 1999 : | |||
| 2000 : | @local1 -- w new fetch_local_four | ||
| 2001 : | w = *(Cell *)(lp+1*sizeof(Cell)); | ||
| 2002 : | |||
| 2003 : | @local2 -- w new fetch_local_eight | ||
| 2004 : | w = *(Cell *)(lp+2*sizeof(Cell)); | ||
| 2005 : | |||
| 2006 : | @local3 -- w new fetch_local_twelve | ||
| 2007 : | w = *(Cell *)(lp+3*sizeof(Cell)); | ||
| 2008 : | |||
| 2009 : | pazsan | 1.15 | \+floating |
| 2010 : | anton | 1.1 | |
| 2011 : | f@local# -- r gforth f_fetch_local_number | ||
| 2012 : | r = *(Float *)(lp+(Cell)NEXT_INST); | ||
| 2013 : | INC_IP(1); | ||
| 2014 : | |||
| 2015 : | f@local0 -- r new f_fetch_local_zero | ||
| 2016 : | r = *(Float *)(lp+0*sizeof(Float)); | ||
| 2017 : | |||
| 2018 : | f@local1 -- r new f_fetch_local_eight | ||
| 2019 : | r = *(Float *)(lp+1*sizeof(Float)); | ||
| 2020 : | |||
| 2021 : | pazsan | 1.15 | \+ |
| 2022 : | anton | 1.1 | |
| 2023 : | laddr# -- c_addr gforth laddr_number | ||
| 2024 : | /* this can also be used to implement lp@ */ | ||
| 2025 : | c_addr = (Char *)(lp+(Cell)NEXT_INST); | ||
| 2026 : | INC_IP(1); | ||
| 2027 : | |||
| 2028 : | lp+!# -- gforth lp_plus_store_number | ||
| 2029 : | ""used with negative immediate values it allocates memory on the | ||
| 2030 : | local stack, a positive immediate argument drops memory from the local | ||
| 2031 : | stack"" | ||
| 2032 : | lp += (Cell)NEXT_INST; | ||
| 2033 : | INC_IP(1); | ||
| 2034 : | |||
| 2035 : | lp- -- new minus_four_lp_plus_store | ||
| 2036 : | lp += -sizeof(Cell); | ||
| 2037 : | |||
| 2038 : | lp+ -- new eight_lp_plus_store | ||
| 2039 : | lp += sizeof(Float); | ||
| 2040 : | |||
| 2041 : | lp+2 -- new sixteen_lp_plus_store | ||
| 2042 : | lp += 2*sizeof(Float); | ||
| 2043 : | |||
| 2044 : | lp! c_addr -- gforth lp_store | ||
| 2045 : | lp = (Address)c_addr; | ||
| 2046 : | |||
| 2047 : | >l w -- gforth to_l | ||
| 2048 : | lp -= sizeof(Cell); | ||
| 2049 : | *(Cell *)lp = w; | ||
| 2050 : | |||
| 2051 : | pazsan | 1.15 | \+floating |
| 2052 : | anton | 1.1 | |
| 2053 : | f>l r -- gforth f_to_l | ||
| 2054 : | lp -= sizeof(Float); | ||
| 2055 : | *(Float *)lp = r; | ||
| 2056 : | |||
| 2057 : | anton | 1.11 | fpick u -- r gforth |
| 2058 : | r = fp[u+1]; /* +1, because update of fp happens before this fragment */ | ||
| 2059 : | : | ||
| 2060 : | floats fp@ + f@ ; | ||
| 2061 : | |||
| 2062 : | pazsan | 1.15 | \+ |
| 2063 : | \+ | ||
| 2064 : | anton | 1.1 | |
| 2065 : | pazsan | 1.15 | \+OS |
| 2066 : | anton | 1.1 | |
| 2067 : | define(`uploop', | ||
| 2068 : | `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') | ||
| 2069 : | define(`_uploop', | ||
| 2070 : | `ifelse($1, `$3', `$5', | ||
| 2071 : | `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')') | ||
| 2072 : | \ argflist(argnum): Forth argument list | ||
| 2073 : | define(argflist, | ||
| 2074 : | `ifelse($1, 0, `', | ||
| 2075 : | `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')') | ||
| 2076 : | \ argdlist(argnum): declare C's arguments | ||
| 2077 : | define(argdlist, | ||
| 2078 : | `ifelse($1, 0, `', | ||
| 2079 : | `uploop(`_i', 1, $1, `Cell, ', `Cell')')') | ||
| 2080 : | \ argclist(argnum): pass C's arguments | ||
| 2081 : | define(argclist, | ||
| 2082 : | `ifelse($1, 0, `', | ||
| 2083 : | `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')') | ||
| 2084 : | \ icall(argnum) | ||
| 2085 : | define(icall, | ||
| 2086 : | `icall$1 argflist($1)u -- uret gforth | ||
| 2087 : | pazsan | 1.9 | uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1)); |
| 2088 : | anton | 1.1 | |
| 2089 : | ') | ||
| 2090 : | define(fcall, | ||
| 2091 : | `fcall$1 argflist($1)u -- rret gforth | ||
| 2092 : | pazsan | 1.9 | rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1)); |
| 2093 : | anton | 1.1 | |
| 2094 : | ') | ||
| 2095 : | |||
| 2096 : | |||
| 2097 : | open-lib c_addr1 u1 -- u2 gforth open_lib | ||
| 2098 : | #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) | ||
| 2099 : | anton | 1.8 | #ifndef RTLD_GLOBAL |
| 2100 : | #define RTLD_GLOBAL 0 | ||
| 2101 : | #endif | ||
| 2102 : | pazsan | 1.7 | u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); |
| 2103 : | anton | 1.1 | #else |
| 2104 : | pazsan | 1.18 | # ifdef _WIN32 |
| 2105 : | anton | 1.1 | u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); |
| 2106 : | # else | ||
| 2107 : | #warning Define open-lib! | ||
| 2108 : | u2 = 0; | ||
| 2109 : | # endif | ||
| 2110 : | #endif | ||
| 2111 : | |||
| 2112 : | lib-sym c_addr1 u1 u2 -- u3 gforth lib_sym | ||
| 2113 : | #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) | ||
| 2114 : | u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); | ||
| 2115 : | #else | ||
| 2116 : | pazsan | 1.18 | # ifdef _WIN32 |
| 2117 : | anton | 1.1 | u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); |
| 2118 : | # else | ||
| 2119 : | #warning Define lib-sym! | ||
| 2120 : | u3 = 0; | ||
| 2121 : | # endif | ||
| 2122 : | #endif | ||
| 2123 : | |||
| 2124 : | uploop(i, 0, 7, `icall(i)') | ||
| 2125 : | icall(20) | ||
| 2126 : | uploop(i, 0, 7, `fcall(i)') | ||
| 2127 : | fcall(20) | ||
| 2128 : | |||
| 2129 : | pazsan | 1.15 | \+ |
| 2130 : | anton | 1.1 | |
| 2131 : | up! a_addr -- gforth up_store | ||
| 2132 : | UP=up=(char *)a_addr; | ||
| 2133 : | : | ||
| 2134 : | up ! ; | ||
| 2135 : | Variable UP |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |