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