1#line 1 "prim" 2\ Gforth primitives 3 4\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 Free Software Foundation, Inc. 5 6\ This file is part of Gforth. 7 8\ Gforth is free software; you can redistribute it and/or 9\ modify it under the terms of the GNU General Public License 10\ as published by the Free Software Foundation, either version 3 11\ of the License, or (at your option) any later version. 12 13\ This program is distributed in the hope that it will be useful, 14\ but WITHOUT ANY WARRANTY; without even the implied warranty of 15\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16\ GNU General Public License for more details. 17 18\ You should have received a copy of the GNU General Public License 19\ along with this program. If not, see http://www.gnu.org/licenses/. 20 21 22\ WARNING: This file is processed by m4. Make sure your identifiers 23\ don't collide with m4's (e.g. by undefining them). 24\ 25\ 26\ 27\ This file contains primitive specifications in the following format: 28\ 29\ forth name ( stack effect ) category [pronunciation] 30\ [""glossary entry""] 31\ C code 32\ [: 33\ Forth code] 34\ 35\ Note: Fields in brackets are optional. Word specifications have to 36\ be separated by at least one empty line 37\ 38\ Both pronounciation and stack items (in the stack effect) must 39\ conform to the C identifier syntax or the C compiler will complain. 40\ If you don't have a pronounciation field, the Forth name is used, 41\ and has to conform to the C identifier syntax. 42\ 43\ These specifications are automatically translated into C-code for the 44\ interpreter and into some other files. I hope that your C compiler has 45\ decent optimization, otherwise the automatically generated code will 46\ be somewhat slow. The Forth version of the code is included for manual 47\ compilers, so they will need to compile only the important words. 48\ 49\ Note that stack pointer adjustment is performed according to stack 50\ effect by automatically generated code and NEXT is automatically 51\ appended to the C code. Also, you can use the names in the stack 52\ effect in the C code. Stack access is automatic. One exception: if 53\ your code does not fall through, the results are not stored into the 54\ stack. Use different names on both sides of the '--', if you change a 55\ value (some stores to the stack are optimized away). 56\ 57\ For superinstructions the syntax is: 58\ 59\ forth-name [/ c-name] = forth-name forth-name ... 60\ 61\ 62\ The stack variables have the following types: 63\ 64\ name matches type 65\ f.* Bool 66\ c.* Char 67\ [nw].* Cell 68\ u.* UCell 69\ d.* DCell 70\ ud.* UDCell 71\ r.* Float 72\ a_.* Cell * 73\ c_.* Char * 74\ f_.* Float * 75\ df_.* DFloat * 76\ sf_.* SFloat * 77\ xt.* XT 78\ f83name.* F83Name * 79 80\E stack data-stack sp Cell 81\E stack fp-stack fp Float 82\E stack return-stack rp Cell 83\E 84\E get-current prefixes set-current 85\E 86\E s" Bool" single data-stack type-prefix f 87\E s" Char" single data-stack type-prefix c 88\E s" Cell" single data-stack type-prefix n 89\E s" Cell" single data-stack type-prefix w 90\E s" UCell" single data-stack type-prefix u 91\E s" DCell" double data-stack type-prefix d 92\E s" UDCell" double data-stack type-prefix ud 93\E s" Float" single fp-stack type-prefix r 94\E s" Cell *" single data-stack type-prefix a_ 95\E s" Char *" single data-stack type-prefix c_ 96\E s" Float *" single data-stack type-prefix f_ 97\E s" DFloat *" single data-stack type-prefix df_ 98\E s" SFloat *" single data-stack type-prefix sf_ 99\E s" Xt" single data-stack type-prefix xt 100\E s" struct F83Name *" single data-stack type-prefix f83name 101\E s" struct Longname *" single data-stack type-prefix longname 102\E 103\E data-stack stack-prefix S: 104\E fp-stack stack-prefix F: 105\E return-stack stack-prefix R: 106\E inst-stream stack-prefix # 107\E 108\E set-current 109\E store-optimization on 110\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump 111\E 112\E include-skipped-insts on \ static superinsts include cells for components 113\E \ useful for dynamic programming and 114\E \ superinsts across entry points 115 116\ 117\ 118\ 119\ In addition the following names can be used: 120\ ip the instruction pointer 121\ sp the data stack pointer 122\ rp the parameter stack pointer 123\ lp the locals stack pointer 124\ NEXT executes NEXT 125\ cfa 126\ NEXT1 executes NEXT1 127\ FLAG(x) makes a Forth flag from a C flag 128\ 129\ 130\ 131\ Percentages in comments are from Koopmans book: average/maximum use 132\ (taken from four, not very representative benchmarks) 133\ 134\ 135\ 136\ To do: 137\ 138\ throw execute, cfa and NEXT1 out? 139\ macroize *ip, ip++, *ip++ (pipelining)? 140 141\ Stack caching setup 142 143#line 1 "cache0.vmg" 144\ stack cache setup 145 146\ Copyright (C) 2003,2007 Free Software Foundation, Inc. 147 148\ This file is part of Gforth. 149 150\ Gforth is free software; you can redistribute it and/or 151\ modify it under the terms of the GNU General Public License 152\ as published by the Free Software Foundation, either version 3 153\ of the License, or (at your option) any later version. 154 155\ This program is distributed in the hope that it will be useful, 156\ but WITHOUT ANY WARRANTY; without even the implied warranty of 157\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 158\ GNU General Public License for more details. 159 160\ You should have received a copy of the GNU General Public License 161\ along with this program. If not, see http://www.gnu.org/licenses/. 162 163\E register IPTOS Cell 164\E register spa Cell 165\E register spb Cell 166\E register spc Cell 167\E register spd Cell 168 169\E create IPregs IPTOS , 170\E create regs spc , spb , spa , 171 172\E IPregs 1 0 stack-state IPss1 173\E regs 3 th 0 0 stack-state ss0 174\E regs 2 th 1 0 stack-state ss1 175\E regs 1 th 2 1 stack-state ss2 176\E regs 0 th 3 2 stack-state ss3 177 178\ the first of these is the default state 179\E state S0 180\E state S1 181\E state S2 182\E state S3 183 184\E ss0 data-stack S0 set-ss 185\E ss1 data-stack S1 set-ss 186\E ss2 data-stack S2 set-ss 187\E ss3 data-stack S3 set-ss 188 189\E IPss1 inst-stream S0 set-ss 190\E IPss1 inst-stream S1 set-ss 191\E IPss1 inst-stream S2 set-ss 192\E IPss1 inst-stream S3 set-ss 193 194\E data-stack to cache-stack 195\E here 4 cache-states 2! s0 , s1 , s2 , s3 , 196 197\ !! the following should be automatic 198\E S0 to state-default 199\E state-default to state-in 200\E state-default to state-out 201#line 142 "prim" 202 203 204\ these m4 macros would collide with identifiers 205 206 207 208 209\F 0 [if] 210 211\ run-time routines for non-primitives. They are defined as 212\ primitives, because that simplifies things. 213 214(docol) ( -- R:a_retaddr ) gforth-internal paren_docol 215""run-time routine for colon definitions"" 216#ifdef NO_IP 217a_retaddr = next_code; 218INST_TAIL; 219goto **(Label *)PFA(CFA); 220#else /* !defined(NO_IP) */ 221a_retaddr = (Cell *)IP; 222SET_IP((Xt *)PFA(CFA)); 223#endif /* !defined(NO_IP) */ 224 225(docon) ( -- w ) gforth-internal paren_docon 226""run-time routine for constants"" 227w = *(Cell *)PFA(CFA); 228#ifdef NO_IP 229INST_TAIL; 230goto *next_code; 231#endif /* defined(NO_IP) */ 232 233(dovar) ( -- a_body ) gforth-internal paren_dovar 234""run-time routine for variables and CREATEd words"" 235a_body = PFA(CFA); 236#ifdef NO_IP 237INST_TAIL; 238goto *next_code; 239#endif /* defined(NO_IP) */ 240 241(douser) ( -- a_user ) gforth-internal paren_douser 242""run-time routine for constants"" 243a_user = (Cell *)(up+*(Cell *)PFA(CFA)); 244#ifdef NO_IP 245INST_TAIL; 246goto *next_code; 247#endif /* defined(NO_IP) */ 248 249(dodefer) ( -- ) gforth-internal paren_dodefer 250""run-time routine for deferred words"" 251#ifndef NO_IP 252ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */ 253#endif /* !defined(NO_IP) */ 254SUPER_END; /* !! probably unnecessary and may lead to measurement errors */ 255VM_JUMP(EXEC1(*(Xt *)PFA(CFA))); 256 257(dofield) ( n1 -- n2 ) gforth-internal paren_field 258""run-time routine for fields"" 259n2 = n1 + *(Cell *)PFA(CFA); 260#ifdef NO_IP 261INST_TAIL; 262goto *next_code; 263#endif /* defined(NO_IP) */ 264 265(dovalue) ( -- w ) gforth-internal paren_doval 266""run-time routine for constants"" 267w = *(Cell *)PFA(CFA); 268#ifdef NO_IP 269INST_TAIL; 270goto *next_code; 271#endif /* defined(NO_IP) */ 272 273(dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes 274""run-time routine for @code{does>}-defined words"" 275#ifdef NO_IP 276a_retaddr = next_code; 277a_body = PFA(CFA); 278INST_TAIL; 279#ifdef DEBUG 280fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); 281#endif 282goto **(Label *)DOES_CODE1(CFA); 283#else /* !defined(NO_IP) */ 284a_retaddr = (Cell *)IP; 285a_body = PFA(CFA); 286#ifdef DEBUG 287fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); 288#endif 289SET_IP(DOES_CODE1(CFA)); 290#endif /* !defined(NO_IP) */ 291 292(does-handler) ( -- ) gforth-internal paren_does_handler 293""just a slot to have an encoding for the DOESJUMP, 294which is no longer used anyway (!! eliminate this)"" 295 296\F [endif] 297 298\g control 299 300noop ( -- ) gforth 301: 302 ; 303 304call ( #a_callee -- R:a_retaddr ) new 305""Call callee (a variant of docol with inline argument)."" 306#ifdef NO_IP 307assert(0); 308INST_TAIL; 309JUMP(a_callee); 310#else 311#ifdef DEBUG 312 { 313 CFA_TO_NAME((((Cell *)a_callee)-2)); 314 fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee, 315 len,name); 316 } 317#endif 318a_retaddr = (Cell *)IP; 319SET_IP((Xt *)a_callee); 320#endif 321 322execute ( xt -- ) core 323""Perform the semantics represented by the execution token, @i{xt}."" 324#ifdef DEBUG 325fprintf(stderr, "execute %08x\n", xt); 326#endif 327#ifndef NO_IP 328ip=IP; 329#endif 330SUPER_END; 331VM_JUMP(EXEC1(xt)); 332 333perform ( a_addr -- ) gforth 334""@code{@@ execute}."" 335/* and pfe */ 336#ifndef NO_IP 337ip=IP; 338#endif 339SUPER_END; 340VM_JUMP(EXEC1(*(Xt *)a_addr)); 341: 342 @ execute ; 343 344;s ( R:w -- ) gforth semis 345""The primitive compiled by @code{EXIT}."" 346#ifdef NO_IP 347INST_TAIL; 348goto *(void *)w; 349#else 350SET_IP((Xt *)w); 351#endif 352 353unloop ( R:w1 R:w2 -- ) core 354/* !! alias for 2rdrop */ 355: 356 r> rdrop rdrop >r ; 357 358lit-perform ( #a_addr -- ) new lit_perform 359#ifndef NO_IP 360ip=IP; 361#endif 362SUPER_END; 363VM_JUMP(EXEC1(*(Xt *)a_addr)); 364 365does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec 366#ifdef NO_IP 367/* compiled to LIT CALL by compile_prim */ 368assert(0); 369#else 370a_pfa = PFA(a_cfa); 371nest = (Cell)IP; 372#ifdef DEBUG 373 { 374 CFA_TO_NAME(a_cfa); 375 fprintf(stderr,"%08lx: does %08lx %.*s\n", 376 (Cell)ip,(Cell)a_cfa,len,name); 377 } 378#endif 379SET_IP(DOES_CODE1(a_cfa)); 380#endif 381 382\+glocals 383 384branch-lp+!# ( #a_target #nlocals -- ) gforth branch_lp_plus_store_number 385/* this will probably not be used */ 386lp += nlocals; 387#ifdef NO_IP 388INST_TAIL; 389JUMP(a_target); 390#else 391SET_IP((Xt *)a_target); 392#endif 393 394\+ 395 396branch ( #a_target -- ) gforth 397#ifdef NO_IP 398INST_TAIL; 399JUMP(a_target); 400#else 401SET_IP((Xt *)a_target); 402#endif 403: 404 r> @ >r ; 405 406\ condbranch(forthname,stackeffect,restline,code1,code2,forthcode) 407\ this is non-syntactical: code must open a brace that is closed by the macro 408#line 380 409 410 411?branch ( #a_target f -- ) f83 question_branch 412#line 382 413 #ifdef NO_IP 414#line 382 415INST_TAIL; 416#line 382 417#endif 418#line 382 419if (f==0) { 420#line 382 421 #ifdef NO_IP 422#line 382 423JUMP(a_target); 424#line 382 425#else 426#line 382 427SET_IP((Xt *)a_target); 428#line 382 429/* 0=0 */ 430#line 382 431#endif 432#line 382 433} 434#line 382 435/* 0=0 */ 436#line 382 437: 438#line 382 439 0= dup 0= \ !f f 440#line 382 441 r> tuck cell+ \ !f branchoffset f IP+ 442#line 382 443 and -rot @ and or \ f&IP+|!f&branch 444#line 382 445 >r ; 446#line 382 447 448#line 382 449\+glocals 450#line 382 451 452#line 382 453?branch-lp+!# ( #a_target #nlocals f -- ) f83 question_branch_lp_plus_store_number 454#line 382 455 #ifdef NO_IP 456#line 382 457INST_TAIL; 458#line 382 459#endif 460#line 382 461if (f==0) { 462#line 382 463 lp += nlocals; 464#line 382 465#ifdef NO_IP 466#line 382 467JUMP(a_target); 468#line 382 469#else 470#line 382 471SET_IP((Xt *)a_target); 472#line 382 473/* 0=0 */ 474#line 382 475#endif 476#line 382 477} 478#line 382 479/* 0=0 */ 480#line 382 481 482#line 382 483\+ 484#line 388 485 486 487\ we don't need an lp_plus_store version of the ?dup-stuff, because it 488\ is only used in if's (yet) 489 490\+xconds 491 492?dup-?branch ( #a_target f -- S:... ) new question_dupe_question_branch 493""The run-time procedure compiled by @code{?DUP-IF}."" 494if (f==0) { 495#ifdef NO_IP 496INST_TAIL; 497JUMP(a_target); 498#else 499SET_IP((Xt *)a_target); 500#endif 501} else { 502sp--; 503sp[0]=f; 504} 505 506?dup-0=-?branch ( #a_target f -- S:... ) new question_dupe_zero_equals_question_branch 507""The run-time procedure compiled by @code{?DUP-0=-IF}."" 508if (f!=0) { 509 sp--; 510 sp[0]=f; 511#ifdef NO_IP 512 JUMP(a_target); 513#else 514 SET_IP((Xt *)a_target); 515#endif 516} 517 518\+ 519\fhas? skiploopprims 0= [IF] 520 521(next) ( #a_target R:n1 -- R:n2 ) cmFORTH paren_next 522#line 424 523n2=n1-1; 524#line 424 525 #ifdef NO_IP 526#line 424 527INST_TAIL; 528#line 424 529#endif 530#line 424 531if (n1) { 532#line 424 533 #ifdef NO_IP 534#line 424 535JUMP(a_target); 536#line 424 537#else 538#line 424 539SET_IP((Xt *)a_target); 540#line 424 541/* 0=0 */ 542#line 424 543#endif 544#line 424 545} 546#line 424 547/* 0=0 */ 548#line 424 549: 550#line 424 551 r> r> dup 1- >r 552#line 424 553 IF @ >r ELSE cell+ >r THEN ; 554#line 424 555 556#line 424 557\+glocals 558#line 424 559 560#line 424 561(next)-lp+!# ( #a_target #nlocals R:n1 -- R:n2 ) cmFORTH paren_next_lp_plus_store_number 562#line 424 563n2=n1-1; 564#line 424 565 #ifdef NO_IP 566#line 424 567INST_TAIL; 568#line 424 569#endif 570#line 424 571if (n1) { 572#line 424 573 lp += nlocals; 574#line 424 575#ifdef NO_IP 576#line 424 577JUMP(a_target); 578#line 424 579#else 580#line 424 581SET_IP((Xt *)a_target); 582#line 424 583/* 0=0 */ 584#line 424 585#endif 586#line 424 587} 588#line 424 589/* 0=0 */ 590#line 424 591 592#line 424 593\+ 594#line 429 595 596 597(loop) ( #a_target R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_loop 598#line 431 599n2=n1+1; 600#line 431 601 #ifdef NO_IP 602#line 431 603INST_TAIL; 604#line 431 605#endif 606#line 431 607if (n2 != nlimit) { 608#line 431 609 #ifdef NO_IP 610#line 431 611JUMP(a_target); 612#line 431 613#else 614#line 431 615SET_IP((Xt *)a_target); 616#line 431 617/* 0=0 */ 618#line 431 619#endif 620#line 431 621} 622#line 431 623/* 0=0 */ 624#line 431 625: 626#line 431 627 r> r> 1+ r> 2dup = 628#line 431 629 IF >r 1- >r cell+ >r 630#line 431 631 ELSE >r >r @ >r THEN ; 632#line 431 633 634#line 431 635\+glocals 636#line 431 637 638#line 431 639(loop)-lp+!# ( #a_target #nlocals R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_loop_lp_plus_store_number 640#line 431 641n2=n1+1; 642#line 431 643 #ifdef NO_IP 644#line 431 645INST_TAIL; 646#line 431 647#endif 648#line 431 649if (n2 != nlimit) { 650#line 431 651 lp += nlocals; 652#line 431 653#ifdef NO_IP 654#line 431 655JUMP(a_target); 656#line 431 657#else 658#line 431 659SET_IP((Xt *)a_target); 660#line 431 661/* 0=0 */ 662#line 431 663#endif 664#line 431 665} 666#line 431 667/* 0=0 */ 668#line 431 669 670#line 431 671\+ 672#line 437 673 674 675(+loop) ( #a_target n R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_plus_loop 676#line 439 677/* !! check this thoroughly */ 678#line 439 679/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ 680#line 439 681/* dependent upon two's complement arithmetic */ 682#line 439 683Cell olddiff = n1-nlimit; 684#line 439 685n2=n1+n; 686#line 439 687 #ifdef NO_IP 688#line 439 689INST_TAIL; 690#line 439 691#endif 692#line 439 693if (((olddiff^(olddiff+n)) /* the limit is not crossed */ 694#line 439 695 &(olddiff^n)) /* OR it is a wrap-around effect */ 696#line 439 697 >=0) { /* & is used to avoid having two branches for gforth-native */ 698#line 439 699 #ifdef NO_IP 700#line 439 701JUMP(a_target); 702#line 439 703#else 704#line 439 705SET_IP((Xt *)a_target); 706#line 439 707/* 0=0 */ 708#line 439 709#endif 710#line 439 711} 712#line 439 713/* 0=0 */ 714#line 439 715: 716#line 439 717 r> swap 718#line 439 719 r> r> 2dup - >r 720#line 439 721 2 pick r@ + r@ xor 0< 0= 722#line 439 723 3 pick r> xor 0< 0= or 724#line 439 725 IF >r + >r @ >r 726#line 439 727 ELSE >r >r drop cell+ >r THEN ; 728#line 439 729 730#line 439 731\+glocals 732#line 439 733 734#line 439 735(+loop)-lp+!# ( #a_target #nlocals n R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_plus_loop_lp_plus_store_number 736#line 439 737/* !! check this thoroughly */ 738#line 439 739/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ 740#line 439 741/* dependent upon two's complement arithmetic */ 742#line 439 743Cell olddiff = n1-nlimit; 744#line 439 745n2=n1+n; 746#line 439 747 #ifdef NO_IP 748#line 439 749INST_TAIL; 750#line 439 751#endif 752#line 439 753if (((olddiff^(olddiff+n)) /* the limit is not crossed */ 754#line 439 755 &(olddiff^n)) /* OR it is a wrap-around effect */ 756#line 439 757 >=0) { /* & is used to avoid having two branches for gforth-native */ 758#line 439 759 lp += nlocals; 760#line 439 761#ifdef NO_IP 762#line 439 763JUMP(a_target); 764#line 439 765#else 766#line 439 767SET_IP((Xt *)a_target); 768#line 439 769/* 0=0 */ 770#line 439 771#endif 772#line 439 773} 774#line 439 775/* 0=0 */ 776#line 439 777 778#line 439 779\+ 780#line 454 781 782 783\+xconds 784 785(-loop) ( #a_target u R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_minus_loop 786#line 458 787UCell olddiff = n1-nlimit; 788#line 458 789n2=n1-u; 790#line 458 791 #ifdef NO_IP 792#line 458 793INST_TAIL; 794#line 458 795#endif 796#line 458 797if (olddiff>u) { 798#line 458 799 #ifdef NO_IP 800#line 458 801JUMP(a_target); 802#line 458 803#else 804#line 458 805SET_IP((Xt *)a_target); 806#line 458 807/* 0=0 */ 808#line 458 809#endif 810#line 458 811} 812#line 458 813/* 0=0 */ 814#line 458 815 816#line 458 817 818#line 458 819\+glocals 820#line 458 821 822#line 458 823(-loop)-lp+!# ( #a_target #nlocals u R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_minus_loop_lp_plus_store_number 824#line 458 825UCell olddiff = n1-nlimit; 826#line 458 827n2=n1-u; 828#line 458 829 #ifdef NO_IP 830#line 458 831INST_TAIL; 832#line 458 833#endif 834#line 458 835if (olddiff>u) { 836#line 458 837 lp += nlocals; 838#line 458 839#ifdef NO_IP 840#line 458 841JUMP(a_target); 842#line 458 843#else 844#line 458 845SET_IP((Xt *)a_target); 846#line 458 847/* 0=0 */ 848#line 458 849#endif 850#line 458 851} 852#line 458 853/* 0=0 */ 854#line 458 855 856#line 458 857\+ 858#line 462 859 860 861(s+loop) ( #a_target n R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_symmetric_plus_loop 862#line 464 863""The run-time procedure compiled by S+LOOP. It loops until the index 864#line 464 865crosses the boundary between limit and limit-sign(n). I.e. a symmetric 866#line 464 867version of (+LOOP)."" 868#line 464 869/* !! check this thoroughly */ 870#line 464 871Cell diff = n1-nlimit; 872#line 464 873Cell newdiff = diff+n; 874#line 464 875if (n<0) { 876#line 464 877 diff = -diff; 878#line 464 879 newdiff = -newdiff; 880#line 464 881} 882#line 464 883n2=n1+n; 884#line 464 885 #ifdef NO_IP 886#line 464 887INST_TAIL; 888#line 464 889#endif 890#line 464 891if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */ 892#line 464 893 #ifdef NO_IP 894#line 464 895JUMP(a_target); 896#line 464 897#else 898#line 464 899SET_IP((Xt *)a_target); 900#line 464 901/* 0=0 */ 902#line 464 903#endif 904#line 464 905} 906#line 464 907/* 0=0 */ 908#line 464 909 910#line 464 911 912#line 464 913\+glocals 914#line 464 915 916#line 464 917(s+loop)-lp+!# ( #a_target #nlocals n R:nlimit R:n1 -- R:nlimit R:n2 ) gforth paren_symmetric_plus_loop_lp_plus_store_number 918#line 464 919""The run-time procedure compiled by S+LOOP. It loops until the index 920#line 464 921crosses the boundary between limit and limit-sign(n). I.e. a symmetric 922#line 464 923version of (+LOOP)."" 924#line 464 925/* !! check this thoroughly */ 926#line 464 927Cell diff = n1-nlimit; 928#line 464 929Cell newdiff = diff+n; 930#line 464 931if (n<0) { 932#line 464 933 diff = -diff; 934#line 464 935 newdiff = -newdiff; 936#line 464 937} 938#line 464 939n2=n1+n; 940#line 464 941 #ifdef NO_IP 942#line 464 943INST_TAIL; 944#line 464 945#endif 946#line 464 947if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */ 948#line 464 949 lp += nlocals; 950#line 464 951#ifdef NO_IP 952#line 464 953JUMP(a_target); 954#line 464 955#else 956#line 464 957SET_IP((Xt *)a_target); 958#line 464 959/* 0=0 */ 960#line 464 961#endif 962#line 464 963} 964#line 464 965/* 0=0 */ 966#line 464 967 968#line 464 969\+ 970#line 477 971 972 973\+ 974 975(for) ( ncount -- R:nlimit R:ncount ) cmFORTH paren_for 976/* or (for) = >r -- collides with unloop! */ 977nlimit=0; 978: 979 r> swap 0 >r >r >r ; 980 981(do) ( nlimit nstart -- R:nlimit R:nstart ) gforth paren_do 982: 983 r> swap rot >r >r >r ; 984 985(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_question_do 986#ifdef NO_IP 987 INST_TAIL; 988#endif 989if (nstart == nlimit) { 990#ifdef NO_IP 991 JUMP(a_target); 992#else 993 SET_IP((Xt *)a_target); 994#endif 995} 996: 997 2dup = 998 IF r> swap rot >r >r 999 @ >r 1000 ELSE r> swap rot >r >r 1001 cell+ >r 1002 THEN ; \ --> CORE-EXT 1003 1004\+xconds 1005 1006(+do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do 1007#ifdef NO_IP 1008 INST_TAIL; 1009#endif 1010if (nstart >= nlimit) { 1011#ifdef NO_IP 1012 JUMP(a_target); 1013#else 1014 SET_IP((Xt *)a_target); 1015#endif 1016} 1017: 1018 swap 2dup 1019 r> swap >r swap >r 1020 >= 1021 IF 1022 @ 1023 ELSE 1024 cell+ 1025 THEN >r ; 1026 1027(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do 1028#ifdef NO_IP 1029 INST_TAIL; 1030#endif 1031if (ustart >= ulimit) { 1032#ifdef NO_IP 1033JUMP(a_target); 1034#else 1035SET_IP((Xt *)a_target); 1036#endif 1037} 1038: 1039 swap 2dup 1040 r> swap >r swap >r 1041 u>= 1042 IF 1043 @ 1044 ELSE 1045 cell+ 1046 THEN >r ; 1047 1048(-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do 1049#ifdef NO_IP 1050 INST_TAIL; 1051#endif 1052if (nstart <= nlimit) { 1053#ifdef NO_IP 1054JUMP(a_target); 1055#else 1056SET_IP((Xt *)a_target); 1057#endif 1058} 1059: 1060 swap 2dup 1061 r> swap >r swap >r 1062 <= 1063 IF 1064 @ 1065 ELSE 1066 cell+ 1067 THEN >r ; 1068 1069(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do 1070#ifdef NO_IP 1071 INST_TAIL; 1072#endif 1073if (ustart <= ulimit) { 1074#ifdef NO_IP 1075JUMP(a_target); 1076#else 1077SET_IP((Xt *)a_target); 1078#endif 1079} 1080: 1081 swap 2dup 1082 r> swap >r swap >r 1083 u<= 1084 IF 1085 @ 1086 ELSE 1087 cell+ 1088 THEN >r ; 1089 1090\+ 1091 1092\ don't make any assumptions where the return stack is!! 1093\ implement this in machine code if it should run quickly! 1094 1095i ( R:n -- R:n n ) core 1096: 1097\ rp@ cell+ @ ; 1098 r> r> tuck >r >r ; 1099 1100i' ( R:w R:w2 -- R:w R:w2 w ) gforth i_tick 1101: 1102\ rp@ cell+ cell+ @ ; 1103 r> r> r> dup itmp ! >r >r >r itmp @ ; 1104variable itmp 1105 1106j ( R:w R:w1 R:w2 -- w R:w R:w1 R:w2 ) core 1107: 1108\ rp@ cell+ cell+ cell+ @ ; 1109 r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; 1110[IFUNDEF] itmp variable itmp [THEN] 1111 1112k ( R:w R:w1 R:w2 R:w3 R:w4 -- w R:w R:w1 R:w2 R:w3 R:w4 ) gforth 1113: 1114\ rp@ [ 5 cells ] Literal + @ ; 1115 r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; 1116[IFUNDEF] itmp variable itmp [THEN] 1117 1118\f[THEN] 1119 1120\ digit is high-level: 0/0% 1121 1122\g strings 1123 1124move ( c_from c_to ucount -- ) core 1125""Copy the contents of @i{ucount} aus at @i{c-from} to 1126@i{c-to}. @code{move} works correctly even if the two areas overlap."" 1127/* !! note that the standard specifies addr, not c-addr */ 1128memmove(c_to,c_from,ucount); 1129/* make an Ifdef for bsd and others? */ 1130: 1131 >r 2dup u< IF r> cmove> ELSE r> cmove THEN ; 1132 1133cmove ( c_from c_to u -- ) string c_move 1134""Copy the contents of @i{ucount} characters from data space at 1135@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} 1136from low address to high address; i.e., for overlapping areas it is 1137safe if @i{c-to}=<@i{c-from}."" 1138cmove(c_from,c_to,u); 1139: 1140 bounds ?DO dup c@ I c! 1+ LOOP drop ; 1141 1142cmove> ( c_from c_to u -- ) string c_move_up 1143""Copy the contents of @i{ucount} characters from data space at 1144@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} 1145from high address to low address; i.e., for overlapping areas it is 1146safe if @i{c-to}>=@i{c-from}."" 1147cmove_up(c_from,c_to,u); 1148: 1149 dup 0= IF drop 2drop exit THEN 1150 rot over + -rot bounds swap 1- 1151 DO 1- dup c@ I c! -1 +LOOP drop ; 1152 1153fill ( c_addr u c -- ) core 1154""Store @i{c} in @i{u} chars starting at @i{c-addr}."" 1155memset(c_addr,c,u); 1156: 1157 -rot bounds 1158 ?DO dup I c! LOOP drop ; 1159 1160compare ( c_addr1 u1 c_addr2 u2 -- n ) string 1161""Compare two strings lexicographically. If they are equal, @i{n} is 0; if 1162the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} 1163is 1. Currently this is based on the machine's character 1164comparison. In the future, this may change to consider the current 1165locale and its collation order."" 1166/* close ' to keep fontify happy */ 1167n = compare(c_addr1, u1, c_addr2, u2); 1168: 1169 rot 2dup swap - >r min swap -text dup 1170 IF rdrop ELSE drop r> sgn THEN ; 1171: -text ( c_addr1 u c_addr2 -- n ) 1172 swap bounds 1173 ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 1174 ELSE c@ I c@ - unloop THEN sgn ; 1175: sgn ( n -- -1/0/1 ) 1176 dup 0= IF EXIT THEN 0< 2* 1+ ; 1177 1178\ -text is only used by replaced primitives now; move it elsewhere 1179\ -text ( c_addr1 u c_addr2 -- n ) new dash_text 1180\ n = memcmp(c_addr1, c_addr2, u); 1181\ if (n<0) 1182\ n = -1; 1183\ else if (n>0) 1184\ n = 1; 1185\ : 1186\ swap bounds 1187\ ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 1188\ ELSE c@ I c@ - unloop THEN sgn ; 1189\ : sgn ( n -- -1/0/1 ) 1190\ dup 0= IF EXIT THEN 0< 2* 1+ ; 1191 1192toupper ( c1 -- c2 ) gforth 1193""If @i{c1} is a lower-case character (in the current locale), @i{c2} 1194is the equivalent upper-case character. All other characters are unchanged."" 1195c2 = toupper(c1); 1196: 1197 dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; 1198 1199capscompare ( c_addr1 u1 c_addr2 u2 -- n ) gforth 1200""Compare two strings lexicographically. If they are equal, @i{n} is 0; if 1201the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} 1202is 1. Currently this is based on the machine's character 1203comparison. In the future, this may change to consider the current 1204locale and its collation order."" 1205/* close ' to keep fontify happy */ 1206n = capscompare(c_addr1, u1, c_addr2, u2); 1207 1208/string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string 1209""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} 1210characters from the start of the string."" 1211c_addr2 = c_addr1+n; 1212u2 = u1-n; 1213: 1214 tuck - >r + r> dup 0< IF - 0 THEN ; 1215 1216\g arith 1217 1218lit ( #w -- w ) gforth 1219: 1220 r> dup @ swap cell+ >r ; 1221 1222+ ( n1 n2 -- n ) core plus 1223n = n1+n2; 1224 1225\ lit+ / lit_plus = lit + 1226 1227lit+ ( n1 #n2 -- n ) new lit_plus 1228#ifdef DEBUG 1229fprintf(stderr, "lit+ %08x\n", n2); 1230#endif 1231n=n1+n2; 1232 1233\ PFE-0.9.14 has it differently, but the next release will have it as follows 1234under+ ( n1 n2 n3 -- n n2 ) gforth under_plus 1235""add @i{n3} to @i{n1} (giving @i{n})"" 1236n = n1+n3; 1237: 1238 rot + swap ; 1239 1240- ( n1 n2 -- n ) core minus 1241n = n1-n2; 1242: 1243 negate + ; 1244 1245negate ( n1 -- n2 ) core 1246/* use minus as alias */ 1247n2 = -n1; 1248: 1249 invert 1+ ; 1250 12511+ ( n1 -- n2 ) core one_plus 1252n2 = n1+1; 1253: 1254 1 + ; 1255 12561- ( n1 -- n2 ) core one_minus 1257n2 = n1-1; 1258: 1259 1 - ; 1260 1261max ( n1 n2 -- n ) core 1262if (n1<n2) 1263 n = n2; 1264else 1265 n = n1; 1266: 1267 2dup < IF swap THEN drop ; 1268 1269min ( n1 n2 -- n ) core 1270if (n1<n2) 1271 n = n1; 1272else 1273 n = n2; 1274: 1275 2dup > IF swap THEN drop ; 1276 1277abs ( n -- u ) core 1278if (n<0) 1279 u = -n; 1280else 1281 u = n; 1282: 1283 dup 0< IF negate THEN ; 1284 1285* ( n1 n2 -- n ) core star 1286n = n1*n2; 1287: 1288 um* drop ; 1289 1290/ ( n1 n2 -- n ) core slash 1291n = n1/n2; 1292if (CHECK_DIVISION_SW && n2 == 0) 1293 throw(BALL_DIVZERO); 1294if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) 1295 throw(BALL_RESULTRANGE); 1296if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0)) 1297 n--; 1298: 1299 /mod nip ; 1300 1301mod ( n1 n2 -- n ) core 1302n = n1%n2; 1303if (CHECK_DIVISION_SW && n2 == 0) 1304 throw(BALL_DIVZERO); 1305if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) 1306 throw(BALL_RESULTRANGE); 1307if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2; 1308: 1309 /mod drop ; 1310 1311/mod ( n1 n2 -- n3 n4 ) core slash_mod 1312n4 = n1/n2; 1313n3 = n1%n2; /* !! is this correct? look into C standard! */ 1314if (CHECK_DIVISION_SW && n2 == 0) 1315 throw(BALL_DIVZERO); 1316if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) 1317 throw(BALL_RESULTRANGE); 1318if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) { 1319 n4--; 1320 n3+=n2; 1321} 1322: 1323 >r s>d r> fm/mod ; 1324 1325*/mod ( n1 n2 n3 -- n4 n5 ) core star_slash_mod 1326""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double."" 1327#ifdef BUGGY_LL_MUL 1328DCell d = mmul(n1,n2); 1329#else 1330DCell d = (DCell)n1 * (DCell)n2; 1331#endif 1332#ifdef ASM_SM_SLASH_REM 1333ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5); 1334if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) { 1335 if (CHECK_DIVISION && n5 == CELL_MIN) 1336 throw(BALL_RESULTRANGE); 1337 n5--; 1338 n4+=n3; 1339} 1340#else 1341DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); 1342n4=DHI(r); 1343n5=DLO(r); 1344#endif 1345: 1346 >r m* r> fm/mod ; 1347 1348*/ ( n1 n2 n3 -- n4 ) core star_slash 1349""n4=(n1*n2)/n3, with the intermediate result being double."" 1350#ifdef BUGGY_LL_MUL 1351DCell d = mmul(n1,n2); 1352#else 1353DCell d = (DCell)n1 * (DCell)n2; 1354#endif 1355#ifdef ASM_SM_SLASH_REM 1356Cell remainder; 1357ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4); 1358if (FLOORED_DIV && ((DHI(d)^n3)<0) && remainder!=0) { 1359 if (CHECK_DIVISION && n4 == CELL_MIN) 1360 throw(BALL_RESULTRANGE); 1361 n4--; 1362} 1363#else 1364DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); 1365n4=DLO(r); 1366#endif 1367: 1368 */mod nip ; 1369 13702* ( n1 -- n2 ) core two_star 1371""Shift left by 1; also works on unsigned numbers"" 1372n2 = 2*n1; 1373: 1374 dup + ; 1375 13762/ ( n1 -- n2 ) core two_slash 1377""Arithmetic shift right by 1. For signed numbers this is a floored 1378division by 2 (note that @code{/} not necessarily floors)."" 1379n2 = n1>>1; 1380: 1381 dup MINI and IF 1 ELSE 0 THEN 1382 [ bits/char cell * 1- ] literal 1383 0 DO 2* swap dup 2* >r MINI and 1384 IF 1 ELSE 0 THEN or r> swap 1385 LOOP nip ; 1386 1387fm/mod ( d1 n1 -- n2 n3 ) core f_m_slash_mod 1388""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}."" 1389#ifdef ASM_SM_SLASH_REM 1390ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3); 1391if (((DHI(d1)^n1)<0) && n2!=0) { 1392 if (CHECK_DIVISION && n3 == CELL_MIN) 1393 throw(BALL_RESULTRANGE); 1394 n3--; 1395 n2+=n1; 1396} 1397#else /* !defined(ASM_SM_SLASH_REM) */ 1398DCell r = fmdiv(d1,n1); 1399n2=DHI(r); 1400n3=DLO(r); 1401#endif /* !defined(ASM_SM_SLASH_REM) */ 1402: 1403 dup >r dup 0< IF negate >r dnegate r> THEN 1404 over 0< IF tuck + swap THEN 1405 um/mod 1406 r> 0< IF swap negate swap THEN ; 1407 1408sm/rem ( d1 n1 -- n2 n3 ) core s_m_slash_rem 1409""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0."" 1410#ifdef ASM_SM_SLASH_REM 1411ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3); 1412#else /* !defined(ASM_SM_SLASH_REM) */ 1413DCell r = smdiv(d1,n1); 1414n2=DHI(r); 1415n3=DLO(r); 1416#endif /* !defined(ASM_SM_SLASH_REM) */ 1417: 1418 over >r dup >r abs -rot 1419 dabs rot um/mod 1420 r> r@ xor 0< IF negate THEN 1421 r> 0< IF swap negate swap THEN ; 1422 1423m* ( n1 n2 -- d ) core m_star 1424#ifdef BUGGY_LL_MUL 1425d = mmul(n1,n2); 1426#else 1427d = (DCell)n1 * (DCell)n2; 1428#endif 1429: 1430 2dup 0< and >r 1431 2dup swap 0< and >r 1432 um* r> - r> - ; 1433 1434um* ( u1 u2 -- ud ) core u_m_star 1435/* use u* as alias */ 1436#ifdef BUGGY_LL_MUL 1437ud = ummul(u1,u2); 1438#else 1439ud = (UDCell)u1 * (UDCell)u2; 1440#endif 1441: 1442 0 -rot dup [ 8 cells ] literal - 1443 DO 1444 dup 0< I' and d2*+ drop 1445 LOOP ; 1446: d2*+ ( ud n -- ud+n c ) 1447 over MINI 1448 and >r >r 2dup d+ swap r> + swap r> ; 1449 1450um/mod ( ud u1 -- u2 u3 ) core u_m_slash_mod 1451""ud=u3*u1+u2, u1>u2>=0"" 1452#ifdef ASM_UM_SLASH_MOD 1453ASM_UM_SLASH_MOD(DLO(ud), DHI(ud), u1, u2, u3); 1454#else /* !defined(ASM_UM_SLASH_MOD) */ 1455UDCell r = umdiv(ud,u1); 1456u2=DHI(r); 1457u3=DLO(r); 1458#endif /* !defined(ASM_UM_SLASH_MOD) */ 1459: 1460 0 swap [ 8 cells 1 + ] literal 0 1461 ?DO /modstep 1462 LOOP drop swap 1 rshift or swap ; 1463: /modstep ( ud c R: u -- ud-?u c R: u ) 1464 >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ; 1465: d2*+ ( ud n -- ud+n c ) 1466 over MINI 1467 and >r >r 2dup d+ swap r> + swap r> ; 1468 1469m+ ( d1 n -- d2 ) double m_plus 1470#ifdef BUGGY_LL_ADD 1471DLO_IS(d2, DLO(d1)+n); 1472DHI_IS(d2, DHI(d1) - (n<0) + (DLO(d2)<DLO(d1))); 1473#else 1474d2 = d1+n; 1475#endif 1476: 1477 s>d d+ ; 1478 1479d+ ( d1 d2 -- d ) double d_plus 1480#ifdef BUGGY_LL_ADD 1481DLO_IS(d, DLO(d1) + DLO(d2)); 1482DHI_IS(d, DHI(d1) + DHI(d2) + (d.lo<DLO(d1))); 1483#else 1484d = d1+d2; 1485#endif 1486: 1487 rot + >r tuck + swap over u> r> swap - ; 1488 1489d- ( d1 d2 -- d ) double d_minus 1490#ifdef BUGGY_LL_ADD 1491DLO_IS(d, DLO(d1) - DLO(d2)); 1492DHI_IS(d, DHI(d1)-DHI(d2)-(DLO(d1)<DLO(d2))); 1493#else 1494d = d1-d2; 1495#endif 1496: 1497 dnegate d+ ; 1498 1499dnegate ( d1 -- d2 ) double d_negate 1500/* use dminus as alias */ 1501#ifdef BUGGY_LL_ADD 1502d2 = dnegate(d1); 1503#else 1504d2 = -d1; 1505#endif 1506: 1507 invert swap negate tuck 0= - ; 1508 1509d2* ( d1 -- d2 ) double d_two_star 1510""Shift left by 1; also works on unsigned numbers"" 1511d2 = DLSHIFT(d1,1); 1512: 1513 2dup d+ ; 1514 1515d2/ ( d1 -- d2 ) double d_two_slash 1516""Arithmetic shift right by 1. For signed numbers this is a floored 1517division by 2."" 1518#ifdef BUGGY_LL_SHIFT 1519DHI_IS(d2, DHI(d1)>>1); 1520DLO_IS(d2, (DLO(d1)>>1) | (DHI(d1)<<(CELL_BITS-1))); 1521#else 1522d2 = d1>>1; 1523#endif 1524: 1525 dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and 1526 r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ; 1527 1528and ( w1 w2 -- w ) core 1529w = w1&w2; 1530 1531or ( w1 w2 -- w ) core 1532w = w1|w2; 1533: 1534 invert swap invert and invert ; 1535 1536xor ( w1 w2 -- w ) core x_or 1537w = w1^w2; 1538 1539invert ( w1 -- w2 ) core 1540w2 = ~w1; 1541: 1542 MAXU xor ; 1543 1544rshift ( u1 n -- u2 ) core r_shift 1545""Logical shift right by @i{n} bits."" 1546#ifdef BROKEN_SHIFT 1547 u2 = rshift(u1, n); 1548#else 1549 u2 = u1 >> n; 1550#endif 1551: 1552 0 ?DO 2/ MAXI and LOOP ; 1553 1554lshift ( u1 n -- u2 ) core l_shift 1555#ifdef BROKEN_SHIFT 1556 u2 = lshift(u1, n); 1557#else 1558 u2 = u1 << n; 1559#endif 1560: 1561 0 ?DO 2* LOOP ; 1562 1563\g compare 1564 1565\ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) 1566#line 1120 1567 1568 15690= ( n -- f ) core zero_equals 1570#line 1122 1571f = FLAG(n==0); 1572#line 1122 1573: 1574#line 1122 1575 [ char 0x char 0 = [IF] 1576#line 1122 1577 ] IF false ELSE true THEN [ 1578#line 1122 1579 [ELSE] 1580#line 1122 1581 ] xor 0= [ 1582#line 1122 1583 [THEN] ] ; 1584#line 1122 1585 1586#line 1122 15870<> ( n -- f ) core-ext zero_not_equals 1588#line 1122 1589f = FLAG(n!=0); 1590#line 1122 1591: 1592#line 1122 1593 [ char 0x char 0 = [IF] 1594#line 1122 1595 ] IF true ELSE false THEN [ 1596#line 1122 1597 [ELSE] 1598#line 1122 1599 ] xor 0<> [ 1600#line 1122 1601 [THEN] ] ; 1602#line 1122 1603 1604#line 1122 16050< ( n -- f ) core zero_less_than 1606#line 1122 1607f = FLAG(n<0); 1608#line 1122 1609: 1610#line 1122 1611 [ char 0x char 0 = [IF] 1612#line 1122 1613 ] MINI and 0<> [ 1614#line 1122 1615 [ELSE] char 0x char u = [IF] 1616#line 1122 1617 ] 2dup xor 0< IF nip ELSE - THEN 0< [ 1618#line 1122 1619 [ELSE] 1620#line 1122 1621 ] MINI xor >r MINI xor r> u< [ 1622#line 1122 1623 [THEN] 1624#line 1122 1625 [THEN] ] ; 1626#line 1122 1627 1628#line 1122 16290> ( n -- f ) core-ext zero_greater_than 1630#line 1122 1631f = FLAG(n>0); 1632#line 1122 1633: 1634#line 1122 1635 [ char 0x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1636#line 1122 1637 0< ; 1638#line 1122 1639 1640#line 1122 16410<= ( n -- f ) gforth zero_less_or_equal 1642#line 1122 1643f = FLAG(n<=0); 1644#line 1122 1645: 1646#line 1122 1647 0> 0= ; 1648#line 1122 1649 1650#line 1122 16510>= ( n -- f ) gforth zero_greater_or_equal 1652#line 1122 1653f = FLAG(n>=0); 1654#line 1122 1655: 1656#line 1122 1657 [ char 0x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1658#line 1122 1659 0<= ; 1660#line 1122 1661 1662#line 1122 1663 1664= ( n1 n2 -- f ) core equals 1665#line 1123 1666f = FLAG(n1==n2); 1667#line 1123 1668: 1669#line 1123 1670 [ char x char 0 = [IF] 1671#line 1123 1672 ] IF false ELSE true THEN [ 1673#line 1123 1674 [ELSE] 1675#line 1123 1676 ] xor 0= [ 1677#line 1123 1678 [THEN] ] ; 1679#line 1123 1680 1681#line 1123 1682<> ( n1 n2 -- f ) core-ext not_equals 1683#line 1123 1684f = FLAG(n1!=n2); 1685#line 1123 1686: 1687#line 1123 1688 [ char x char 0 = [IF] 1689#line 1123 1690 ] IF true ELSE false THEN [ 1691#line 1123 1692 [ELSE] 1693#line 1123 1694 ] xor 0<> [ 1695#line 1123 1696 [THEN] ] ; 1697#line 1123 1698 1699#line 1123 1700< ( n1 n2 -- f ) core less_than 1701#line 1123 1702f = FLAG(n1<n2); 1703#line 1123 1704: 1705#line 1123 1706 [ char x char 0 = [IF] 1707#line 1123 1708 ] MINI and 0<> [ 1709#line 1123 1710 [ELSE] char x char u = [IF] 1711#line 1123 1712 ] 2dup xor 0< IF nip ELSE - THEN 0< [ 1713#line 1123 1714 [ELSE] 1715#line 1123 1716 ] MINI xor >r MINI xor r> u< [ 1717#line 1123 1718 [THEN] 1719#line 1123 1720 [THEN] ] ; 1721#line 1123 1722 1723#line 1123 1724> ( n1 n2 -- f ) core greater_than 1725#line 1123 1726f = FLAG(n1>n2); 1727#line 1123 1728: 1729#line 1123 1730 [ char x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1731#line 1123 1732 < ; 1733#line 1123 1734 1735#line 1123 1736<= ( n1 n2 -- f ) gforth less_or_equal 1737#line 1123 1738f = FLAG(n1<=n2); 1739#line 1123 1740: 1741#line 1123 1742 > 0= ; 1743#line 1123 1744 1745#line 1123 1746>= ( n1 n2 -- f ) gforth greater_or_equal 1747#line 1123 1748f = FLAG(n1>=n2); 1749#line 1123 1750: 1751#line 1123 1752 [ char x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1753#line 1123 1754 <= ; 1755#line 1123 1756 1757#line 1123 1758 1759u= ( u1 u2 -- f ) gforth u_equals 1760#line 1124 1761f = FLAG(u1==u2); 1762#line 1124 1763: 1764#line 1124 1765 [ char ux char 0 = [IF] 1766#line 1124 1767 ] IF false ELSE true THEN [ 1768#line 1124 1769 [ELSE] 1770#line 1124 1771 ] xor 0= [ 1772#line 1124 1773 [THEN] ] ; 1774#line 1124 1775 1776#line 1124 1777u<> ( u1 u2 -- f ) gforth u_not_equals 1778#line 1124 1779f = FLAG(u1!=u2); 1780#line 1124 1781: 1782#line 1124 1783 [ char ux char 0 = [IF] 1784#line 1124 1785 ] IF true ELSE false THEN [ 1786#line 1124 1787 [ELSE] 1788#line 1124 1789 ] xor 0<> [ 1790#line 1124 1791 [THEN] ] ; 1792#line 1124 1793 1794#line 1124 1795u< ( u1 u2 -- f ) core u_less_than 1796#line 1124 1797f = FLAG(u1<u2); 1798#line 1124 1799: 1800#line 1124 1801 [ char ux char 0 = [IF] 1802#line 1124 1803 ] MINI and 0<> [ 1804#line 1124 1805 [ELSE] char ux char u = [IF] 1806#line 1124 1807 ] 2dup xor 0< IF nip ELSE - THEN 0< [ 1808#line 1124 1809 [ELSE] 1810#line 1124 1811 ] MINI xor >r MINI xor r> u< [ 1812#line 1124 1813 [THEN] 1814#line 1124 1815 [THEN] ] ; 1816#line 1124 1817 1818#line 1124 1819u> ( u1 u2 -- f ) core-ext u_greater_than 1820#line 1124 1821f = FLAG(u1>u2); 1822#line 1124 1823: 1824#line 1124 1825 [ char ux char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1826#line 1124 1827 u< ; 1828#line 1124 1829 1830#line 1124 1831u<= ( u1 u2 -- f ) gforth u_less_or_equal 1832#line 1124 1833f = FLAG(u1<=u2); 1834#line 1124 1835: 1836#line 1124 1837 u> 0= ; 1838#line 1124 1839 1840#line 1124 1841u>= ( u1 u2 -- f ) gforth u_greater_or_equal 1842#line 1124 1843f = FLAG(u1>=u2); 1844#line 1124 1845: 1846#line 1124 1847 [ char ux char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 1848#line 1124 1849 u<= ; 1850#line 1124 1851 1852#line 1124 1853 1854 1855\ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...) 1856#line 1170 1857 1858 1859\+dcomps 1860 1861d= ( d1 d2 -- f ) double d_equals 1862#line 1174 1863#ifdef BUGGY_LL_CMP 1864#line 1174 1865f = FLAG(d1.lo==d2.lo && d1.hi==d2.hi); 1866#line 1174 1867#else 1868#line 1174 1869f = FLAG(d1==d2); 1870#line 1174 1871#endif 1872#line 1174 1873 1874#line 1174 1875d<> ( d1 d2 -- f ) gforth d_not_equals 1876#line 1174 1877#ifdef BUGGY_LL_CMP 1878#line 1174 1879f = FLAG(d1.lo!=d2.lo || d1.hi!=d2.hi); 1880#line 1174 1881#else 1882#line 1174 1883f = FLAG(d1!=d2); 1884#line 1174 1885#endif 1886#line 1174 1887 1888#line 1174 1889d< ( d1 d2 -- f ) double d_less_than 1890#line 1174 1891#ifdef BUGGY_LL_CMP 1892#line 1174 1893f = FLAG(d1.hi==d2.hi ? d1.lo<d2.lo : d1.hi<d2.hi); 1894#line 1174 1895#else 1896#line 1174 1897f = FLAG(d1<d2); 1898#line 1174 1899#endif 1900#line 1174 1901 1902#line 1174 1903d> ( d1 d2 -- f ) gforth d_greater_than 1904#line 1174 1905#ifdef BUGGY_LL_CMP 1906#line 1174 1907f = FLAG(d1.hi==d2.hi ? d1.lo>d2.lo : d1.hi>d2.hi); 1908#line 1174 1909#else 1910#line 1174 1911f = FLAG(d1>d2); 1912#line 1174 1913#endif 1914#line 1174 1915 1916#line 1174 1917d<= ( d1 d2 -- f ) gforth d_less_or_equal 1918#line 1174 1919#ifdef BUGGY_LL_CMP 1920#line 1174 1921f = FLAG(d1.hi==d2.hi ? d1.lo<=d2.lo : d1.hi<=d2.hi); 1922#line 1174 1923#else 1924#line 1174 1925f = FLAG(d1<=d2); 1926#line 1174 1927#endif 1928#line 1174 1929 1930#line 1174 1931d>= ( d1 d2 -- f ) gforth d_greater_or_equal 1932#line 1174 1933#ifdef BUGGY_LL_CMP 1934#line 1174 1935f = FLAG(d1.hi==d2.hi ? d1.lo>=d2.lo : d1.hi>=d2.hi); 1936#line 1174 1937#else 1938#line 1174 1939f = FLAG(d1>=d2); 1940#line 1174 1941#endif 1942#line 1174 1943 1944#line 1174 1945 1946d0= ( d -- f ) double d_zero_equals 1947#line 1175 1948#ifdef BUGGY_LL_CMP 1949#line 1175 1950f = FLAG(d.lo==DZERO.lo && d.hi==DZERO.hi); 1951#line 1175 1952#else 1953#line 1175 1954f = FLAG(d==DZERO); 1955#line 1175 1956#endif 1957#line 1175 1958 1959#line 1175 1960d0<> ( d -- f ) gforth d_zero_not_equals 1961#line 1175 1962#ifdef BUGGY_LL_CMP 1963#line 1175 1964f = FLAG(d.lo!=DZERO.lo || d.hi!=DZERO.hi); 1965#line 1175 1966#else 1967#line 1175 1968f = FLAG(d!=DZERO); 1969#line 1175 1970#endif 1971#line 1175 1972 1973#line 1175 1974d0< ( d -- f ) double d_zero_less_than 1975#line 1175 1976#ifdef BUGGY_LL_CMP 1977#line 1175 1978f = FLAG(d.hi==DZERO.hi ? d.lo<DZERO.lo : d.hi<DZERO.hi); 1979#line 1175 1980#else 1981#line 1175 1982f = FLAG(d<DZERO); 1983#line 1175 1984#endif 1985#line 1175 1986 1987#line 1175 1988d0> ( d -- f ) gforth d_zero_greater_than 1989#line 1175 1990#ifdef BUGGY_LL_CMP 1991#line 1175 1992f = FLAG(d.hi==DZERO.hi ? d.lo>DZERO.lo : d.hi>DZERO.hi); 1993#line 1175 1994#else 1995#line 1175 1996f = FLAG(d>DZERO); 1997#line 1175 1998#endif 1999#line 1175 2000 2001#line 1175 2002d0<= ( d -- f ) gforth d_zero_less_or_equal 2003#line 1175 2004#ifdef BUGGY_LL_CMP 2005#line 1175 2006f = FLAG(d.hi==DZERO.hi ? d.lo<=DZERO.lo : d.hi<=DZERO.hi); 2007#line 1175 2008#else 2009#line 1175 2010f = FLAG(d<=DZERO); 2011#line 1175 2012#endif 2013#line 1175 2014 2015#line 1175 2016d0>= ( d -- f ) gforth d_zero_greater_or_equal 2017#line 1175 2018#ifdef BUGGY_LL_CMP 2019#line 1175 2020f = FLAG(d.hi==DZERO.hi ? d.lo>=DZERO.lo : d.hi>=DZERO.hi); 2021#line 1175 2022#else 2023#line 1175 2024f = FLAG(d>=DZERO); 2025#line 1175 2026#endif 2027#line 1175 2028 2029#line 1175 2030 2031du= ( ud1 ud2 -- f ) gforth d_u_equals 2032#line 1176 2033#ifdef BUGGY_LL_CMP 2034#line 1176 2035f = FLAG(ud1.lo==ud2.lo && ud1.hi==ud2.hi); 2036#line 1176 2037#else 2038#line 1176 2039f = FLAG(ud1==ud2); 2040#line 1176 2041#endif 2042#line 1176 2043 2044#line 1176 2045du<> ( ud1 ud2 -- f ) gforth d_u_not_equals 2046#line 1176 2047#ifdef BUGGY_LL_CMP 2048#line 1176 2049f = FLAG(ud1.lo!=ud2.lo || ud1.hi!=ud2.hi); 2050#line 1176 2051#else 2052#line 1176 2053f = FLAG(ud1!=ud2); 2054#line 1176 2055#endif 2056#line 1176 2057 2058#line 1176 2059du< ( ud1 ud2 -- f ) double-ext d_u_less_than 2060#line 1176 2061#ifdef BUGGY_LL_CMP 2062#line 1176 2063f = FLAG(ud1.hi==ud2.hi ? ud1.lo<ud2.lo : ud1.hi<ud2.hi); 2064#line 1176 2065#else 2066#line 1176 2067f = FLAG(ud1<ud2); 2068#line 1176 2069#endif 2070#line 1176 2071 2072#line 1176 2073du> ( ud1 ud2 -- f ) gforth d_u_greater_than 2074#line 1176 2075#ifdef BUGGY_LL_CMP 2076#line 1176 2077f = FLAG(ud1.hi==ud2.hi ? ud1.lo>ud2.lo : ud1.hi>ud2.hi); 2078#line 1176 2079#else 2080#line 1176 2081f = FLAG(ud1>ud2); 2082#line 1176 2083#endif 2084#line 1176 2085 2086#line 1176 2087du<= ( ud1 ud2 -- f ) gforth d_u_less_or_equal 2088#line 1176 2089#ifdef BUGGY_LL_CMP 2090#line 1176 2091f = FLAG(ud1.hi==ud2.hi ? ud1.lo<=ud2.lo : ud1.hi<=ud2.hi); 2092#line 1176 2093#else 2094#line 1176 2095f = FLAG(ud1<=ud2); 2096#line 1176 2097#endif 2098#line 1176 2099 2100#line 1176 2101du>= ( ud1 ud2 -- f ) gforth d_u_greater_or_equal 2102#line 1176 2103#ifdef BUGGY_LL_CMP 2104#line 1176 2105f = FLAG(ud1.hi==ud2.hi ? ud1.lo>=ud2.lo : ud1.hi>=ud2.hi); 2106#line 1176 2107#else 2108#line 1176 2109f = FLAG(ud1>=ud2); 2110#line 1176 2111#endif 2112#line 1176 2113 2114#line 1176 2115 2116 2117\+ 2118 2119within ( u1 u2 u3 -- f ) core-ext 2120""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2). This works for 2121unsigned and signed numbers (but not a mixture). Another way to think 2122about this word is to consider the numbers as a circle (wrapping 2123around from @code{max-u} to 0 for unsigned, and from @code{max-n} to 2124min-n for signed numbers); now consider the range from u2 towards 2125increasing numbers up to and excluding u3 (giving an empty range if 2126u2=u3); if u1 is in this range, @code{within} returns true."" 2127f = FLAG(u1-u2 < u3-u2); 2128: 2129 over - >r - r> u< ; 2130 2131\g stack 2132 2133useraddr ( #u -- a_addr ) new 2134a_addr = (Cell *)(up+u); 2135 2136up! ( a_addr -- ) gforth up_store 2137gforth_UP=up=(Address)a_addr; 2138: 2139 up ! ; 2140Variable UP 2141 2142sp@ ( S:... -- a_addr ) gforth sp_fetch 2143a_addr = sp; 2144 2145sp! ( a_addr -- S:... ) gforth sp_store 2146sp = a_addr; 2147 2148rp@ ( -- a_addr ) gforth rp_fetch 2149a_addr = rp; 2150 2151rp! ( a_addr -- ) gforth rp_store 2152rp = a_addr; 2153 2154\+floating 2155 2156fp@ ( f:... -- f_addr ) gforth fp_fetch 2157f_addr = fp; 2158 2159fp! ( f_addr -- f:... ) gforth fp_store 2160fp = f_addr; 2161 2162\+ 2163 2164>r ( w -- R:w ) core to_r 2165: 2166 (>r) ; 2167: (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ; 2168 2169r> ( R:w -- w ) core r_from 2170: 2171 rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ; 2172Create (rdrop) ' ;s A, 2173 2174rdrop ( R:w -- ) gforth 2175: 2176 r> r> drop >r ; 2177 21782>r ( d -- R:d ) core-ext two_to_r 2179: 2180 swap r> swap >r swap >r >r ; 2181 21822r> ( R:d -- d ) core-ext two_r_from 2183: 2184 r> r> swap r> swap >r swap ; 2185 21862r@ ( R:d -- R:d d ) core-ext two_r_fetch 2187: 2188 i' j ; 2189 21902rdrop ( R:d -- ) gforth two_r_drop 2191: 2192 r> r> drop r> drop >r ; 2193 2194over ( w1 w2 -- w1 w2 w1 ) core 2195: 2196 sp@ cell+ @ ; 2197 2198drop ( w -- ) core 2199: 2200 IF THEN ; 2201 2202swap ( w1 w2 -- w2 w1 ) core 2203: 2204 >r (swap) ! r> (swap) @ ; 2205Variable (swap) 2206 2207dup ( w -- w w ) core dupe 2208: 2209 sp@ @ ; 2210 2211rot ( w1 w2 w3 -- w2 w3 w1 ) core rote 2212: 2213[ defined? (swap) [IF] ] 2214 (swap) ! (rot) ! >r (rot) @ (swap) @ r> ; 2215Variable (rot) 2216[ELSE] ] 2217 >r swap r> swap ; 2218[THEN] 2219 2220-rot ( w1 w2 w3 -- w3 w1 w2 ) gforth not_rote 2221: 2222 rot rot ; 2223 2224nip ( w1 w2 -- w2 ) core-ext 2225: 2226 swap drop ; 2227 2228tuck ( w1 w2 -- w2 w1 w2 ) core-ext 2229: 2230 swap over ; 2231 2232?dup ( w -- S:... w ) core question_dupe 2233""Actually the stack effect is: @code{( w -- 0 | w w )}. It performs a 2234@code{dup} if w is nonzero."" 2235if (w!=0) { 2236 *--sp = w; 2237} 2238: 2239 dup IF dup THEN ; 2240 2241pick ( S:... u -- S:... w ) core-ext 2242""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }."" 2243w = sp[u]; 2244: 2245 1+ cells sp@ + @ ; 2246 22472drop ( w1 w2 -- ) core two_drop 2248: 2249 drop drop ; 2250 22512dup ( w1 w2 -- w1 w2 w1 w2 ) core two_dupe 2252: 2253 over over ; 2254 22552over ( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 ) core two_over 2256: 2257 3 pick 3 pick ; 2258 22592swap ( w1 w2 w3 w4 -- w3 w4 w1 w2 ) core two_swap 2260: 2261 rot >r rot r> ; 2262 22632rot ( w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 ) double-ext two_rote 2264: 2265 >r >r 2swap r> r> 2swap ; 2266 22672nip ( w1 w2 w3 w4 -- w3 w4 ) gforth two_nip 2268: 2269 2swap 2drop ; 2270 22712tuck ( w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 ) gforth two_tuck 2272: 2273 2swap 2over ; 2274 2275\ toggle is high-level: 0.11/0.42% 2276 2277\g memory 2278 2279@ ( a_addr -- w ) core fetch 2280""@i{w} is the cell stored at @i{a_addr}."" 2281w = *a_addr; 2282 2283\ lit@ / lit_fetch = lit @ 2284 2285lit@ ( #a_addr -- w ) new lit_fetch 2286w = *a_addr; 2287 2288! ( w a_addr -- ) core store 2289""Store @i{w} into the cell at @i{a-addr}."" 2290*a_addr = w; 2291 2292+! ( n a_addr -- ) core plus_store 2293""Add @i{n} to the cell at @i{a-addr}."" 2294*a_addr += n; 2295: 2296 tuck @ + swap ! ; 2297 2298c@ ( c_addr -- c ) core c_fetch 2299""@i{c} is the char stored at @i{c_addr}."" 2300c = *c_addr; 2301: 2302[ bigendian [IF] ] 2303 [ cell>bit 4 = [IF] ] 2304 dup [ 0 cell - ] Literal and @ swap 1 and 2305 IF $FF and ELSE 8>> THEN ; 2306 [ [ELSE] ] 2307 dup [ cell 1- ] literal and 2308 tuck - @ swap [ cell 1- ] literal xor 2309 0 ?DO 8>> LOOP $FF and 2310 [ [THEN] ] 2311[ [ELSE] ] 2312 [ cell>bit 4 = [IF] ] 2313 dup [ 0 cell - ] Literal and @ swap 1 and 2314 IF 8>> ELSE $FF and THEN 2315 [ [ELSE] ] 2316 dup [ cell 1- ] literal and 2317 tuck - @ swap 2318 0 ?DO 8>> LOOP 255 and 2319 [ [THEN] ] 2320[ [THEN] ] 2321; 2322: 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; 2323 2324c! ( c c_addr -- ) core c_store 2325""Store @i{c} into the char at @i{c-addr}."" 2326*c_addr = c; 2327: 2328[ bigendian [IF] ] 2329 [ cell>bit 4 = [IF] ] 2330 tuck 1 and IF $FF and ELSE 8<< THEN >r 2331 dup -2 and @ over 1 and cells masks + @ and 2332 r> or swap -2 and ! ; 2333 Create masks $00FF , $FF00 , 2334 [ELSE] ] 2335 dup [ cell 1- ] literal and dup 2336 [ cell 1- ] literal xor >r 2337 - dup @ $FF r@ 0 ?DO 8<< LOOP invert and 2338 rot $FF and r> 0 ?DO 8<< LOOP or swap ! ; 2339 [THEN] 2340[ELSE] ] 2341 [ cell>bit 4 = [IF] ] 2342 tuck 1 and IF 8<< ELSE $FF and THEN >r 2343 dup -2 and @ over 1 and cells masks + @ and 2344 r> or swap -2 and ! ; 2345 Create masks $FF00 , $00FF , 2346 [ELSE] ] 2347 dup [ cell 1- ] literal and dup >r 2348 - dup @ $FF r@ 0 ?DO 8<< LOOP invert and 2349 rot $FF and r> 0 ?DO 8<< LOOP or swap ! ; 2350 [THEN] 2351[THEN] 2352: 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; 2353 23542! ( w1 w2 a_addr -- ) core two_store 2355""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell."" 2356a_addr[0] = w2; 2357a_addr[1] = w1; 2358: 2359 tuck ! cell+ ! ; 2360 23612@ ( a_addr -- w1 w2 ) core two_fetch 2362""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is 2363the content of the next cell."" 2364w2 = a_addr[0]; 2365w1 = a_addr[1]; 2366: 2367 dup cell+ @ swap @ ; 2368 2369cell+ ( a_addr1 -- a_addr2 ) core cell_plus 2370""@code{1 cells +}"" 2371a_addr2 = a_addr1+1; 2372: 2373 cell + ; 2374 2375cells ( n1 -- n2 ) core 2376"" @i{n2} is the number of address units of @i{n1} cells."" 2377n2 = n1 * sizeof(Cell); 2378: 2379 [ cell 2380 2/ dup [IF] ] 2* [ [THEN] 2381 2/ dup [IF] ] 2* [ [THEN] 2382 2/ dup [IF] ] 2* [ [THEN] 2383 2/ dup [IF] ] 2* [ [THEN] 2384 drop ] ; 2385 2386char+ ( c_addr1 -- c_addr2 ) core char_plus 2387""@code{1 chars +}."" 2388c_addr2 = c_addr1 + 1; 2389: 2390 1+ ; 2391 2392(chars) ( n1 -- n2 ) gforth paren_chars 2393n2 = n1 * sizeof(Char); 2394: 2395 ; 2396 2397count ( c_addr1 -- c_addr2 u ) core 2398""@i{c-addr2} is the first character and @i{u} the length of the 2399counted string at @i{c-addr1}."" 2400u = *c_addr1; 2401c_addr2 = c_addr1+1; 2402: 2403 dup 1+ swap c@ ; 2404 2405\g compiler 2406 2407\+f83headerstring 2408 2409(f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find 2410for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) 2411 if ((UCell)F83NAME_COUNT(f83name1)==u && 2412 memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) 2413 break; 2414f83name2=f83name1; 2415#ifdef DEBUG 2416fprintf(stderr, "F83find "); 2417fwrite(c_addr, u, 1, stderr); 2418fprintf(stderr, " found %08x\n", f83name2); 2419#endif 2420: 2421 BEGIN dup WHILE (find-samelen) dup WHILE 2422 >r 2dup r@ cell+ char+ capscomp 0= 2423 IF 2drop r> EXIT THEN 2424 r> @ 2425 REPEAT THEN nip nip ; 2426: (find-samelen) ( u f83name1 -- u f83name2/0 ) 2427 BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; 2428: capscomp ( c_addr1 u c_addr2 -- n ) 2429 swap bounds 2430 ?DO dup c@ I c@ <> 2431 IF dup c@ toupper I c@ toupper = 2432 ELSE true THEN WHILE 1+ LOOP drop 0 2433 ELSE c@ toupper I c@ toupper - unloop THEN sgn ; 2434: sgn ( n -- -1/0/1 ) 2435 dup 0= IF EXIT THEN 0< 2* 1+ ; 2436 2437\- 2438 2439(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind 2440longname2=listlfind(c_addr, u, longname1); 2441: 2442 BEGIN dup WHILE (findl-samelen) dup WHILE 2443 >r 2dup r@ cell+ cell+ capscomp 0= 2444 IF 2drop r> EXIT THEN 2445 r> @ 2446 REPEAT THEN nip nip ; 2447: (findl-samelen) ( u longname1 -- u longname2/0 ) 2448 BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ; 2449: capscomp ( c_addr1 u c_addr2 -- n ) 2450 swap bounds 2451 ?DO dup c@ I c@ <> 2452 IF dup c@ toupper I c@ toupper = 2453 ELSE true THEN WHILE 1+ LOOP drop 0 2454 ELSE c@ toupper I c@ toupper - unloop THEN sgn ; 2455: sgn ( n -- -1/0/1 ) 2456 dup 0= IF EXIT THEN 0< 2* 1+ ; 2457 2458\+hash 2459 2460(hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind 2461longname2 = hashlfind(c_addr, u, a_addr); 2462: 2463 BEGIN dup WHILE 2464 2@ >r >r dup r@ cell+ @ lcount-mask and = 2465 IF 2dup r@ cell+ cell+ capscomp 0= 2466 IF 2drop r> rdrop EXIT THEN THEN 2467 rdrop r> 2468 REPEAT nip nip ; 2469 2470(tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind 2471""A case-sensitive variant of @code{(hashfind)}"" 2472longname2 = tablelfind(c_addr, u, a_addr); 2473: 2474 BEGIN dup WHILE 2475 2@ >r >r dup r@ cell+ @ lcount-mask and = 2476 IF 2dup r@ cell+ cell+ -text 0= 2477 IF 2drop r> rdrop EXIT THEN THEN 2478 rdrop r> 2479 REPEAT nip nip ; 2480: -text ( c_addr1 u c_addr2 -- n ) 2481 swap bounds 2482 ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 2483 ELSE c@ I c@ - unloop THEN sgn ; 2484: sgn ( n -- -1/0/1 ) 2485 dup 0= IF EXIT THEN 0< 2* 1+ ; 2486 2487(hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 2488""ukey is the hash key for the string c_addr u fitting in ubits bits"" 2489ukey = hashkey1(c_addr, u, ubits); 2490: 2491 dup rot-values + c@ over 1 swap lshift 1- >r 2492 tuck - 2swap r> 0 2swap bounds 2493 ?DO dup 4 pick lshift swap 3 pick rshift or 2494 I c@ toupper xor 2495 over and LOOP 2496 nip nip nip ; 2497Create rot-values 2498 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c, 2499 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c, 2500 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, 2501 7 c, 5 c, 5 c, 2502 2503\+ 2504 2505\+ 2506 2507(parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white 2508struct Cellpair r=parse_white(c_addr1, u1); 2509c_addr2 = (Char *)(r.n1); 2510u2 = r.n2; 2511: 2512 BEGIN dup WHILE over c@ bl <= WHILE 1 /string 2513 REPEAT THEN 2dup 2514 BEGIN dup WHILE over c@ bl > WHILE 1 /string 2515 REPEAT THEN nip - ; 2516 2517aligned ( c_addr -- a_addr ) core 2518"" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}."" 2519a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); 2520: 2521 [ cell 1- ] Literal + [ -1 cells ] Literal and ; 2522 2523faligned ( c_addr -- f_addr ) float f_aligned 2524"" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}."" 2525f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); 2526: 2527 [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; 2528 2529\ threading stuff is currently only interesting if we have a compiler 2530\fhas? standardthreading has? compiler and [IF] 2531threading-method ( -- n ) gforth threading_method 2532""0 if the engine is direct threaded. Note that this may change during 2533the lifetime of an image."" 2534#if defined(DOUBLY_INDIRECT) 2535n=2; 2536#else 2537# if defined(DIRECT_THREADED) 2538n=0; 2539# else 2540n=1; 2541# endif 2542#endif 2543: 2544 1 ; 2545 2546\f[THEN] 2547 2548\g hostos 2549 2550key-file ( wfileid -- c ) gforth paren_key_file 2551""Read one character @i{c} from @i{wfileid}. This word disables 2552buffering for @i{wfileid}. If you want to read characters from a 2553terminal in non-canonical (raw) mode, you have to put the terminal in 2554non-canonical mode yourself (using the C interface); the exception is 2555@code{stdin}: Gforth automatically puts it into non-canonical mode."" 2556#ifdef HAS_FILE 2557fflush(stdout); 2558c = key((FILE*)wfileid); 2559#else 2560c = key(stdin); 2561#endif 2562 2563key?-file ( wfileid -- f ) gforth key_q_file 2564""@i{f} is true if at least one character can be read from @i{wfileid} 2565without blocking. If you also want to use @code{read-file} or 2566@code{read-line} on the file, you have to call @code{key?-file} or 2567@code{key-file} first (these two words disable buffering)."" 2568#ifdef HAS_FILE 2569fflush(stdout); 2570f = key_query((FILE*)wfileid); 2571#else 2572f = key_query(stdin); 2573#endif 2574 2575stdin ( -- wfileid ) gforth 2576""The standard input file of the Gforth process."" 2577wfileid = (Cell)stdin; 2578 2579stdout ( -- wfileid ) gforth 2580""The standard output file of the Gforth process."" 2581wfileid = (Cell)stdout; 2582 2583stderr ( -- wfileid ) gforth 2584""The standard error output file of the Gforth process."" 2585wfileid = (Cell)stderr; 2586 2587\+os 2588 2589form ( -- urows ucols ) gforth 2590""The number of lines and columns in the terminal. These numbers may 2591change with the window size. Note that it depends on the OS whether 2592this reflects the actual size and changes with the window size 2593(currently only on Unix-like OSs). On other OSs you just get a 2594default, and can tell Gforth the terminal size by setting the 2595environment variables @code{COLUMNS} and @code{LINES} before starting 2596Gforth."" 2597/* we could block SIGWINCH here to get a consistent size, but I don't 2598 think this is necessary or always beneficial */ 2599urows=rows; 2600ucols=cols; 2601 2602wcwidth ( u -- n ) gforth 2603""The number of fixed-width characters per unicode character u"" 2604#ifdef HAVE_WCWIDTH 2605n = wcwidth(u); 2606#else 2607n = 1; 2608#endif 2609 2610flush-icache ( c_addr u -- ) gforth flush_icache 2611""Make sure that the instruction cache of the processor (if there is 2612one) does not contain stale data at @i{c-addr} and @i{u} bytes 2613afterwards. @code{END-CODE} performs a @code{flush-icache} 2614automatically. Caveat: @code{flush-icache} might not work on your 2615installation; this is usually the case if direct threading is not 2616supported on your machine (take a look at your @file{machine.h}) and 2617your machine has a separate instruction cache. In such cases, 2618@code{flush-icache} does nothing instead of flushing the instruction 2619cache."" 2620FLUSH_ICACHE((caddr_t)c_addr,u); 2621 2622(bye) ( n -- ) gforth paren_bye 2623SUPER_END; 2624return (Label *)n; 2625 2626(system) ( c_addr u -- wretval wior ) gforth paren_system 2627wretval = gforth_system(c_addr, u); 2628wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); 2629 2630getenv ( c_addr1 u1 -- c_addr2 u2 ) gforth 2631""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2} 2632is the host operating system's expansion of that environment variable. If the 2633environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters 2634in length."" 2635/* close ' to keep fontify happy */ 2636c_addr2 = (Char *)getenv(cstr(c_addr1,u1,1)); 2637u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2)); 2638 2639open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe 2640wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */ 2641wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ 2642 2643close-pipe ( wfileid -- wretval wior ) gforth close_pipe 2644wretval = pclose((FILE *)wfileid); 2645wior = IOR(wretval==-1); 2646 2647time&date ( -- nsec nmin nhour nday nmonth nyear ) facility-ext time_and_date 2648""Report the current time of day. Seconds, minutes and hours are numbered from 0. 2649Months are numbered from 1."" 2650#if 1 2651time_t now; 2652struct tm *ltime; 2653time(&now); 2654ltime=localtime(&now); 2655#else 2656struct timeval time1; 2657struct timezone zone1; 2658struct tm *ltime; 2659gettimeofday(&time1,&zone1); 2660/* !! Single Unix specification: 2661 If tzp is not a null pointer, the behaviour is unspecified. */ 2662ltime=localtime((time_t *)&time1.tv_sec); 2663#endif 2664nyear =ltime->tm_year+1900; 2665nmonth=ltime->tm_mon+1; 2666nday =ltime->tm_mday; 2667nhour =ltime->tm_hour; 2668nmin =ltime->tm_min; 2669nsec =ltime->tm_sec; 2670 2671ms ( u -- ) facility-ext 2672""Wait at least @i{n} milli-second."" 2673gforth_ms(u); 2674 2675allocate ( u -- a_addr wior ) memory 2676""Allocate @i{u} address units of contiguous data space. The initial 2677contents of the data space is undefined. If the allocation is successful, 2678@i{a-addr} is the start address of the allocated region and @i{wior} 2679is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior} 2680is a non-zero I/O result code."" 2681a_addr = (Cell *)malloc(u?u:1); 2682wior = IOR(a_addr==NULL); 2683 2684free ( a_addr -- wior ) memory 2685""Return the region of data space starting at @i{a-addr} to the system. 2686The region must originally have been obtained using @code{allocate} or 2687@code{resize}. If the operational is successful, @i{wior} is 0. 2688If the operation fails, @i{wior} is a non-zero I/O result code."" 2689free(a_addr); 2690wior = 0; 2691 2692resize ( a_addr1 u -- a_addr2 wior ) memory 2693""Change the size of the allocated area at @i{a-addr1} to @i{u} 2694address units, possibly moving the contents to a different 2695area. @i{a-addr2} is the address of the resulting area. 2696If the operation is successful, @i{wior} is 0. 2697If the operation fails, @i{wior} is a non-zero 2698I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard) 2699@code{resize} @code{allocate}s @i{u} address units."" 2700/* the following check is not necessary on most OSs, but it is needed 2701 on SunOS 4.1.2. */ 2702/* close ' to keep fontify happy */ 2703if (a_addr1==NULL) 2704 a_addr2 = (Cell *)malloc(u); 2705else 2706 a_addr2 = (Cell *)realloc(a_addr1, u); 2707wior = IOR(a_addr2==NULL); /* !! Define a return code */ 2708 2709strerror ( n -- c_addr u ) gforth 2710c_addr = (Char *)strerror(n); 2711u = strlen((char *)c_addr); 2712 2713strsignal ( n -- c_addr u ) gforth 2714c_addr = (Char *)strsignal(n); 2715u = strlen((char *)c_addr); 2716 2717call-c ( ... w -- ... ) gforth call_c 2718""Call the C function pointed to by @i{w}. The C function has to 2719access the stack itself. The stack pointers are exported in the global 2720variables @code{gforth_SP} and @code{gforth_FP}."" 2721/* This is a first attempt at support for calls to C. This may change in 2722 the future */ 2723IF_fpTOS(fp[0]=fpTOS); 2724gforth_FP=fp; 2725gforth_SP=sp; 2726gforth_RP=rp; 2727gforth_LP=lp; 2728#ifdef HAS_LINKBACK 2729((void (*)())w)(); 2730#else 2731((void (*)(void *))w)(gforth_pointers); 2732#endif 2733sp=gforth_SP; 2734fp=gforth_FP; 2735rp=gforth_RP; 2736lp=gforth_LP; 2737IF_fpTOS(fpTOS=fp[0]); 2738 2739\+ 2740\+file 2741 2742close-file ( wfileid -- wior ) file close_file 2743wior = IOR(fclose((FILE *)wfileid)==EOF); 2744 2745open-file ( c_addr u wfam -- wfileid wior ) file open_file 2746wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, 0, &wior); 2747 2748create-file ( c_addr u wfam -- wfileid wior ) file create_file 2749wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, O_CREAT|O_TRUNC, &wior); 2750 2751delete-file ( c_addr u -- wior ) file delete_file 2752wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); 2753 2754rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file 2755""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" 2756wior = rename_file(c_addr1, u1, c_addr2, u2); 2757 2758file-position ( wfileid -- ud wior ) file file_position 2759/* !! use tell and lseek? */ 2760ud = OFF2UD(ftello((FILE *)wfileid)); 2761wior = IOR(UD2OFF(ud)==-1); 2762 2763reposition-file ( ud wfileid -- wior ) file reposition_file 2764wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1); 2765 2766file-size ( wfileid -- ud wior ) file file_size 2767struct stat buf; 2768wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); 2769ud = OFF2UD(buf.st_size); 2770 2771resize-file ( ud wfileid -- wior ) file resize_file 2772wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1); 2773 2774read-file ( c_addr u1 wfileid -- u2 wior ) file read_file 2775/* !! fread does not guarantee enough */ 2776u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); 2777wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); 2778/* !! is the value of ferror errno-compatible? */ 2779if (wior) 2780 clearerr((FILE *)wfileid); 2781 2782(read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line 2783struct Cellquad r = read_line(c_addr, u1, wfileid); 2784u2 = r.n1; 2785flag = r.n2; 2786u3 = r.n3; 2787wior = r.n4; 2788 2789\+ 2790 2791write-file ( c_addr u1 wfileid -- wior ) file write_file 2792/* !! fwrite does not guarantee enough */ 2793#ifdef HAS_FILE 2794{ 2795 UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); 2796 wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); 2797 if (wior) 2798 clearerr((FILE *)wfileid); 2799} 2800#else 2801TYPE(c_addr, u1); 2802#endif 2803 2804emit-file ( c wfileid -- wior ) gforth emit_file 2805#ifdef HAS_FILE 2806wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); 2807if (wior) 2808 clearerr((FILE *)wfileid); 2809#else 2810PUTC(c); 2811#endif 2812 2813\+file 2814 2815flush-file ( wfileid -- wior ) file-ext flush_file 2816wior = IOR(fflush((FILE *) wfileid)==EOF); 2817 2818file-status ( c_addr u -- wfam wior ) file-ext file_status 2819struct Cellpair r = file_status(c_addr, u); 2820wfam = r.n1; 2821wior = r.n2; 2822 2823file-eof? ( wfileid -- flag ) gforth file_eof_query 2824flag = FLAG(feof((FILE *) wfileid)); 2825 2826open-dir ( c_addr u -- wdirid wior ) gforth open_dir 2827""Open the directory specified by @i{c-addr, u} 2828and return @i{dir-id} for futher access to it."" 2829wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1)); 2830wior = IOR(wdirid == 0); 2831 2832read-dir ( c_addr u1 wdirid -- u2 flag wior ) gforth read_dir 2833""Attempt to read the next entry from the directory specified 2834by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}. 2835If the attempt fails because there is no more entries, 2836@i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified. 2837If the attempt to read the next entry fails because of any other reason, 2838return @i{ior}<>0. 2839If the attempt succeeds, store file name to the buffer at @i{c-addr} 2840and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name. 2841If the length of the file name is greater than @i{u1}, 2842store first @i{u1} characters from file name into the buffer and 2843indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}."" 2844struct dirent * dent; 2845dent = readdir((DIR *)wdirid); 2846wior = 0; 2847flag = -1; 2848if(dent == NULL) { 2849 u2 = 0; 2850 flag = 0; 2851} else { 2852 u2 = strlen((char *)dent->d_name); 2853 if(u2 > u1) { 2854 u2 = u1; 2855 wior = -512-ENAMETOOLONG; 2856 } 2857 memmove(c_addr, dent->d_name, u2); 2858} 2859 2860close-dir ( wdirid -- wior ) gforth close_dir 2861""Close the directory specified by @i{dir-id}."" 2862wior = IOR(closedir((DIR *)wdirid)); 2863 2864filename-match ( c_addr1 u1 c_addr2 u2 -- flag ) gforth match_file 2865char * string = cstr(c_addr1, u1, 1); 2866char * pattern = cstr(c_addr2, u2, 0); 2867flag = FLAG(!fnmatch(pattern, string, 0)); 2868 2869set-dir ( c_addr u -- wior ) gforth set_dir 2870""Change the current directory to @i{c-addr, u}. 2871Return an error if this is not possible"" 2872wior = IOR(chdir(tilde_cstr(c_addr, u, 1))); 2873 2874get-dir ( c_addr1 u1 -- c_addr2 u2 ) gforth get_dir 2875""Store the current directory in the buffer specified by @i{c-addr1, u1}. 2876If the buffer size is not sufficient, return 0 0"" 2877c_addr2 = (Char *)getcwd((char *)c_addr1, u1); 2878if(c_addr2 != NULL) { 2879 u2 = strlen((char *)c_addr2); 2880} else { 2881 u2 = 0; 2882} 2883 2884=mkdir ( c_addr u wmode -- wior ) gforth equals_mkdir 2885""Create directory @i{c-addr u} with mode @i{wmode}."" 2886wior = IOR(mkdir(tilde_cstr(c_addr,u,1),wmode)); 2887 2888\+ 2889 2890newline ( -- c_addr u ) gforth 2891""String containing the newline sequence of the host OS"" 2892static const char newline[] = { 2893#if DIRSEP=='/' 2894/* Unix */ 2895'\n' 2896#else 2897/* DOS, Win, OS/2 */ 2898'\r','\n' 2899#endif 2900}; 2901c_addr=(Char *)newline; 2902u=sizeof(newline); 2903: 2904 "newline count ; 2905Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c, 2906 2907\+os 2908 2909utime ( -- dtime ) gforth 2910""Report the current time in microseconds since some epoch."" 2911struct timeval time1; 2912gettimeofday(&time1,NULL); 2913dtime = timeval2us(&time1); 2914 2915cputime ( -- duser dsystem ) gforth 2916""duser and dsystem are the respective user- and system-level CPU 2917times used since the start of the Forth system (excluding child 2918processes), in microseconds (the granularity may be much larger, 2919however). On platforms without the getrusage call, it reports elapsed 2920time (since some epoch) for duser and 0 for dsystem."" 2921#ifdef HAVE_GETRUSAGE 2922struct rusage usage; 2923getrusage(RUSAGE_SELF, &usage); 2924duser = timeval2us(&usage.ru_utime); 2925dsystem = timeval2us(&usage.ru_stime); 2926#else 2927struct timeval time1; 2928gettimeofday(&time1,NULL); 2929duser = timeval2us(&time1); 2930dsystem = DZERO; 2931#endif 2932 2933\+ 2934 2935\+floating 2936 2937\g floating 2938 2939f= ( r1 r2 -- f ) gforth f_equals 2940#line 2000 2941f = FLAG(r1==r2); 2942#line 2000 2943: 2944#line 2000 2945 [ char fx char 0 = [IF] 2946#line 2000 2947 ] IF false ELSE true THEN [ 2948#line 2000 2949 [ELSE] 2950#line 2000 2951 ] xor 0= [ 2952#line 2000 2953 [THEN] ] ; 2954#line 2000 2955 2956#line 2000 2957f<> ( r1 r2 -- f ) gforth f_not_equals 2958#line 2000 2959f = FLAG(r1!=r2); 2960#line 2000 2961: 2962#line 2000 2963 [ char fx char 0 = [IF] 2964#line 2000 2965 ] IF true ELSE false THEN [ 2966#line 2000 2967 [ELSE] 2968#line 2000 2969 ] xor 0<> [ 2970#line 2000 2971 [THEN] ] ; 2972#line 2000 2973 2974#line 2000 2975f< ( r1 r2 -- f ) float f_less_than 2976#line 2000 2977f = FLAG(r1<r2); 2978#line 2000 2979: 2980#line 2000 2981 [ char fx char 0 = [IF] 2982#line 2000 2983 ] MINI and 0<> [ 2984#line 2000 2985 [ELSE] char fx char u = [IF] 2986#line 2000 2987 ] 2dup xor 0< IF nip ELSE - THEN 0< [ 2988#line 2000 2989 [ELSE] 2990#line 2000 2991 ] MINI xor >r MINI xor r> u< [ 2992#line 2000 2993 [THEN] 2994#line 2000 2995 [THEN] ] ; 2996#line 2000 2997 2998#line 2000 2999f> ( r1 r2 -- f ) gforth f_greater_than 3000#line 2000 3001f = FLAG(r1>r2); 3002#line 2000 3003: 3004#line 2000 3005 [ char fx char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 3006#line 2000 3007 f< ; 3008#line 2000 3009 3010#line 2000 3011f<= ( r1 r2 -- f ) gforth f_less_or_equal 3012#line 2000 3013f = FLAG(r1<=r2); 3014#line 2000 3015: 3016#line 2000 3017 f> 0= ; 3018#line 2000 3019 3020#line 2000 3021f>= ( r1 r2 -- f ) gforth f_greater_or_equal 3022#line 2000 3023f = FLAG(r1>=r2); 3024#line 2000 3025: 3026#line 2000 3027 [ char fx char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 3028#line 2000 3029 f<= ; 3030#line 2000 3031 3032#line 2000 3033 3034f0= ( r -- f ) float f_zero_equals 3035#line 2001 3036f = FLAG(r==0.); 3037#line 2001 3038: 3039#line 2001 3040 [ char f0x char 0 = [IF] 3041#line 2001 3042 ] IF false ELSE true THEN [ 3043#line 2001 3044 [ELSE] 3045#line 2001 3046 ] xor 0= [ 3047#line 2001 3048 [THEN] ] ; 3049#line 2001 3050 3051#line 2001 3052f0<> ( r -- f ) gforth f_zero_not_equals 3053#line 2001 3054f = FLAG(r!=0.); 3055#line 2001 3056: 3057#line 2001 3058 [ char f0x char 0 = [IF] 3059#line 2001 3060 ] IF true ELSE false THEN [ 3061#line 2001 3062 [ELSE] 3063#line 2001 3064 ] xor 0<> [ 3065#line 2001 3066 [THEN] ] ; 3067#line 2001 3068 3069#line 2001 3070f0< ( r -- f ) float f_zero_less_than 3071#line 2001 3072f = FLAG(r<0.); 3073#line 2001 3074: 3075#line 2001 3076 [ char f0x char 0 = [IF] 3077#line 2001 3078 ] MINI and 0<> [ 3079#line 2001 3080 [ELSE] char f0x char u = [IF] 3081#line 2001 3082 ] 2dup xor 0< IF nip ELSE - THEN 0< [ 3083#line 2001 3084 [ELSE] 3085#line 2001 3086 ] MINI xor >r MINI xor r> u< [ 3087#line 2001 3088 [THEN] 3089#line 2001 3090 [THEN] ] ; 3091#line 2001 3092 3093#line 2001 3094f0> ( r -- f ) gforth f_zero_greater_than 3095#line 2001 3096f = FLAG(r>0.); 3097#line 2001 3098: 3099#line 2001 3100 [ char f0x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 3101#line 2001 3102 f0< ; 3103#line 2001 3104 3105#line 2001 3106f0<= ( r -- f ) gforth f_zero_less_or_equal 3107#line 2001 3108f = FLAG(r<=0.); 3109#line 2001 3110: 3111#line 2001 3112 f0> 0= ; 3113#line 2001 3114 3115#line 2001 3116f0>= ( r -- f ) gforth f_zero_greater_or_equal 3117#line 2001 3118f = FLAG(r>=0.); 3119#line 2001 3120: 3121#line 2001 3122 [ char f0x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] 3123#line 2001 3124 f0<= ; 3125#line 2001 3126 3127#line 2001 3128 3129 3130s>f ( n -- r ) float s_to_f 3131r = n; 3132 3133d>f ( d -- r ) float d_to_f 3134#ifdef BUGGY_LL_D2F 3135extern double ldexp(double x, int exp); 3136if (DHI(d)<0) { 3137#ifdef BUGGY_LL_ADD 3138 DCell d2=dnegate(d); 3139#else 3140 DCell d2=-d; 3141#endif 3142 r = -(ldexp((Float)DHI(d2),CELL_BITS) + (Float)DLO(d2)); 3143} else 3144 r = ldexp((Float)DHI(d),CELL_BITS) + (Float)DLO(d); 3145#else 3146r = d; 3147#endif 3148 3149f>d ( r -- d ) float f_to_d 3150extern DCell double2ll(Float r); 3151d = double2ll(r); 3152 3153f>s ( r -- n ) float f_to_s 3154n = (Cell)r; 3155 3156f! ( r f_addr -- ) float f_store 3157""Store @i{r} into the float at address @i{f-addr}."" 3158*f_addr = r; 3159 3160f@ ( f_addr -- r ) float f_fetch 3161""@i{r} is the float at address @i{f-addr}."" 3162r = *f_addr; 3163 3164df@ ( df_addr -- r ) float-ext d_f_fetch 3165""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}."" 3166#ifdef IEEE_FP 3167r = *df_addr; 3168#else 3169!! df@ 3170#endif 3171 3172df! ( r df_addr -- ) float-ext d_f_store 3173""Store @i{r} as double-precision IEEE floating-point value to the 3174address @i{df-addr}."" 3175#ifdef IEEE_FP 3176*df_addr = r; 3177#else 3178!! df! 3179#endif 3180 3181sf@ ( sf_addr -- r ) float-ext s_f_fetch 3182""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}."" 3183#ifdef IEEE_FP 3184r = *sf_addr; 3185#else 3186!! sf@ 3187#endif 3188 3189sf! ( r sf_addr -- ) float-ext s_f_store 3190""Store @i{r} as single-precision IEEE floating-point value to the 3191address @i{sf-addr}."" 3192#ifdef IEEE_FP 3193*sf_addr = r; 3194#else 3195!! sf! 3196#endif 3197 3198f+ ( r1 r2 -- r3 ) float f_plus 3199r3 = r1+r2; 3200 3201f- ( r1 r2 -- r3 ) float f_minus 3202r3 = r1-r2; 3203 3204f* ( r1 r2 -- r3 ) float f_star 3205r3 = r1*r2; 3206 3207f/ ( r1 r2 -- r3 ) float f_slash 3208r3 = r1/r2; 3209 3210f** ( r1 r2 -- r3 ) float-ext f_star_star 3211""@i{r3} is @i{r1} raised to the @i{r2}th power."" 3212CLOBBER_TOS_WORKAROUND_START; 3213r3 = pow(r1,r2); 3214CLOBBER_TOS_WORKAROUND_END; 3215 3216fm* ( r1 n -- r2 ) gforth fm_star 3217r2 = r1*n; 3218 3219fm/ ( r1 n -- r2 ) gforth fm_slash 3220r2 = r1/n; 3221 3222fm*/ ( r1 n1 n2 -- r2 ) gforth fm_star_slash 3223r2 = (r1*n1)/n2; 3224 3225f**2 ( r1 -- r2 ) gforth fm_square 3226r2 = r1*r1; 3227 3228fnegate ( r1 -- r2 ) float f_negate 3229r2 = - r1; 3230 3231fdrop ( r -- ) float f_drop 3232 3233fdup ( r -- r r ) float f_dupe 3234 3235fswap ( r1 r2 -- r2 r1 ) float f_swap 3236 3237fover ( r1 r2 -- r1 r2 r1 ) float f_over 3238 3239frot ( r1 r2 r3 -- r2 r3 r1 ) float f_rote 3240 3241fnip ( r1 r2 -- r2 ) gforth f_nip 3242 3243ftuck ( r1 r2 -- r2 r1 r2 ) gforth f_tuck 3244 3245float+ ( f_addr1 -- f_addr2 ) float float_plus 3246""@code{1 floats +}."" 3247f_addr2 = f_addr1+1; 3248 3249floats ( n1 -- n2 ) float 3250""@i{n2} is the number of address units of @i{n1} floats."" 3251n2 = n1*sizeof(Float); 3252 3253floor ( r1 -- r2 ) float 3254""Round towards the next smaller integral value, i.e., round toward negative infinity."" 3255/* !! unclear wording */ 3256CLOBBER_TOS_WORKAROUND_START; 3257r2 = floor(r1); 3258CLOBBER_TOS_WORKAROUND_END; 3259 3260fround ( r1 -- r2 ) float f_round 3261""Round to the nearest integral value."" 3262CLOBBER_TOS_WORKAROUND_START; 3263r2 = rint(r1); 3264CLOBBER_TOS_WORKAROUND_END; 3265 3266fmax ( r1 r2 -- r3 ) float f_max 3267if (r1<r2) 3268 r3 = r2; 3269else 3270 r3 = r1; 3271 3272fmin ( r1 r2 -- r3 ) float f_min 3273if (r1<r2) 3274 r3 = r1; 3275else 3276 r3 = r2; 3277 3278represent ( r c_addr u -- n f1 f2 ) float 3279char *sig; 3280size_t siglen; 3281int flag; 3282int decpt; 3283sig=ecvt(r, u, &decpt, &flag); 3284n=(r==0. ? 1 : decpt); 3285f1=FLAG(flag!=0); 3286f2=FLAG(isdigit((unsigned)(sig[0]))!=0); 3287siglen=strlen((char *)sig); 3288if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */ 3289 siglen=u; 3290if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */ 3291 for (; sig[siglen-1]=='0'; siglen--); 3292 ; 3293memcpy(c_addr,sig,siglen); 3294memset(c_addr+siglen,f2?'0':' ',u-siglen); 3295 3296>float ( c_addr u -- f:... flag ) float to_float 3297""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the 3298character string @i{c-addr u} to internal floating-point 3299representation. If the string represents a valid floating-point number 3300@i{r} is placed on the floating-point stack and @i{flag} is 3301true. Otherwise, @i{flag} is false. A string of blanks is a special 3302case and represents the floating-point number 0."" 3303Float r; 3304flag = to_float(c_addr, u, &r); 3305if (flag) { 3306 fp--; 3307 fp[0]=r; 3308} 3309 3310fabs ( r1 -- r2 ) float-ext f_abs 3311r2 = fabs(r1); 3312 3313facos ( r1 -- r2 ) float-ext f_a_cos 3314CLOBBER_TOS_WORKAROUND_START; 3315r2 = acos(r1); 3316CLOBBER_TOS_WORKAROUND_END; 3317 3318fasin ( r1 -- r2 ) float-ext f_a_sine 3319CLOBBER_TOS_WORKAROUND_START; 3320r2 = asin(r1); 3321CLOBBER_TOS_WORKAROUND_END; 3322 3323fatan ( r1 -- r2 ) float-ext f_a_tan 3324CLOBBER_TOS_WORKAROUND_START; 3325r2 = atan(r1); 3326CLOBBER_TOS_WORKAROUND_END; 3327 3328fatan2 ( r1 r2 -- r3 ) float-ext f_a_tan_two 3329""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably 3330intends this to be the inverse of @code{fsincos}. In gforth it is."" 3331CLOBBER_TOS_WORKAROUND_START; 3332r3 = atan2(r1,r2); 3333CLOBBER_TOS_WORKAROUND_END; 3334 3335fcos ( r1 -- r2 ) float-ext f_cos 3336CLOBBER_TOS_WORKAROUND_START; 3337r2 = cos(r1); 3338CLOBBER_TOS_WORKAROUND_END; 3339 3340fexp ( r1 -- r2 ) float-ext f_e_x_p 3341CLOBBER_TOS_WORKAROUND_START; 3342r2 = exp(r1); 3343CLOBBER_TOS_WORKAROUND_END; 3344 3345fexpm1 ( r1 -- r2 ) float-ext f_e_x_p_m_one 3346""@i{r2}=@i{e}**@i{r1}@minus{}1"" 3347CLOBBER_TOS_WORKAROUND_START; 3348#ifdef HAVE_EXPM1 3349extern double 3350#ifdef NeXT 3351 const 3352#endif 3353 expm1(double); 3354r2 = expm1(r1); 3355#else 3356r2 = exp(r1)-1.; 3357#endif 3358CLOBBER_TOS_WORKAROUND_END; 3359 3360fln ( r1 -- r2 ) float-ext f_l_n 3361CLOBBER_TOS_WORKAROUND_START; 3362r2 = log(r1); 3363CLOBBER_TOS_WORKAROUND_END; 3364 3365flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one 3366""@i{r2}=ln(@i{r1}+1)"" 3367CLOBBER_TOS_WORKAROUND_START; 3368#ifdef HAVE_LOG1P 3369extern double 3370#ifdef NeXT 3371 const 3372#endif 3373 log1p(double); 3374r2 = log1p(r1); 3375#else 3376r2 = log(r1+1.); 3377#endif 3378CLOBBER_TOS_WORKAROUND_END; 3379 3380flog ( r1 -- r2 ) float-ext f_log 3381""The decimal logarithm."" 3382CLOBBER_TOS_WORKAROUND_START; 3383r2 = log10(r1); 3384CLOBBER_TOS_WORKAROUND_END; 3385 3386falog ( r1 -- r2 ) float-ext f_a_log 3387""@i{r2}=10**@i{r1}"" 3388extern double pow10(double); 3389CLOBBER_TOS_WORKAROUND_START; 3390r2 = pow10(r1); 3391CLOBBER_TOS_WORKAROUND_END; 3392 3393fsin ( r1 -- r2 ) float-ext f_sine 3394CLOBBER_TOS_WORKAROUND_START; 3395r2 = sin(r1); 3396 3397fsincos ( r1 -- r2 r3 ) float-ext f_sine_cos 3398""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" 3399CLOBBER_TOS_WORKAROUND_START; 3400r2 = sin(r1); 3401r3 = cos(r1); 3402CLOBBER_TOS_WORKAROUND_END; 3403 3404fsqrt ( r1 -- r2 ) float-ext f_square_root 3405CLOBBER_TOS_WORKAROUND_START; 3406r2 = sqrt(r1); 3407CLOBBER_TOS_WORKAROUND_END; 3408 3409ftan ( r1 -- r2 ) float-ext f_tan 3410CLOBBER_TOS_WORKAROUND_START; 3411r2 = tan(r1); 3412CLOBBER_TOS_WORKAROUND_END; 3413: 3414 fsincos f/ ; 3415 3416fsinh ( r1 -- r2 ) float-ext f_cinch 3417CLOBBER_TOS_WORKAROUND_START; 3418r2 = sinh(r1); 3419CLOBBER_TOS_WORKAROUND_END; 3420: 3421 fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; 3422 3423fcosh ( r1 -- r2 ) float-ext f_cosh 3424CLOBBER_TOS_WORKAROUND_START; 3425r2 = cosh(r1); 3426CLOBBER_TOS_WORKAROUND_END; 3427: 3428 fexp fdup 1/f f+ f2/ ; 3429 3430ftanh ( r1 -- r2 ) float-ext f_tan_h 3431CLOBBER_TOS_WORKAROUND_START; 3432r2 = tanh(r1); 3433CLOBBER_TOS_WORKAROUND_END; 3434: 3435 f2* fexpm1 fdup 2. d>f f+ f/ ; 3436 3437fasinh ( r1 -- r2 ) float-ext f_a_cinch 3438CLOBBER_TOS_WORKAROUND_START; 3439r2 = asinh(r1); 3440CLOBBER_TOS_WORKAROUND_END; 3441: 3442 fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; 3443 3444facosh ( r1 -- r2 ) float-ext f_a_cosh 3445CLOBBER_TOS_WORKAROUND_START; 3446r2 = acosh(r1); 3447CLOBBER_TOS_WORKAROUND_END; 3448: 3449 fdup fdup f* 1. d>f f- fsqrt f+ fln ; 3450 3451fatanh ( r1 -- r2 ) float-ext f_a_tan_h 3452CLOBBER_TOS_WORKAROUND_START; 3453r2 = atanh(r1); 3454CLOBBER_TOS_WORKAROUND_END; 3455: 3456 fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ 3457 r> IF fnegate THEN ; 3458 3459sfloats ( n1 -- n2 ) float-ext s_floats 3460""@i{n2} is the number of address units of @i{n1} 3461single-precision IEEE floating-point numbers."" 3462n2 = n1*sizeof(SFloat); 3463 3464dfloats ( n1 -- n2 ) float-ext d_floats 3465""@i{n2} is the number of address units of @i{n1} 3466double-precision IEEE floating-point numbers."" 3467n2 = n1*sizeof(DFloat); 3468 3469sfaligned ( c_addr -- sf_addr ) float-ext s_f_aligned 3470""@i{sf-addr} is the first single-float-aligned address greater 3471than or equal to @i{c-addr}."" 3472sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); 3473: 3474 [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; 3475 3476dfaligned ( c_addr -- df_addr ) float-ext d_f_aligned 3477""@i{df-addr} is the first double-float-aligned address greater 3478than or equal to @i{c-addr}."" 3479df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); 3480: 3481 [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; 3482 3483v* ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star 3484""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the 3485next at f_addr1+nstride1 and so on (similar for v2). Both vectors have 3486ucount elements."" 3487r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount); 3488: 3489 >r swap 2swap swap 0e r> 0 ?DO 3490 dup f@ over + 2swap dup f@ f* f+ over + 2swap 3491 LOOP 2drop 2drop ; 3492 3493faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth 3494""vy=ra*vx+vy"" 3495faxpy(ra, f_x, nstridex, f_y, nstridey, ucount); 3496: 3497 >r swap 2swap swap r> 0 ?DO 3498 fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap 3499 LOOP 2drop 2drop fdrop ; 3500 3501\+ 3502 3503\ The following words access machine/OS/installation-dependent 3504\ Gforth internals 3505\ !! how about environmental queries DIRECT-THREADED, 3506\ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ 3507 3508\ local variable implementation primitives 3509 3510\+glocals 3511 3512\g locals 3513 3514@local# ( #noffset -- w ) gforth fetch_local_number 3515w = *(Cell *)(lp+noffset); 3516 3517@local0 ( -- w ) new fetch_local_zero 3518w = ((Cell *)lp)[0]; 3519 3520@local1 ( -- w ) new fetch_local_four 3521w = ((Cell *)lp)[1]; 3522 3523@local2 ( -- w ) new fetch_local_eight 3524w = ((Cell *)lp)[2]; 3525 3526@local3 ( -- w ) new fetch_local_twelve 3527w = ((Cell *)lp)[3]; 3528 3529\+floating 3530 3531f@local# ( #noffset -- r ) gforth f_fetch_local_number 3532r = *(Float *)(lp+noffset); 3533 3534f@local0 ( -- r ) new f_fetch_local_zero 3535r = ((Float *)lp)[0]; 3536 3537f@local1 ( -- r ) new f_fetch_local_eight 3538r = ((Float *)lp)[1]; 3539 3540\+ 3541 3542laddr# ( #noffset -- c_addr ) gforth laddr_number 3543/* this can also be used to implement lp@ */ 3544c_addr = (Char *)(lp+noffset); 3545 3546lp+!# ( #noffset -- ) gforth lp_plus_store_number 3547""used with negative immediate values it allocates memory on the 3548local stack, a positive immediate argument drops memory from the local 3549stack"" 3550lp += noffset; 3551 3552lp- ( -- ) new minus_four_lp_plus_store 3553lp += -sizeof(Cell); 3554 3555lp+ ( -- ) new eight_lp_plus_store 3556lp += sizeof(Float); 3557 3558lp+2 ( -- ) new sixteen_lp_plus_store 3559lp += 2*sizeof(Float); 3560 3561lp! ( c_addr -- ) gforth lp_store 3562lp = (Address)c_addr; 3563 3564>l ( w -- ) gforth to_l 3565lp -= sizeof(Cell); 3566*(Cell *)lp = w; 3567 3568\+floating 3569 3570f>l ( r -- ) gforth f_to_l 3571lp -= sizeof(Float); 3572*(Float *)lp = r; 3573 3574fpick ( f:... u -- f:... r ) gforth 3575""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }."" 3576r = fp[u]; 3577: 3578 floats fp@ + f@ ; 3579 3580\+ 3581\+ 3582 3583\+OS 3584 3585\g syslib 3586 3587open-lib ( c_addr1 u1 -- u2 ) gforth open_lib 3588u2 = gforth_dlopen(c_addr1, u1); 3589 3590lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym 3591#ifdef HAVE_LIBLTDL 3592u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1)); 3593#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) 3594u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); 3595#else 3596# ifdef _WIN32 3597u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); 3598# else 3599#warning Define lib-sym! 3600u3 = 0; 3601# endif 3602#endif 3603 3604wcall ( ... u -- ... ) gforth 3605gforth_FP=fp; 3606sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &gforth_FP); 3607fp=gforth_FP; 3608 3609uw@ ( c_addr -- u ) gforth u_w_fetch 3610""@i{u} is the zero-extended 16-bit value stored at @i{c_addr}."" 3611u = *(UWyde*)(c_addr); 3612 3613sw@ ( c_addr -- n ) gforth s_w_fetch 3614""@i{n} is the sign-extended 16-bit value stored at @i{c_addr}."" 3615n = *(Wyde*)(c_addr); 3616 3617w! ( w c_addr -- ) gforth w_store 3618""Store the bottom 16 bits of @i{w} at @i{c_addr}."" 3619*(Wyde*)(c_addr) = w; 3620 3621ul@ ( c_addr -- u ) gforth u_l_fetch 3622""@i{u} is the zero-extended 32-bit value stored at @i{c_addr}."" 3623u = *(UTetrabyte*)(c_addr); 3624 3625sl@ ( c_addr -- n ) gforth s_l_fetch 3626""@i{n} is the sign-extended 32-bit value stored at @i{c_addr}."" 3627n = *(Tetrabyte*)(c_addr); 3628 3629l! ( w c_addr -- ) gforth l_store 3630""Store the bottom 32 bits of @i{w} at @i{c_addr}."" 3631*(Tetrabyte*)(c_addr) = w; 3632 3633lib-error ( -- c_addr u ) gforth lib_error 3634""Error message for last failed @code{open-lib} or @code{lib-sym}."" 3635#ifdef HAVE_LIBLTDL 3636c_addr = (Char *)lt_dlerror(); 3637u = (c_addr == NULL) ? 0 : strlen((char *)c_addr); 3638#else 3639c_addr = "libltdl is not configured"; 3640u = strlen(c_addr); 3641#endif 3642 3643\+ 3644\g peephole 3645 3646\+peephole 3647 3648compile-prim1 ( a_prim -- ) gforth compile_prim1 3649""compile prim (incl. immargs) at @var{a_prim}"" 3650compile_prim1(a_prim); 3651 3652finish-code ( ... -- ... ) gforth finish_code 3653""Perform delayed steps in code generation (branch resolution, I-cache 3654flushing)."" 3655/* The ... above are a workaround for a bug in gcc-2.95, which fails 3656 to save spTOS (gforth-fast --enable-force-reg) */ 3657finish_code(); 3658 3659forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode 3660f = forget_dyncode(c_code); 3661 3662decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim 3663""a_prim is the code address of the primitive that has been 3664compile_prim1ed to a_code"" 3665a_prim = (Cell *)decompile_code((Label)a_code); 3666 3667\ set-next-code and call2 do not appear in images and can be 3668\ renumbered arbitrarily 3669 3670set-next-code ( #w -- ) gforth set_next_code 3671#ifdef NO_IP 3672next_code = (Label)w; 3673#endif 3674 3675call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth 3676/* call with explicit return address */ 3677#ifdef NO_IP 3678INST_TAIL; 3679JUMP(a_callee); 3680#else 3681assert(0); 3682#endif 3683 3684tag-offsets ( -- a_addr ) gforth tag_offsets 3685extern Cell groups[32]; 3686a_addr = groups; 3687 3688\+ 3689 3690\g static_super 3691 3692#line 2566 3693 3694 3695\g end 3696