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