gforth/primitives - view

File: [gforth] / gforth / Attic / primitives
Revision 1.12: download - view: text, annotated - select for diffs
Wed Jul 13 19:21:05 1994 UTC (29 years, 9 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD

Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).

Added restrict's functionalitz to cross.fs

removed all occurency of cell+ name>, because the bug in name> is
fixed.

Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.

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