gforth/primitives - view

File: [gforth] / gforth / Attic / primitives
Revision 1.18: download - view: text, annotated - select for diffs
Mon Sep 12 19:00:35 1994 UTC (29 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD

Added forth variants for primitives
Added a generator for forth primitives
Cleaned up some minor errors
Changed names of local access (was cell size dependent)
Where is "getopt.h"???!? Added tiny workaround. Where is getopt_long?

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