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