File:
[gforth] /
gforth /
Attic /
primitives
Revision
1.36:
download - view:
text,
annotated -
select for diffs
Thu Apr 6 16:56:13 1995 UTC (29 years ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
fixed bug in resize ("0 n resize" is now equivalent to "n allocate")
added primitives call-c and strerror
most primitives producing iors now produce error numbers derived from OS error
numbers (EAGAIN and its kin)
.error now prints OS error messages for OS-derived error numbers.
primitives working with ferror now call clearerr
added a bit of documentation to glocals.fs to satisfy TeX
added definition of CC to Makefile.in again
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)NEXT_INST;
90: INC_IP(1);
91:
92: execute xt -- core,fig
93: ip=IP;
94: cfa = xt;
95: IF_TOS(TOS = sp[0]);
96: NEXT1;
97:
98: branch-lp+!# -- new branch_lp_plus_store_number
99: /* this will probably not be used */
100: branch_adjust_lp:
101: lp += (Cell)(IP[1]);
102: goto branch;
103:
104: branch -- fig
105: branch:
106: ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
107: NEXT_P0;
108: :
109: r> dup @ + >r ;
110:
111: \ condbranch(forthname,restline,code)
112: \ this is non-syntactical: code must open a brace that is closed by the macro
113: define(condbranch,
114: $1 $2
115: $3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
116: NEXT_P0;
117: NEXT;
118: }
119: else
120: INC_IP(1);
121:
122: $1-lp+!# $2_lp_plus_store_number
123: $3 goto branch_adjust_lp;
124: }
125: else
126: INC_IP(2);
127:
128: )
129:
130: condbranch(?branch,f -- f83 question_branch,
131: if (f==0) {
132: IF_TOS(TOS = sp[0]);
133: )
134:
135: condbranch((next),-- cmFORTH paren_next,
136: if ((*rp)--) {
137: )
138:
139: condbranch((loop),-- fig paren_loop,
140: Cell index = *rp+1;
141: Cell limit = rp[1];
142: if (index != limit) {
143: *rp = index;
144: )
145:
146: condbranch((+loop),n -- fig paren_plus_loop,
147: /* !! check this thoroughly */
148: Cell index = *rp;
149: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
150: /* dependent upon two's complement arithmetic */
151: Cell olddiff = index-rp[1];
152: #ifndef undefined
153: if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
154: || (olddiff^n)>=0 /* it is a wrap-around effect */) {
155: #else
156: #ifndef MAXINT
157: #define MAXINT ((((Cell)1)<<(8*sizeof(Cell)-1))-1)
158: #endif
159: if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
160: #endif
161: #ifdef i386
162: *rp += n;
163: #else
164: *rp = index + n;
165: #endif
166: IF_TOS(TOS = sp[0]);
167: )
168:
169: condbranch((s+loop),n -- new paren_symmetric_plus_loop,
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 */
174: Cell index = *rp;
175: Cell diff = index-rp[1];
176: Cell newdiff = diff+n;
177: if (n<0) {
178: diff = -diff;
179: newdiff = -newdiff;
180: }
181: if (diff>=0 || newdiff<0) {
182: #ifdef i386
183: *rp += n;
184: #else
185: *rp = index + n;
186: #endif
187: IF_TOS(TOS = sp[0]);
188: )
189:
190: unloop -- core
191: rp += 2;
192: :
193: r> rdrop rdrop >r ;
194:
195: (for) ncount -- cmFORTH paren_for
196: /* or (for) = >r -- collides with unloop! */
197: *--rp = 0;
198: *--rp = ncount;
199: :
200: r> swap 0 >r >r >r ;
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: :
207: r> -rot swap >r >r >r ;
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 {
217: INC_IP(1);
218: }
219:
220: i -- n core,fig
221: n = *rp;
222:
223: j -- n core
224: n = rp[2];
225:
226: \ digit is high-level: 0/0%
227:
228: (emit) c -- fig paren_emit
229: putchar(c);
230: emitcounter++;
231:
232: (type) c_addr n -- fig paren_type
233: fwrite(c_addr,sizeof(Char),n,stdout);
234: emitcounter += n;
235:
236: (key) -- n fig paren_key
237: fflush(stdout);
238: /* !! noecho */
239: n = key();
240:
241: key? -- n fig key_q
242: fflush(stdout);
243: n = key_query;
244:
245: cr -- fig
246: puts("");
247: :
248: $0A emit ;
249:
250: move c_from c_to ucount -- core
251: memmove(c_to,c_from,ucount);
252: /* make an Ifdef for bsd and others? */
253: :
254: >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
255:
256: cmove c_from c_to u -- string
257: while (u-- > 0)
258: *c_to++ = *c_from++;
259: :
260: bounds ?DO dup c@ I c! 1+ LOOP drop ;
261:
262: cmove> c_from c_to u -- string c_move_up
263: while (u-- > 0)
264: c_to[u] = c_from[u];
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 ;
269:
270: fill c_addr u c -- core
271: memset(c_addr,c,u);
272: :
273: -rot bounds
274: ?DO dup I c! LOOP drop ;
275:
276: compare c_addr1 u1 c_addr2 u2 -- n string
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.""
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;
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 ;
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;
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 ;
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: }
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 ;
332:
333: -trailing c_addr u1 -- c_addr u2 string dash_trailing
334: u2 = u1;
335: while (c_addr[u2-1] == ' ')
336: u2--;
337: :
338: BEGIN 1- 2dup + c@ bl = WHILE
339: dup 0= UNTIL ELSE 1+ THEN ;
340:
341: /string c_addr1 u1 n -- c_addr2 u2 string slash_string
342: c_addr2 = c_addr1+n;
343: u2 = u1-n;
344: :
345: tuck - >r + r> dup 0< IF - 0 THEN ;
346:
347: + n1 n2 -- n core,fig plus
348: n = n1+n2;
349:
350: - n1 n2 -- n core,fig minus
351: n = n1-n2;
352: :
353: negate + ;
354:
355: negate n1 -- n2 core,fig
356: /* use minus as alias */
357: n2 = -n1;
358: :
359: invert 1+ ;
360:
361: 1+ n1 -- n2 core one_plus
362: n2 = n1+1;
363: :
364: 1 + ;
365:
366: 1- n1 -- n2 core one_minus
367: n2 = n1-1;
368: :
369: 1 - ;
370:
371: max n1 n2 -- n core
372: if (n1<n2)
373: n = n2;
374: else
375: n = n1;
376: :
377: 2dup < IF swap THEN drop ;
378:
379: min n1 n2 -- n core
380: if (n1<n2)
381: n = n1;
382: else
383: n = n2;
384: :
385: 2dup > IF swap THEN drop ;
386:
387: abs n1 -- n2 core
388: if (n1<0)
389: n2 = -n1;
390: else
391: n2 = n1;
392: :
393: dup 0< IF negate THEN ;
394:
395: * n1 n2 -- n core,fig star
396: n = n1*n2;
397: :
398: um* drop ;
399:
400: / n1 n2 -- n core,fig slash
401: n = n1/n2;
402: :
403: /mod nip ;
404:
405: mod n1 n2 -- n core
406: n = n1%n2;
407: :
408: /mod drop ;
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! */
413: :
414: >r s>d r> fm/mod ;
415:
416: 2* n1 -- n2 core two_star
417: n2 = 2*n1;
418: :
419: dup + ;
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: }
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 ;
451:
452: m* n1 n2 -- d core m_star
453: d = (DCell)n1 * (DCell)n2;
454: :
455: 2dup 0< and >r
456: 2dup swap 0< and >r
457: um* r> - r> - ;
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;
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 ;
475:
476: m+ d1 n -- d2 double m_plus
477: d2 = d1+n;
478: :
479: s>d d+ ;
480:
481: d+ d1 d2 -- d double,fig d_plus
482: d = d1+d2;
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 - ;
486:
487: d- d1 d2 -- d double d_minus
488: d = d1-d2;
489: :
490: dnegate d+ ;
491:
492: dnegate d1 -- d2 double
493: /* use dminus as alias */
494: d2 = -d1;
495: :
496: invert swap negate tuck 0= - ;
497:
498: dmax d1 d2 -- d double
499: if (d1<d2)
500: d = d2;
501: else
502: d = d1;
503: :
504: 2over 2over d> IF 2swap THEN 2drop ;
505:
506: dmin d1 d2 -- d double
507: if (d1<d2)
508: d = d1;
509: else
510: d = d2;
511: :
512: 2over 2over d< IF 2swap THEN 2drop ;
513:
514: dabs d1 -- d2 double
515: if (d1<0)
516: d2 = -d1;
517: else
518: d2 = d1;
519: :
520: dup 0< IF dnegate THEN ;
521:
522: d2* d1 -- d2 double d_two_star
523: d2 = 2*d1;
524: :
525: 2dup d+ ;
526:
527: d2/ d1 -- d2 double d_two_slash
528: /* !! is this still correct? */
529: d2 = d1>>1;
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 ;
533:
534: d>s d -- n double d_to_s
535: /* make this an alias for drop? */
536: n = d;
537: :
538: drop ;
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;
551: :
552: -1 xor ;
553:
554: rshift u1 n -- u2 core
555: u2 = u1>>n;
556:
557: lshift u1 n -- u2 core
558: u2 = u1<<n;
559:
560: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
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);
592: :
593: over - >r - r> u< ;
594:
595: sp@ -- a_addr fig spat
596: a_addr = sp+1;
597:
598: sp! a_addr -- fig spstore
599: sp = a_addr;
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:
614: ;s -- fig semis
615: ip = (Xt *)(*rp++);
616: NEXT_P0;
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:
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:
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
661: :
662: rot rot ;
663:
664: nip w1 w2 -- w2 core-ext
665: :
666: swap drop ;
667:
668: tuck w1 w2 -- w2 w1 w2 core-ext
669: :
670: swap over ;
671:
672: ?dup w -- w core question_dupe
673: if (w!=0) {
674: IF_TOS(*sp-- = w;)
675: #ifndef USE_TOS
676: *--sp = w;
677: #endif
678: }
679: :
680: dup IF dup THEN ;
681:
682: pick u -- w core-ext
683: w = sp[u+1];
684: :
685: 1+ cells sp@ + @ ;
686:
687: 2drop w1 w2 -- core two_drop
688: :
689: drop drop ;
690:
691: 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe
692: :
693: over over ;
694:
695: 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over
696: :
697: 3 pick 3 pick ;
698:
699: 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap
700: :
701: >r -rot r> -rot ;
702:
703: 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double two_rote
704: :
705: >r >r 2swap r> r> 2swap ;
706:
707: \ toggle is high-level: 0.11/0.42%
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;
727: :
728: tuck ! cell+ ! ;
729:
730: 2@ a_addr -- w1 w2 core two_fetch
731: w2 = a_addr[0];
732: w1 = a_addr[1];
733: :
734: dup cell+ @ swap @ ;
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;
745: :
746: [ cell ] Literal + ;
747:
748: cells n1 -- n2 core
749: n2 = n1 * sizeof(Cell);
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 ] ;
757:
758: char+ c_addr1 -- c_addr2 core care_plus
759: c_addr2 = c_addr1 + 1;
760: :
761: 1+ ;
762:
763: (chars) n1 -- n2 gforth paren_cares
764: n2 = n1 * sizeof(Char);
765: :
766: ;
767:
768: count c_addr1 -- c_addr2 u core
769: u = *c_addr1;
770: c_addr2 = c_addr1+1;
771: :
772: dup 1+ swap c@ ;
773:
774: (bye) n -- toolkit-ext paren_bye
775: return (Label *)n;
776:
777: system c_addr u -- n own
778: n=system(cstr(c_addr,u,1));
779:
780: getenv c_addr1 u1 -- c_addr2 u2 new
781: c_addr2 = getenv(cstr(c_addr1,u1,1));
782: u2=strlen(c_addr2);
783:
784: popen c_addr u n -- wfileid own
785: static char* mode[2]={"r","w"};
786: wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);
787:
788: pclose wfileid -- wior own
789: wior=pclose((FILE *)wfileid); /* !! what to do with the result */
790:
791: time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date
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;
798: nmonth=ltime->tm_mon+1;
799: nday =ltime->tm_mday;
800: nhour =ltime->tm_hour;
801: nmin =ltime->tm_min;
802: nsec =ltime->tm_sec;
803:
804: ms n -- facility-ext
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);
809:
810: allocate u -- a_addr wior memory
811: a_addr = (Cell *)malloc(u);
812: wior = IOR(a_addr==NULL);
813:
814: free a_addr -- wior memory
815: free(a_addr);
816: wior = 0;
817:
818: resize a_addr1 u -- a_addr2 wior memory
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 */
831:
832: (f83find) c_addr u f83name1 -- f83name2 new paren_f83find
833: for (; f83name1 != NULL; f83name1 = f83name1->next)
834: if (F83NAME_COUNT(f83name1)==u &&
835: strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
836: break;
837: f83name2=f83name1;
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 ;
845:
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: }
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 ;
867:
868: (hashkey) c_addr u1 -- u2 new paren_hashkey
869: u2=0;
870: while(u1--)
871: u2+=(Cell)toupper(*c_addr++);
872: :
873: 0 -rot bounds ?DO I c@ toupper + LOOP ;
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));
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,
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: }
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 - ;
921:
922: close-file wfileid -- wior file close_file
923: wior = IOR(fclose((FILE *)wfileid)==EOF);
924:
925: open-file c_addr u ntype -- w2 wior file open_file
926: w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
927: wior = IOR(w2 == NULL);
928:
929: create-file c_addr u ntype -- w2 wior file create_file
930: Cell fd;
931: fd = open(cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);
932: if (fd != -1) {
933: w2 = (Cell)fdopen(fd, fileattr[ntype]);
934: wior = IOR(w2==NULL);
935: } else {
936: w2 = 0;
937: wior = IOR(1);
938: }
939:
940: delete-file c_addr u -- wior file delete_file
941: wior = IOR(unlink(cstr(c_addr, u, 1))==-1);
942:
943: rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file
944: char *s1=cstr(c_addr2, u2, 1);
945: wior = IOR(rename(cstr(c_addr1, u1, 0), s1)==-1);
946:
947: file-position wfileid -- ud wior file file_position
948: /* !! use tell and lseek? */
949: ud = ftell((FILE *)wfileid);
950: wior = IOR(ud==-1);
951:
952: reposition-file ud wfileid -- wior file reposition_file
953: wior = IOR(fseek((FILE *)wfileid, (long)ud, SEEK_SET)==-1);
954:
955: file-size wfileid -- ud wior file file_size
956: struct stat buf;
957: wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
958: ud = buf.st_size;
959:
960: resize-file ud wfileid -- wior file resize_file
961: wior = IOR(ftruncate(fileno((FILE *)wfileid), (Cell)ud)==-1);
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);
966: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
967: /* !! is the value of ferror errno-compatible? */
968: if (wior)
969: clearerr((FILE *)wfileid);
970:
971: read-line c_addr u1 wfileid -- u2 flag wior file read_line
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))) {
989: wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */
990: if (wior)
991: clearerr((FILE *)wfileid);
992: u2 = strlen(c_addr);
993: u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
994: }
995: else {
996: wior=0;
997: u2=0;
998: }
999:
1000: write-file c_addr u1 wfileid -- wior file write_file
1001: /* !! fwrite does not guarantee enough */
1002: {
1003: Cell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1004: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1005: if (wior)
1006: clearerr((FILE *)wfileid);
1007: }
1008:
1009: flush-file wfileid -- wior file-ext flush_file
1010: wior = IOR(fflush((FILE *) wfileid)==EOF);
1011:
1012: comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
1013: comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
1014:
1015: d>f d -- r float d_to_f
1016: r = d;
1017:
1018: f>d r -- d float f_to_d
1019: /* !! basis 15 is not very specific */
1020: d = r;
1021:
1022: f! r f_addr -- float f_store
1023: *f_addr = r;
1024:
1025: f@ f_addr -- r float f_fetch
1026: r = *f_addr;
1027:
1028: df@ df_addr -- r float-ext d_f_fetch
1029: #ifdef IEEE_FP
1030: r = *df_addr;
1031: #else
1032: !! df@
1033: #endif
1034:
1035: df! r df_addr -- float-ext d_f_store
1036: #ifdef IEEE_FP
1037: *df_addr = r;
1038: #else
1039: !! df!
1040: #endif
1041:
1042: sf@ sf_addr -- r float-ext s_f_fetch
1043: #ifdef IEEE_FP
1044: r = *sf_addr;
1045: #else
1046: !! sf@
1047: #endif
1048:
1049: sf! r sf_addr -- float-ext s_f_store
1050: #ifdef IEEE_FP
1051: *sf_addr = r;
1052: #else
1053: !! sf!
1054: #endif
1055:
1056: f+ r1 r2 -- r3 float f_plus
1057: r3 = r1+r2;
1058:
1059: f- r1 r2 -- r3 float f_minus
1060: r3 = r1-r2;
1061:
1062: f* r1 r2 -- r3 float f_star
1063: r3 = r1*r2;
1064:
1065: f/ r1 r2 -- r3 float f_slash
1066: r3 = r1/r2;
1067:
1068: f** r1 r2 -- r3 float-ext f_star_star
1069: ""@i{r3} is @i{r1} raised to the @i{r2}th power""
1070: r3 = pow(r1,r2);
1071:
1072: fnegate r1 -- r2 float
1073: r2 = - r1;
1074:
1075: fdrop r -- float
1076:
1077: fdup r -- r r float
1078:
1079: fswap r1 r2 -- r2 r1 float
1080:
1081: fover r1 r2 -- r1 r2 r1 float
1082:
1083: frot r1 r2 r3 -- r2 r3 r1 float
1084:
1085: float+ f_addr1 -- f_addr2 float float_plus
1086: f_addr2 = f_addr1+1;
1087:
1088: floats n1 -- n2 float
1089: n2 = n1*sizeof(Float);
1090:
1091: floor r1 -- r2 float
1092: ""round towards the next smaller integral value, i.e., round toward negative infinity""
1093: /* !! unclear wording */
1094: r2 = floor(r1);
1095:
1096: fround r1 -- r2 float
1097: ""round to the nearest integral value""
1098: /* !! unclear wording */
1099: #ifdef HAVE_RINT
1100: r2 = rint(r1);
1101: #else
1102: r2 = floor(r1+0.5);
1103: /* !! This is not quite true to the rounding rules given in the standard */
1104: #endif
1105:
1106: fmax r1 r2 -- r3 float
1107: if (r1<r2)
1108: r3 = r2;
1109: else
1110: r3 = r1;
1111:
1112: fmin r1 r2 -- r3 float
1113: if (r1<r2)
1114: r3 = r1;
1115: else
1116: r3 = r2;
1117:
1118: represent r c_addr u -- n f1 f2 float
1119: char *sig;
1120: Cell flag;
1121: Cell decpt;
1122: sig=ecvt(r, u, &decpt, &flag);
1123: n=(r==0 ? 1 : decpt);
1124: f1=FLAG(flag!=0);
1125: f2=FLAG(isdigit(sig[0])!=0);
1126: memmove(c_addr,sig,u);
1127:
1128: >float c_addr u -- flag float to_float
1129: /* real signature: c_addr u -- r t / f */
1130: Float r;
1131: char *number=cstr(c_addr, u, 1);
1132: char *endconv;
1133: while(isspace(number[--u]) && u>0);
1134: switch(number[u])
1135: {
1136: case 'd':
1137: case 'D':
1138: case 'e':
1139: case 'E': break;
1140: default : u++; break;
1141: }
1142: number[u]='\0';
1143: r=strtod(number,&endconv);
1144: if((flag=FLAG(!(Cell)*endconv)))
1145: {
1146: IF_FTOS(fp[0] = FTOS);
1147: fp += -1;
1148: FTOS = r;
1149: }
1150: else if(*endconv=='d' || *endconv=='D')
1151: {
1152: *endconv='E';
1153: r=strtod(number,&endconv);
1154: if((flag=FLAG(!(Cell)*endconv)))
1155: {
1156: IF_FTOS(fp[0] = FTOS);
1157: fp += -1;
1158: FTOS = r;
1159: }
1160: }
1161:
1162: fabs r1 -- r2 float-ext
1163: r2 = fabs(r1);
1164:
1165: facos r1 -- r2 float-ext
1166: r2 = acos(r1);
1167:
1168: fasin r1 -- r2 float-ext
1169: r2 = asin(r1);
1170:
1171: fatan r1 -- r2 float-ext
1172: r2 = atan(r1);
1173:
1174: fatan2 r1 r2 -- r3 float-ext
1175: ""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably
1176: intends this to be the inverse of @code{fsincos}. In gforth it is.""
1177: r3 = atan2(r1,r2);
1178:
1179: fcos r1 -- r2 float-ext
1180: r2 = cos(r1);
1181:
1182: fexp r1 -- r2 float-ext
1183: r2 = exp(r1);
1184:
1185: fexpm1 r1 -- r2 float-ext
1186: ""@i{r2}=@i{e}**@i{r1}@minus{}1""
1187: #ifdef HAVE_EXPM1
1188: extern double expm1(double);
1189: r2 = expm1(r1);
1190: #else
1191: r2 = exp(r1)-1.;
1192: #endif
1193:
1194: fln r1 -- r2 float-ext
1195: r2 = log(r1);
1196:
1197: flnp1 r1 -- r2 float-ext
1198: ""@i{r2}=ln(@i{r1}+1)""
1199: #ifdef HAVE_LOG1P
1200: extern double log1p(double);
1201: r2 = log1p(r1);
1202: #else
1203: r2 = log(r1+1.);
1204: #endif
1205:
1206: flog r1 -- r2 float-ext
1207: ""the decimal logarithm""
1208: r2 = log10(r1);
1209:
1210: falog r1 -- r2 float-ext
1211: ""@i{r2}=10**@i{r1}""
1212: #ifdef HAVE_POW10
1213: extern double pow10(double);
1214: r2 = pow10(r1);
1215: #else
1216: #ifndef M_LN10
1217: #define M_LN10 2.30258509299404568402
1218: #endif
1219: r2 = exp(r1*M_LN10);
1220: #endif
1221:
1222: fsin r1 -- r2 float-ext
1223: r2 = sin(r1);
1224:
1225: fsincos r1 -- r2 r3 float-ext
1226: ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
1227: r2 = sin(r1);
1228: r3 = cos(r1);
1229:
1230: fsqrt r1 -- r2 float-ext
1231: r2 = sqrt(r1);
1232:
1233: ftan r1 -- r2 float-ext
1234: r2 = tan(r1);
1235: :
1236: fsincos f/ ;
1237:
1238: fsinh r1 -- r2 float-ext
1239: r2 = sinh(r1);
1240: :
1241: fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
1242:
1243: fcosh r1 -- r2 float-ext
1244: r2 = cosh(r1);
1245: :
1246: fexp fdup 1/f f+ f2/ ;
1247:
1248: ftanh r1 -- r2 float-ext
1249: r2 = tanh(r1);
1250: :
1251: f2* fexpm1 fdup 2. d>f f+ f/ ;
1252:
1253: fasinh r1 -- r2 float-ext
1254: r2 = asinh(r1);
1255: :
1256: fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
1257:
1258: facosh r1 -- r2 float-ext
1259: r2 = acosh(r1);
1260: :
1261: fdup fdup f* 1. d>f f- fsqrt f+ fln ;
1262:
1263: fatanh r1 -- r2 float-ext
1264: r2 = atanh(r1);
1265: :
1266: fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/
1267: r> IF fnegate THEN ;
1268:
1269: \ The following words access machine/OS/installation-dependent ANSI
1270: \ figForth internals
1271: \ !! how about environmental queries DIRECT-THREADED,
1272: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
1273:
1274: >body xt -- a_addr core to_body
1275: a_addr = PFA(xt);
1276:
1277: >code-address xt -- c_addr new to_code_address
1278: ""c_addr is the code address of the word xt""
1279: /* !! This behaves installation-dependently for DOES-words */
1280: c_addr = CODE_ADDRESS(xt);
1281:
1282: >does-code xt -- a_addr new to_does_code
1283: ""If xt ist the execution token of a defining-word-defined word,
1284: a_addr is the start of the Forth code after the DOES>; Otherwise the
1285: behaviour is undefined""
1286: /* !! there is currently no way to determine whether a word is
1287: defining-word-defined */
1288: a_addr = (Cell *)DOES_CODE(xt);
1289:
1290: code-address! n xt -- new code_address_store
1291: ""Creates a code field with code address c_addr at xt""
1292: MAKE_CF(xt, symbols[CF(n)]);
1293: CACHE_FLUSH(xt,PFA(0));
1294:
1295: does-code! a_addr xt -- new does_code_store
1296: ""creates a code field at xt for a defining-word-defined word; a_addr
1297: is the start of the Forth code after DOES>""
1298: MAKE_DOES_CF(xt, a_addr);
1299: CACHE_FLUSH(xt,PFA(0));
1300:
1301: does-handler! a_addr -- new does_jump_store
1302: ""creates a DOES>-handler at address a_addr. a_addr usually points
1303: just behind a DOES>.""
1304: MAKE_DOES_HANDLER(a_addr);
1305: CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
1306:
1307: /does-handler -- n new slash_does_handler
1308: ""the size of a does-handler (includes possible padding)""
1309: /* !! a constant or environmental query might be better */
1310: n = DOES_HANDLER_SIZE;
1311:
1312: toupper c1 -- c2 new
1313: c2 = toupper(c1);
1314:
1315: \ local variable implementation primitives
1316: @local# -- w new fetch_local_number
1317: w = *(Cell *)(lp+(Cell)NEXT_INST);
1318: INC_IP(1);
1319:
1320: @local0 -- w new fetch_local_zero
1321: w = *(Cell *)(lp+0*sizeof(Cell));
1322:
1323: @local1 -- w new fetch_local_four
1324: w = *(Cell *)(lp+1*sizeof(Cell));
1325:
1326: @local2 -- w new fetch_local_eight
1327: w = *(Cell *)(lp+2*sizeof(Cell));
1328:
1329: @local3 -- w new fetch_local_twelve
1330: w = *(Cell *)(lp+3*sizeof(Cell));
1331:
1332: f@local# -- r new f_fetch_local_number
1333: r = *(Float *)(lp+(Cell)NEXT_INST);
1334: INC_IP(1);
1335:
1336: f@local0 -- r new f_fetch_local_zero
1337: r = *(Float *)(lp+0*sizeof(Float));
1338:
1339: f@local1 -- r new f_fetch_local_eight
1340: r = *(Float *)(lp+1*sizeof(Float));
1341:
1342: laddr# -- c_addr new laddr_number
1343: /* this can also be used to implement lp@ */
1344: c_addr = (Char *)(lp+(Cell)NEXT_INST);
1345: INC_IP(1);
1346:
1347: lp+!# -- new lp_plus_store_number
1348: ""used with negative immediate values it allocates memory on the
1349: local stack, a positive immediate argument drops memory from the local
1350: stack""
1351: lp += (Cell)NEXT_INST;
1352: INC_IP(1);
1353:
1354: lp- -- new minus_four_lp_plus_store
1355: lp += -sizeof(Cell);
1356:
1357: lp+ -- new eight_lp_plus_store
1358: lp += sizeof(Float);
1359:
1360: lp+2 -- new sixteen_lp_plus_store
1361: lp += 2*sizeof(Float);
1362:
1363: lp! c_addr -- new lp_store
1364: lp = (Address)c_addr;
1365:
1366: >l w -- new to_l
1367: lp -= sizeof(Cell);
1368: *(Cell *)lp = w;
1369:
1370: f>l r -- new f_to_l
1371: lp -= sizeof(Float);
1372: *(Float *)lp = r;
1373:
1374: up! a_addr -- new up_store
1375: up0=up=(char *)a_addr;
1376:
1377: call-c w -- new call_c
1378: ""Call the C function pointed to by @i{w}. The C function has to
1379: access the stack itself. The stack pointers are exported in the gloabl
1380: variables @code{SP} and @code{FP}.""
1381: /* This is a first attempt at support for calls to C. This may change in
1382: the future */
1383: IF_FTOS(fp[0]=FTOS);
1384: FP=fp;
1385: SP=sp;
1386: ((void (*)())w)();
1387: sp=SP;
1388: fp=FP;
1389: IF_TOS(TOS=sp[0]);
1390: IF_FTOS(FTOS=fp[0]);
1391:
1392: strerror n -- c_addr u new
1393: c_addr = strerror(n);
1394: 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