Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | /* |
| 2 : | pazsan | 1.2 | $Id: primitives,v 1.19 1993/11/18 17:10:01 anton Exp pazsan $ |
| 3 : | anton | 1.1 | Copyright 1992 by the ANSI figForth Development Group |
| 4 : | |||
| 5 : | WARNING: This file is processed by m4. Make sure your identifiers | ||
| 6 : | don't collide with m4's (e.g. by undefining them). | ||
| 7 : | |||
| 8 : | This file contains instructions in the following format: | ||
| 9 : | |||
| 10 : | forth name stack effect category [pronounciation] | ||
| 11 : | [""glossary entry""] | ||
| 12 : | C code | ||
| 13 : | [: | ||
| 14 : | Forth code] | ||
| 15 : | |||
| 16 : | The pronounciataion is also used for forming C names. | ||
| 17 : | |||
| 18 : | These informations are automagically translated into C-code for the | ||
| 19 : | interpreter and into some other files. The forth name of a word is | ||
| 20 : | automatically turned into upper case. I hope that your C compiler has | ||
| 21 : | decent optimization, otherwise the automatically generated code will | ||
| 22 : | be somewhat slow. The Forth version of the code is included for manual | ||
| 23 : | compilers, so they will need to compile only the important words. | ||
| 24 : | |||
| 25 : | Note that stack pointer adjustment is performed according to stack | ||
| 26 : | effect by automatically generated code and NEXT is automatically | ||
| 27 : | appended to the C code. Also, you can use the names in the stack | ||
| 28 : | effect in the C code. Stack access is automatic. One exception: if | ||
| 29 : | your code does not fall through, the results are not stored into the | ||
| 30 : | stack. Use different names on both sides of the '--', if you change a | ||
| 31 : | value (some stores to the stack are optimized away). | ||
| 32 : | |||
| 33 : | The stack variables have the following types: | ||
| 34 : | name matches type | ||
| 35 : | f.* Bool | ||
| 36 : | c.* Char | ||
| 37 : | [nw].* Cell | ||
| 38 : | u.* UCell | ||
| 39 : | d.* DCell | ||
| 40 : | ud.* UDCell | ||
| 41 : | r.* Float | ||
| 42 : | a_.* Cell * | ||
| 43 : | c_.* Char * | ||
| 44 : | f_.* Float * | ||
| 45 : | df_.* DFloat * | ||
| 46 : | sf_.* SFloat * | ||
| 47 : | xt.* XT | ||
| 48 : | wid.* WID | ||
| 49 : | f83name.* F83Name * | ||
| 50 : | |||
| 51 : | In addition the following names can be used: | ||
| 52 : | ip the instruction pointer | ||
| 53 : | sp the data stack pointer | ||
| 54 : | rp the parameter stack pointer | ||
| 55 : | NEXT executes NEXT | ||
| 56 : | cfa | ||
| 57 : | NEXT1 executes NEXT1 | ||
| 58 : | FLAG(x) makes a Forth flag from a C flag | ||
| 59 : | |||
| 60 : | Percentages in comments are from Koopmans book: average/maximum use | ||
| 61 : | (taken from four, not very representattive benchmarks) | ||
| 62 : | |||
| 63 : | To do: | ||
| 64 : | make sensible error returns for file words | ||
| 65 : | |||
| 66 : | throw execute, cfa and NEXT1 out? | ||
| 67 : | macroize *ip, ip++, *ip++ (pipelining)? | ||
| 68 : | */ | ||
| 69 : | |||
| 70 : | /* these m4 macros would collide with identifiers */ | ||
| 71 : | undefine(`index') | ||
| 72 : | undefine(`shift') | ||
| 73 : | |||
| 74 : | noop -- fig | ||
| 75 : | ; | ||
| 76 : | |||
| 77 : | lit -- w fig | ||
| 78 : | w = (Cell)*ip++; | ||
| 79 : | |||
| 80 : | /* no clit today */ | ||
| 81 : | |||
| 82 : | execute xt -- core,fig | ||
| 83 : | cfa = xt; | ||
| 84 : | IF_TOS(TOS = sp[0]); | ||
| 85 : | NEXT1; | ||
| 86 : | |||
| 87 : | branch -- fig | ||
| 88 : | branch: | ||
| 89 : | ip = (Xt *)(((int)ip)+(int)*ip); | ||
| 90 : | |||
| 91 : | ?branch f -- f83 question_branch | ||
| 92 : | ""also known as 0branch"" | ||
| 93 : | if (f==0) { | ||
| 94 : | IF_TOS(TOS = sp[0]); | ||
| 95 : | goto branch; | ||
| 96 : | } | ||
| 97 : | else | ||
| 98 : | ip++; | ||
| 99 : | |||
| 100 : | (next) -- cmFORTH paren_next | ||
| 101 : | if ((*rp)--) { | ||
| 102 : | goto branch; | ||
| 103 : | } else { | ||
| 104 : | ip++; | ||
| 105 : | } | ||
| 106 : | |||
| 107 : | (loop) -- fig paren_loop | ||
| 108 : | int index = *rp+1; | ||
| 109 : | int limit = rp[1]; | ||
| 110 : | if (index != limit) { | ||
| 111 : | *rp = index; | ||
| 112 : | goto branch; | ||
| 113 : | } else { | ||
| 114 : | ip++; | ||
| 115 : | } | ||
| 116 : | |||
| 117 : | (+loop) n -- fig paren_plus_loop | ||
| 118 : | /* !! check this thoroughly */ | ||
| 119 : | int index = *rp; | ||
| 120 : | int olddiff = index-rp[1]; | ||
| 121 : | /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ | ||
| 122 : | /* dependent upon two's complement arithmetic */ | ||
| 123 : | if ((olddiff^(olddiff+n))<0 /* the limit is crossed */ | ||
| 124 : | && (olddiff^n)<0 /* it is not a wrap-around effect */) { | ||
| 125 : | /* break */ | ||
| 126 : | ip++; | ||
| 127 : | } else { | ||
| 128 : | /* continue */ | ||
| 129 : | *rp = index+n; | ||
| 130 : | IF_TOS(TOS = sp[0]); | ||
| 131 : | goto branch; | ||
| 132 : | } | ||
| 133 : | |||
| 134 : | (s+loop) n -- new paren_symmetric_plus_loop | ||
| 135 : | ""The run-time procedure compiled by S+LOOP. It loops until the index | ||
| 136 : | crosses the boundary between limit and limit-sign(n). I.e. a symmetric | ||
| 137 : | version of (+LOOP)."" | ||
| 138 : | /* !! check this thoroughly */ | ||
| 139 : | int oldindex = *rp; | ||
| 140 : | int diff = oldindex-rp[1]; | ||
| 141 : | int newdiff = diff+n; | ||
| 142 : | if (n<0) { | ||
| 143 : | diff = -diff; | ||
| 144 : | newdiff = - newdiff; | ||
| 145 : | } | ||
| 146 : | if (diff>=0 || newdiff<0) { | ||
| 147 : | *rp = oldindex+n; | ||
| 148 : | IF_TOS(TOS = sp[0]); | ||
| 149 : | goto branch; | ||
| 150 : | } else { | ||
| 151 : | ip++; | ||
| 152 : | } | ||
| 153 : | |||
| 154 : | unloop -- core | ||
| 155 : | rp += 2; | ||
| 156 : | |||
| 157 : | (for) ncount -- cmFORTH paren_for | ||
| 158 : | /* or (for) = >r -- collides with unloop! */ | ||
| 159 : | *--rp = 0; | ||
| 160 : | *--rp = ncount; | ||
| 161 : | |||
| 162 : | (do) nlimit nstart -- fig paren_do | ||
| 163 : | /* or do it in high-level? 0.09/0.23% */ | ||
| 164 : | *--rp = nlimit; | ||
| 165 : | *--rp = nstart; | ||
| 166 : | : | ||
| 167 : | swap >r >r ; | ||
| 168 : | |||
| 169 : | (?do) nlimit nstart -- core-ext paren_question_do | ||
| 170 : | *--rp = nlimit; | ||
| 171 : | *--rp = nstart; | ||
| 172 : | if (nstart == nlimit) { | ||
| 173 : | IF_TOS(TOS = sp[0]); | ||
| 174 : | goto branch; | ||
| 175 : | } | ||
| 176 : | else { | ||
| 177 : | ip++; | ||
| 178 : | } | ||
| 179 : | |||
| 180 : | i -- n core,fig | ||
| 181 : | n = *rp; | ||
| 182 : | |||
| 183 : | j -- n core | ||
| 184 : | n = rp[2]; | ||
| 185 : | |||
| 186 : | /* digit is high-level: 0/0% */ | ||
| 187 : | |||
| 188 : | emit c -- fig | ||
| 189 : | putchar(c); | ||
| 190 : | emitcounter++; | ||
| 191 : | |||
| 192 : | key -- n fig | ||
| 193 : | fflush(stdout); | ||
| 194 : | /* !! noecho */ | ||
| 195 : | n = key(); | ||
| 196 : | |||
| 197 : | pazsan | 1.2 | key? -- n fig key_q |
| 198 : | fflush(stdout); | ||
| 199 : | n = key_query; | ||
| 200 : | |||
| 201 : | anton | 1.1 | cr -- fig |
| 202 : | puts(""); | ||
| 203 : | |||
| 204 : | move c_from c_to ucount -- core | ||
| 205 : | memmove(c_to,c_from,ucount); | ||
| 206 : | /* make an ifdef for bsd and others? */ | ||
| 207 : | |||
| 208 : | cmove c_from c_to u -- string | ||
| 209 : | while (u-- > 0) | ||
| 210 : | *c_to++ = *c_from++; | ||
| 211 : | |||
| 212 : | cmove> c_from c_to u -- string c_move_up | ||
| 213 : | while (u-- > 0) | ||
| 214 : | c_to[u] = c_from[u]; | ||
| 215 : | |||
| 216 : | fill c_addr u c -- core | ||
| 217 : | memset(c_addr,c,u); | ||
| 218 : | |||
| 219 : | compare c_addr1 u1 c_addr2 u2 -- n string | ||
| 220 : | n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); | ||
| 221 : | if (n==0) | ||
| 222 : | n = u1-u2; | ||
| 223 : | if (n<0) | ||
| 224 : | n = -1; | ||
| 225 : | else if (n>0) | ||
| 226 : | n = 1; | ||
| 227 : | |||
| 228 : | -text c_addr1 u c_addr2 -- n new dash_text | ||
| 229 : | n = memcmp(c_addr1, c_addr2, u); | ||
| 230 : | if (n<0) | ||
| 231 : | n = -1; | ||
| 232 : | else if (n>0) | ||
| 233 : | n = 1; | ||
| 234 : | |||
| 235 : | capscomp c_addr1 u c_addr2 -- n new | ||
| 236 : | Char c1, c2; | ||
| 237 : | for (;; u--, c_addr1++, c_addr2++) { | ||
| 238 : | if (u == 0) { | ||
| 239 : | n = 0; | ||
| 240 : | break; | ||
| 241 : | } | ||
| 242 : | c1 = toupper(*c_addr1); | ||
| 243 : | c2 = toupper(*c_addr2); | ||
| 244 : | if (c1 != c2) { | ||
| 245 : | if (c1 < c2) | ||
| 246 : | n = -1; | ||
| 247 : | else | ||
| 248 : | n = 1; | ||
| 249 : | break; | ||
| 250 : | } | ||
| 251 : | } | ||
| 252 : | |||
| 253 : | -trailing c_addr u1 -- c_addr u2 string dash_trailing | ||
| 254 : | u2 = u1; | ||
| 255 : | while (c_addr[u2-1] == ' ') | ||
| 256 : | u2--; | ||
| 257 : | |||
| 258 : | /string c_addr1 u1 n -- c_addr2 u2 string slash_string | ||
| 259 : | c_addr2 = c_addr1+n; | ||
| 260 : | u2 = u1-n; | ||
| 261 : | |||
| 262 : | + n1 n2 -- n core,fig plus | ||
| 263 : | n = n1+n2; | ||
| 264 : | |||
| 265 : | - n1 n2 -- n core,fig minus | ||
| 266 : | n = n1-n2; | ||
| 267 : | |||
| 268 : | negate n1 -- n2 core,fig | ||
| 269 : | /* use minus as alias */ | ||
| 270 : | n2 = -n1; | ||
| 271 : | |||
| 272 : | 1+ n1 -- n2 core one_plus | ||
| 273 : | n2 = n1+1; | ||
| 274 : | |||
| 275 : | 1- n1 -- n2 core one_minus | ||
| 276 : | n2 = n1-1; | ||
| 277 : | |||
| 278 : | max n1 n2 -- n core | ||
| 279 : | if (n1<n2) | ||
| 280 : | n = n2; | ||
| 281 : | else | ||
| 282 : | n = n1; | ||
| 283 : | : | ||
| 284 : | 2dup < if | ||
| 285 : | swap drop | ||
| 286 : | else | ||
| 287 : | drop | ||
| 288 : | endif ; | ||
| 289 : | |||
| 290 : | min n1 n2 -- n core | ||
| 291 : | if (n1<n2) | ||
| 292 : | n = n1; | ||
| 293 : | else | ||
| 294 : | n = n2; | ||
| 295 : | |||
| 296 : | abs n1 -- n2 core | ||
| 297 : | if (n1<0) | ||
| 298 : | n2 = -n1; | ||
| 299 : | else | ||
| 300 : | n2 = n1; | ||
| 301 : | |||
| 302 : | * n1 n2 -- n core,fig star | ||
| 303 : | n = n1*n2; | ||
| 304 : | |||
| 305 : | / n1 n2 -- n core,fig slash | ||
| 306 : | n = n1/n2; | ||
| 307 : | |||
| 308 : | mod n1 n2 -- n core | ||
| 309 : | n = n1%n2; | ||
| 310 : | |||
| 311 : | /mod n1 n2 -- n3 n4 core slash_mod | ||
| 312 : | n4 = n1/n2; | ||
| 313 : | n3 = n1%n2; /* !! is this correct? look into C standard! */ | ||
| 314 : | |||
| 315 : | 2* n1 -- n2 core two_star | ||
| 316 : | n2 = 2*n1; | ||
| 317 : | |||
| 318 : | 2/ n1 -- n2 core two_slash | ||
| 319 : | /* !! is this still correct? */ | ||
| 320 : | n2 = n1>>1; | ||
| 321 : | |||
| 322 : | fm/mod d1 n1 -- n2 n3 core f_m_slash_mod | ||
| 323 : | ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1"" | ||
| 324 : | /* assumes that the processor uses either floored or symmetric division */ | ||
| 325 : | n3 = d1/n1; | ||
| 326 : | n2 = d1%n1; | ||
| 327 : | /* note that this 1%-3>0 is optimized by the compiler */ | ||
| 328 : | if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) { | ||
| 329 : | n3--; | ||
| 330 : | n2+=n1; | ||
| 331 : | } | ||
| 332 : | |||
| 333 : | sm/rem d1 n1 -- n2 n3 core s_m_slash_rem | ||
| 334 : | ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0"" | ||
| 335 : | /* assumes that the processor uses either floored or symmetric division */ | ||
| 336 : | n3 = d1/n1; | ||
| 337 : | n2 = d1%n1; | ||
| 338 : | /* note that this 1%-3<0 is optimized by the compiler */ | ||
| 339 : | if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) { | ||
| 340 : | n3++; | ||
| 341 : | n2-=n1; | ||
| 342 : | } | ||
| 343 : | |||
| 344 : | m* n1 n2 -- d core m_star | ||
| 345 : | d = (DCell)n1 * (DCell)n2; | ||
| 346 : | |||
| 347 : | um* u1 u2 -- ud core u_m_star | ||
| 348 : | /* use u* as alias */ | ||
| 349 : | ud = (UDCell)u1 * (UDCell)u2; | ||
| 350 : | |||
| 351 : | um/mod ud u1 -- u2 u3 core u_m_slash_mod | ||
| 352 : | u3 = ud/u1; | ||
| 353 : | u2 = ud%u1; | ||
| 354 : | |||
| 355 : | m+ d1 n -- d2 double m_plus | ||
| 356 : | d2 = d1+n; | ||
| 357 : | |||
| 358 : | d+ d1 d2 -- d double,fig d_plus | ||
| 359 : | d = d1+d2; | ||
| 360 : | |||
| 361 : | d- d1 d2 -- d double d_minus | ||
| 362 : | d = d1-d2; | ||
| 363 : | |||
| 364 : | dnegate d1 -- d2 double | ||
| 365 : | /* use dminus as alias */ | ||
| 366 : | d2 = -d1; | ||
| 367 : | |||
| 368 : | dmax d1 d2 -- d double | ||
| 369 : | if (d1<d2) | ||
| 370 : | d = d2; | ||
| 371 : | else | ||
| 372 : | d = d1; | ||
| 373 : | |||
| 374 : | dmin d1 d2 -- d double | ||
| 375 : | if (d1<d2) | ||
| 376 : | d = d1; | ||
| 377 : | else | ||
| 378 : | d = d2; | ||
| 379 : | |||
| 380 : | dabs d1 -- d2 double | ||
| 381 : | if (d1<0) | ||
| 382 : | d2 = -d1; | ||
| 383 : | else | ||
| 384 : | d2 = d1; | ||
| 385 : | |||
| 386 : | d2* d1 -- d2 double d_two_star | ||
| 387 : | d2 = 2*d1; | ||
| 388 : | |||
| 389 : | d2/ d1 -- d2 double d_two_slash | ||
| 390 : | /* !! is this still correct? */ | ||
| 391 : | d2 = d1/2; | ||
| 392 : | |||
| 393 : | d>s d -- n double d_to_s | ||
| 394 : | /* make this an alias for drop? */ | ||
| 395 : | n = d; | ||
| 396 : | |||
| 397 : | and w1 w2 -- w core,fig | ||
| 398 : | w = w1&w2; | ||
| 399 : | |||
| 400 : | or w1 w2 -- w core,fig | ||
| 401 : | w = w1|w2; | ||
| 402 : | |||
| 403 : | xor w1 w2 -- w core,fig | ||
| 404 : | w = w1^w2; | ||
| 405 : | |||
| 406 : | invert w1 -- w2 core | ||
| 407 : | w2 = ~w1; | ||
| 408 : | |||
| 409 : | rshift u1 n -- u2 core | ||
| 410 : | u2 = u1>>n; | ||
| 411 : | |||
| 412 : | lshift u1 n -- u2 core | ||
| 413 : | u2 = u1<<n; | ||
| 414 : | |||
| 415 : | /* comparisons(prefix, args, prefix, arg1, arg2, wordsets...) */ | ||
| 416 : | define(comparisons, | ||
| 417 : | $1= $2 -- f $6 $3equals | ||
| 418 : | f = FLAG($4==$5); | ||
| 419 : | |||
| 420 : | $1<> $2 -- f $7 $3different | ||
| 421 : | /* use != as alias ? */ | ||
| 422 : | f = FLAG($4!=$5); | ||
| 423 : | |||
| 424 : | $1< $2 -- f $8 $3less | ||
| 425 : | f = FLAG($4<$5); | ||
| 426 : | |||
| 427 : | $1> $2 -- f $9 $3greater | ||
| 428 : | f = FLAG($4>$5); | ||
| 429 : | |||
| 430 : | $1<= $2 -- f new $3less_or_equal | ||
| 431 : | f = FLAG($4<=$5); | ||
| 432 : | |||
| 433 : | $1>= $2 -- f new $3greater_or_equal | ||
| 434 : | f = FLAG($4>=$5); | ||
| 435 : | |||
| 436 : | ) | ||
| 437 : | |||
| 438 : | comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext) | ||
| 439 : | comparisons(, n1 n2, , n1, n2, core, core-ext, core, core) | ||
| 440 : | comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext) | ||
| 441 : | comparisons(d, d1 d2, d_, d1, d2, double, new, double, new) | ||
| 442 : | comparisons(d0, d, d_zero_, d, 0, double, new, double, new) | ||
| 443 : | comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new) | ||
| 444 : | |||
| 445 : | within u1 u2 u3 -- f core-ext | ||
| 446 : | f = FLAG(u1-u2 < u3-u2); | ||
| 447 : | |||
| 448 : | sp@ -- a_addr fig spat | ||
| 449 : | a_addr = sp; | ||
| 450 : | |||
| 451 : | sp! a_addr -- fig spstore | ||
| 452 : | sp = a_addr+1; | ||
| 453 : | /* works with and without TOS caching */ | ||
| 454 : | |||
| 455 : | rp@ -- a_addr fig rpat | ||
| 456 : | a_addr = rp; | ||
| 457 : | |||
| 458 : | rp! a_addr -- fig rpstore | ||
| 459 : | rp = a_addr; | ||
| 460 : | |||
| 461 : | fp@ -- f_addr new fp_fetch | ||
| 462 : | f_addr = fp; | ||
| 463 : | |||
| 464 : | fp! f_addr -- new fp_store | ||
| 465 : | fp = f_addr; | ||
| 466 : | |||
| 467 : | pazsan | 1.3 | ;s -- core exit |
| 468 : | anton | 1.1 | /* use ;s as alias */ |
| 469 : | ip = (Xt *)(*rp++); | ||
| 470 : | |||
| 471 : | ?exit w -- core question_exit | ||
| 472 : | /* use ;s as alias */ | ||
| 473 : | if(w) | ||
| 474 : | ip = (Xt *)(*rp++); | ||
| 475 : | |||
| 476 : | >r w -- core,fig to_r | ||
| 477 : | *--rp = w; | ||
| 478 : | |||
| 479 : | r> -- w core,fig r_from | ||
| 480 : | w = *rp++; | ||
| 481 : | |||
| 482 : | r@ -- w core,fig r_fetch | ||
| 483 : | /* use r as alias */ | ||
| 484 : | /* make r@ an alias for i */ | ||
| 485 : | w = *rp; | ||
| 486 : | |||
| 487 : | rdrop -- fig | ||
| 488 : | rp++; | ||
| 489 : | |||
| 490 : | i' -- w fig i_tick | ||
| 491 : | w=rp[1]; | ||
| 492 : | |||
| 493 : | over w1 w2 -- w1 w2 w1 core,fig | ||
| 494 : | |||
| 495 : | drop w -- core,fig | ||
| 496 : | |||
| 497 : | swap w1 w2 -- w2 w1 core,fig | ||
| 498 : | |||
| 499 : | dup w -- w w core,fig | ||
| 500 : | |||
| 501 : | rot w1 w2 w3 -- w2 w3 w1 core rote | ||
| 502 : | |||
| 503 : | -rot w1 w2 w3 -- w3 w1 w2 fig not_rote | ||
| 504 : | |||
| 505 : | nip w1 w2 -- w2 core-ext | ||
| 506 : | |||
| 507 : | tuck w1 w2 -- w2 w1 w2 core-ext | ||
| 508 : | |||
| 509 : | ?dup w -- w core question_dupe | ||
| 510 : | /* resulting C code suboptimal */ | ||
| 511 : | /* make -dup an alias */ | ||
| 512 : | if (w!=0) { | ||
| 513 : | --sp; | ||
| 514 : | #ifndef USE_TOS | ||
| 515 : | *sp = w; | ||
| 516 : | #endif | ||
| 517 : | } | ||
| 518 : | |||
| 519 : | pick u -- w core-ext | ||
| 520 : | w = sp[u+1]; | ||
| 521 : | |||
| 522 : | 2drop w1 w2 -- core two_drop | ||
| 523 : | |||
| 524 : | 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe | ||
| 525 : | |||
| 526 : | 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over | ||
| 527 : | |||
| 528 : | 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap | ||
| 529 : | |||
| 530 : | 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double two_rote | ||
| 531 : | |||
| 532 : | /* toggle is high-level: 0.11/0.42% */ | ||
| 533 : | |||
| 534 : | @ a_addr -- w fig fetch | ||
| 535 : | w = *a_addr; | ||
| 536 : | |||
| 537 : | ! w a_addr -- core,fig store | ||
| 538 : | *a_addr = w; | ||
| 539 : | |||
| 540 : | +! n a_addr -- core,fig plus_store | ||
| 541 : | *a_addr += n; | ||
| 542 : | |||
| 543 : | c@ c_addr -- c fig cfetch | ||
| 544 : | c = *c_addr; | ||
| 545 : | |||
| 546 : | c! c c_addr -- fig cstore | ||
| 547 : | *c_addr = c; | ||
| 548 : | |||
| 549 : | 2! w1 w2 a_addr -- core two_store | ||
| 550 : | a_addr[0] = w2; | ||
| 551 : | a_addr[1] = w1; | ||
| 552 : | |||
| 553 : | 2@ a_addr -- w1 w2 core two_fetch | ||
| 554 : | w2 = a_addr[0]; | ||
| 555 : | w1 = a_addr[1]; | ||
| 556 : | |||
| 557 : | d! d a_addr -- double d_store | ||
| 558 : | /* !! alignment problems on some machines */ | ||
| 559 : | *(DCell *)a_addr = d; | ||
| 560 : | |||
| 561 : | d@ a_addr -- d double d_fetch | ||
| 562 : | d = *(DCell *)a_addr; | ||
| 563 : | |||
| 564 : | cell+ a_addr1 -- a_addr2 core cell_plus | ||
| 565 : | a_addr2 = a_addr1+1; | ||
| 566 : | |||
| 567 : | cells n1 -- n2 core | ||
| 568 : | n2 = n1 * sizeof(Cell); | ||
| 569 : | |||
| 570 : | char+ c_addr1 -- c_addr2 core care_plus | ||
| 571 : | c_addr2 = c_addr1+1; | ||
| 572 : | |||
| 573 : | chars n1 -- n2 core cares | ||
| 574 : | n2 = n1 * sizeof(Char); | ||
| 575 : | |||
| 576 : | count c_addr1 -- c_addr2 u core | ||
| 577 : | u = *c_addr1; | ||
| 578 : | c_addr2 = c_addr1+1; | ||
| 579 : | |||
| 580 : | (bye) n -- toolkit-ext paren_bye | ||
| 581 : | deprep_terminal(); | ||
| 582 : | exit(n); | ||
| 583 : | |||
| 584 : | system c_addr u -- n own | ||
| 585 : | char pname[u+1]; | ||
| 586 : | cstr(pname,c_addr,u); | ||
| 587 : | n=system(pname); | ||
| 588 : | |||
| 589 : | popen c_addr u n -- wfileid own | ||
| 590 : | char pname[u+1]; | ||
| 591 : | static char* mode[2]={"r","w"}; | ||
| 592 : | cstr(pname,c_addr,u); | ||
| 593 : | wfileid=(Cell)popen(pname,mode[n]); | ||
| 594 : | |||
| 595 : | pclose wfileid -- wior own | ||
| 596 : | wior=pclose((FILE *)wfileid); | ||
| 597 : | pazsan | 1.2 | |
| 598 : | time&date -- nyear nmonth nday nhour nmin nsec ansi time_and_date | ||
| 599 : | struct timeval time1; | ||
| 600 : | struct timezone zone1; | ||
| 601 : | struct tm *ltime; | ||
| 602 : | gettimeofday(&time1,&zone1); | ||
| 603 : | ltime=localtime(&time1.tv_sec); | ||
| 604 : | nyear =ltime->tm_year+1900; | ||
| 605 : | nmonth=ltime->tm_mon; | ||
| 606 : | nday =ltime->tm_mday; | ||
| 607 : | nhour =ltime->tm_hour; | ||
| 608 : | nmin =ltime->tm_min; | ||
| 609 : | nsec =ltime->tm_sec; | ||
| 610 : | |||
| 611 : | ms n -- ansi | ||
| 612 : | struct timeval timeout; | ||
| 613 : | timeout.tv_sec=n/1000; | ||
| 614 : | timeout.tv_usec=1000*(n%1000); | ||
| 615 : | (void)select(0,0,0,0,&timeout); | ||
| 616 : | anton | 1.1 | |
| 617 : | allocate u -- a_addr wior memory | ||
| 618 : | a_addr = (Cell *)malloc(u); | ||
| 619 : | wior = a_addr==NULL; /* !! define a return code */ | ||
| 620 : | |||
| 621 : | free a_addr -- wior memory | ||
| 622 : | free(a_addr); | ||
| 623 : | wior = 0; | ||
| 624 : | |||
| 625 : | resize a_addr1 u -- a_addr2 wior memory | ||
| 626 : | a_addr2 = realloc(a_addr1, u); | ||
| 627 : | wior = a_addr2==NULL; /* !! define a return code */ | ||
| 628 : | |||
| 629 : | (f83find) c_addr u f83name1 -- f83name2 new paren_f83find | ||
| 630 : | for (; f83name1 != NULL; f83name1 = f83name1->next) | ||
| 631 : | if (F83NAME_COUNT(f83name1)==u && !F83NAME_SMUDGE(f83name1) && | ||
| 632 : | strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) | ||
| 633 : | break; | ||
| 634 : | f83name2=f83name1; | ||
| 635 : | |||
| 636 : | (parse-white) c_addr1 u1 -- c_addr2 u2 new paren_parse_white | ||
| 637 : | /* use !isgraph instead of isspace? */ | ||
| 638 : | Char *endp = c_addr1+u1; | ||
| 639 : | while (c_addr1<endp && isspace(*c_addr1)) | ||
| 640 : | c_addr1++; | ||
| 641 : | if (c_addr1<endp) { | ||
| 642 : | for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++) | ||
| 643 : | ; | ||
| 644 : | u2 = c_addr1-c_addr2; | ||
| 645 : | } | ||
| 646 : | else { | ||
| 647 : | c_addr2 = c_addr1; | ||
| 648 : | u2 = 0; | ||
| 649 : | } | ||
| 650 : | |||
| 651 : | close-file wfileid -- wior file close_file | ||
| 652 : | wior = FLAG(fclose((FILE *)wfileid)==EOF); | ||
| 653 : | |||
| 654 : | open-file c_addr u ntype -- w2 wior file open_file | ||
| 655 : | char fname[u+1]; | ||
| 656 : | cstr(fname, c_addr, u); | ||
| 657 : | w2 = (Cell)fopen(fname, fileattr[ntype]); | ||
| 658 : | wior = FLAG(w2 == NULL); | ||
| 659 : | |||
| 660 : | create-file c_addr u ntype -- w2 wior file create_file | ||
| 661 : | int fd; | ||
| 662 : | char fname[u+1]; | ||
| 663 : | cstr(fname, c_addr, u); | ||
| 664 : | fd = creat(fname, 0666); | ||
| 665 : | if (fd > -1) { | ||
| 666 : | w2 = (Cell)fdopen(fd, fileattr[ntype]); | ||
| 667 : | assert(w2 != NULL); | ||
| 668 : | wior = 0; | ||
| 669 : | } else { | ||
| 670 : | assert(fd == -1); | ||
| 671 : | wior = fd; | ||
| 672 : | w2 = 0; | ||
| 673 : | } | ||
| 674 : | |||
| 675 : | delete-file c_addr u -- wior file delete_file | ||
| 676 : | char fname[u+1]; | ||
| 677 : | cstr(fname, c_addr, u); | ||
| 678 : | wior = unlink(fname); | ||
| 679 : | |||
| 680 : | rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file | ||
| 681 : | char fname1[u1+1]; | ||
| 682 : | char fname2[u2+1]; | ||
| 683 : | cstr(fname1, c_addr1, u1); | ||
| 684 : | cstr(fname2, c_addr2, u2); | ||
| 685 : | wior = rename(fname1, fname2); | ||
| 686 : | |||
| 687 : | file-position wfileid -- ud wior file file_position | ||
| 688 : | /* !! use tell and lseek? */ | ||
| 689 : | ud = ftell((FILE *)wfileid); | ||
| 690 : | wior = 0; /* !! or wior = FLAG(ud<0) */ | ||
| 691 : | |||
| 692 : | reposition-file ud wfileid -- wior file reposition_file | ||
| 693 : | wior = fseek((FILE *)wfileid, (long)ud, SEEK_SET); | ||
| 694 : | |||
| 695 : | file-size wfileid -- ud wior file file_size | ||
| 696 : | struct stat buf; | ||
| 697 : | wior = fstat(fileno((FILE *)wfileid), &buf); | ||
| 698 : | ud = buf.st_size; | ||
| 699 : | |||
| 700 : | resize-file ud wfileid -- wior file resize_file | ||
| 701 : | wior = ftruncate(fileno((FILE *)wfileid), (int)ud); | ||
| 702 : | |||
| 703 : | read-file c_addr u1 wfileid -- u2 wior file read_file | ||
| 704 : | /* !! fread does not guarantee enough */ | ||
| 705 : | u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); | ||
| 706 : | wior = FLAG(u2<u1 && ferror((FILE *)wfileid)); | ||
| 707 : | /* !! who performs clearerr((FILE *)wfileid); ? */ | ||
| 708 : | |||
| 709 : | read-line c_addr u1 wfileid -- u2 flag wior file read_line | ||
| 710 : | wior=(Cell)fgets(c_addr,u1+1,(FILE *)wfileid); | ||
| 711 : | flag=FLAG(!feof((FILE *)wfileid) && wior); | ||
| 712 : | wior=FLAG(ferror((FILE *)wfileid)) & flag; | ||
| 713 : | u2=(flag & strlen(c_addr)); | ||
| 714 : | u2-=((u2>0) && (c_addr[u2-1]==NEWLINE)); | ||
| 715 : | |||
| 716 : | write-file c_addr u1 wfileid -- wior file write_file | ||
| 717 : | /* !! fwrite does not guarantee enough */ | ||
| 718 : | { | ||
| 719 : | int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); | ||
| 720 : | wior = FLAG(u2<u1 && ferror((FILE *)wfileid)); | ||
| 721 : | } | ||
| 722 : | |||
| 723 : | flush-file wfileid -- wior file-ext flush_file | ||
| 724 : | wior = fflush((FILE *)wfileid); | ||
| 725 : | |||
| 726 : | comparisons(f, r1 r2, f_, r1, r2, new, new, float, new) | ||
| 727 : | comparisons(f0, r, f_zero_, r, 0., float, new, float, new) | ||
| 728 : | |||
| 729 : | d>f d -- r float d_to_f | ||
| 730 : | r = d; | ||
| 731 : | |||
| 732 : | f>d r -- d float f_to_d | ||
| 733 : | /* !! basis 15 is not very specific */ | ||
| 734 : | d = r; | ||
| 735 : | |||
| 736 : | f! r f_addr -- float f_store | ||
| 737 : | *f_addr = r; | ||
| 738 : | |||
| 739 : | f@ f_addr -- r float f_fetch | ||
| 740 : | r = *f_addr; | ||
| 741 : | |||
| 742 : | df@ df_addr -- r float-ext d_f_fetch | ||
| 743 : | #ifdef IEEE_FP | ||
| 744 : | r = *df_addr; | ||
| 745 : | #else | ||
| 746 : | !! df@ | ||
| 747 : | #endif | ||
| 748 : | |||
| 749 : | df! r df_addr -- float-ext d_f_store | ||
| 750 : | #ifdef IEEE_FP | ||
| 751 : | *df_addr = r; | ||
| 752 : | #else | ||
| 753 : | !! df! | ||
| 754 : | #endif | ||
| 755 : | |||
| 756 : | sf@ sf_addr -- r float-ext s_f_fetch | ||
| 757 : | #ifdef IEEE_FP | ||
| 758 : | r = *sf_addr; | ||
| 759 : | #else | ||
| 760 : | !! sf@ | ||
| 761 : | #endif | ||
| 762 : | |||
| 763 : | sf! r sf_addr -- float-ext s_f_store | ||
| 764 : | #ifdef IEEE_FP | ||
| 765 : | *sf_addr = r; | ||
| 766 : | #else | ||
| 767 : | !! sf! | ||
| 768 : | #endif | ||
| 769 : | |||
| 770 : | f+ r1 r2 -- r3 float f_plus | ||
| 771 : | r3 = r1+r2; | ||
| 772 : | |||
| 773 : | f- r1 r2 -- r3 float f_minus | ||
| 774 : | r3 = r1-r2; | ||
| 775 : | |||
| 776 : | f* r1 r2 -- r3 float f_star | ||
| 777 : | r3 = r1*r2; | ||
| 778 : | |||
| 779 : | f/ r1 r2 -- r3 float f_slash | ||
| 780 : | r3 = r1/r2; | ||
| 781 : | |||
| 782 : | f** r1 r2 -- r3 float-ext f_star_star | ||
| 783 : | r3 = pow(r1,r2); | ||
| 784 : | |||
| 785 : | fnegate r1 -- r2 float | ||
| 786 : | r2 = - r1; | ||
| 787 : | |||
| 788 : | fdrop r -- float | ||
| 789 : | |||
| 790 : | fdup r -- r r float | ||
| 791 : | |||
| 792 : | fswap r1 r2 -- r2 r1 float | ||
| 793 : | |||
| 794 : | fover r1 r2 -- r1 r2 r1 float | ||
| 795 : | |||
| 796 : | frot r1 r2 r3 -- r2 r3 r1 float | ||
| 797 : | |||
| 798 : | float+ f_addr1 -- f_addr2 float float_plus | ||
| 799 : | f_addr2 = f_addr1+1; | ||
| 800 : | |||
| 801 : | floats n1 -- n2 float | ||
| 802 : | n2 = n1*sizeof(Float); | ||
| 803 : | |||
| 804 : | floor r1 -- r2 float | ||
| 805 : | /* !! unclear wording */ | ||
| 806 : | r2 = floor(r1); | ||
| 807 : | |||
| 808 : | fround r1 -- r2 float | ||
| 809 : | /* !! unclear wording */ | ||
| 810 : | r2 = rint(r1); | ||
| 811 : | |||
| 812 : | fmax r1 r2 -- r3 float | ||
| 813 : | if (r1<r2) | ||
| 814 : | r3 = r2; | ||
| 815 : | else | ||
| 816 : | r3 = r1; | ||
| 817 : | |||
| 818 : | fmin r1 r2 -- r3 float | ||
| 819 : | if (r1<r2) | ||
| 820 : | r3 = r1; | ||
| 821 : | else | ||
| 822 : | r3 = r2; | ||
| 823 : | |||
| 824 : | represent r c_addr u -- n f1 f2 float | ||
| 825 : | char *sig; | ||
| 826 : | int flag; | ||
| 827 : | sig=ecvt(r, u, &n, &flag); | ||
| 828 : | f1=FLAG(flag!=0); | ||
| 829 : | f2=FLAG(isdigit(sig[0])!=0); | ||
| 830 : | memmove(c_addr,sig,u); | ||
| 831 : | |||
| 832 : | >float c_addr u -- flag float to_float | ||
| 833 : | /* real signature: c_addr u -- r t / f */ | ||
| 834 : | Float r; | ||
| 835 : | char number[u+1]; | ||
| 836 : | char *endconv; | ||
| 837 : | cstr(number, c_addr, u); | ||
| 838 : | r=strtod(number,&endconv); | ||
| 839 : | if(flag=FLAG(!(int)*endconv)) | ||
| 840 : | { | ||
| 841 : | IF_FTOS(fp[0] = FTOS); | ||
| 842 : | fp += -1; | ||
| 843 : | FTOS = r; | ||
| 844 : | } | ||
| 845 : | else if(*endconv=='d' || *endconv=='D') | ||
| 846 : | { | ||
| 847 : | *endconv='E'; | ||
| 848 : | r=strtod(number,&endconv); | ||
| 849 : | if(flag=FLAG(!(int)*endconv)) | ||
| 850 : | { | ||
| 851 : | IF_FTOS(fp[0] = FTOS); | ||
| 852 : | fp += -1; | ||
| 853 : | FTOS = r; | ||
| 854 : | } | ||
| 855 : | } | ||
| 856 : | |||
| 857 : | fabs r1 -- r2 float-ext | ||
| 858 : | r2 = fabs(r1); | ||
| 859 : | |||
| 860 : | facos r1 -- r2 float-ext | ||
| 861 : | r2 = acos(r1); | ||
| 862 : | |||
| 863 : | fasin r1 -- r2 float-ext | ||
| 864 : | r2 = asin(r1); | ||
| 865 : | |||
| 866 : | fatan r1 -- r2 float-ext | ||
| 867 : | r2 = atan(r1); | ||
| 868 : | |||
| 869 : | fatan2 r1 r2 -- r3 float-ext | ||
| 870 : | r3 = atan2(r1,r2); | ||
| 871 : | |||
| 872 : | fcos r1 -- r2 float-ext | ||
| 873 : | r2 = cos(r1); | ||
| 874 : | |||
| 875 : | fexp r1 -- r2 float-ext | ||
| 876 : | r2 = exp(r1); | ||
| 877 : | |||
| 878 : | pazsan | 1.3 | fexpm1 r1 -- r2 float-ext |
| 879 : | r2 = | ||
| 880 : | #ifdef expm1 | ||
| 881 : | expm1(r1); | ||
| 882 : | #else | ||
| 883 : | exp(r1)-1; | ||
| 884 : | #endif | ||
| 885 : | |||
| 886 : | anton | 1.1 | fln r1 -- r2 float-ext |
| 887 : | r2 = log(r1); | ||
| 888 : | |||
| 889 : | pazsan | 1.3 | flnp1 r1 -- r2 float-ext |
| 890 : | r2 = | ||
| 891 : | #ifdef log1p | ||
| 892 : | log1p(r1); | ||
| 893 : | #else | ||
| 894 : | log(r1+1); | ||
| 895 : | #endif | ||
| 896 : | |||
| 897 : | anton | 1.1 | flog r1 -- r2 float-ext |
| 898 : | r2 = log10(r1); | ||
| 899 : | |||
| 900 : | pazsan | 1.3 | fsin r1 -- r2 float-ext |
| 901 : | r2 = sin(r1); | ||
| 902 : | |||
| 903 : | fsincos r1 -- r2 r3 float-ext | ||
| 904 : | anton | 1.1 | r2 = sin(r1); |
| 905 : | r3 = cos(r1); | ||
| 906 : | |||
| 907 : | fsqrt r1 -- r2 float-ext | ||
| 908 : | r2 = sqrt(r1); | ||
| 909 : | |||
| 910 : | ftan r1 -- r2 float-ext | ||
| 911 : | r2 = tan(r1); | ||
| 912 : | |||
| 913 : | /* The following words access machine/OS/installation-dependent ANSI | ||
| 914 : | figForth internals */ | ||
| 915 : | /* !! how about environmental queries DIRECT-THREADED, | ||
| 916 : | INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ | ||
| 917 : | |||
| 918 : | >body xt -- a_addr core to_body | ||
| 919 : | a_addr = PFA(xt); | ||
| 920 : | |||
| 921 : | >code-address xt -- c_addr new to_code_address | ||
| 922 : | ""c_addr is the code address of the word xt"" | ||
| 923 : | /* !! This behaves installation-dependently for DOES-words */ | ||
| 924 : | c_addr = CODE_ADDRESS(xt); | ||
| 925 : | |||
| 926 : | >does-code xt -- a_addr new to_does_code | ||
| 927 : | ""If xt ist the execution token of a defining-word-defined word, | ||
| 928 : | a_addr is the start of the Forth code after the DOES>; Otherwise the | ||
| 929 : | behaviour is uundefined"" | ||
| 930 : | /* !! there is currently no way to determine whether a word is | ||
| 931 : | defining-word-defined */ | ||
| 932 : | a_addr = DOES_CODE(xt); | ||
| 933 : | |||
| 934 : | pazsan | 1.4 | code-address! n xt -- new code_address_store |
| 935 : | anton | 1.1 | ""Creates a code field with code address c_addr at xt"" |
| 936 : | pazsan | 1.4 | MAKE_CF(xt, symbols[CF(n)]); |
| 937 : | anton | 1.1 | |
| 938 : | does-code! a_addr xt -- new does_code_store | ||
| 939 : | ""creates a code field at xt for a defining-word-defined word; a_addr | ||
| 940 : | is the start of the Forth code after DOES>"" | ||
| 941 : | MAKE_DOES_CF(xt, a_addr); | ||
| 942 : | |||
| 943 : | does-handler! a_addr -- new does_jump_store | ||
| 944 : | ""creates a DOES>-handler at address a_addr. a_addr usually points | ||
| 945 : | just behind a DOES>."" | ||
| 946 : | MAKE_DOES_HANDLER(a_addr); | ||
| 947 : | |||
| 948 : | /does-handler -- n new slash_does_handler | ||
| 949 : | ""the size of a does-handler (includes possible padding)"" | ||
| 950 : | /* !! a constant or environmental query might be better */ | ||
| 951 : | n = DOES_HANDLER_SIZE; | ||
| 952 : | |||
| 953 : | toupper c1 -- c2 new | ||
| 954 : | c2 = toupper(c1); | ||
| 955 : | |||
| 956 : | /* local variable implementation primitives */ | ||
| 957 : | @local# -- w new fetch_local_number | ||
| 958 : | w = *(Cell *)(lp+(int)(*ip++)); | ||
| 959 : | |||
| 960 : | f@local# -- r new f_fetch_local_number | ||
| 961 : | r = *(Float *)(lp+(int)(*ip++)); | ||
| 962 : | |||
| 963 : | laddr# -- c_addr new laddr_number | ||
| 964 : | /* this can also be used to implement lp@ */ | ||
| 965 : | c_addr = (Char *)(lp+(int)(*ip++)); | ||
| 966 : | |||
| 967 : | lp+!# -- new lp_plus_store_number | ||
| 968 : | ""used with negative immediate values it allocates memory on the | ||
| 969 : | local stack, a positive immediate argument drops memory from the local | ||
| 970 : | stack"" | ||
| 971 : | lp += (int)(*ip++); | ||
| 972 : | |||
| 973 : | lp! c_addr -- new lp_store | ||
| 974 : | lp = (Address)c_addr; | ||
| 975 : | |||
| 976 : | >l w -- new to_l | ||
| 977 : | lp -= sizeof(Cell); | ||
| 978 : | *(Cell *)lp = w; | ||
| 979 : | |||
| 980 : | f>l r -- new f_to_l | ||
| 981 : | lp -= sizeof(Float); | ||
| 982 : | *(Float *)lp = r; | ||
| 983 : | pazsan | 1.4 | |
| 984 : | up! a_addr -- new up_store | ||
| 985 : | up=a_addr; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |