gforth/primitives - view

File: [gforth] / gforth / Attic / primitives
Revision 1.26: download - view: text, annotated - select for diffs
Mon Dec 12 17:10:49 1994 UTC (29 years, 4 months ago) by anton
Branches: MAIN
CVS tags: HEAD

Reorganized configuration: configure is now created by autoconf from
configure.in; I still left it in the CVS repository because not
everyone has autoconf. decstation.h renamed to mips.h and apollo68k to
m68k. Added general 32bit.h description, which the other machine
descriptions use. Created/copied replacement files install-sh memcmp.c
memmove.c select.c (carved out from ecvt.c) strtol.c
strtoul.c. Bytesex is now handled by configure.

Deciding the threading method is now done in machine.h, this should
also be done for USE_TOS and USE_FTOS.

1: \ Copyright 1992 by the ANSI figForth Development Group 2: \ 3: \ WARNING: This file is processed by m4. Make sure your identifiers 4: \ don't collide with m4's (e.g. by undefining them). 5: \ 6: \ 7: \ 8: \ This file contains instructions in the following format: 9: \ 10: \ forth name stack effect category [pronunciation] 11: \ [""glossary entry""] 12: \ C code 13: \ [: 14: \ Forth code] 15: \ 16: \ The pronunciation is also used for forming C names. 17: \ 18: \ 19: \ 20: \ These informations are automatically translated into C-code for the 21: \ interpreter and into some other files. I hope that your C compiler has 22: \ decent optimization, otherwise the automatically generated code will 23: \ be somewhat slow. The Forth version of the code is included for manual 24: \ compilers, so they will need to compile only the important words. 25: \ 26: \ Note that stack pointer adjustment is performed according to stack 27: \ effect by automatically generated code and NEXT is automatically 28: \ appended to the C code. Also, you can use the names in the stack 29: \ effect in the C code. Stack access is automatic. One exception: if 30: \ your code does not fall through, the results are not stored into the 31: \ stack. Use different names on both sides of the '--', if you change a 32: \ value (some stores to the stack are optimized away). 33: \ 34: \ 35: \ 36: \ The stack variables have the following types: 37: \ 38: \ name matches type 39: \ f.* Bool 40: \ c.* Char 41: \ [nw].* Cell 42: \ u.* UCell 43: \ d.* DCell 44: \ ud.* UDCell 45: \ r.* Float 46: \ a_.* Cell * 47: \ c_.* Char * 48: \ f_.* Float * 49: \ df_.* DFloat * 50: \ sf_.* SFloat * 51: \ xt.* XT 52: \ wid.* WID 53: \ f83name.* F83Name * 54: \ 55: \ 56: \ 57: \ In addition the following names can be used: 58: \ ip the instruction pointer 59: \ sp the data stack pointer 60: \ rp the parameter stack pointer 61: \ lp the locals stack pointer 62: \ NEXT executes NEXT 63: \ cfa 64: \ NEXT1 executes NEXT1 65: \ FLAG(x) makes a Forth flag from a C flag 66: \ 67: \ 68: \ 69: \ Percentages in comments are from Koopmans book: average/maximum use 70: \ (taken from four, not very representative benchmarks) 71: \ 72: \ 73: \ 74: \ To do: 75: \ 76: \ throw execute, cfa and NEXT1 out? 77: \ macroize *ip, ip++, *ip++ (pipelining)? 78: 79: \ these m4 macros would collide with identifiers 80: undefine(`index') 81: undefine(`shift') 82: 83: noop -- fig 84: ; 85: : 86: ; 87: 88: lit -- w fig 89: w = (Cell)*ip++; 90: 91: execute xt -- core,fig 92: cfa = xt; 93: IF_TOS(TOS = sp[0]); 94: NEXT1; 95: 96: branch-lp+!# -- new branch_lp_plus_store_number 97: /* this will probably not be used */ 98: branch_adjust_lp: 99: lp += (int)(ip[1]); 100: goto branch; 101: 102: branch -- fig 103: branch: 104: ip = (Xt *)(((int)ip)+(int)*ip); 105: : 106: r> dup @ + >r ; 107: 108: \ condbranch(forthname,restline,code) 109: \ this is non-syntactical: code must open a brace that is close by the macro 110: define(condbranch, 111: $1 $2 112: $3 goto branch; 113: } 114: else 115: ip++; 116: 117: $1-lp+!# $2_lp_plus_store_number 118: $3 goto branch_adjust_lp; 119: } 120: else 121: ip+=2; 122: 123: ) 124: 125: condbranch(?branch,f -- f83 question_branch, 126: if (f==0) { 127: IF_TOS(TOS = sp[0]); 128: ) 129: 130: condbranch((next),-- cmFORTH paren_next, 131: if ((*rp)--) { 132: ) 133: 134: condbranch((loop),-- fig paren_loop, 135: int index = *rp+1; 136: int limit = rp[1]; 137: if (index != limit) { 138: *rp = index; 139: ) 140: 141: condbranch((+loop),n -- fig paren_plus_loop, 142: /* !! check this thoroughly */ 143: int index = *rp; 144: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ 145: /* dependent upon two's complement arithmetic */ 146: int olddiff = index-rp[1]; 147: #ifdef undefined 148: if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ 149: || (olddiff^n)>=0 /* it is a wrap-around effect */) { 150: #else 151: #ifndef MAXINT 152: #define MAXINT ((1<<(8*sizeof(Cell)-1))-1) 153: #endif 154: if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) { 155: #endif 156: #ifdef i386 157: *rp += n; 158: #else 159: *rp = index + n; 160: #endif 161: IF_TOS(TOS = sp[0]); 162: ) 163: 164: condbranch((s+loop),n -- new paren_symmetric_plus_loop, 165: ""The run-time procedure compiled by S+LOOP. It loops until the index 166: crosses the boundary between limit and limit-sign(n). I.e. a symmetric 167: version of (+LOOP)."" 168: /* !! check this thoroughly */ 169: int index = *rp; 170: int diff = index-rp[1]; 171: int newdiff = diff+n; 172: if (n<0) { 173: diff = -diff; 174: newdiff = -newdiff; 175: } 176: if (diff>=0 || newdiff<0) { 177: #ifdef i386 178: *rp += n; 179: #else 180: *rp = index + n; 181: #endif 182: IF_TOS(TOS = sp[0]); 183: ) 184: 185: unloop -- core 186: rp += 2; 187: : 188: r> rdrop rdrop >r ; 189: 190: (for) ncount -- cmFORTH paren_for 191: /* or (for) = >r -- collides with unloop! */ 192: *--rp = 0; 193: *--rp = ncount; 194: : 195: r> swap 0 >r >r >r ; 196: 197: (do) nlimit nstart -- fig paren_do 198: /* or do it in high-level? 0.09/0.23% */ 199: *--rp = nlimit; 200: *--rp = nstart; 201: : 202: r> -rot swap >r >r >r ; 203: 204: (?do) nlimit nstart -- core-ext paren_question_do 205: *--rp = nlimit; 206: *--rp = nstart; 207: if (nstart == nlimit) { 208: IF_TOS(TOS = sp[0]); 209: goto branch; 210: } 211: else { 212: ip++; 213: } 214: 215: i -- n core,fig 216: n = *rp; 217: 218: j -- n core 219: n = rp[2]; 220: 221: \ digit is high-level: 0/0% 222: 223: (emit) c -- fig paren_emit 224: putchar(c); 225: emitcounter++; 226: 227: (type) c_addr n -- fig paren_type 228: fwrite(c_addr,sizeof(Char),n,stdout); 229: emitcounter += n; 230: 231: (key) -- n fig paren_key 232: fflush(stdout); 233: /* !! noecho */ 234: n = key(); 235: 236: key? -- n fig key_q 237: fflush(stdout); 238: n = key_query; 239: 240: cr -- fig 241: puts(""); 242: : 243: $0A emit ; 244: 245: move c_from c_to ucount -- core 246: memmove(c_to,c_from,ucount); 247: /* make an Ifdef for bsd and others? */ 248: : 249: >r 2dup u< IF r> cmove> ELSE r> cmove THEN ; 250: 251: cmove c_from c_to u -- string 252: while (u-- > 0) 253: *c_to++ = *c_from++; 254: : 255: bounds ?DO dup c@ I c! 1+ LOOP drop ; 256: 257: cmove> c_from c_to u -- string c_move_up 258: while (u-- > 0) 259: c_to[u] = c_from[u]; 260: : 261: dup 0= IF drop 2drop exit THEN 262: rot over + -rot bounds swap 1- 263: DO 1- dup c@ I c! -1 +LOOP drop ; 264: 265: fill c_addr u c -- core 266: memset(c_addr,c,u); 267: : 268: -rot bounds 269: ?DO dup I c! LOOP drop ; 270: 271: compare c_addr1 u1 c_addr2 u2 -- n string 272: ""Compare the strings lexicographically. If they are equal, n is 0; if 273: the first string is smaller, n is -1; if the first string is larger, n 274: is 1. Currently this is based on the machine's character 275: comparison. In the future, this may change to considering the current 276: locale and its collation order."" 277: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); 278: if (n==0) 279: n = u1-u2; 280: if (n<0) 281: n = -1; 282: else if (n>0) 283: n = 1; 284: : 285: rot 2dup - >r min swap -text dup 286: IF rdrop 287: ELSE drop r@ 0> 288: IF rdrop -1 289: ELSE r> 1 and 290: THEN 291: THEN ; 292: 293: -text c_addr1 u c_addr2 -- n new dash_text 294: n = memcmp(c_addr1, c_addr2, u); 295: if (n<0) 296: n = -1; 297: else if (n>0) 298: n = 1; 299: : 300: swap bounds 301: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 302: ELSE c@ I c@ - unloop THEN -text-flag ; 303: : -text-flag ( n -- -1/0/1 ) 304: dup 0< IF drop -1 ELSE 0> IF 1 ELSE 0 THEN THEN ; 305: 306: capscomp c_addr1 u c_addr2 -- n new 307: Char c1, c2; 308: for (;; u--, c_addr1++, c_addr2++) { 309: if (u == 0) { 310: n = 0; 311: break; 312: } 313: c1 = toupper(*c_addr1); 314: c2 = toupper(*c_addr2); 315: if (c1 != c2) { 316: if (c1 < c2) 317: n = -1; 318: else 319: n = 1; 320: break; 321: } 322: } 323: : 324: swap bounds 325: ?DO dup c@ toupper I c@ toupper = WHILE 1+ LOOP drop 0 326: ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ; 327: 328: -trailing c_addr u1 -- c_addr u2 string dash_trailing 329: u2 = u1; 330: while (c_addr[u2-1] == ' ') 331: u2--; 332: : 333: BEGIN 1- 2dup + c@ bl = WHILE 334: dup 0= UNTIL ELSE 1+ THEN ; 335: 336: /string c_addr1 u1 n -- c_addr2 u2 string slash_string 337: c_addr2 = c_addr1+n; 338: u2 = u1-n; 339: : 340: tuck - >r + r> dup 0< IF - 0 THEN ; 341: 342: + n1 n2 -- n core,fig plus 343: n = n1+n2; 344: 345: - n1 n2 -- n core,fig minus 346: n = n1-n2; 347: : 348: negate + ; 349: 350: negate n1 -- n2 core,fig 351: /* use minus as alias */ 352: n2 = -n1; 353: : 354: invert 1+ ; 355: 356: 1+ n1 -- n2 core one_plus 357: n2 = n1+1; 358: : 359: 1 + ; 360: 361: 1- n1 -- n2 core one_minus 362: n2 = n1-1; 363: : 364: 1 - ; 365: 366: max n1 n2 -- n core 367: if (n1<n2) 368: n = n2; 369: else 370: n = n1; 371: : 372: 2dup < IF swap THEN drop ; 373: 374: min n1 n2 -- n core 375: if (n1<n2) 376: n = n1; 377: else 378: n = n2; 379: : 380: 2dup > IF swap THEN drop ; 381: 382: abs n1 -- n2 core 383: if (n1<0) 384: n2 = -n1; 385: else 386: n2 = n1; 387: : 388: dup 0< IF negate THEN ; 389: 390: * n1 n2 -- n core,fig star 391: n = n1*n2; 392: : 393: um* drop ; 394: 395: / n1 n2 -- n core,fig slash 396: n = n1/n2; 397: : 398: /mod nip ; 399: 400: mod n1 n2 -- n core 401: n = n1%n2; 402: : 403: /mod drop ; 404: 405: /mod n1 n2 -- n3 n4 core slash_mod 406: n4 = n1/n2; 407: n3 = n1%n2; /* !! is this correct? look into C standard! */ 408: : 409: >r s>d r> fm/mod ; 410: 411: 2* n1 -- n2 core two_star 412: n2 = 2*n1; 413: : 414: dup + ; 415: 416: 2/ n1 -- n2 core two_slash 417: /* !! is this still correct? */ 418: n2 = n1>>1; 419: 420: fm/mod d1 n1 -- n2 n3 core f_m_slash_mod 421: ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1"" 422: /* assumes that the processor uses either floored or symmetric division */ 423: n3 = d1/n1; 424: n2 = d1%n1; 425: /* note that this 1%-3>0 is optimized by the compiler */ 426: if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) { 427: n3--; 428: n2+=n1; 429: } 430: 431: sm/rem d1 n1 -- n2 n3 core s_m_slash_rem 432: ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0"" 433: /* assumes that the processor uses either floored or symmetric division */ 434: n3 = d1/n1; 435: n2 = d1%n1; 436: /* note that this 1%-3<0 is optimized by the compiler */ 437: if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) { 438: n3++; 439: n2-=n1; 440: } 441: : 442: over >r dup >r abs -rot 443: dabs rot um/mod 444: r> 0< IF negate THEN 445: r> 0< IF swap negate swap THEN ; 446: 447: m* n1 n2 -- d core m_star 448: d = (DCell)n1 * (DCell)n2; 449: : 450: 2dup 0< and >r 451: 2dup swap 0< and >r 452: um* r> - r> - ; 453: 454: um* u1 u2 -- ud core u_m_star 455: /* use u* as alias */ 456: ud = (UDCell)u1 * (UDCell)u2; 457: 458: um/mod ud u1 -- u2 u3 core u_m_slash_mod 459: u3 = ud/u1; 460: u2 = ud%u1; 461: : 462: dup IF 0 (um/mod) THEN nip ; 463: : (um/mod) ( ud ud--ud u) 464: 2dup >r >r dup 0< 465: IF 2drop 0 466: ELSE 2dup d+ (um/mod) 2* THEN 467: -rot r> r> 2over 2over du< 468: IF 2drop rot 469: ELSE dnegate d+ rot 1+ THEN ; 470: 471: m+ d1 n -- d2 double m_plus 472: d2 = d1+n; 473: : 474: s>d d+ ; 475: 476: d+ d1 d2 -- d double,fig d_plus 477: d = d1+d2; 478: : 479: >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/ 480: r> + >r + r> 0< r> r> + swap - ; 481: 482: d- d1 d2 -- d double d_minus 483: d = d1-d2; 484: : 485: dnegate d+ ; 486: 487: dnegate d1 -- d2 double 488: /* use dminus as alias */ 489: d2 = -d1; 490: : 491: invert swap negate tuck 0= - ; 492: 493: dmax d1 d2 -- d double 494: if (d1<d2) 495: d = d2; 496: else 497: d = d1; 498: : 499: 2over 2over d> IF 2swap THEN 2drop ; 500: 501: dmin d1 d2 -- d double 502: if (d1<d2) 503: d = d1; 504: else 505: d = d2; 506: : 507: 2over 2over d< IF 2swap THEN 2drop ; 508: 509: dabs d1 -- d2 double 510: if (d1<0) 511: d2 = -d1; 512: else 513: d2 = d1; 514: : 515: dup 0< IF dnegate THEN ; 516: 517: d2* d1 -- d2 double d_two_star 518: d2 = 2*d1; 519: : 520: 2dup d+ ; 521: 522: d2/ d1 -- d2 double d_two_slash 523: /* !! is this still correct? */ 524: d2 = d1>>1; 525: : 526: dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and 527: r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ; 528: 529: d>s d -- n double d_to_s 530: /* make this an alias for drop? */ 531: n = d; 532: : 533: drop ; 534: 535: and w1 w2 -- w core,fig 536: w = w1&w2; 537: 538: or w1 w2 -- w core,fig 539: w = w1|w2; 540: 541: xor w1 w2 -- w core,fig 542: w = w1^w2; 543: 544: invert w1 -- w2 core 545: w2 = ~w1; 546: : 547: -1 xor ; 548: 549: rshift u1 n -- u2 core 550: u2 = u1>>n; 551: 552: lshift u1 n -- u2 core 553: u2 = u1<<n; 554: 555: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) 556: define(comparisons, 557: $1= $2 -- f $6 $3equals 558: f = FLAG($4==$5); 559: 560: $1<> $2 -- f $7 $3different 561: /* use != as alias ? */ 562: f = FLAG($4!=$5); 563: 564: $1< $2 -- f $8 $3less 565: f = FLAG($4<$5); 566: 567: $1> $2 -- f $9 $3greater 568: f = FLAG($4>$5); 569: 570: $1<= $2 -- f new $3less_or_equal 571: f = FLAG($4<=$5); 572: 573: $1>= $2 -- f new $3greater_or_equal 574: f = FLAG($4>=$5); 575: 576: ) 577: 578: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext) 579: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core) 580: comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext) 581: comparisons(d, d1 d2, d_, d1, d2, double, new, double, new) 582: comparisons(d0, d, d_zero_, d, 0, double, new, double, new) 583: comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new) 584: 585: within u1 u2 u3 -- f core-ext 586: f = FLAG(u1-u2 < u3-u2); 587: : 588: over - >r - r> u< ; 589: 590: sp@ -- a_addr fig spat 591: a_addr = sp+1; 592: 593: sp! a_addr -- fig spstore 594: sp = a_addr; 595: /* works with and without TOS caching */ 596: 597: rp@ -- a_addr fig rpat 598: a_addr = rp; 599: 600: rp! a_addr -- fig rpstore 601: rp = a_addr; 602: 603: fp@ -- f_addr new fp_fetch 604: f_addr = fp; 605: 606: fp! f_addr -- new fp_store 607: fp = f_addr; 608: 609: ;s -- fig semis 610: ip = (Xt *)(*rp++); 611: 612: >r w -- core,fig to_r 613: *--rp = w; 614: 615: r> -- w core,fig r_from 616: w = *rp++; 617: 618: r@ -- w core,fig r_fetch 619: /* use r as alias */ 620: /* make r@ an alias for i */ 621: w = *rp; 622: 623: rdrop -- fig 624: rp++; 625: 626: i' -- w fig i_tick 627: w=rp[1]; 628: 629: 2>r w1 w2 -- core-ext two_to_r 630: *--rp = w1; 631: *--rp = w2; 632: 633: 2r> -- w1 w2 core-ext two_r_from 634: w2 = *rp++; 635: w1 = *rp++; 636: 637: 2r@ -- w1 w2 core-ext two_r_fetch 638: w2 = rp[0]; 639: w1 = rp[1]; 640: 641: 2rdrop -- new two_r_drop 642: rp+=2; 643: 644: over w1 w2 -- w1 w2 w1 core,fig 645: 646: drop w -- core,fig 647: 648: swap w1 w2 -- w2 w1 core,fig 649: 650: dup w -- w w core,fig 651: 652: rot w1 w2 w3 -- w2 w3 w1 core rote 653: 654: -rot w1 w2 w3 -- w3 w1 w2 fig not_rote 655: : 656: rot rot ; 657: 658: nip w1 w2 -- w2 core-ext 659: : 660: swap drop ; 661: 662: tuck w1 w2 -- w2 w1 w2 core-ext 663: : 664: swap over ; 665: 666: ?dup w -- w core question_dupe 667: if (w!=0) { 668: IF_TOS(*sp-- = w;) 669: #ifndef USE_TOS 670: *--sp = w; 671: #endif 672: } 673: : 674: dup IF dup THEN ; 675: 676: pick u -- w core-ext 677: w = sp[u+1]; 678: : 679: 1+ cells sp@ + @ ; 680: 681: 2drop w1 w2 -- core two_drop 682: : 683: drop drop ; 684: 685: 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe 686: : 687: over over ; 688: 689: 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over 690: : 691: 3 pick 3 pick ; 692: 693: 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap 694: : 695: >r -rot r> -rot ; 696: 697: 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double two_rote 698: : 699: >r >r 2swap r> r> 2swap ; 700: 701: \ toggle is high-level: 0.11/0.42% 702: 703: @ a_addr -- w fig fetch 704: w = *a_addr; 705: 706: ! w a_addr -- core,fig store 707: *a_addr = w; 708: 709: +! n a_addr -- core,fig plus_store 710: *a_addr += n; 711: 712: c@ c_addr -- c fig cfetch 713: c = *c_addr; 714: 715: c! c c_addr -- fig cstore 716: *c_addr = c; 717: 718: 2! w1 w2 a_addr -- core two_store 719: a_addr[0] = w2; 720: a_addr[1] = w1; 721: : 722: tuck ! cell+ ! ; 723: 724: 2@ a_addr -- w1 w2 core two_fetch 725: w2 = a_addr[0]; 726: w1 = a_addr[1]; 727: : 728: dup cell+ @ swap @ ; 729: 730: d! d a_addr -- double d_store 731: /* !! alignment problems on some machines */ 732: *(DCell *)a_addr = d; 733: 734: d@ a_addr -- d double d_fetch 735: d = *(DCell *)a_addr; 736: 737: cell+ a_addr1 -- a_addr2 core cell_plus 738: a_addr2 = a_addr1+1; 739: : 740: [ cell ] Literal + ; 741: 742: cells n1 -- n2 core 743: n2 = n1 * sizeof(Cell); 744: : 745: [ cell ] 746: [ 2/ dup ] [IF] 2* [THEN] 747: [ 2/ dup ] [IF] 2* [THEN] 748: [ 2/ dup ] [IF] 2* [THEN] 749: [ 2/ dup ] [IF] 2* [THEN] 750: [ drop ] ; 751: 752: char+ c_addr1 -- c_addr2 core care_plus 753: c_addr2 = c_addr1 + 1; 754: : 755: 1+ ; 756: 757: (chars) n1 -- n2 gforth paren_cares 758: n2 = n1 * sizeof(Char); 759: : 760: ; 761: 762: count c_addr1 -- c_addr2 u core 763: u = *c_addr1; 764: c_addr2 = c_addr1+1; 765: : 766: dup 1+ swap c@ ; 767: 768: (bye) n -- toolkit-ext paren_bye 769: return (Label *)n; 770: 771: system c_addr u -- n own 772: n=system(cstr(c_addr,u,1)); 773: 774: getenv c_addr1 u1 -- c_addr2 u2 new 775: c_addr2 = getenv(cstr(c_addr1,u1,1)); 776: u2=strlen(c_addr2); 777: 778: popen c_addr u n -- wfileid own 779: static char* mode[2]={"r","w"}; 780: wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]); 781: 782: pclose wfileid -- wior own 783: wior=pclose((FILE *)wfileid); 784: 785: time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date 786: struct timeval time1; 787: struct timezone zone1; 788: struct tm *ltime; 789: gettimeofday(&time1,&zone1); 790: ltime=localtime(&time1.tv_sec); 791: nyear =ltime->tm_year+1900; 792: nmonth=ltime->tm_mon+1; 793: nday =ltime->tm_mday; 794: nhour =ltime->tm_hour; 795: nmin =ltime->tm_min; 796: nsec =ltime->tm_sec; 797: 798: ms n -- facility-ext 799: struct timeval timeout; 800: timeout.tv_sec=n/1000; 801: timeout.tv_usec=1000*(n%1000); 802: (void)select(0,0,0,0,&timeout); 803: 804: allocate u -- a_addr wior memory 805: a_addr = (Cell *)malloc(u); 806: wior = a_addr==NULL; /* !! Define a return code */ 807: 808: free a_addr -- wior memory 809: free(a_addr); 810: wior = 0; 811: 812: resize a_addr1 u -- a_addr2 wior memory 813: a_addr2 = realloc(a_addr1, u); 814: wior = a_addr2==NULL; /* !! Define a return code */ 815: 816: (f83find) c_addr u f83name1 -- f83name2 new paren_f83find 817: for (; f83name1 != NULL; f83name1 = f83name1->next) 818: if (F83NAME_COUNT(f83name1)==u && 819: strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) 820: break; 821: f83name2=f83name1; 822: : 823: BEGIN dup WHILE 824: >r dup r@ cell+ c@ $1F and = 825: IF 2dup r@ cell+ char+ capscomp 0= 826: IF 2drop r> EXIT THEN THEN 827: r> @ 828: REPEAT nip nip ; 829: 830: (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind 831: F83Name *f83name1; 832: f83name2=NULL; 833: while(a_addr != NULL) 834: { 835: f83name1=(F83Name *)(a_addr[1]); 836: a_addr=(Cell *)(a_addr[0]); 837: if (F83NAME_COUNT(f83name1)==u && 838: strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) 839: { 840: f83name2=f83name1; 841: break; 842: } 843: } 844: : 845: BEGIN dup WHILE 846: 2@ >r >r dup r@ cell+ c@ $1F and = 847: IF 2dup r@ cell+ char+ capscomp 0= 848: IF 2drop r> rdrop EXIT THEN THEN 849: rdrop r> 850: REPEAT nip nip ; 851: 852: (hashkey) c_addr u1 -- u2 new paren_hashkey 853: u2=0; 854: while(u1--) 855: u2+=(int)toupper(*c_addr++); 856: : 857: 0 -rot bounds ?DO I c@ toupper + LOOP ; 858: 859: (hashkey1) c_addr u ubits -- ukey new paren_hashkey1 860: ""ukey is the hash key for the string c_addr u fitting in ubits bits"" 861: /* this hash function rotates the key at every step by rot bits within 862: ubits bits and xors it with the character. This function does ok in 863: the chi-sqare-test. Rot should be <=7 (preferably <=5) for 864: ASCII strings (larger if ubits is large), and should share no 865: divisors with ubits. 866: */ 867: 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]; 868: Char *cp = c_addr; 869: for (ukey=0; cp<c_addr+u; cp++) 870: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) 871: ^ toupper(*cp)) 872: & ((1<<ubits)-1)); 873: : 874: dup rot-values + c@ over 1 swap lshift 1- >r 875: tuck - 2swap r> 0 2swap bounds 876: ?DO dup 4 pick lshift swap 3 pick rshift or 877: I c@ toupper xor 878: over and LOOP 879: nip nip nip ; 880: Create rot-values 881: 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c, 882: 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c, 883: 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, 884: 7 c, 5 c, 5 c, 885: 886: (parse-white) c_addr1 u1 -- c_addr2 u2 new paren_parse_white 887: /* use !isgraph instead of isspace? */ 888: Char *endp = c_addr1+u1; 889: while (c_addr1<endp && isspace(*c_addr1)) 890: c_addr1++; 891: if (c_addr1<endp) { 892: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++) 893: ; 894: u2 = c_addr1-c_addr2; 895: } 896: else { 897: c_addr2 = c_addr1; 898: u2 = 0; 899: } 900: : 901: BEGIN dup WHILE over c@ bl <= WHILE 1 /string 902: REPEAT THEN 2dup 903: BEGIN dup WHILE over c@ bl > WHILE 1 /string 904: REPEAT THEN nip - ; 905: 906: close-file wfileid -- wior file close_file 907: wior = FILEIO(fclose((FILE *)wfileid)==EOF); 908: 909: open-file c_addr u ntype -- w2 wior file open_file 910: w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]); 911: wior = FILEEXIST(w2 == NULL); 912: 913: create-file c_addr u ntype -- w2 wior file create_file 914: int fd; 915: fd = creat(cstr(c_addr, u, 1), 0644); 916: if (fd > -1) { 917: w2 = (Cell)fdopen(fd, fileattr[ntype]); 918: assert(w2 != NULL); 919: wior = 0; 920: } else { 921: assert(fd == -1); 922: wior = FILEIO(fd); 923: w2 = 0; 924: } 925: 926: delete-file c_addr u -- wior file delete_file 927: wior = FILEEXIST(unlink(cstr(c_addr, u, 1))); 928: 929: rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file 930: char *s1=cstr(c_addr2, u2, 1); 931: wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1)); 932: 933: file-position wfileid -- ud wior file file_position 934: /* !! use tell and lseek? */ 935: ud = ftell((FILE *)wfileid); 936: wior = 0; /* !! or wior = FLAG(ud<0) */ 937: 938: reposition-file ud wfileid -- wior file reposition_file 939: wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET)); 940: 941: file-size wfileid -- ud wior file file_size 942: struct stat buf; 943: wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf)); 944: ud = buf.st_size; 945: 946: resize-file ud wfileid -- wior file resize_file 947: wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud)); 948: 949: read-file c_addr u1 wfileid -- u2 wior file read_file 950: /* !! fread does not guarantee enough */ 951: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); 952: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); 953: /* !! who performs clearerr((FILE *)wfileid); ? */ 954: 955: read-line c_addr u1 wfileid -- u2 flag wior file read_line 956: /* 957: Cell c; 958: flag=-1; 959: for(u2=0; u2<u1; u2++) 960: { 961: *c_addr++ = (Char)(c = getc((FILE *)wfileid)); 962: if(c=='\n') break; 963: if(c==EOF) 964: { 965: flag=FLAG(u2!=0); 966: break; 967: } 968: } 969: wior=FILEIO(ferror((FILE *)wfileid)); 970: */ 971: if ((flag=FLAG(!feof((FILE *)wfileid) && 972: fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { 973: wior=FILEIO(ferror((FILE *)wfileid)); 974: u2 = strlen(c_addr); 975: u2-=((u2>0) && (c_addr[u2-1]==NEWLINE)); 976: } 977: else { 978: wior=0; 979: u2=0; 980: } 981: 982: write-file c_addr u1 wfileid -- wior file write_file 983: /* !! fwrite does not guarantee enough */ 984: { 985: int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); 986: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); 987: } 988: 989: flush-file wfileid -- wior file-ext flush_file 990: wior = FILEIO(fflush((FILE *) wfileid)); 991: 992: comparisons(f, r1 r2, f_, r1, r2, new, new, float, new) 993: comparisons(f0, r, f_zero_, r, 0., float, new, float, new) 994: 995: d>f d -- r float d_to_f 996: r = d; 997: 998: f>d r -- d float f_to_d 999: /* !! basis 15 is not very specific */ 1000: d = r; 1001: 1002: f! r f_addr -- float f_store 1003: *f_addr = r; 1004: 1005: f@ f_addr -- r float f_fetch 1006: r = *f_addr; 1007: 1008: df@ df_addr -- r float-ext d_f_fetch 1009: #ifdef IEEE_FP 1010: r = *df_addr; 1011: #else 1012: !! df@ 1013: #endif 1014: 1015: df! r df_addr -- float-ext d_f_store 1016: #ifdef IEEE_FP 1017: *df_addr = r; 1018: #else 1019: !! df! 1020: #endif 1021: 1022: sf@ sf_addr -- r float-ext s_f_fetch 1023: #ifdef IEEE_FP 1024: r = *sf_addr; 1025: #else 1026: !! sf@ 1027: #endif 1028: 1029: sf! r sf_addr -- float-ext s_f_store 1030: #ifdef IEEE_FP 1031: *sf_addr = r; 1032: #else 1033: !! sf! 1034: #endif 1035: 1036: f+ r1 r2 -- r3 float f_plus 1037: r3 = r1+r2; 1038: 1039: f- r1 r2 -- r3 float f_minus 1040: r3 = r1-r2; 1041: 1042: f* r1 r2 -- r3 float f_star 1043: r3 = r1*r2; 1044: 1045: f/ r1 r2 -- r3 float f_slash 1046: r3 = r1/r2; 1047: 1048: f** r1 r2 -- r3 float-ext f_star_star 1049: r3 = pow(r1,r2); 1050: 1051: fnegate r1 -- r2 float 1052: r2 = - r1; 1053: 1054: fdrop r -- float 1055: 1056: fdup r -- r r float 1057: 1058: fswap r1 r2 -- r2 r1 float 1059: 1060: fover r1 r2 -- r1 r2 r1 float 1061: 1062: frot r1 r2 r3 -- r2 r3 r1 float 1063: 1064: float+ f_addr1 -- f_addr2 float float_plus 1065: f_addr2 = f_addr1+1; 1066: 1067: floats n1 -- n2 float 1068: n2 = n1*sizeof(Float); 1069: 1070: floor r1 -- r2 float 1071: /* !! unclear wording */ 1072: r2 = floor(r1); 1073: 1074: fround r1 -- r2 float 1075: /* !! unclear wording */ 1076: #ifdef HAVE_RINT 1077: r2 = rint(r1); 1078: #else 1079: r2 = floor(r1+0.5); 1080: /* !! This is not quite true to the rounding rules given in the standard */ 1081: #endif 1082: 1083: fmax r1 r2 -- r3 float 1084: if (r1<r2) 1085: r3 = r2; 1086: else 1087: r3 = r1; 1088: 1089: fmin r1 r2 -- r3 float 1090: if (r1<r2) 1091: r3 = r1; 1092: else 1093: r3 = r2; 1094: 1095: represent r c_addr u -- n f1 f2 float 1096: char *sig; 1097: int flag; 1098: int decpt; 1099: sig=ecvt(r, u, &decpt, &flag); 1100: n=decpt; 1101: f1=FLAG(flag!=0); 1102: f2=FLAG(isdigit(sig[0])!=0); 1103: memmove(c_addr,sig,u); 1104: 1105: >float c_addr u -- flag float to_float 1106: /* real signature: c_addr u -- r t / f */ 1107: Float r; 1108: char *number=cstr(c_addr, u, 1); 1109: char *endconv; 1110: while(isspace(number[u-1])) u--; 1111: switch(number[u-1]) 1112: { 1113: case 'd': 1114: case 'D': 1115: case 'e': 1116: case 'E': u--; break; 1117: default: break; 1118: } 1119: number[u]='\0'; 1120: r=strtod(number,&endconv); 1121: if((flag=FLAG(!(int)*endconv))) 1122: { 1123: IF_FTOS(fp[0] = FTOS); 1124: fp += -1; 1125: FTOS = r; 1126: } 1127: else if(*endconv=='d' || *endconv=='D') 1128: { 1129: *endconv='E'; 1130: r=strtod(number,&endconv); 1131: if((flag=FLAG(!(int)*endconv))) 1132: { 1133: IF_FTOS(fp[0] = FTOS); 1134: fp += -1; 1135: FTOS = r; 1136: } 1137: } 1138: 1139: fabs r1 -- r2 float-ext 1140: r2 = fabs(r1); 1141: 1142: facos r1 -- r2 float-ext 1143: r2 = acos(r1); 1144: 1145: fasin r1 -- r2 float-ext 1146: r2 = asin(r1); 1147: 1148: fatan r1 -- r2 float-ext 1149: r2 = atan(r1); 1150: 1151: fatan2 r1 r2 -- r3 float-ext 1152: r3 = atan2(r1,r2); 1153: 1154: fcos r1 -- r2 float-ext 1155: r2 = cos(r1); 1156: 1157: fexp r1 -- r2 float-ext 1158: r2 = exp(r1); 1159: 1160: fexpm1 r1 -- r2 float-ext 1161: r2 = 1162: #ifdef HAS_EXPM1 1163: expm1(r1); 1164: #else 1165: exp(r1)-1; 1166: #endif 1167: 1168: fln r1 -- r2 float-ext 1169: r2 = log(r1); 1170: 1171: flnp1 r1 -- r2 float-ext 1172: r2 = 1173: #ifdef HAS_LOG1P 1174: log1p(r1); 1175: #else 1176: log(r1+1); 1177: #endif 1178: 1179: flog r1 -- r2 float-ext 1180: r2 = log10(r1); 1181: 1182: fsin r1 -- r2 float-ext 1183: r2 = sin(r1); 1184: 1185: fsincos r1 -- r2 r3 float-ext 1186: r2 = sin(r1); 1187: r3 = cos(r1); 1188: 1189: fsqrt r1 -- r2 float-ext 1190: r2 = sqrt(r1); 1191: 1192: ftan r1 -- r2 float-ext 1193: r2 = tan(r1); 1194: 1195: \ The following words access machine/OS/installation-dependent ANSI 1196: \ figForth internals 1197: \ !! how about environmental queries DIRECT-THREADED, 1198: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ 1199: 1200: >body xt -- a_addr core to_body 1201: a_addr = PFA(xt); 1202: 1203: >code-address xt -- c_addr new to_code_address 1204: ""c_addr is the code address of the word xt"" 1205: /* !! This behaves installation-dependently for DOES-words */ 1206: c_addr = CODE_ADDRESS(xt); 1207: 1208: >does-code xt -- a_addr new to_does_code 1209: ""If xt ist the execution token of a defining-word-defined word, 1210: a_addr is the start of the Forth code after the DOES>; Otherwise the 1211: behaviour is uundefined"" 1212: /* !! there is currently no way to determine whether a word is 1213: defining-word-defined */ 1214: a_addr = (Cell *)DOES_CODE(xt); 1215: 1216: code-address! n xt -- new code_address_store 1217: ""Creates a code field with code address c_addr at xt"" 1218: MAKE_CF(xt, symbols[CF(n)]); 1219: CACHE_FLUSH(xt,PFA(0)); 1220: 1221: does-code! a_addr xt -- new does_code_store 1222: ""creates a code field at xt for a defining-word-defined word; a_addr 1223: is the start of the Forth code after DOES>"" 1224: MAKE_DOES_CF(xt, a_addr); 1225: CACHE_FLUSH(xt,PFA(0)); 1226: 1227: does-handler! a_addr -- new does_jump_store 1228: ""creates a DOES>-handler at address a_addr. a_addr usually points 1229: just behind a DOES>."" 1230: MAKE_DOES_HANDLER(a_addr); 1231: CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE); 1232: 1233: /does-handler -- n new slash_does_handler 1234: ""the size of a does-handler (includes possible padding)"" 1235: /* !! a constant or environmental query might be better */ 1236: n = DOES_HANDLER_SIZE; 1237: 1238: toupper c1 -- c2 new 1239: c2 = toupper(c1); 1240: 1241: \ local variable implementation primitives 1242: @local# -- w new fetch_local_number 1243: w = *(Cell *)(lp+(int)(*ip++)); 1244: 1245: @local0 -- w new fetch_local_zero 1246: w = *(Cell *)(lp+0*sizeof(Cell)); 1247: 1248: @local1 -- w new fetch_local_four 1249: w = *(Cell *)(lp+1*sizeof(Cell)); 1250: 1251: @local2 -- w new fetch_local_eight 1252: w = *(Cell *)(lp+2*sizeof(Cell)); 1253: 1254: @local3 -- w new fetch_local_twelve 1255: w = *(Cell *)(lp+3*sizeof(Cell)); 1256: 1257: f@local# -- r new f_fetch_local_number 1258: r = *(Float *)(lp+(int)(*ip++)); 1259: 1260: f@local0 -- r new f_fetch_local_zero 1261: r = *(Float *)(lp+0*sizeof(Float)); 1262: 1263: f@local1 -- r new f_fetch_local_eight 1264: r = *(Float *)(lp+1*sizeof(Float)); 1265: 1266: laddr# -- c_addr new laddr_number 1267: /* this can also be used to implement lp@ */ 1268: c_addr = (Char *)(lp+(int)(*ip++)); 1269: 1270: lp+!# -- new lp_plus_store_number 1271: ""used with negative immediate values it allocates memory on the 1272: local stack, a positive immediate argument drops memory from the local 1273: stack"" 1274: lp += (int)(*ip++); 1275: 1276: lp- -- new minus_four_lp_plus_store 1277: lp += -sizeof(Cell); 1278: 1279: lp+ -- new eight_lp_plus_store 1280: lp += sizeof(Float); 1281: 1282: lp+2 -- new sixteen_lp_plus_store 1283: lp += 2*sizeof(Float); 1284: 1285: lp! c_addr -- new lp_store 1286: lp = (Address)c_addr; 1287: 1288: >l w -- new to_l 1289: lp -= sizeof(Cell); 1290: *(Cell *)lp = w; 1291: 1292: f>l r -- new f_to_l 1293: lp -= sizeof(Float); 1294: *(Float *)lp = r; 1295: 1296: up! a_addr -- new up_store 1297: up0=up=(char *)a_addr;