![]() ![]() | ![]() |
removed usage of libtool-2.2 ltdl functions
1: \ Gforth primitives 2: 3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc. 4: 5: \ This file is part of Gforth. 6: 7: \ Gforth is free software; you can redistribute it and/or 8: \ modify it under the terms of the GNU General Public License 9: \ as published by the Free Software Foundation, either version 3 10: \ of the License, or (at your option) any later version. 11: 12: \ This program is distributed in the hope that it will be useful, 13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15: \ GNU General Public License for more details. 16: 17: \ You should have received a copy of the GNU General Public License 18: \ along with this program. If not, see http://www.gnu.org/licenses/. 19: 20: 21: \ WARNING: This file is processed by m4. Make sure your identifiers 22: \ don't collide with m4's (e.g. by undefining them). 23: \ 24: \ 25: \ 26: \ This file contains primitive specifications in the following format: 27: \ 28: \ forth name ( stack effect ) category [pronunciation] 29: \ [""glossary entry""] 30: \ C code 31: \ [: 32: \ Forth code] 33: \ 34: \ Note: Fields in brackets are optional. Word specifications have to 35: \ be separated by at least one empty line 36: \ 37: \ Both pronounciation and stack items (in the stack effect) must 38: \ conform to the C identifier syntax or the C compiler will complain. 39: \ If you don't have a pronounciation field, the Forth name is used, 40: \ and has to conform to the C identifier syntax. 41: \ 42: \ These specifications are automatically translated into C-code for the 43: \ interpreter and into some other files. I hope that your C compiler has 44: \ decent optimization, otherwise the automatically generated code will 45: \ be somewhat slow. The Forth version of the code is included for manual 46: \ compilers, so they will need to compile only the important words. 47: \ 48: \ Note that stack pointer adjustment is performed according to stack 49: \ effect by automatically generated code and NEXT is automatically 50: \ appended to the C code. Also, you can use the names in the stack 51: \ effect in the C code. Stack access is automatic. One exception: if 52: \ your code does not fall through, the results are not stored into the 53: \ stack. Use different names on both sides of the '--', if you change a 54: \ value (some stores to the stack are optimized away). 55: \ 56: \ For superinstructions the syntax is: 57: \ 58: \ forth-name [/ c-name] = forth-name forth-name ... 59: \ 60: \ 61: \ The stack variables have the following types: 62: \ 63: \ name matches type 64: \ f.* Bool 65: \ c.* Char 66: \ [nw].* Cell 67: \ u.* UCell 68: \ d.* DCell 69: \ ud.* UDCell 70: \ r.* Float 71: \ a_.* Cell * 72: \ c_.* Char * 73: \ f_.* Float * 74: \ df_.* DFloat * 75: \ sf_.* SFloat * 76: \ xt.* XT 77: \ f83name.* F83Name * 78: 79: \E stack data-stack sp Cell 80: \E stack fp-stack fp Float 81: \E stack return-stack rp Cell 82: \E 83: \E get-current prefixes set-current 84: \E 85: \E s" Bool" single data-stack type-prefix f 86: \E s" Char" single data-stack type-prefix c 87: \E s" Cell" single data-stack type-prefix n 88: \E s" Cell" single data-stack type-prefix w 89: \E s" UCell" single data-stack type-prefix u 90: \E s" DCell" double data-stack type-prefix d 91: \E s" UDCell" double data-stack type-prefix ud 92: \E s" Float" single fp-stack type-prefix r 93: \E s" Cell *" single data-stack type-prefix a_ 94: \E s" Char *" single data-stack type-prefix c_ 95: \E s" Float *" single data-stack type-prefix f_ 96: \E s" DFloat *" single data-stack type-prefix df_ 97: \E s" SFloat *" single data-stack type-prefix sf_ 98: \E s" Xt" single data-stack type-prefix xt 99: \E s" struct F83Name *" single data-stack type-prefix f83name 100: \E s" struct Longname *" single data-stack type-prefix longname 101: \E 102: \E data-stack stack-prefix S: 103: \E fp-stack stack-prefix F: 104: \E return-stack stack-prefix R: 105: \E inst-stream stack-prefix # 106: \E 107: \E set-current 108: \E store-optimization on 109: \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump 110: \E 111: \E `include-skipped-insts' on \ static superinsts include cells for components 112: \E \ useful for dynamic programming and 113: \E \ superinsts across entry points 114: 115: \ 116: \ 117: \ 118: \ In addition the following names can be used: 119: \ ip the instruction pointer 120: \ sp the data stack pointer 121: \ rp the parameter stack pointer 122: \ lp the locals stack pointer 123: \ NEXT executes NEXT 124: \ cfa 125: \ NEXT1 executes NEXT1 126: \ FLAG(x) makes a Forth flag from a C flag 127: \ 128: \ 129: \ 130: \ Percentages in comments are from Koopmans book: average/maximum use 131: \ (taken from four, not very representative benchmarks) 132: \ 133: \ 134: \ 135: \ To do: 136: \ 137: \ throw execute, cfa and NEXT1 out? 138: \ macroize *ip, ip++, *ip++ (pipelining)? 139: 140: \ Stack caching setup 141: 142: ifdef(`STACK_CACHE_FILE', `include(STACK_CACHE_FILE)', `include(cache0.vmg)') 143: 144: \ these m4 macros would collide with identifiers 145: undefine(`index') 146: undefine(`shift') 147: undefine(`symbols') 148: 149: \F 0 [if] 150: 151: \ run-time routines for non-primitives. They are defined as 152: \ primitives, because that simplifies things. 153: 154: (docol) ( -- R:a_retaddr ) gforth-internal paren_docol 155: ""run-time routine for colon definitions"" 156: #ifdef NO_IP 157: a_retaddr = next_code; 158: INST_TAIL; 159: goto **(Label *)PFA(CFA); 160: #else /* !defined(NO_IP) */ 161: a_retaddr = (Cell *)IP; 162: SET_IP((Xt *)PFA(CFA)); 163: #endif /* !defined(NO_IP) */ 164: 165: (docon) ( -- w ) gforth-internal paren_docon 166: ""run-time routine for constants"" 167: w = *(Cell *)PFA(CFA); 168: #ifdef NO_IP 169: INST_TAIL; 170: goto *next_code; 171: #endif /* defined(NO_IP) */ 172: 173: (dovar) ( -- a_body ) gforth-internal paren_dovar 174: ""run-time routine for variables and CREATEd words"" 175: a_body = PFA(CFA); 176: #ifdef NO_IP 177: INST_TAIL; 178: goto *next_code; 179: #endif /* defined(NO_IP) */ 180: 181: (douser) ( -- a_user ) gforth-internal paren_douser 182: ""run-time routine for constants"" 183: a_user = (Cell *)(up+*(Cell *)PFA(CFA)); 184: #ifdef NO_IP 185: INST_TAIL; 186: goto *next_code; 187: #endif /* defined(NO_IP) */ 188: 189: (dodefer) ( -- ) gforth-internal paren_dodefer 190: ""run-time routine for deferred words"" 191: #ifndef NO_IP 192: ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */ 193: #endif /* !defined(NO_IP) */ 194: SUPER_END; /* !! probably unnecessary and may lead to measurement errors */ 195: VM_JUMP(EXEC1(*(Xt *)PFA(CFA))); 196: 197: (dofield) ( n1 -- n2 ) gforth-internal paren_field 198: ""run-time routine for fields"" 199: n2 = n1 + *(Cell *)PFA(CFA); 200: #ifdef NO_IP 201: INST_TAIL; 202: goto *next_code; 203: #endif /* defined(NO_IP) */ 204: 205: (dovalue) ( -- w ) gforth-internal paren_doval 206: ""run-time routine for constants"" 207: w = *(Cell *)PFA(CFA); 208: #ifdef NO_IP 209: INST_TAIL; 210: goto *next_code; 211: #endif /* defined(NO_IP) */ 212: 213: (dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes 214: ""run-time routine for @code{does>}-defined words"" 215: #ifdef NO_IP 216: a_retaddr = next_code; 217: a_body = PFA(CFA); 218: INST_TAIL; 219: #ifdef DEBUG 220: fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); 221: #endif 222: goto **(Label *)DOES_CODE1(CFA); 223: #else /* !defined(NO_IP) */ 224: a_retaddr = (Cell *)IP; 225: a_body = PFA(CFA); 226: #ifdef DEBUG 227: fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); 228: #endif 229: SET_IP(DOES_CODE1(CFA)); 230: #endif /* !defined(NO_IP) */ 231: 232: (does-handler) ( -- ) gforth-internal paren_does_handler 233: ""just a slot to have an encoding for the DOESJUMP, 234: which is no longer used anyway (!! eliminate this)"" 235: 236: \F [endif] 237: 238: \g control 239: 240: noop ( -- ) gforth 241: : 242: ; 243: 244: call ( #a_callee -- R:a_retaddr ) new 245: ""Call callee (a variant of docol with inline argument)."" 246: #ifdef NO_IP 247: assert(0); 248: INST_TAIL; 249: JUMP(a_callee); 250: #else 251: #ifdef DEBUG 252: { 253: CFA_TO_NAME((((Cell *)a_callee)-2)); 254: fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee, 255: len,name); 256: } 257: #endif 258: a_retaddr = (Cell *)IP; 259: SET_IP((Xt *)a_callee); 260: #endif 261: 262: execute ( xt -- ) core 263: ""Perform the semantics represented by the execution token, @i{xt}."" 264: #ifdef DEBUG 265: fprintf(stderr, "execute %08x\n", xt); 266: #endif 267: #ifndef NO_IP 268: ip=IP; 269: #endif 270: SUPER_END; 271: VM_JUMP(EXEC1(xt)); 272: 273: perform ( a_addr -- ) gforth 274: ""@code{@@ execute}."" 275: /* and pfe */ 276: #ifndef NO_IP 277: ip=IP; 278: #endif 279: SUPER_END; 280: VM_JUMP(EXEC1(*(Xt *)a_addr)); 281: : 282: @ execute ; 283: 284: ;s ( R:w -- ) gforth semis 285: ""The primitive compiled by @code{EXIT}."" 286: #ifdef NO_IP 287: INST_TAIL; 288: goto *(void *)w; 289: #else 290: SET_IP((Xt *)w); 291: #endif 292: 293: unloop ( R:w1 R:w2 -- ) core 294: /* !! alias for 2rdrop */ 295: : 296: r> rdrop rdrop >r ; 297: 298: lit-perform ( #a_addr -- ) new lit_perform 299: #ifndef NO_IP 300: ip=IP; 301: #endif 302: SUPER_END; 303: VM_JUMP(EXEC1(*(Xt *)a_addr)); 304: 305: does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec 306: #ifdef NO_IP 307: /* compiled to LIT CALL by compile_prim */ 308: assert(0); 309: #else 310: a_pfa = PFA(a_cfa); 311: nest = (Cell)IP; 312: #ifdef DEBUG 313: { 314: CFA_TO_NAME(a_cfa); 315: fprintf(stderr,"%08lx: does %08lx %.*s\n", 316: (Cell)ip,(Cell)a_cfa,len,name); 317: } 318: #endif 319: SET_IP(DOES_CODE1(a_cfa)); 320: #endif 321: 322: \+glocals 323: 324: branch-lp+!# ( #a_target #nlocals -- ) gforth branch_lp_plus_store_number 325: /* this will probably not be used */ 326: lp += nlocals; 327: #ifdef NO_IP 328: INST_TAIL; 329: JUMP(a_target); 330: #else 331: SET_IP((Xt *)a_target); 332: #endif 333: 334: \+ 335: 336: branch ( #a_target -- ) gforth 337: #ifdef NO_IP 338: INST_TAIL; 339: JUMP(a_target); 340: #else 341: SET_IP((Xt *)a_target); 342: #endif 343: : 344: r> @ >r ; 345: 346: \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode) 347: \ this is non-syntactical: code must open a brace that is closed by the macro 348: define(condbranch, 349: $1 ( `#'a_target $2 ) $3 350: $4 #ifdef NO_IP 351: INST_TAIL; 352: #endif 353: $5 #ifdef NO_IP 354: JUMP(a_target); 355: #else 356: SET_IP((Xt *)a_target); 357: ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */') 358: #endif 359: } 360: ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */') 361: $6 362: 363: \+glocals 364: 365: $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number 366: $4 #ifdef NO_IP 367: INST_TAIL; 368: #endif 369: $5 lp += nlocals; 370: #ifdef NO_IP 371: JUMP(a_target); 372: #else 373: SET_IP((Xt *)a_target); 374: ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */') 375: #endif 376: } 377: ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */') 378: 379: \+ 380: ) 381: 382: condbranch(?branch,f --,f83 question_branch, 383: ,if (f==0) { 384: ,: 385: 0= dup 0= \ !f f 386: r> tuck cell+ \ !f branchoffset f IP+ 387: and -rot @ and or \ f&IP+|!f&branch 388: >r ;) 389: 390: \ we don't need an lp_plus_store version of the ?dup-stuff, because it 391: \ is only used in if's (yet) 392: 393: \+xconds 394: 395: ?dup-?branch ( #a_target f -- S:... ) new question_dupe_question_branch 396: ""The run-time procedure compiled by @code{?DUP-IF}."" 397: if (f==0) { 398: #ifdef NO_IP 399: INST_TAIL; 400: JUMP(a_target); 401: #else 402: SET_IP((Xt *)a_target); 403: #endif 404: } else { 405: sp--; 406: sp[0]=f; 407: } 408: 409: ?dup-0=-?branch ( #a_target f -- S:... ) new question_dupe_zero_equals_question_branch 410: ""The run-time procedure compiled by @code{?DUP-0=-IF}."" 411: if (f!=0) { 412: sp--; 413: sp[0]=f; 414: #ifdef NO_IP 415: JUMP(a_target); 416: #else 417: SET_IP((Xt *)a_target); 418: #endif 419: } 420: 421: \+ 422: \fhas? skiploopprims 0= [IF] 423: 424: condbranch((next),R:n1 -- R:n2,cmFORTH paren_next, 425: n2=n1-1; 426: ,if (n1) { 427: ,: 428: r> r> dup 1- >r 429: IF @ >r ELSE cell+ >r THEN ;) 430: 431: condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop, 432: n2=n1+1; 433: ,if (n2 != nlimit) { 434: ,: 435: r> r> 1+ r> 2dup = 436: IF >r 1- >r cell+ >r 437: ELSE >r >r @ >r THEN ;) 438: 439: condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop, 440: /* !! check this thoroughly */ 441: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ 442: /* dependent upon two's complement arithmetic */ 443: Cell olddiff = n1-nlimit; 444: n2=n1+n; 445: ,if (((olddiff^(olddiff+n)) /* the limit is not crossed */ 446: &(olddiff^n)) /* OR it is a wrap-around effect */ 447: >=0) { /* & is used to avoid having two branches for gforth-native */ 448: ,: 449: r> swap 450: r> r> 2dup - >r 451: 2 pick r@ + r@ xor 0< 0= 452: 3 pick r> xor 0< 0= or 453: IF >r + >r @ >r 454: ELSE >r >r drop cell+ >r THEN ;) 455: 456: \+xconds 457: 458: condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop, 459: UCell olddiff = n1-nlimit; 460: n2=n1-u; 461: ,if (olddiff>u) { 462: ,) 463: 464: condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_symmetric_plus_loop, 465: ""The run-time procedure compiled by S+LOOP. It loops until the index 466: crosses the boundary between limit and limit-sign(n). I.e. a symmetric 467: version of (+LOOP)."" 468: /* !! check this thoroughly */ 469: Cell diff = n1-nlimit; 470: Cell newdiff = diff+n; 471: if (n<0) { 472: diff = -diff; 473: newdiff = -newdiff; 474: } 475: n2=n1+n; 476: ,if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */ 477: ,) 478: 479: \+ 480: 481: (for) ( ncount -- R:nlimit R:ncount ) cmFORTH paren_for 482: /* or (for) = >r -- collides with unloop! */ 483: nlimit=0; 484: : 485: r> swap 0 >r >r >r ; 486: 487: (do) ( nlimit nstart -- R:nlimit R:nstart ) gforth paren_do 488: : 489: r> swap rot >r >r >r ; 490: 491: (?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_question_do 492: #ifdef NO_IP 493: INST_TAIL; 494: #endif 495: if (nstart == nlimit) { 496: #ifdef NO_IP 497: JUMP(a_target); 498: #else 499: SET_IP((Xt *)a_target); 500: #endif 501: } 502: : 503: 2dup = 504: IF r> swap rot >r >r 505: @ >r 506: ELSE r> swap rot >r >r 507: cell+ >r 508: THEN ; \ --> CORE-EXT 509: 510: \+xconds 511: 512: (+do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do 513: #ifdef NO_IP 514: INST_TAIL; 515: #endif 516: if (nstart >= nlimit) { 517: #ifdef NO_IP 518: JUMP(a_target); 519: #else 520: SET_IP((Xt *)a_target); 521: #endif 522: } 523: : 524: swap 2dup 525: r> swap >r swap >r 526: >= 527: IF 528: @ 529: ELSE 530: cell+ 531: THEN >r ; 532: 533: (u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do 534: #ifdef NO_IP 535: INST_TAIL; 536: #endif 537: if (ustart >= ulimit) { 538: #ifdef NO_IP 539: JUMP(a_target); 540: #else 541: SET_IP((Xt *)a_target); 542: #endif 543: } 544: : 545: swap 2dup 546: r> swap >r swap >r 547: u>= 548: IF 549: @ 550: ELSE 551: cell+ 552: THEN >r ; 553: 554: (-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do 555: #ifdef NO_IP 556: INST_TAIL; 557: #endif 558: if (nstart <= nlimit) { 559: #ifdef NO_IP 560: JUMP(a_target); 561: #else 562: SET_IP((Xt *)a_target); 563: #endif 564: } 565: : 566: swap 2dup 567: r> swap >r swap >r 568: <= 569: IF 570: @ 571: ELSE 572: cell+ 573: THEN >r ; 574: 575: (u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do 576: #ifdef NO_IP 577: INST_TAIL; 578: #endif 579: if (ustart <= ulimit) { 580: #ifdef NO_IP 581: JUMP(a_target); 582: #else 583: SET_IP((Xt *)a_target); 584: #endif 585: } 586: : 587: swap 2dup 588: r> swap >r swap >r 589: u<= 590: IF 591: @ 592: ELSE 593: cell+ 594: THEN >r ; 595: 596: \+ 597: 598: \ don't make any assumptions where the return stack is!! 599: \ implement this in machine code if it should run quickly! 600: 601: i ( R:n -- R:n n ) core 602: : 603: \ rp@ cell+ @ ; 604: r> r> tuck >r >r ; 605: 606: i' ( R:w R:w2 -- R:w R:w2 w ) gforth i_tick 607: : 608: \ rp@ cell+ cell+ @ ; 609: r> r> r> dup itmp ! >r >r >r itmp @ ; 610: variable itmp 611: 612: j ( R:w R:w1 R:w2 -- w R:w R:w1 R:w2 ) core 613: : 614: \ rp@ cell+ cell+ cell+ @ ; 615: r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; 616: [IFUNDEF] itmp variable itmp [THEN] 617: 618: k ( R:w R:w1 R:w2 R:w3 R:w4 -- w R:w R:w1 R:w2 R:w3 R:w4 ) gforth 619: : 620: \ rp@ [ 5 cells ] Literal + @ ; 621: r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; 622: [IFUNDEF] itmp variable itmp [THEN] 623: 624: \f[THEN] 625: 626: \ digit is high-level: 0/0% 627: 628: \g strings 629: 630: move ( c_from c_to ucount -- ) core 631: ""Copy the contents of @i{ucount} aus at @i{c-from} to 632: @i{c-to}. @code{move} works correctly even if the two areas overlap."" 633: /* !! note that the standard specifies addr, not c-addr */ 634: memmove(c_to,c_from,ucount); 635: /* make an Ifdef for bsd and others? */ 636: : 637: >r 2dup u< IF r> cmove> ELSE r> cmove THEN ; 638: 639: cmove ( c_from c_to u -- ) string c_move 640: ""Copy the contents of @i{ucount} characters from data space at 641: @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} 642: from low address to high address; i.e., for overlapping areas it is 643: safe if @i{c-to}=<@i{c-from}."" 644: cmove(c_from,c_to,u); 645: : 646: bounds ?DO dup c@ I c! 1+ LOOP drop ; 647: 648: cmove> ( c_from c_to u -- ) string c_move_up 649: ""Copy the contents of @i{ucount} characters from data space at 650: @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} 651: from high address to low address; i.e., for overlapping areas it is 652: safe if @i{c-to}>=@i{c-from}."" 653: cmove_up(c_from,c_to,u); 654: : 655: dup 0= IF drop 2drop exit THEN 656: rot over + -rot bounds swap 1- 657: DO 1- dup c@ I c! -1 +LOOP drop ; 658: 659: fill ( c_addr u c -- ) core 660: ""Store @i{c} in @i{u} chars starting at @i{c-addr}."" 661: memset(c_addr,c,u); 662: : 663: -rot bounds 664: ?DO dup I c! LOOP drop ; 665: 666: compare ( c_addr1 u1 c_addr2 u2 -- n ) string 667: ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if 668: the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} 669: is 1. Currently this is based on the machine's character 670: comparison. In the future, this may change to consider the current 671: locale and its collation order."" 672: /* close ' to keep fontify happy */ 673: n = compare(c_addr1, u1, c_addr2, u2); 674: : 675: rot 2dup swap - >r min swap -text dup 676: IF rdrop ELSE drop r> sgn THEN ; 677: : -text ( c_addr1 u c_addr2 -- n ) 678: swap bounds 679: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 680: ELSE c@ I c@ - unloop THEN sgn ; 681: : sgn ( n -- -1/0/1 ) 682: dup 0= IF EXIT THEN 0< 2* 1+ ; 683: 684: \ -text is only used by replaced primitives now; move it elsewhere 685: \ -text ( c_addr1 u c_addr2 -- n ) new dash_text 686: \ n = memcmp(c_addr1, c_addr2, u); 687: \ if (n<0) 688: \ n = -1; 689: \ else if (n>0) 690: \ n = 1; 691: \ : 692: \ swap bounds 693: \ ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 694: \ ELSE c@ I c@ - unloop THEN sgn ; 695: \ : sgn ( n -- -1/0/1 ) 696: \ dup 0= IF EXIT THEN 0< 2* 1+ ; 697: 698: toupper ( c1 -- c2 ) gforth 699: ""If @i{c1} is a lower-case character (in the current locale), @i{c2} 700: is the equivalent upper-case character. All other characters are unchanged."" 701: c2 = toupper(c1); 702: : 703: dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; 704: 705: capscompare ( c_addr1 u1 c_addr2 u2 -- n ) gforth 706: ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if 707: the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} 708: is 1. Currently this is based on the machine's character 709: comparison. In the future, this may change to consider the current 710: locale and its collation order."" 711: /* close ' to keep fontify happy */ 712: n = capscompare(c_addr1, u1, c_addr2, u2); 713: 714: /string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string 715: ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} 716: characters from the start of the string."" 717: c_addr2 = c_addr1+n; 718: u2 = u1-n; 719: : 720: tuck - >r + r> dup 0< IF - 0 THEN ; 721: 722: \g arith 723: 724: lit ( #w -- w ) gforth 725: : 726: r> dup @ swap cell+ >r ; 727: 728: + ( n1 n2 -- n ) core plus 729: n = n1+n2; 730: 731: \ lit+ / lit_plus = lit + 732: 733: lit+ ( n1 #n2 -- n ) new lit_plus 734: #ifdef DEBUG 735: fprintf(stderr, "lit+ %08x\n", n2); 736: #endif 737: n=n1+n2; 738: 739: \ PFE-0.9.14 has it differently, but the next release will have it as follows 740: under+ ( n1 n2 n3 -- n n2 ) gforth under_plus 741: ""add @i{n3} to @i{n1} (giving @i{n})"" 742: n = n1+n3; 743: : 744: rot + swap ; 745: 746: - ( n1 n2 -- n ) core minus 747: n = n1-n2; 748: : 749: negate + ; 750: 751: negate ( n1 -- n2 ) core 752: /* use minus as alias */ 753: n2 = -n1; 754: : 755: invert 1+ ; 756: 757: 1+ ( n1 -- n2 ) core one_plus 758: n2 = n1+1; 759: : 760: 1 + ; 761: 762: 1- ( n1 -- n2 ) core one_minus 763: n2 = n1-1; 764: : 765: 1 - ; 766: 767: max ( n1 n2 -- n ) core 768: if (n1<n2) 769: n = n2; 770: else 771: n = n1; 772: : 773: 2dup < IF swap THEN drop ; 774: 775: min ( n1 n2 -- n ) core 776: if (n1<n2) 777: n = n1; 778: else 779: n = n2; 780: : 781: 2dup > IF swap THEN drop ; 782: 783: abs ( n -- u ) core 784: if (n<0) 785: u = -n; 786: else 787: u = n; 788: : 789: dup 0< IF negate THEN ; 790: 791: * ( n1 n2 -- n ) core star 792: n = n1*n2; 793: : 794: um* drop ; 795: 796: / ( n1 n2 -- n ) core slash 797: n = n1/n2; 798: if (CHECK_DIVISION_SW && n2 == 0) 799: throw(BALL_DIVZERO); 800: if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) 801: throw(BALL_RESULTRANGE); 802: if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0)) 803: n--; 804: : 805: /mod nip ; 806: 807: mod ( n1 n2 -- n ) core 808: n = n1%n2; 809: if (CHECK_DIVISION_SW && n2 == 0) 810: throw(BALL_DIVZERO); 811: if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) 812: throw(BALL_RESULTRANGE); 813: if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2; 814: : 815: /mod drop ; 816: 817: /mod ( n1 n2 -- n3 n4 ) core slash_mod 818: n4 = n1/n2; 819: n3 = n1%n2; /* !! is this correct? look into C standard! */ 820: if (CHECK_DIVISION_SW && n2 == 0) 821: throw(BALL_DIVZERO); 822: if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) 823: throw(BALL_RESULTRANGE); 824: if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) { 825: n4--; 826: n3+=n2; 827: } 828: : 829: >r s>d r> fm/mod ; 830: 831: */mod ( n1 n2 n3 -- n4 n5 ) core star_slash_mod 832: ""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double."" 833: #ifdef BUGGY_LL_MUL 834: DCell d = mmul(n1,n2); 835: #else 836: DCell d = (DCell)n1 * (DCell)n2; 837: #endif 838: #ifdef ASM_SM_SLASH_REM 839: ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5); 840: if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) { 841: if (CHECK_DIVISION && n5 == CELL_MIN) 842: throw(BALL_RESULTRANGE); 843: n5--; 844: n4+=n3; 845: } 846: #else 847: DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); 848: n4=DHI(r); 849: n5=DLO(r); 850: #endif 851: : 852: >r m* r> fm/mod ; 853: 854: */ ( n1 n2 n3 -- n4 ) core star_slash 855: ""n4=(n1*n2)/n3, with the intermediate result being double."" 856: #ifdef BUGGY_LL_MUL 857: DCell d = mmul(n1,n2); 858: #else 859: DCell d = (DCell)n1 * (DCell)n2; 860: #endif 861: #ifdef ASM_SM_SLASH_REM 862: Cell remainder; 863: ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4); 864: if (FLOORED_DIV && ((DHI(d)^n3)<0) && remainder!=0) { 865: if (CHECK_DIVISION && n4 == CELL_MIN) 866: throw(BALL_RESULTRANGE); 867: n4--; 868: } 869: #else 870: DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); 871: n4=DLO(r); 872: #endif 873: : 874: */mod nip ; 875: 876: 2* ( n1 -- n2 ) core two_star 877: ""Shift left by 1; also works on unsigned numbers"" 878: n2 = 2*n1; 879: : 880: dup + ; 881: 882: 2/ ( n1 -- n2 ) core two_slash 883: ""Arithmetic shift right by 1. For signed numbers this is a floored 884: division by 2 (note that @code{/} not necessarily floors)."" 885: n2 = n1>>1; 886: : 887: dup MINI and IF 1 ELSE 0 THEN 888: [ bits/char cell * 1- ] literal 889: 0 DO 2* swap dup 2* >r MINI and 890: IF 1 ELSE 0 THEN or r> swap 891: LOOP nip ; 892: 893: fm/mod ( d1 n1 -- n2 n3 ) core f_m_slash_mod 894: ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}."" 895: #ifdef ASM_SM_SLASH_REM 896: ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3); 897: if (((DHI(d1)^n1)<0) && n2!=0) { 898: if (CHECK_DIVISION && n3 == CELL_MIN) 899: throw(BALL_RESULTRANGE); 900: n3--; 901: n2+=n1; 902: } 903: #else /* !defined(ASM_SM_SLASH_REM) */ 904: DCell r = fmdiv(d1,n1); 905: n2=DHI(r); 906: n3=DLO(r); 907: #endif /* !defined(ASM_SM_SLASH_REM) */ 908: : 909: dup >r dup 0< IF negate >r dnegate r> THEN 910: over 0< IF tuck + swap THEN 911: um/mod 912: r> 0< IF swap negate swap THEN ; 913: 914: sm/rem ( d1 n1 -- n2 n3 ) core s_m_slash_rem 915: ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0."" 916: #ifdef ASM_SM_SLASH_REM 917: ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3); 918: #else /* !defined(ASM_SM_SLASH_REM) */ 919: DCell r = smdiv(d1,n1); 920: n2=DHI(r); 921: n3=DLO(r); 922: #endif /* !defined(ASM_SM_SLASH_REM) */ 923: : 924: over >r dup >r abs -rot 925: dabs rot um/mod 926: r> r@ xor 0< IF negate THEN 927: r> 0< IF swap negate swap THEN ; 928: 929: m* ( n1 n2 -- d ) core m_star 930: #ifdef BUGGY_LL_MUL 931: d = mmul(n1,n2); 932: #else 933: d = (DCell)n1 * (DCell)n2; 934: #endif 935: : 936: 2dup 0< and >r 937: 2dup swap 0< and >r 938: um* r> - r> - ; 939: 940: um* ( u1 u2 -- ud ) core u_m_star 941: /* use u* as alias */ 942: #ifdef BUGGY_LL_MUL 943: ud = ummul(u1,u2); 944: #else 945: ud = (UDCell)u1 * (UDCell)u2; 946: #endif 947: : 948: 0 -rot dup [ 8 cells ] literal - 949: DO 950: dup 0< I' and d2*+ drop 951: LOOP ; 952: : d2*+ ( ud n -- ud+n c ) 953: over MINI 954: and >r >r 2dup d+ swap r> + swap r> ; 955: 956: um/mod ( ud u1 -- u2 u3 ) core u_m_slash_mod 957: ""ud=u3*u1+u2, u1>u2>=0"" 958: #ifdef ASM_UM_SLASH_MOD 959: ASM_UM_SLASH_MOD(DLO(ud), DHI(ud), u1, u2, u3); 960: #else /* !defined(ASM_UM_SLASH_MOD) */ 961: UDCell r = umdiv(ud,u1); 962: u2=DHI(r); 963: u3=DLO(r); 964: #endif /* !defined(ASM_UM_SLASH_MOD) */ 965: : 966: 0 swap [ 8 cells 1 + ] literal 0 967: ?DO /modstep 968: LOOP drop swap 1 rshift or swap ; 969: : /modstep ( ud c R: u -- ud-?u c R: u ) 970: >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ; 971: : d2*+ ( ud n -- ud+n c ) 972: over MINI 973: and >r >r 2dup d+ swap r> + swap r> ; 974: 975: m+ ( d1 n -- d2 ) double m_plus 976: #ifdef BUGGY_LL_ADD 977: DLO_IS(d2, DLO(d1)+n); 978: DHI_IS(d2, DHI(d1) - (n<0) + (DLO(d2)<DLO(d1))); 979: #else 980: d2 = d1+n; 981: #endif 982: : 983: s>d d+ ; 984: 985: d+ ( d1 d2 -- d ) double d_plus 986: #ifdef BUGGY_LL_ADD 987: DLO_IS(d, DLO(d1) + DLO(d2)); 988: DHI_IS(d, DHI(d1) + DHI(d2) + (d.lo<DLO(d1))); 989: #else 990: d = d1+d2; 991: #endif 992: : 993: rot + >r tuck + swap over u> r> swap - ; 994: 995: d- ( d1 d2 -- d ) double d_minus 996: #ifdef BUGGY_LL_ADD 997: DLO_IS(d, DLO(d1) - DLO(d2)); 998: DHI_IS(d, DHI(d1)-DHI(d2)-(DLO(d1)<DLO(d2))); 999: #else 1000: d = d1-d2; 1001: #endif 1002: : 1003: dnegate d+ ; 1004: 1005: dnegate ( d1 -- d2 ) double d_negate 1006: /* use dminus as alias */ 1007: #ifdef BUGGY_LL_ADD 1008: d2 = dnegate(d1); 1009: #else 1010: d2 = -d1; 1011: #endif 1012: : 1013: invert swap negate tuck 0= - ; 1014: 1015: d2* ( d1 -- d2 ) double d_two_star 1016: ""Shift left by 1; also works on unsigned numbers"" 1017: d2 = DLSHIFT(d1,1); 1018: : 1019: 2dup d+ ; 1020: 1021: d2/ ( d1 -- d2 ) double d_two_slash 1022: ""Arithmetic shift right by 1. For signed numbers this is a floored 1023: division by 2."" 1024: #ifdef BUGGY_LL_SHIFT 1025: DHI_IS(d2, DHI(d1)>>1); 1026: DLO_IS(d2, (DLO(d1)>>1) | (DHI(d1)<<(CELL_BITS-1))); 1027: #else 1028: d2 = d1>>1; 1029: #endif 1030: : 1031: dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and 1032: r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ; 1033: 1034: and ( w1 w2 -- w ) core 1035: w = w1&w2; 1036: 1037: or ( w1 w2 -- w ) core 1038: w = w1|w2; 1039: : 1040: invert swap invert and invert ; 1041: 1042: xor ( w1 w2 -- w ) core x_or 1043: w = w1^w2; 1044: 1045: invert ( w1 -- w2 ) core 1046: w2 = ~w1; 1047: : 1048: MAXU xor ; 1049: 1050: rshift ( u1 n -- u2 ) core r_shift 1051: ""Logical shift right by @i{n} bits."" 1052: #ifdef BROKEN_SHIFT 1053: u2 = rshift(u1, n); 1054: #else 1055: u2 = u1 >> n; 1056: #endif 1057: : 1058: 0 ?DO 2/ MAXI and LOOP ; 1059: 1060: lshift ( u1 n -- u2 ) core l_shift 1061: #ifdef BROKEN_SHIFT 1062: u2 = lshift(u1, n); 1063: #else 1064: u2 = u1 << n; 1065: #endif 1066: : 1067: 0 ?DO 2* LOOP ; 1068: 1069: \g compare 1070: 1071: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) 1072: define(comparisons, 1073: $1= ( $2 -- f ) $6 $3equals 1074: f = FLAG($4==$5); 1075: : 1076: [ char $1x char 0 = [IF] 1077: ] IF false ELSE true THEN [ 1078: [ELSE] 1079: ] xor 0= [ 1080: [THEN] ] ; 1081: 1082: $1<> ( $2 -- f ) $7 $3not_equals 1083: f = FLAG($4!=$5); 1084: : 1085: [ char $1x char 0 = [IF] 1086: ] IF true ELSE false THEN [ 1087: [ELSE] 1088: ] xor 0<> [ 1089: [THEN] ] ; 1090: 1091: $1< ( $2 -- f ) $8 $3less_than 1092: f = FLAG($4<$5); 1093: : 1094: [ char $1x char 0 = [IF] 1095: ] MINI and 0<> [ 1096: [ELSE] char $1x char u = [IF] 1097: ] 2dup xor 0< IF nip ELSE - THEN 0< [ 1098: [ELSE] 1099: ] MINI xor >r MINI xor r> u< [ 1100: [THEN] 1101: [THEN] ] ; 1102: 1103: $1> ( $2 -- f ) $9 $3greater_than 1104: f = FLAG($4>$5); 1105: : 1106: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1107: $1< ; 1108: 1109: $1<= ( $2 -- f ) gforth $3less_or_equal 1110: f = FLAG($4<=$5); 1111: : 1112: $1> 0= ; 1113: 1114: $1>= ( $2 -- f ) gforth $3greater_or_equal 1115: f = FLAG($4>=$5); 1116: : 1117: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1118: $1<= ; 1119: 1120: ) 1121: 1122: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext) 1123: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core) 1124: comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext) 1125: 1126: \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...) 1127: define(dcomparisons, 1128: $1= ( $2 -- f ) $6 $3equals 1129: #ifdef BUGGY_LL_CMP 1130: f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); 1131: #else 1132: f = FLAG($4==$5); 1133: #endif 1134: 1135: $1<> ( $2 -- f ) $7 $3not_equals 1136: #ifdef BUGGY_LL_CMP 1137: f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); 1138: #else 1139: f = FLAG($4!=$5); 1140: #endif 1141: 1142: $1< ( $2 -- f ) $8 $3less_than 1143: #ifdef BUGGY_LL_CMP 1144: f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); 1145: #else 1146: f = FLAG($4<$5); 1147: #endif 1148: 1149: $1> ( $2 -- f ) $9 $3greater_than 1150: #ifdef BUGGY_LL_CMP 1151: f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); 1152: #else 1153: f = FLAG($4>$5); 1154: #endif 1155: 1156: $1<= ( $2 -- f ) gforth $3less_or_equal 1157: #ifdef BUGGY_LL_CMP 1158: f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi); 1159: #else 1160: f = FLAG($4<=$5); 1161: #endif 1162: 1163: $1>= ( $2 -- f ) gforth $3greater_or_equal 1164: #ifdef BUGGY_LL_CMP 1165: f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi); 1166: #else 1167: f = FLAG($4>=$5); 1168: #endif 1169: 1170: ) 1171: 1172: \+dcomps 1173: 1174: dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth) 1175: dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth) 1176: dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth) 1177: 1178: \+ 1179: 1180: within ( u1 u2 u3 -- f ) core-ext 1181: ""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2). This works for 1182: unsigned and signed numbers (but not a mixture). Another way to think 1183: about this word is to consider the numbers as a circle (wrapping 1184: around from @code{max-u} to 0 for unsigned, and from @code{max-n} to 1185: min-n for signed numbers); now consider the range from u2 towards 1186: increasing numbers up to and excluding u3 (giving an empty range if 1187: u2=u3); if u1 is in this range, @code{within} returns true."" 1188: f = FLAG(u1-u2 < u3-u2); 1189: : 1190: over - >r - r> u< ; 1191: 1192: \g stack 1193: 1194: useraddr ( #u -- a_addr ) new 1195: a_addr = (Cell *)(up+u); 1196: 1197: up! ( a_addr -- ) gforth up_store 1198: gforth_UP=up=(Address)a_addr; 1199: : 1200: up ! ; 1201: Variable UP 1202: 1203: sp@ ( S:... -- a_addr ) gforth sp_fetch 1204: a_addr = sp; 1205: 1206: sp! ( a_addr -- S:... ) gforth sp_store 1207: sp = a_addr; 1208: 1209: rp@ ( -- a_addr ) gforth rp_fetch 1210: a_addr = rp; 1211: 1212: rp! ( a_addr -- ) gforth rp_store 1213: rp = a_addr; 1214: 1215: \+floating 1216: 1217: fp@ ( f:... -- f_addr ) gforth fp_fetch 1218: f_addr = fp; 1219: 1220: fp! ( f_addr -- f:... ) gforth fp_store 1221: fp = f_addr; 1222: 1223: \+ 1224: 1225: >r ( w -- R:w ) core to_r 1226: : 1227: (>r) ; 1228: : (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ; 1229: 1230: r> ( R:w -- w ) core r_from 1231: : 1232: rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ; 1233: Create (rdrop) ' ;s A, 1234: 1235: rdrop ( R:w -- ) gforth 1236: : 1237: r> r> drop >r ; 1238: 1239: 2>r ( d -- R:d ) core-ext two_to_r 1240: : 1241: swap r> swap >r swap >r >r ; 1242: 1243: 2r> ( R:d -- d ) core-ext two_r_from 1244: : 1245: r> r> swap r> swap >r swap ; 1246: 1247: 2r@ ( R:d -- R:d d ) core-ext two_r_fetch 1248: : 1249: i' j ; 1250: 1251: 2rdrop ( R:d -- ) gforth two_r_drop 1252: : 1253: r> r> drop r> drop >r ; 1254: 1255: over ( w1 w2 -- w1 w2 w1 ) core 1256: : 1257: sp@ cell+ @ ; 1258: 1259: drop ( w -- ) core 1260: : 1261: IF THEN ; 1262: 1263: swap ( w1 w2 -- w2 w1 ) core 1264: : 1265: >r (swap) ! r> (swap) @ ; 1266: Variable (swap) 1267: 1268: dup ( w -- w w ) core dupe 1269: : 1270: sp@ @ ; 1271: 1272: rot ( w1 w2 w3 -- w2 w3 w1 ) core rote 1273: : 1274: [ defined? (swap) [IF] ] 1275: (swap) ! (rot) ! >r (rot) @ (swap) @ r> ; 1276: Variable (rot) 1277: [ELSE] ] 1278: >r swap r> swap ; 1279: [THEN] 1280: 1281: -rot ( w1 w2 w3 -- w3 w1 w2 ) gforth not_rote 1282: : 1283: rot rot ; 1284: 1285: nip ( w1 w2 -- w2 ) core-ext 1286: : 1287: swap drop ; 1288: 1289: tuck ( w1 w2 -- w2 w1 w2 ) core-ext 1290: : 1291: swap over ; 1292: 1293: ?dup ( w -- S:... w ) core question_dupe 1294: ""Actually the stack effect is: @code{( w -- 0 | w w )}. It performs a 1295: @code{dup} if w is nonzero."" 1296: if (w!=0) { 1297: *--sp = w; 1298: } 1299: : 1300: dup IF dup THEN ; 1301: 1302: pick ( S:... u -- S:... w ) core-ext 1303: ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }."" 1304: w = sp[u]; 1305: : 1306: 1+ cells sp@ + @ ; 1307: 1308: 2drop ( w1 w2 -- ) core two_drop 1309: : 1310: drop drop ; 1311: 1312: 2dup ( w1 w2 -- w1 w2 w1 w2 ) core two_dupe 1313: : 1314: over over ; 1315: 1316: 2over ( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 ) core two_over 1317: : 1318: 3 pick 3 pick ; 1319: 1320: 2swap ( w1 w2 w3 w4 -- w3 w4 w1 w2 ) core two_swap 1321: : 1322: rot >r rot r> ; 1323: 1324: 2rot ( w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 ) double-ext two_rote 1325: : 1326: >r >r 2swap r> r> 2swap ; 1327: 1328: 2nip ( w1 w2 w3 w4 -- w3 w4 ) gforth two_nip 1329: : 1330: 2swap 2drop ; 1331: 1332: 2tuck ( w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 ) gforth two_tuck 1333: : 1334: 2swap 2over ; 1335: 1336: \ toggle is high-level: 0.11/0.42% 1337: 1338: \g memory 1339: 1340: @ ( a_addr -- w ) core fetch 1341: ""@i{w} is the cell stored at @i{a_addr}."" 1342: w = *a_addr; 1343: 1344: \ lit@ / lit_fetch = lit @ 1345: 1346: lit@ ( #a_addr -- w ) new lit_fetch 1347: w = *a_addr; 1348: 1349: ! ( w a_addr -- ) core store 1350: ""Store @i{w} into the cell at @i{a-addr}."" 1351: *a_addr = w; 1352: 1353: +! ( n a_addr -- ) core plus_store 1354: ""Add @i{n} to the cell at @i{a-addr}."" 1355: *a_addr += n; 1356: : 1357: tuck @ + swap ! ; 1358: 1359: c@ ( c_addr -- c ) core c_fetch 1360: ""@i{c} is the char stored at @i{c_addr}."" 1361: c = *c_addr; 1362: : 1363: [ bigendian [IF] ] 1364: [ cell>bit 4 = [IF] ] 1365: dup [ 0 cell - ] Literal and @ swap 1 and 1366: IF $FF and ELSE 8>> THEN ; 1367: [ [ELSE] ] 1368: dup [ cell 1- ] literal and 1369: tuck - @ swap [ cell 1- ] literal xor 1370: 0 ?DO 8>> LOOP $FF and 1371: [ [THEN] ] 1372: [ [ELSE] ] 1373: [ cell>bit 4 = [IF] ] 1374: dup [ 0 cell - ] Literal and @ swap 1 and 1375: IF 8>> ELSE $FF and THEN 1376: [ [ELSE] ] 1377: dup [ cell 1- ] literal and 1378: tuck - @ swap 1379: 0 ?DO 8>> LOOP 255 and 1380: [ [THEN] ] 1381: [ [THEN] ] 1382: ; 1383: : 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; 1384: 1385: c! ( c c_addr -- ) core c_store 1386: ""Store @i{c} into the char at @i{c-addr}."" 1387: *c_addr = c; 1388: : 1389: [ bigendian [IF] ] 1390: [ cell>bit 4 = [IF] ] 1391: tuck 1 and IF $FF and ELSE 8<< THEN >r 1392: dup -2 and @ over 1 and cells masks + @ and 1393: r> or swap -2 and ! ; 1394: Create masks $00FF , $FF00 , 1395: [ELSE] ] 1396: dup [ cell 1- ] literal and dup 1397: [ cell 1- ] literal xor >r 1398: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and 1399: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ; 1400: [THEN] 1401: [ELSE] ] 1402: [ cell>bit 4 = [IF] ] 1403: tuck 1 and IF 8<< ELSE $FF and THEN >r 1404: dup -2 and @ over 1 and cells masks + @ and 1405: r> or swap -2 and ! ; 1406: Create masks $FF00 , $00FF , 1407: [ELSE] ] 1408: dup [ cell 1- ] literal and dup >r 1409: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and 1410: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ; 1411: [THEN] 1412: [THEN] 1413: : 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; 1414: 1415: 2! ( w1 w2 a_addr -- ) core two_store 1416: ""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell."" 1417: a_addr[0] = w2; 1418: a_addr[1] = w1; 1419: : 1420: tuck ! cell+ ! ; 1421: 1422: 2@ ( a_addr -- w1 w2 ) core two_fetch 1423: ""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is 1424: the content of the next cell."" 1425: w2 = a_addr[0]; 1426: w1 = a_addr[1]; 1427: : 1428: dup cell+ @ swap @ ; 1429: 1430: cell+ ( a_addr1 -- a_addr2 ) core cell_plus 1431: ""@code{1 cells +}"" 1432: a_addr2 = a_addr1+1; 1433: : 1434: cell + ; 1435: 1436: cells ( n1 -- n2 ) core 1437: "" @i{n2} is the number of address units of @i{n1} cells."" 1438: n2 = n1 * sizeof(Cell); 1439: : 1440: [ cell 1441: 2/ dup [IF] ] 2* [ [THEN] 1442: 2/ dup [IF] ] 2* [ [THEN] 1443: 2/ dup [IF] ] 2* [ [THEN] 1444: 2/ dup [IF] ] 2* [ [THEN] 1445: drop ] ; 1446: 1447: char+ ( c_addr1 -- c_addr2 ) core char_plus 1448: ""@code{1 chars +}."" 1449: c_addr2 = c_addr1 + 1; 1450: : 1451: 1+ ; 1452: 1453: (chars) ( n1 -- n2 ) gforth paren_chars 1454: n2 = n1 * sizeof(Char); 1455: : 1456: ; 1457: 1458: count ( c_addr1 -- c_addr2 u ) core 1459: ""@i{c-addr2} is the first character and @i{u} the length of the 1460: counted string at @i{c-addr1}."" 1461: u = *c_addr1; 1462: c_addr2 = c_addr1+1; 1463: : 1464: dup 1+ swap c@ ; 1465: 1466: \g compiler 1467: 1468: \+f83headerstring 1469: 1470: (f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find 1471: for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) 1472: if ((UCell)F83NAME_COUNT(f83name1)==u && 1473: memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) 1474: break; 1475: f83name2=f83name1; 1476: #ifdef DEBUG 1477: fprintf(stderr, "F83find "); 1478: fwrite(c_addr, u, 1, stderr); 1479: fprintf(stderr, " found %08x\n", f83name2); 1480: #endif 1481: : 1482: BEGIN dup WHILE (find-samelen) dup WHILE 1483: >r 2dup r@ cell+ char+ capscomp 0= 1484: IF 2drop r> EXIT THEN 1485: r> @ 1486: REPEAT THEN nip nip ; 1487: : (find-samelen) ( u f83name1 -- u f83name2/0 ) 1488: BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; 1489: : capscomp ( c_addr1 u c_addr2 -- n ) 1490: swap bounds 1491: ?DO dup c@ I c@ <> 1492: IF dup c@ toupper I c@ toupper = 1493: ELSE true THEN WHILE 1+ LOOP drop 0 1494: ELSE c@ toupper I c@ toupper - unloop THEN sgn ; 1495: : sgn ( n -- -1/0/1 ) 1496: dup 0= IF EXIT THEN 0< 2* 1+ ; 1497: 1498: \- 1499: 1500: (listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind 1501: longname2=listlfind(c_addr, u, longname1); 1502: : 1503: BEGIN dup WHILE (findl-samelen) dup WHILE 1504: >r 2dup r@ cell+ cell+ capscomp 0= 1505: IF 2drop r> EXIT THEN 1506: r> @ 1507: REPEAT THEN nip nip ; 1508: : (findl-samelen) ( u longname1 -- u longname2/0 ) 1509: BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ; 1510: : capscomp ( c_addr1 u c_addr2 -- n ) 1511: swap bounds 1512: ?DO dup c@ I c@ <> 1513: IF dup c@ toupper I c@ toupper = 1514: ELSE true THEN WHILE 1+ LOOP drop 0 1515: ELSE c@ toupper I c@ toupper - unloop THEN sgn ; 1516: : sgn ( n -- -1/0/1 ) 1517: dup 0= IF EXIT THEN 0< 2* 1+ ; 1518: 1519: \+hash 1520: 1521: (hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind 1522: longname2 = hashlfind(c_addr, u, a_addr); 1523: : 1524: BEGIN dup WHILE 1525: 2@ >r >r dup r@ cell+ @ lcount-mask and = 1526: IF 2dup r@ cell+ cell+ capscomp 0= 1527: IF 2drop r> rdrop EXIT THEN THEN 1528: rdrop r> 1529: REPEAT nip nip ; 1530: 1531: (tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind 1532: ""A case-sensitive variant of @code{(hashfind)}"" 1533: longname2 = tablelfind(c_addr, u, a_addr); 1534: : 1535: BEGIN dup WHILE 1536: 2@ >r >r dup r@ cell+ @ lcount-mask and = 1537: IF 2dup r@ cell+ cell+ -text 0= 1538: IF 2drop r> rdrop EXIT THEN THEN 1539: rdrop r> 1540: REPEAT nip nip ; 1541: : -text ( c_addr1 u c_addr2 -- n ) 1542: swap bounds 1543: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 1544: ELSE c@ I c@ - unloop THEN sgn ; 1545: : sgn ( n -- -1/0/1 ) 1546: dup 0= IF EXIT THEN 0< 2* 1+ ; 1547: 1548: (hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 1549: ""ukey is the hash key for the string c_addr u fitting in ubits bits"" 1550: ukey = hashkey1(c_addr, u, ubits); 1551: : 1552: dup rot-values + c@ over 1 swap lshift 1- >r 1553: tuck - 2swap r> 0 2swap bounds 1554: ?DO dup 4 pick lshift swap 3 pick rshift or 1555: I c@ toupper xor 1556: over and LOOP 1557: nip nip nip ; 1558: Create rot-values 1559: 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c, 1560: 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c, 1561: 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, 1562: 7 c, 5 c, 5 c, 1563: 1564: \+ 1565: 1566: \+ 1567: 1568: (parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white 1569: struct Cellpair r=parse_white(c_addr1, u1); 1570: c_addr2 = (Char *)(r.n1); 1571: u2 = r.n2; 1572: : 1573: BEGIN dup WHILE over c@ bl <= WHILE 1 /string 1574: REPEAT THEN 2dup 1575: BEGIN dup WHILE over c@ bl > WHILE 1 /string 1576: REPEAT THEN nip - ; 1577: 1578: aligned ( c_addr -- a_addr ) core 1579: "" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}."" 1580: a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); 1581: : 1582: [ cell 1- ] Literal + [ -1 cells ] Literal and ; 1583: 1584: faligned ( c_addr -- f_addr ) float f_aligned 1585: "" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}."" 1586: f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); 1587: : 1588: [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; 1589: 1590: \ threading stuff is currently only interesting if we have a compiler 1591: \fhas? standardthreading has? compiler and [IF] 1592: threading-method ( -- n ) gforth threading_method 1593: ""0 if the engine is direct threaded. Note that this may change during 1594: the lifetime of an image."" 1595: #if defined(DOUBLY_INDIRECT) 1596: n=2; 1597: #else 1598: # if defined(DIRECT_THREADED) 1599: n=0; 1600: # else 1601: n=1; 1602: # endif 1603: #endif 1604: : 1605: 1 ; 1606: 1607: \f[THEN] 1608: 1609: \g hostos 1610: 1611: key-file ( wfileid -- c ) gforth paren_key_file 1612: ""Read one character @i{c} from @i{wfileid}. This word disables 1613: buffering for @i{wfileid}. If you want to read characters from a 1614: terminal in non-canonical (raw) mode, you have to put the terminal in 1615: non-canonical mode yourself (using the C interface); the exception is 1616: @code{stdin}: Gforth automatically puts it into non-canonical mode."" 1617: #ifdef HAS_FILE 1618: fflush(stdout); 1619: c = key((FILE*)wfileid); 1620: #else 1621: c = key(stdin); 1622: #endif 1623: 1624: key?-file ( wfileid -- f ) gforth key_q_file 1625: ""@i{f} is true if at least one character can be read from @i{wfileid} 1626: without blocking. If you also want to use @code{read-file} or 1627: @code{read-line} on the file, you have to call @code{key?-file} or 1628: @code{key-file} first (these two words disable buffering)."" 1629: #ifdef HAS_FILE 1630: fflush(stdout); 1631: f = key_query((FILE*)wfileid); 1632: #else 1633: f = key_query(stdin); 1634: #endif 1635: 1636: stdin ( -- wfileid ) gforth 1637: ""The standard input file of the Gforth process."" 1638: wfileid = (Cell)stdin; 1639: 1640: stdout ( -- wfileid ) gforth 1641: ""The standard output file of the Gforth process."" 1642: wfileid = (Cell)stdout; 1643: 1644: stderr ( -- wfileid ) gforth 1645: ""The standard error output file of the Gforth process."" 1646: wfileid = (Cell)stderr; 1647: 1648: \+os 1649: 1650: form ( -- urows ucols ) gforth 1651: ""The number of lines and columns in the terminal. These numbers may 1652: change with the window size. Note that it depends on the OS whether 1653: this reflects the actual size and changes with the window size 1654: (currently only on Unix-like OSs). On other OSs you just get a 1655: default, and can tell Gforth the terminal size by setting the 1656: environment variables @code{COLUMNS} and @code{LINES} before starting 1657: Gforth."" 1658: /* we could block SIGWINCH here to get a consistent size, but I don't 1659: think this is necessary or always beneficial */ 1660: urows=rows; 1661: ucols=cols; 1662: 1663: wcwidth ( u -- n ) gforth 1664: ""The number of fixed-width characters per unicode character u"" 1665: n = wcwidth(u); 1666: 1667: flush-icache ( c_addr u -- ) gforth flush_icache 1668: ""Make sure that the instruction cache of the processor (if there is 1669: one) does not contain stale data at @i{c-addr} and @i{u} bytes 1670: afterwards. @code{END-CODE} performs a @code{flush-icache} 1671: automatically. Caveat: @code{flush-icache} might not work on your 1672: installation; this is usually the case if direct threading is not 1673: supported on your machine (take a look at your @file{machine.h}) and 1674: your machine has a separate instruction cache. In such cases, 1675: @code{flush-icache} does nothing instead of flushing the instruction 1676: cache."" 1677: FLUSH_ICACHE(c_addr,u); 1678: 1679: (bye) ( n -- ) gforth paren_bye 1680: SUPER_END; 1681: return (Label *)n; 1682: 1683: (system) ( c_addr u -- wretval wior ) gforth paren_system 1684: wretval = gforth_system(c_addr, u); 1685: wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); 1686: 1687: getenv ( c_addr1 u1 -- c_addr2 u2 ) gforth 1688: ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2} 1689: is the host operating system's expansion of that environment variable. If the 1690: environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters 1691: in length."" 1692: /* close ' to keep fontify happy */ 1693: c_addr2 = (Char *)getenv(cstr(c_addr1,u1,1)); 1694: u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2)); 1695: 1696: open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe 1697: wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */ 1698: wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ 1699: 1700: close-pipe ( wfileid -- wretval wior ) gforth close_pipe 1701: wretval = pclose((FILE *)wfileid); 1702: wior = IOR(wretval==-1); 1703: 1704: time&date ( -- nsec nmin nhour nday nmonth nyear ) facility-ext time_and_date 1705: ""Report the current time of day. Seconds, minutes and hours are numbered from 0. 1706: Months are numbered from 1."" 1707: #if 1 1708: time_t now; 1709: struct tm *ltime; 1710: time(&now); 1711: ltime=localtime(&now); 1712: #else 1713: struct timeval time1; 1714: struct timezone zone1; 1715: struct tm *ltime; 1716: gettimeofday(&time1,&zone1); 1717: /* !! Single Unix specification: 1718: If tzp is not a null pointer, the behaviour is unspecified. */ 1719: ltime=localtime((time_t *)&time1.tv_sec); 1720: #endif 1721: nyear =ltime->tm_year+1900; 1722: nmonth=ltime->tm_mon+1; 1723: nday =ltime->tm_mday; 1724: nhour =ltime->tm_hour; 1725: nmin =ltime->tm_min; 1726: nsec =ltime->tm_sec; 1727: 1728: ms ( u -- ) facility-ext 1729: ""Wait at least @i{n} milli-second."" 1730: gforth_ms(u); 1731: 1732: allocate ( u -- a_addr wior ) memory 1733: ""Allocate @i{u} address units of contiguous data space. The initial 1734: contents of the data space is undefined. If the allocation is successful, 1735: @i{a-addr} is the start address of the allocated region and @i{wior} 1736: is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior} 1737: is a non-zero I/O result code."" 1738: a_addr = (Cell *)malloc(u?u:1); 1739: wior = IOR(a_addr==NULL); 1740: 1741: free ( a_addr -- wior ) memory 1742: ""Return the region of data space starting at @i{a-addr} to the system. 1743: The region must originally have been obtained using @code{allocate} or 1744: @code{resize}. If the operational is successful, @i{wior} is 0. 1745: If the operation fails, @i{wior} is a non-zero I/O result code."" 1746: free(a_addr); 1747: wior = 0; 1748: 1749: resize ( a_addr1 u -- a_addr2 wior ) memory 1750: ""Change the size of the allocated area at @i{a-addr1} to @i{u} 1751: address units, possibly moving the contents to a different 1752: area. @i{a-addr2} is the address of the resulting area. 1753: If the operation is successful, @i{wior} is 0. 1754: If the operation fails, @i{wior} is a non-zero 1755: I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard) 1756: @code{resize} @code{allocate}s @i{u} address units."" 1757: /* the following check is not necessary on most OSs, but it is needed 1758: on SunOS 4.1.2. */ 1759: /* close ' to keep fontify happy */ 1760: if (a_addr1==NULL) 1761: a_addr2 = (Cell *)malloc(u); 1762: else 1763: a_addr2 = (Cell *)realloc(a_addr1, u); 1764: wior = IOR(a_addr2==NULL); /* !! Define a return code */ 1765: 1766: strerror ( n -- c_addr u ) gforth 1767: c_addr = (Char *)strerror(n); 1768: u = strlen((char *)c_addr); 1769: 1770: strsignal ( n -- c_addr u ) gforth 1771: c_addr = (Char *)strsignal(n); 1772: u = strlen((char *)c_addr); 1773: 1774: call-c ( ... w -- ... ) gforth call_c 1775: ""Call the C function pointed to by @i{w}. The C function has to 1776: access the stack itself. The stack pointers are exported in the global 1777: variables @code{gforth_SP} and @code{gforth_FP}."" 1778: /* This is a first attempt at support for calls to C. This may change in 1779: the future */ 1780: gforth_FP=fp; 1781: gforth_SP=sp; 1782: ((void (*)())w)(); 1783: sp=gforth_SP; 1784: fp=gforth_FP; 1785: 1786: \+ 1787: \+file 1788: 1789: close-file ( wfileid -- wior ) file close_file 1790: wior = IOR(fclose((FILE *)wfileid)==EOF); 1791: 1792: open-file ( c_addr u wfam -- wfileid wior ) file open_file 1793: wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, 0, &wior); 1794: 1795: create-file ( c_addr u wfam -- wfileid wior ) file create_file 1796: wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, O_CREAT|O_TRUNC, &wior); 1797: 1798: delete-file ( c_addr u -- wior ) file delete_file 1799: wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); 1800: 1801: rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file 1802: ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" 1803: wior = rename_file(c_addr1, u1, c_addr2, u2); 1804: 1805: file-position ( wfileid -- ud wior ) file file_position 1806: /* !! use tell and lseek? */ 1807: ud = OFF2UD(ftello((FILE *)wfileid)); 1808: wior = IOR(UD2OFF(ud)==-1); 1809: 1810: reposition-file ( ud wfileid -- wior ) file reposition_file 1811: wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1); 1812: 1813: file-size ( wfileid -- ud wior ) file file_size 1814: struct stat buf; 1815: wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); 1816: ud = OFF2UD(buf.st_size); 1817: 1818: resize-file ( ud wfileid -- wior ) file resize_file 1819: wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1); 1820: 1821: read-file ( c_addr u1 wfileid -- u2 wior ) file read_file 1822: /* !! fread does not guarantee enough */ 1823: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); 1824: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); 1825: /* !! is the value of ferror errno-compatible? */ 1826: if (wior) 1827: clearerr((FILE *)wfileid); 1828: 1829: (read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line 1830: struct Cellquad r = read_line(c_addr, u1, wfileid); 1831: u2 = r.n1; 1832: flag = r.n2; 1833: u3 = r.n3; 1834: wior = r.n4; 1835: 1836: \+ 1837: 1838: write-file ( c_addr u1 wfileid -- wior ) file write_file 1839: /* !! fwrite does not guarantee enough */ 1840: #ifdef HAS_FILE 1841: { 1842: UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); 1843: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); 1844: if (wior) 1845: clearerr((FILE *)wfileid); 1846: } 1847: #else 1848: TYPE(c_addr, u1); 1849: #endif 1850: 1851: emit-file ( c wfileid -- wior ) gforth emit_file 1852: #ifdef HAS_FILE 1853: wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); 1854: if (wior) 1855: clearerr((FILE *)wfileid); 1856: #else 1857: PUTC(c); 1858: #endif 1859: 1860: \+file 1861: 1862: flush-file ( wfileid -- wior ) file-ext flush_file 1863: wior = IOR(fflush((FILE *) wfileid)==EOF); 1864: 1865: file-status ( c_addr u -- wfam wior ) file-ext file_status 1866: struct Cellpair r = file_status(c_addr, u); 1867: wfam = r.n1; 1868: wior = r.n2; 1869: 1870: file-eof? ( wfileid -- flag ) gforth file_eof_query 1871: flag = FLAG(feof((FILE *) wfileid)); 1872: 1873: open-dir ( c_addr u -- wdirid wior ) gforth open_dir 1874: ""Open the directory specified by @i{c-addr, u} 1875: and return @i{dir-id} for futher access to it."" 1876: wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1)); 1877: wior = IOR(wdirid == 0); 1878: 1879: read-dir ( c_addr u1 wdirid -- u2 flag wior ) gforth read_dir 1880: ""Attempt to read the next entry from the directory specified 1881: by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}. 1882: If the attempt fails because there is no more entries, 1883: @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified. 1884: If the attempt to read the next entry fails because of any other reason, 1885: return @i{ior}<>0. 1886: If the attempt succeeds, store file name to the buffer at @i{c-addr} 1887: and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name. 1888: If the length of the file name is greater than @i{u1}, 1889: store first @i{u1} characters from file name into the buffer and 1890: indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}."" 1891: struct dirent * dent; 1892: dent = readdir((DIR *)wdirid); 1893: wior = 0; 1894: flag = -1; 1895: if(dent == NULL) { 1896: u2 = 0; 1897: flag = 0; 1898: } else { 1899: u2 = strlen((char *)dent->d_name); 1900: if(u2 > u1) { 1901: u2 = u1; 1902: wior = -512-ENAMETOOLONG; 1903: } 1904: memmove(c_addr, dent->d_name, u2); 1905: } 1906: 1907: close-dir ( wdirid -- wior ) gforth close_dir 1908: ""Close the directory specified by @i{dir-id}."" 1909: wior = IOR(closedir((DIR *)wdirid)); 1910: 1911: filename-match ( c_addr1 u1 c_addr2 u2 -- flag ) gforth match_file 1912: char * string = cstr(c_addr1, u1, 1); 1913: char * pattern = cstr(c_addr2, u2, 0); 1914: flag = FLAG(!fnmatch(pattern, string, 0)); 1915: 1916: set-dir ( c_addr u -- wior ) gforth set_dir 1917: ""Change the current directory to @i{c-addr, u}. 1918: Return an error if this is not possible"" 1919: wior = IOR(chdir(tilde_cstr(c_addr, u, 1))); 1920: 1921: get-dir ( c_addr1 u1 -- c_addr2 u2 ) gforth get_dir 1922: ""Store the current directory in the buffer specified by @{c-addr1, u1}. 1923: If the buffer size is not sufficient, return 0 0"" 1924: c_addr2 = (Char *)getcwd((char *)c_addr1, u1); 1925: if(c_addr2 != NULL) { 1926: u2 = strlen((char *)c_addr2); 1927: } else { 1928: u2 = 0; 1929: } 1930: 1931: \+ 1932: 1933: newline ( -- c_addr u ) gforth 1934: ""String containing the newline sequence of the host OS"" 1935: char newline[] = { 1936: #if DIRSEP=='/' 1937: /* Unix */ 1938: '\n' 1939: #else 1940: /* DOS, Win, OS/2 */ 1941: '\r','\n' 1942: #endif 1943: }; 1944: c_addr=(Char *)newline; 1945: u=sizeof(newline); 1946: : 1947: "newline count ; 1948: Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c, 1949: 1950: \+os 1951: 1952: utime ( -- dtime ) gforth 1953: ""Report the current time in microseconds since some epoch."" 1954: struct timeval time1; 1955: gettimeofday(&time1,NULL); 1956: dtime = timeval2us(&time1); 1957: 1958: cputime ( -- duser dsystem ) gforth 1959: ""duser and dsystem are the respective user- and system-level CPU 1960: times used since the start of the Forth system (excluding child 1961: processes), in microseconds (the granularity may be much larger, 1962: however). On platforms without the getrusage call, it reports elapsed 1963: time (since some epoch) for duser and 0 for dsystem."" 1964: #ifdef HAVE_GETRUSAGE 1965: struct rusage usage; 1966: getrusage(RUSAGE_SELF, &usage); 1967: duser = timeval2us(&usage.ru_utime); 1968: dsystem = timeval2us(&usage.ru_stime); 1969: #else 1970: struct timeval time1; 1971: gettimeofday(&time1,NULL); 1972: duser = timeval2us(&time1); 1973: dsystem = DZERO; 1974: #endif 1975: 1976: \+ 1977: 1978: \+floating 1979: 1980: \g floating 1981: 1982: comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) 1983: comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) 1984: 1985: s>f ( n -- r ) float s_to_f 1986: r = n; 1987: 1988: d>f ( d -- r ) float d_to_f 1989: #ifdef BUGGY_LL_D2F 1990: extern double ldexp(double x, int exp); 1991: if (DHI(d)<0) { 1992: #ifdef BUGGY_LL_ADD 1993: DCell d2=dnegate(d); 1994: #else 1995: DCell d2=-d; 1996: #endif 1997: r = -(ldexp((Float)DHI(d2),CELL_BITS) + (Float)DLO(d2)); 1998: } else 1999: r = ldexp((Float)DHI(d),CELL_BITS) + (Float)DLO(d); 2000: #else 2001: r = d; 2002: #endif 2003: 2004: f>d ( r -- d ) float f_to_d 2005: extern DCell double2ll(Float r); 2006: d = double2ll(r); 2007: 2008: f>s ( r -- n ) float f_to_s 2009: n = (Cell)r; 2010: 2011: f! ( r f_addr -- ) float f_store 2012: ""Store @i{r} into the float at address @i{f-addr}."" 2013: *f_addr = r; 2014: 2015: f@ ( f_addr -- r ) float f_fetch 2016: ""@i{r} is the float at address @i{f-addr}."" 2017: r = *f_addr; 2018: 2019: df@ ( df_addr -- r ) float-ext d_f_fetch 2020: ""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}."" 2021: #ifdef IEEE_FP 2022: r = *df_addr; 2023: #else 2024: !! df@ 2025: #endif 2026: 2027: df! ( r df_addr -- ) float-ext d_f_store 2028: ""Store @i{r} as double-precision IEEE floating-point value to the 2029: address @i{df-addr}."" 2030: #ifdef IEEE_FP 2031: *df_addr = r; 2032: #else 2033: !! df! 2034: #endif 2035: 2036: sf@ ( sf_addr -- r ) float-ext s_f_fetch 2037: ""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}."" 2038: #ifdef IEEE_FP 2039: r = *sf_addr; 2040: #else 2041: !! sf@ 2042: #endif 2043: 2044: sf! ( r sf_addr -- ) float-ext s_f_store 2045: ""Store @i{r} as single-precision IEEE floating-point value to the 2046: address @i{sf-addr}."" 2047: #ifdef IEEE_FP 2048: *sf_addr = r; 2049: #else 2050: !! sf! 2051: #endif 2052: 2053: f+ ( r1 r2 -- r3 ) float f_plus 2054: r3 = r1+r2; 2055: 2056: f- ( r1 r2 -- r3 ) float f_minus 2057: r3 = r1-r2; 2058: 2059: f* ( r1 r2 -- r3 ) float f_star 2060: r3 = r1*r2; 2061: 2062: f/ ( r1 r2 -- r3 ) float f_slash 2063: r3 = r1/r2; 2064: 2065: f** ( r1 r2 -- r3 ) float-ext f_star_star 2066: ""@i{r3} is @i{r1} raised to the @i{r2}th power."" 2067: r3 = pow(r1,r2); 2068: 2069: fm* ( r1 n -- r2 ) gforth fm_star 2070: r2 = r1*n; 2071: 2072: fm/ ( r1 n -- r2 ) gforth fm_slash 2073: r2 = r1/n; 2074: 2075: fm*/ ( r1 n1 n2 -- r2 ) gforth fm_star_slash 2076: r2 = (r1*n1)/n2; 2077: 2078: f**2 ( r1 -- r2 ) gforth fm_square 2079: r2 = r1*r1; 2080: 2081: fnegate ( r1 -- r2 ) float f_negate 2082: r2 = - r1; 2083: 2084: fdrop ( r -- ) float f_drop 2085: 2086: fdup ( r -- r r ) float f_dupe 2087: 2088: fswap ( r1 r2 -- r2 r1 ) float f_swap 2089: 2090: fover ( r1 r2 -- r1 r2 r1 ) float f_over 2091: 2092: frot ( r1 r2 r3 -- r2 r3 r1 ) float f_rote 2093: 2094: fnip ( r1 r2 -- r2 ) gforth f_nip 2095: 2096: ftuck ( r1 r2 -- r2 r1 r2 ) gforth f_tuck 2097: 2098: float+ ( f_addr1 -- f_addr2 ) float float_plus 2099: ""@code{1 floats +}."" 2100: f_addr2 = f_addr1+1; 2101: 2102: floats ( n1 -- n2 ) float 2103: ""@i{n2} is the number of address units of @i{n1} floats."" 2104: n2 = n1*sizeof(Float); 2105: 2106: floor ( r1 -- r2 ) float 2107: ""Round towards the next smaller integral value, i.e., round toward negative infinity."" 2108: /* !! unclear wording */ 2109: r2 = floor(r1); 2110: 2111: fround ( r1 -- r2 ) float f_round 2112: ""Round to the nearest integral value."" 2113: r2 = rint(r1); 2114: 2115: fmax ( r1 r2 -- r3 ) float f_max 2116: if (r1<r2) 2117: r3 = r2; 2118: else 2119: r3 = r1; 2120: 2121: fmin ( r1 r2 -- r3 ) float f_min 2122: if (r1<r2) 2123: r3 = r1; 2124: else 2125: r3 = r2; 2126: 2127: represent ( r c_addr u -- n f1 f2 ) float 2128: char *sig; 2129: size_t siglen; 2130: int flag; 2131: int decpt; 2132: sig=ecvt(r, u, &decpt, &flag); 2133: n=(r==0. ? 1 : decpt); 2134: f1=FLAG(flag!=0); 2135: f2=FLAG(isdigit((unsigned)(sig[0]))!=0); 2136: siglen=strlen((char *)sig); 2137: if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */ 2138: siglen=u; 2139: if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */ 2140: for (; sig[siglen-1]=='0'; siglen--); 2141: ; 2142: memcpy(c_addr,sig,siglen); 2143: memset(c_addr+siglen,f2?'0':' ',u-siglen); 2144: 2145: >float ( c_addr u -- f:... flag ) float to_float 2146: ""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the 2147: character string @i{c-addr u} to internal floating-point 2148: representation. If the string represents a valid floating-point number 2149: @i{r} is placed on the floating-point stack and @i{flag} is 2150: true. Otherwise, @i{flag} is false. A string of blanks is a special 2151: case and represents the floating-point number 0."" 2152: Float r; 2153: flag = to_float(c_addr, u, &r); 2154: if (flag) { 2155: fp--; 2156: fp[0]=r; 2157: } 2158: 2159: fabs ( r1 -- r2 ) float-ext f_abs 2160: r2 = fabs(r1); 2161: 2162: facos ( r1 -- r2 ) float-ext f_a_cos 2163: r2 = acos(r1); 2164: 2165: fasin ( r1 -- r2 ) float-ext f_a_sine 2166: r2 = asin(r1); 2167: 2168: fatan ( r1 -- r2 ) float-ext f_a_tan 2169: r2 = atan(r1); 2170: 2171: fatan2 ( r1 r2 -- r3 ) float-ext f_a_tan_two 2172: ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably 2173: intends this to be the inverse of @code{fsincos}. In gforth it is."" 2174: r3 = atan2(r1,r2); 2175: 2176: fcos ( r1 -- r2 ) float-ext f_cos 2177: r2 = cos(r1); 2178: 2179: fexp ( r1 -- r2 ) float-ext f_e_x_p 2180: r2 = exp(r1); 2181: 2182: fexpm1 ( r1 -- r2 ) float-ext f_e_x_p_m_one 2183: ""@i{r2}=@i{e}**@i{r1}@minus{}1"" 2184: #ifdef HAVE_EXPM1 2185: extern double 2186: #ifdef NeXT 2187: const 2188: #endif 2189: expm1(double); 2190: r2 = expm1(r1); 2191: #else 2192: r2 = exp(r1)-1.; 2193: #endif 2194: 2195: fln ( r1 -- r2 ) float-ext f_l_n 2196: r2 = log(r1); 2197: 2198: flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one 2199: ""@i{r2}=ln(@i{r1}+1)"" 2200: #ifdef HAVE_LOG1P 2201: extern double 2202: #ifdef NeXT 2203: const 2204: #endif 2205: log1p(double); 2206: r2 = log1p(r1); 2207: #else 2208: r2 = log(r1+1.); 2209: #endif 2210: 2211: flog ( r1 -- r2 ) float-ext f_log 2212: ""The decimal logarithm."" 2213: r2 = log10(r1); 2214: 2215: falog ( r1 -- r2 ) float-ext f_a_log 2216: ""@i{r2}=10**@i{r1}"" 2217: extern double pow10(double); 2218: r2 = pow10(r1); 2219: 2220: fsin ( r1 -- r2 ) float-ext f_sine 2221: r2 = sin(r1); 2222: 2223: fsincos ( r1 -- r2 r3 ) float-ext f_sine_cos 2224: ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" 2225: r2 = sin(r1); 2226: r3 = cos(r1); 2227: 2228: fsqrt ( r1 -- r2 ) float-ext f_square_root 2229: r2 = sqrt(r1); 2230: 2231: ftan ( r1 -- r2 ) float-ext f_tan 2232: r2 = tan(r1); 2233: : 2234: fsincos f/ ; 2235: 2236: fsinh ( r1 -- r2 ) float-ext f_cinch 2237: r2 = sinh(r1); 2238: : 2239: fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; 2240: 2241: fcosh ( r1 -- r2 ) float-ext f_cosh 2242: r2 = cosh(r1); 2243: : 2244: fexp fdup 1/f f+ f2/ ; 2245: 2246: ftanh ( r1 -- r2 ) float-ext f_tan_h 2247: r2 = tanh(r1); 2248: : 2249: f2* fexpm1 fdup 2. d>f f+ f/ ; 2250: 2251: fasinh ( r1 -- r2 ) float-ext f_a_cinch 2252: r2 = asinh(r1); 2253: : 2254: fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; 2255: 2256: facosh ( r1 -- r2 ) float-ext f_a_cosh 2257: r2 = acosh(r1); 2258: : 2259: fdup fdup f* 1. d>f f- fsqrt f+ fln ; 2260: 2261: fatanh ( r1 -- r2 ) float-ext f_a_tan_h 2262: r2 = atanh(r1); 2263: : 2264: fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ 2265: r> IF fnegate THEN ; 2266: 2267: sfloats ( n1 -- n2 ) float-ext s_floats 2268: ""@i{n2} is the number of address units of @i{n1} 2269: single-precision IEEE floating-point numbers."" 2270: n2 = n1*sizeof(SFloat); 2271: 2272: dfloats ( n1 -- n2 ) float-ext d_floats 2273: ""@i{n2} is the number of address units of @i{n1} 2274: double-precision IEEE floating-point numbers."" 2275: n2 = n1*sizeof(DFloat); 2276: 2277: sfaligned ( c_addr -- sf_addr ) float-ext s_f_aligned 2278: ""@i{sf-addr} is the first single-float-aligned address greater 2279: than or equal to @i{c-addr}."" 2280: sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); 2281: : 2282: [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; 2283: 2284: dfaligned ( c_addr -- df_addr ) float-ext d_f_aligned 2285: ""@i{df-addr} is the first double-float-aligned address greater 2286: than or equal to @i{c-addr}."" 2287: df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); 2288: : 2289: [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; 2290: 2291: v* ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star 2292: ""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the 2293: next at f_addr1+nstride1 and so on (similar for v2). Both vectors have 2294: ucount elements."" 2295: r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount); 2296: : 2297: >r swap 2swap swap 0e r> 0 ?DO 2298: dup f@ over + 2swap dup f@ f* f+ over + 2swap 2299: LOOP 2drop 2drop ; 2300: 2301: faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth 2302: ""vy=ra*vx+vy"" 2303: faxpy(ra, f_x, nstridex, f_y, nstridey, ucount); 2304: : 2305: >r swap 2swap swap r> 0 ?DO 2306: fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap 2307: LOOP 2drop 2drop fdrop ; 2308: 2309: \+ 2310: 2311: \ The following words access machine/OS/installation-dependent 2312: \ Gforth internals 2313: \ !! how about environmental queries DIRECT-THREADED, 2314: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ 2315: 2316: \ local variable implementation primitives 2317: 2318: \+glocals 2319: 2320: \g locals 2321: 2322: @local# ( #noffset -- w ) gforth fetch_local_number 2323: w = *(Cell *)(lp+noffset); 2324: 2325: @local0 ( -- w ) new fetch_local_zero 2326: w = ((Cell *)lp)[0]; 2327: 2328: @local1 ( -- w ) new fetch_local_four 2329: w = ((Cell *)lp)[1]; 2330: 2331: @local2 ( -- w ) new fetch_local_eight 2332: w = ((Cell *)lp)[2]; 2333: 2334: @local3 ( -- w ) new fetch_local_twelve 2335: w = ((Cell *)lp)[3]; 2336: 2337: \+floating 2338: 2339: f@local# ( #noffset -- r ) gforth f_fetch_local_number 2340: r = *(Float *)(lp+noffset); 2341: 2342: f@local0 ( -- r ) new f_fetch_local_zero 2343: r = ((Float *)lp)[0]; 2344: 2345: f@local1 ( -- r ) new f_fetch_local_eight 2346: r = ((Float *)lp)[1]; 2347: 2348: \+ 2349: 2350: laddr# ( #noffset -- c_addr ) gforth laddr_number 2351: /* this can also be used to implement lp@ */ 2352: c_addr = (Char *)(lp+noffset); 2353: 2354: lp+!# ( #noffset -- ) gforth lp_plus_store_number 2355: ""used with negative immediate values it allocates memory on the 2356: local stack, a positive immediate argument drops memory from the local 2357: stack"" 2358: lp += noffset; 2359: 2360: lp- ( -- ) new minus_four_lp_plus_store 2361: lp += -sizeof(Cell); 2362: 2363: lp+ ( -- ) new eight_lp_plus_store 2364: lp += sizeof(Float); 2365: 2366: lp+2 ( -- ) new sixteen_lp_plus_store 2367: lp += 2*sizeof(Float); 2368: 2369: lp! ( c_addr -- ) gforth lp_store 2370: lp = (Address)c_addr; 2371: 2372: >l ( w -- ) gforth to_l 2373: lp -= sizeof(Cell); 2374: *(Cell *)lp = w; 2375: 2376: \+floating 2377: 2378: f>l ( r -- ) gforth f_to_l 2379: lp -= sizeof(Float); 2380: *(Float *)lp = r; 2381: 2382: fpick ( f:... u -- f:... r ) gforth 2383: ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }."" 2384: r = fp[u]; 2385: : 2386: floats fp@ + f@ ; 2387: 2388: \+ 2389: \+ 2390: 2391: \+OS 2392: 2393: \g syslib 2394: 2395: open-lib ( c_addr1 u1 -- u2 ) gforth open_lib 2396: #if 1 2397: u2 = (UCell)lt_dlopen(cstr(c_addr1, u1, 1)); 2398: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) 2399: #ifndef RTLD_GLOBAL 2400: #define RTLD_GLOBAL 0 2401: #endif 2402: u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); 2403: #else 2404: # ifdef _WIN32 2405: u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); 2406: # else 2407: #warning Define open-lib! 2408: u2 = 0; 2409: # endif 2410: #endif 2411: 2412: lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym 2413: #if 1 2414: u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1)); 2415: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) 2416: u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); 2417: #else 2418: # ifdef _WIN32 2419: u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); 2420: # else 2421: #warning Define lib-sym! 2422: u3 = 0; 2423: # endif 2424: #endif 2425: 2426: wcall ( ... u -- ... ) gforth 2427: gforth_FP=fp; 2428: sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &gforth_FP); 2429: fp=gforth_FP; 2430: 2431: uw@ ( c_addr -- u ) gforth u_w_fetch 2432: ""@i{u} is the zero-extended 16-bit value stored at @i{c_addr}."" 2433: u = *(UWyde*)(c_addr); 2434: 2435: sw@ ( c_addr -- n ) gforth s_w_fetch 2436: ""@i{n} is the sign-extended 16-bit value stored at @i{c_addr}."" 2437: n = *(Wyde*)(c_addr); 2438: 2439: w! ( w c_addr -- ) gforth w_store 2440: ""Store the bottom 16 bits of @i{w} at @i{c_addr}."" 2441: *(Wyde*)(c_addr) = w; 2442: 2443: ul@ ( c_addr -- u ) gforth u_l_fetch 2444: ""@i{u} is the zero-extended 32-bit value stored at @i{c_addr}."" 2445: u = *(UTetrabyte*)(c_addr); 2446: 2447: sl@ ( c_addr -- n ) gforth s_l_fetch 2448: ""@i{n} is the sign-extended 32-bit value stored at @i{c_addr}."" 2449: n = *(Tetrabyte*)(c_addr); 2450: 2451: l! ( w c_addr -- ) gforth l_store 2452: ""Store the bottom 32 bits of @i{w} at @i{c_addr}."" 2453: *(Tetrabyte*)(c_addr) = w; 2454: 2455: \+FFCALL 2456: 2457: av-start-void ( c_addr -- ) gforth av_start_void 2458: av_start_void(alist, c_addr); 2459: 2460: av-start-int ( c_addr -- ) gforth av_start_int 2461: av_start_int(alist, c_addr, &irv); 2462: 2463: av-start-float ( c_addr -- ) gforth av_start_float 2464: av_start_float(alist, c_addr, &frv); 2465: 2466: av-start-double ( c_addr -- ) gforth av_start_double 2467: av_start_double(alist, c_addr, &drv); 2468: 2469: av-start-longlong ( c_addr -- ) gforth av_start_longlong 2470: av_start_longlong(alist, c_addr, &llrv); 2471: 2472: av-start-ptr ( c_addr -- ) gforth av_start_ptr 2473: av_start_ptr(alist, c_addr, void*, &prv); 2474: 2475: av-int ( w -- ) gforth av_int 2476: av_int(alist, w); 2477: 2478: av-float ( r -- ) gforth av_float 2479: av_float(alist, r); 2480: 2481: av-double ( r -- ) gforth av_double 2482: av_double(alist, r); 2483: 2484: av-longlong ( d -- ) gforth av_longlong 2485: #ifdef BUGGY_LL_SIZE 2486: av_longlong(alist, DLO(d)); 2487: #else 2488: av_longlong(alist, d); 2489: #endif 2490: 2491: av-ptr ( c_addr -- ) gforth av_ptr 2492: av_ptr(alist, void*, c_addr); 2493: 2494: av-int-r ( R:w -- ) gforth av_int_r 2495: av_int(alist, w); 2496: 2497: av-float-r ( -- ) gforth av_float_r 2498: float r = *(Float*)lp; 2499: lp += sizeof(Float); 2500: av_float(alist, r); 2501: 2502: av-double-r ( -- ) gforth av_double_r 2503: double r = *(Float*)lp; 2504: lp += sizeof(Float); 2505: av_double(alist, r); 2506: 2507: av-longlong-r ( R:d -- ) gforth av_longlong_r 2508: #ifdef BUGGY_LL_SIZE 2509: av_longlong(alist, DLO(d)); 2510: #else 2511: av_longlong(alist, d); 2512: #endif 2513: 2514: av-ptr-r ( R:c_addr -- ) gforth av_ptr_r 2515: av_ptr(alist, void*, c_addr); 2516: 2517: av-call-void ( ... -- ... ) gforth av_call_void 2518: SAVE_REGS 2519: av_call(alist); 2520: REST_REGS 2521: 2522: av-call-int ( ... -- ... w ) gforth av_call_int 2523: SAVE_REGS 2524: av_call(alist); 2525: REST_REGS 2526: w = irv; 2527: 2528: av-call-float ( ... -- ... r ) gforth av_call_float 2529: SAVE_REGS 2530: av_call(alist); 2531: REST_REGS 2532: r = frv; 2533: 2534: av-call-double ( ... -- ... r ) gforth av_call_double 2535: SAVE_REGS 2536: av_call(alist); 2537: REST_REGS 2538: r = drv; 2539: 2540: av-call-longlong ( ... -- ... d ) gforth av_call_longlong 2541: SAVE_REGS 2542: av_call(alist); 2543: REST_REGS 2544: #ifdef BUGGY_LONG_LONG 2545: DLO_IS(d, llrv); 2546: DHI_IS(d, 0); 2547: #else 2548: d = llrv; 2549: #endif 2550: 2551: av-call-ptr ( ... -- ... c_addr ) gforth av_call_ptr 2552: SAVE_REGS 2553: av_call(alist); 2554: REST_REGS 2555: c_addr = prv; 2556: 2557: alloc-callback ( a_ip -- c_addr ) gforth alloc_callback 2558: c_addr = (char *)alloc_callback(gforth_callback, (Xt *)a_ip); 2559: 2560: va-start-void ( -- ) gforth va_start_void 2561: va_start_void(gforth_clist); 2562: 2563: va-start-int ( -- ) gforth va_start_int 2564: va_start_int(gforth_clist); 2565: 2566: va-start-longlong ( -- ) gforth va_start_longlong 2567: va_start_longlong(gforth_clist); 2568: 2569: va-start-ptr ( -- ) gforth va_start_ptr 2570: va_start_ptr(gforth_clist, (char *)); 2571: 2572: va-start-float ( -- ) gforth va_start_float 2573: va_start_float(gforth_clist); 2574: 2575: va-start-double ( -- ) gforth va_start_double 2576: va_start_double(gforth_clist); 2577: 2578: va-arg-int ( -- w ) gforth va_arg_int 2579: w = va_arg_int(gforth_clist); 2580: 2581: va-arg-longlong ( -- d ) gforth va_arg_longlong 2582: #ifdef BUGGY_LONG_LONG 2583: DLO_IS(d, va_arg_longlong(gforth_clist)); 2584: DHI_IS(d, 0); 2585: #else 2586: d = va_arg_longlong(gforth_clist); 2587: #endif 2588: 2589: va-arg-ptr ( -- c_addr ) gforth va_arg_ptr 2590: c_addr = (char *)va_arg_ptr(gforth_clist,char*); 2591: 2592: va-arg-float ( -- r ) gforth va_arg_float 2593: r = va_arg_float(gforth_clist); 2594: 2595: va-arg-double ( -- r ) gforth va_arg_double 2596: r = va_arg_double(gforth_clist); 2597: 2598: va-return-void ( -- ) gforth va_return_void 2599: va_return_void(gforth_clist); 2600: return 0; 2601: 2602: va-return-int ( w -- ) gforth va_return_int 2603: va_return_int(gforth_clist, w); 2604: return 0; 2605: 2606: va-return-ptr ( c_addr -- ) gforth va_return_ptr 2607: va_return_ptr(gforth_clist, void *, c_addr); 2608: return 0; 2609: 2610: va-return-longlong ( d -- ) gforth va_return_longlong 2611: #ifdef BUGGY_LONG_LONG 2612: va_return_longlong(gforth_clist, d.lo); 2613: #else 2614: va_return_longlong(gforth_clist, d); 2615: #endif 2616: return 0; 2617: 2618: va-return-float ( r -- ) gforth va_return_float 2619: va_return_float(gforth_clist, r); 2620: return 0; 2621: 2622: va-return-double ( r -- ) gforth va_return_double 2623: va_return_double(gforth_clist, r); 2624: return 0; 2625: 2626: \+ 2627: 2628: \+LIBFFI 2629: 2630: ffi-type ( n -- a_type ) gforth ffi_type 2631: static void* ffi_types[] = 2632: { &ffi_type_void, 2633: &ffi_type_uint8, &ffi_type_sint8, 2634: &ffi_type_uint16, &ffi_type_sint16, 2635: &ffi_type_uint32, &ffi_type_sint32, 2636: &ffi_type_uint64, &ffi_type_sint64, 2637: &ffi_type_float, &ffi_type_double, &ffi_type_longdouble, 2638: &ffi_type_pointer }; 2639: a_type = ffi_types[n]; 2640: 2641: ffi-size ( n1 -- n2 ) gforth ffi_size 2642: static int ffi_sizes[] = 2643: { sizeof(ffi_cif), sizeof(ffi_closure) }; 2644: n2 = ffi_sizes[n1]; 2645: 2646: ffi-prep-cif ( a_atypes n a_rtype a_cif -- w ) gforth ffi_prep_cif 2647: w = ffi_prep_cif((ffi_cif *)a_cif, FFI_DEFAULT_ABI, n, 2648: (ffi_type *)a_rtype, (ffi_type **)a_atypes); 2649: 2650: ffi-call ( a_avalues a_rvalue a_ip a_cif -- ) gforth ffi_call 2651: SAVE_REGS 2652: ffi_call((ffi_cif *)a_cif, (void(*)())a_ip, (void *)a_rvalue, (void **)a_avalues); 2653: REST_REGS 2654: 2655: ffi-prep-closure ( a_ip a_cif a_closure -- w ) gforth ffi_prep_closure 2656: w = ffi_prep_closure((ffi_closure *)a_closure, (ffi_cif *)a_cif, gforth_callback, (void *)a_ip); 2657: 2658: ffi-2@ ( a_addr -- d ) gforth ffi_2fetch 2659: #ifdef BUGGY_LONG_LONG 2660: DLO_IS(d, *(Cell*)(*a_addr)); 2661: DHI_IS(d, 0); 2662: #else 2663: d = *(DCell*)(a_addr); 2664: #endif 2665: 2666: ffi-2! ( d a_addr -- ) gforth ffi_2store 2667: #ifdef BUGGY_LONG_LONG 2668: *(Cell*)(a_addr) = DLO(d); 2669: #else 2670: *(DCell*)(a_addr) = d; 2671: #endif 2672: 2673: ffi-arg-int ( -- w ) gforth ffi_arg_int 2674: w = *(int *)(*gforth_clist++); 2675: 2676: ffi-arg-long ( -- w ) gforth ffi_arg_long 2677: w = *(long *)(*gforth_clist++); 2678: 2679: ffi-arg-longlong ( -- d ) gforth ffi_arg_longlong 2680: #ifdef BUGGY_LONG_LONG 2681: DLO_IS(d, *(Cell*)(*gforth_clist++)); 2682: DHI_IS(d, -(*(Cell*)(*gforth_clist++)<0)); 2683: #else 2684: d = *(DCell*)(*gforth_clist++); 2685: #endif 2686: 2687: ffi-arg-dlong ( -- d ) gforth ffi_arg_dlong 2688: #ifdef BUGGY_LONG_LONG 2689: DLO_IS(d, *(Cell*)(*gforth_clist++)); 2690: DHI_IS(d, -(*(Cell*)(*gforth_clist++)<0)); 2691: #else 2692: d = *(Cell*)(*gforth_clist++); 2693: #endif 2694: 2695: ffi-arg-ptr ( -- c_addr ) gforth ffi_arg_ptr 2696: c_addr = *(Char **)(*gforth_clist++); 2697: 2698: ffi-arg-float ( -- r ) gforth ffi_arg_float 2699: r = *(float*)(*gforth_clist++); 2700: 2701: ffi-arg-double ( -- r ) gforth ffi_arg_double 2702: r = *(double*)(*gforth_clist++); 2703: 2704: ffi-ret-void ( -- ) gforth ffi_ret_void 2705: return 0; 2706: 2707: ffi-ret-int ( w -- ) gforth ffi_ret_int 2708: *(int*)(gforth_ritem) = w; 2709: return 0; 2710: 2711: ffi-ret-longlong ( d -- ) gforth ffi_ret_longlong 2712: #ifdef BUGGY_LONG_LONG 2713: *(Cell*)(gforth_ritem) = DLO(d); 2714: #else 2715: *(DCell*)(gforth_ritem) = d; 2716: #endif 2717: return 0; 2718: 2719: ffi-ret-dlong ( d -- ) gforth ffi_ret_dlong 2720: #ifdef BUGGY_LONG_LONG 2721: *(Cell*)(gforth_ritem) = DLO(d); 2722: #else 2723: *(Cell*)(gforth_ritem) = d; 2724: #endif 2725: return 0; 2726: 2727: ffi-ret-long ( n -- ) gforth ffi_ret_long 2728: *(Cell*)(gforth_ritem) = n; 2729: return 0; 2730: 2731: ffi-ret-ptr ( c_addr -- ) gforth ffi_ret_ptr 2732: *(Char **)(gforth_ritem) = c_addr; 2733: return 0; 2734: 2735: ffi-ret-float ( r -- ) gforth ffi_ret_float 2736: *(float*)(gforth_ritem) = r; 2737: return 0; 2738: 2739: ffi-ret-double ( r -- ) gforth ffi_ret_double 2740: *(double*)(gforth_ritem) = r; 2741: return 0; 2742: 2743: \+ 2744: 2745: \+OLDCALL 2746: 2747: define(`uploop', 2748: `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') 2749: define(`_uploop', 2750: `ifelse($1, `$3', `$5', 2751: `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')') 2752: 2753: \ argflist(argnum): Forth argument list 2754: define(argflist, 2755: `ifelse($1, 0, `', 2756: `uploop(`_i', 1, $1, ``u''`_i ', ``u''`_i')')') 2757: \ argdlist(argnum): declare C's arguments 2758: define(argdlist, 2759: `ifelse($1, 0, `', 2760: `uploop(`_i', 1, $1, `Cell, ', `Cell')')') 2761: \ argclist(argnum): pass C's arguments 2762: define(argclist, 2763: `ifelse($1, 0, `', 2764: `uploop(`_i', 1, $1, ``u''`_i, ', ``u''`_i')')') 2765: \ icall(argnum) 2766: define(icall, 2767: `icall$1 ( argflist($1) u -- uret ) gforth 2768: uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1)); 2769: 2770: ') 2771: define(fcall, 2772: `fcall$1 ( argflist($1) u -- rret ) gforth 2773: rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1)); 2774: 2775: ') 2776: 2777: \ close ' to keep fontify happy 2778: 2779: uploop(i, 0, 7, `icall(i)') 2780: icall(20) 2781: uploop(i, 0, 7, `fcall(i)') 2782: fcall(20) 2783: 2784: \+ 2785: 2786: lib-error ( -- c_addr u ) gforth lib_error 2787: c_addr = lt_dlerror(); 2788: u = (c_addr == NULL) ? 0 : strlen(c_addr); 2789: 2790: \+ 2791: \g peephole 2792: 2793: \+peephole 2794: 2795: compile-prim1 ( a_prim -- ) gforth compile_prim1 2796: ""compile prim (incl. immargs) at @var{a_prim}"" 2797: compile_prim1(a_prim); 2798: 2799: finish-code ( ... -- ... ) gforth finish_code 2800: ""Perform delayed steps in code generation (branch resolution, I-cache 2801: flushing)."" 2802: /* The ... above are a workaround for a bug in gcc-2.95, which fails 2803: to save spTOS (gforth-fast --enable-force-reg) */ 2804: finish_code(); 2805: 2806: forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode 2807: f = forget_dyncode(c_code); 2808: 2809: decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim 2810: ""a_prim is the code address of the primitive that has been 2811: compile_prim1ed to a_code"" 2812: a_prim = (Cell *)decompile_code((Label)a_code); 2813: 2814: \ set-next-code and call2 do not appear in images and can be 2815: \ renumbered arbitrarily 2816: 2817: set-next-code ( #w -- ) gforth set_next_code 2818: #ifdef NO_IP 2819: next_code = (Label)w; 2820: #endif 2821: 2822: call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth 2823: /* call with explicit return address */ 2824: #ifdef NO_IP 2825: INST_TAIL; 2826: JUMP(a_callee); 2827: #else 2828: assert(0); 2829: #endif 2830: 2831: tag-offsets ( -- a_addr ) gforth tag_offsets 2832: extern Cell groups[32]; 2833: a_addr = groups; 2834: 2835: \+ 2836: 2837: \g static_super 2838: 2839: ifdef(`STACK_CACHE_FILE', 2840: `include(peeprules.vmg)') 2841: 2842: \g end