File:
[gforth] /
gforth /
prim
Revision
1.75:
download - view:
text,
annotated -
select for diffs
Mon Feb 26 15:14:20 2001 UTC (23 years ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
gforthmi now deals properly with arguments containing spaces
added CALL and USERADDR primitives
all references to colon defs, constants etc. are now compiled to primitives
with inline arguments
improved COMPARE test case
1: \ Gforth primitives
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21:
22: \ WARNING: This file is processed by m4. Make sure your identifiers
23: \ don't collide with m4's (e.g. by undefining them).
24: \
25: \
26: \
27: \ This file contains primitive specifications in the following format:
28: \
29: \ forth name ( stack effect ) category [pronunciation]
30: \ [""glossary entry""]
31: \ C code
32: \ [:
33: \ Forth code]
34: \
35: \ Note: Fields in brackets are optional. Word specifications have to
36: \ be separated by at least one empty line
37: \
38: \ Both pronounciation and stack items (in the stack effect) must
39: \ conform to the C identifier syntax or the C compiler will complain.
40: \ If you don't have a pronounciation field, the Forth name is used,
41: \ and has to conform to the C identifier syntax.
42: \
43: \ These specifications are automatically translated into C-code for the
44: \ interpreter and into some other files. I hope that your C compiler has
45: \ decent optimization, otherwise the automatically generated code will
46: \ be somewhat slow. The Forth version of the code is included for manual
47: \ compilers, so they will need to compile only the important words.
48: \
49: \ Note that stack pointer adjustment is performed according to stack
50: \ effect by automatically generated code and NEXT is automatically
51: \ appended to the C code. Also, you can use the names in the stack
52: \ effect in the C code. Stack access is automatic. One exception: if
53: \ your code does not fall through, the results are not stored into the
54: \ stack. Use different names on both sides of the '--', if you change a
55: \ value (some stores to the stack are optimized away).
56: \
57: \
58: \
59: \ The stack variables have the following types:
60: \
61: \ name matches type
62: \ f.* Bool
63: \ c.* Char
64: \ [nw].* Cell
65: \ u.* UCell
66: \ d.* DCell
67: \ ud.* UDCell
68: \ r.* Float
69: \ a_.* Cell *
70: \ c_.* Char *
71: \ f_.* Float *
72: \ df_.* DFloat *
73: \ sf_.* SFloat *
74: \ xt.* XT
75: \ f83name.* F83Name *
76:
77: \E get-current prefixes set-current
78: \E
79: \E s" Bool" single data-stack type-prefix f
80: \E s" Char" single data-stack type-prefix c
81: \E s" Cell" single data-stack type-prefix n
82: \E s" Cell" single data-stack type-prefix w
83: \E s" UCell" single data-stack type-prefix u
84: \E s" DCell" double data-stack type-prefix d
85: \E s" UDCell" double data-stack type-prefix ud
86: \E s" Float" single fp-stack type-prefix r
87: \E s" Cell *" single data-stack type-prefix a_
88: \E s" Char *" single data-stack type-prefix c_
89: \E s" Float *" single data-stack type-prefix f_
90: \E s" DFloat *" single data-stack type-prefix df_
91: \E s" SFloat *" single data-stack type-prefix sf_
92: \E s" Xt" single data-stack type-prefix xt
93: \E s" struct F83Name *" single data-stack type-prefix f83name
94: \E s" struct Longname *" single data-stack type-prefix longname
95: \E
96: \E return-stack stack-prefix R:
97: \E inst-stream stack-prefix #
98: \E
99: \E set-current
100:
101: \
102: \
103: \
104: \ In addition the following names can be used:
105: \ ip the instruction pointer
106: \ sp the data stack pointer
107: \ rp the parameter stack pointer
108: \ lp the locals stack pointer
109: \ NEXT executes NEXT
110: \ cfa
111: \ NEXT1 executes NEXT1
112: \ FLAG(x) makes a Forth flag from a C flag
113: \
114: \
115: \
116: \ Percentages in comments are from Koopmans book: average/maximum use
117: \ (taken from four, not very representative benchmarks)
118: \
119: \
120: \
121: \ To do:
122: \
123: \ throw execute, cfa and NEXT1 out?
124: \ macroize *ip, ip++, *ip++ (pipelining)?
125:
126: \ these m4 macros would collide with identifiers
127: undefine(`index')
128: undefine(`shift')
129:
130: noop ( -- ) gforth
131: :
132: ;
133:
134: lit ( #w -- w ) gforth
135: :
136: r> dup @ swap cell+ >r ;
137:
138: execute ( xt -- ) core
139: ""Perform the semantics represented by the execution token, @i{xt}.""
140: ip=IP;
141: IF_spTOS(spTOS = sp[0]);
142: EXEC(xt);
143:
144: perform ( a_addr -- ) gforth
145: ""@code{@@ execute}.""
146: /* and pfe */
147: ip=IP;
148: IF_spTOS(spTOS = sp[0]);
149: EXEC(*(Xt *)a_addr);
150: :
151: @ execute ;
152:
153: \fhas? skipbranchprims 0= [IF]
154: \+glocals
155:
156: branch-lp+!# ( #ndisp #nlocals -- ) gforth branch_lp_plus_store_number
157: /* this will probably not be used */
158: lp += nlocals;
159: SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
160:
161: \+
162:
163: branch ( #ndisp -- ) gforth
164: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
165: :
166: r> dup @ + >r ;
167:
168: \ condbranch(forthname,stackeffect,restline,code,forthcode)
169: \ this is non-syntactical: code must open a brace that is closed by the macro
170: define(condbranch,
171: $1 ( `#'ndisp $2 ) $3
172: $4 SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
173: TAIL;
174: }
175: $5
176:
177: \+glocals
178:
179: $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number
180: $4 lp += nlocals;
181: SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
182: TAIL;
183: }
184:
185: \+
186: )
187:
188: condbranch(?branch,f --,f83 question_branch,
189: if (f==0) {
190: ,:
191: 0= dup \ !f !f
192: r> dup @ \ !f !f IP branchoffset
193: rot and + \ !f IP|IP+branchoffset
194: swap 0= cell and + \ IP''
195: >r ;)
196:
197: \ we don't need an lp_plus_store version of the ?dup-stuff, because it
198: \ is only used in if's (yet)
199:
200: \+xconds
201:
202: ?dup-?branch ( #ndisp f -- f ) new question_dupe_question_branch
203: ""The run-time procedure compiled by @code{?DUP-IF}.""
204: if (f==0) {
205: sp++;
206: IF_spTOS(spTOS = sp[0]);
207: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
208: TAIL;
209: }
210:
211: ?dup-0=-?branch ( #ndisp f -- ) new question_dupe_zero_equals_question_branch
212: ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
213: /* the approach taken here of declaring the word as having the stack
214: effect ( f -- ) and correcting for it in the branch-taken case costs a
215: few cycles in that case, but is easy to convert to a CONDBRANCH
216: invocation */
217: if (f!=0) {
218: sp--;
219: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
220: NEXT;
221: }
222:
223: \+
224: \f[THEN]
225: \fhas? skiploopprims 0= [IF]
226:
227: condbranch((next),R:n1 -- R:n2,cmFORTH paren_next,
228: n2=n1-1;
229: if (n1) {
230: ,:
231: r> r> dup 1- >r
232: IF dup @ + >r ELSE cell+ >r THEN ;)
233:
234: condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,
235: n2=n1+1;
236: if (n2 != nlimit) {
237: ,:
238: r> r> 1+ r> 2dup =
239: IF >r 1- >r cell+ >r
240: ELSE >r >r dup @ + >r THEN ;)
241:
242: condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop,
243: /* !! check this thoroughly */
244: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
245: /* dependent upon two's complement arithmetic */
246: Cell olddiff = n1-nlimit;
247: n2=n1+n;
248: if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
249: || (olddiff^n)>=0 /* it is a wrap-around effect */) {
250: ,:
251: r> swap
252: r> r> 2dup - >r
253: 2 pick r@ + r@ xor 0< 0=
254: 3 pick r> xor 0< 0= or
255: IF >r + >r dup @ + >r
256: ELSE >r >r drop cell+ >r THEN ;)
257:
258: \+xconds
259:
260: condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
261: UCell olddiff = n1-nlimit;
262: n2=n1-u;
263: if (olddiff>u) {
264: ,)
265:
266: condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_symmetric_plus_loop,
267: ""The run-time procedure compiled by S+LOOP. It loops until the index
268: crosses the boundary between limit and limit-sign(n). I.e. a symmetric
269: version of (+LOOP).""
270: /* !! check this thoroughly */
271: Cell diff = n1-nlimit;
272: Cell newdiff = diff+n;
273: if (n<0) {
274: diff = -diff;
275: newdiff = -newdiff;
276: }
277: n2=n1+n;
278: if (diff>=0 || newdiff<0) {
279: ,)
280:
281: \+
282:
283: unloop ( R:w1 R:w2 -- ) core
284: /* !! alias for 2rdrop */
285: :
286: r> rdrop rdrop >r ;
287:
288: (for) ( ncount -- R:nlimit R:ncount ) cmFORTH paren_for
289: /* or (for) = >r -- collides with unloop! */
290: nlimit=0;
291: :
292: r> swap 0 >r >r >r ;
293:
294: (do) ( nlimit nstart -- R:nlimit R:nstart ) gforth paren_do
295: :
296: r> swap rot >r >r >r ;
297:
298: (?do) ( #ndisp nlimit nstart -- R:nlimit R:nstart ) gforth paren_question_do
299: if (nstart == nlimit) {
300: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
301: TAIL;
302: }
303: :
304: 2dup =
305: IF r> swap rot >r >r
306: dup @ + >r
307: ELSE r> swap rot >r >r
308: cell+ >r
309: THEN ; \ --> CORE-EXT
310:
311: \+xconds
312:
313: (+do) ( #ndisp nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do
314: if (nstart >= nlimit) {
315: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
316: TAIL;
317: }
318: :
319: swap 2dup
320: r> swap >r swap >r
321: >=
322: IF
323: dup @ +
324: ELSE
325: cell+
326: THEN >r ;
327:
328: (u+do) ( #ndisp ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do
329: if (ustart >= ulimit) {
330: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
331: TAIL;
332: }
333: :
334: swap 2dup
335: r> swap >r swap >r
336: u>=
337: IF
338: dup @ +
339: ELSE
340: cell+
341: THEN >r ;
342:
343: (-do) ( #ndisp nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do
344: if (nstart <= nlimit) {
345: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
346: TAIL;
347: }
348: :
349: swap 2dup
350: r> swap >r swap >r
351: <=
352: IF
353: dup @ +
354: ELSE
355: cell+
356: THEN >r ;
357:
358: (u-do) ( #ndisp ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do
359: if (ustart <= ulimit) {
360: SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
361: TAIL;
362: }
363: :
364: swap 2dup
365: r> swap >r swap >r
366: u<=
367: IF
368: dup @ +
369: ELSE
370: cell+
371: THEN >r ;
372:
373: \+
374:
375: \ don't make any assumptions where the return stack is!!
376: \ implement this in machine code if it should run quickly!
377:
378: i ( R:n -- R:n n ) core
379: :
380: \ rp@ cell+ @ ;
381: r> r> tuck >r >r ;
382:
383: i' ( R:w R:w2 -- R:w R:w2 w ) gforth i_tick
384: :
385: \ rp@ cell+ cell+ @ ;
386: r> r> r> dup itmp ! >r >r >r itmp @ ;
387: variable itmp
388:
389: j ( R:n R:d1 -- n R:n R:d1 ) core
390: :
391: \ rp@ cell+ cell+ cell+ @ ;
392: r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
393: [IFUNDEF] itmp variable itmp [THEN]
394:
395: k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 ) gforth
396: :
397: \ rp@ [ 5 cells ] Literal + @ ;
398: r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
399: [IFUNDEF] itmp variable itmp [THEN]
400:
401: \f[THEN]
402:
403: \ digit is high-level: 0/0%
404:
405: move ( c_from c_to ucount -- ) core
406: ""Copy the contents of @i{ucount} aus at @i{c-from} to
407: @i{c-to}. @code{move} works correctly even if the two areas overlap.""
408: /* !! note that the standard specifies addr, not c-addr */
409: memmove(c_to,c_from,ucount);
410: /* make an Ifdef for bsd and others? */
411: :
412: >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
413:
414: cmove ( c_from c_to u -- ) string c_move
415: ""Copy the contents of @i{ucount} characters from data space at
416: @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
417: from low address to high address; i.e., for overlapping areas it is
418: safe if @i{c-to}=<@i{c-from}.""
419: while (u-- > 0)
420: *c_to++ = *c_from++;
421: :
422: bounds ?DO dup c@ I c! 1+ LOOP drop ;
423:
424: cmove> ( c_from c_to u -- ) string c_move_up
425: ""Copy the contents of @i{ucount} characters from data space at
426: @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
427: from high address to low address; i.e., for overlapping areas it is
428: safe if @i{c-to}>=@i{c-from}.""
429: while (u-- > 0)
430: c_to[u] = c_from[u];
431: :
432: dup 0= IF drop 2drop exit THEN
433: rot over + -rot bounds swap 1-
434: DO 1- dup c@ I c! -1 +LOOP drop ;
435:
436: fill ( c_addr u c -- ) core
437: ""Store @i{c} in @i{u} chars starting at @i{c-addr}.""
438: memset(c_addr,c,u);
439: :
440: -rot bounds
441: ?DO dup I c! LOOP drop ;
442:
443: compare ( c_addr1 u1 c_addr2 u2 -- n ) string
444: ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
445: the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}
446: is 1. Currently this is based on the machine's character
447: comparison. In the future, this may change to consider the current
448: locale and its collation order.""
449: /* close ' to keep fontify happy */
450: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
451: if (n==0)
452: n = u1-u2;
453: if (n<0)
454: n = -1;
455: else if (n>0)
456: n = 1;
457: :
458: rot 2dup swap - >r min swap -text dup
459: IF rdrop ELSE drop r> sgn THEN ;
460: : sgn ( n -- -1/0/1 )
461: dup 0= IF EXIT THEN 0< 2* 1+ ;
462:
463: -text ( c_addr1 u c_addr2 -- n ) new dash_text
464: n = memcmp(c_addr1, c_addr2, u);
465: if (n<0)
466: n = -1;
467: else if (n>0)
468: n = 1;
469: :
470: swap bounds
471: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
472: ELSE c@ I c@ - unloop THEN sgn ;
473: : sgn ( n -- -1/0/1 )
474: dup 0= IF EXIT THEN 0< 2* 1+ ;
475:
476: toupper ( c1 -- c2 ) gforth
477: ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
478: is the equivalent upper-case character. All other characters are unchanged.""
479: c2 = toupper(c1);
480: :
481: dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ;
482:
483: capscomp ( c_addr1 u c_addr2 -- n ) new
484: n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
485: if (n<0)
486: n = -1;
487: else if (n>0)
488: n = 1;
489: :
490: swap bounds
491: ?DO dup c@ I c@ <>
492: IF dup c@ toupper I c@ toupper =
493: ELSE true THEN WHILE 1+ LOOP drop 0
494: ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
495:
496: -trailing ( c_addr u1 -- c_addr u2 ) string dash_trailing
497: ""Adjust the string specified by @i{c-addr, u1} to remove all trailing
498: spaces. @i{u2} is the length of the modified string.""
499: u2 = u1;
500: while (u2>0 && c_addr[u2-1] == ' ')
501: u2--;
502: :
503: BEGIN 1- 2dup + c@ bl = WHILE
504: dup 0= UNTIL ELSE 1+ THEN ;
505:
506: /string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string
507: ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
508: characters from the start of the string.""
509: c_addr2 = c_addr1+n;
510: u2 = u1-n;
511: :
512: tuck - >r + r> dup 0< IF - 0 THEN ;
513:
514: + ( n1 n2 -- n ) core plus
515: n = n1+n2;
516:
517: \ PFE-0.9.14 has it differently, but the next release will have it as follows
518: under+ ( n1 n2 n3 -- n n2 ) gforth under_plus
519: ""add @i{n3} to @i{n1} (giving @i{n})""
520: n = n1+n3;
521: :
522: rot + swap ;
523:
524: - ( n1 n2 -- n ) core minus
525: n = n1-n2;
526: :
527: negate + ;
528:
529: negate ( n1 -- n2 ) core
530: /* use minus as alias */
531: n2 = -n1;
532: :
533: invert 1+ ;
534:
535: 1+ ( n1 -- n2 ) core one_plus
536: n2 = n1+1;
537: :
538: 1 + ;
539:
540: 1- ( n1 -- n2 ) core one_minus
541: n2 = n1-1;
542: :
543: 1 - ;
544:
545: max ( n1 n2 -- n ) core
546: if (n1<n2)
547: n = n2;
548: else
549: n = n1;
550: :
551: 2dup < IF swap THEN drop ;
552:
553: min ( n1 n2 -- n ) core
554: if (n1<n2)
555: n = n1;
556: else
557: n = n2;
558: :
559: 2dup > IF swap THEN drop ;
560:
561: abs ( n -- u ) core
562: if (n<0)
563: u = -n;
564: else
565: u = n;
566: :
567: dup 0< IF negate THEN ;
568:
569: * ( n1 n2 -- n ) core star
570: n = n1*n2;
571: :
572: um* drop ;
573:
574: / ( n1 n2 -- n ) core slash
575: n = n1/n2;
576: :
577: /mod nip ;
578:
579: mod ( n1 n2 -- n ) core
580: n = n1%n2;
581: :
582: /mod drop ;
583:
584: /mod ( n1 n2 -- n3 n4 ) core slash_mod
585: n4 = n1/n2;
586: n3 = n1%n2; /* !! is this correct? look into C standard! */
587: :
588: >r s>d r> fm/mod ;
589:
590: 2* ( n1 -- n2 ) core two_star
591: ""Shift left by 1; also works on unsigned numbers""
592: n2 = 2*n1;
593: :
594: dup + ;
595:
596: 2/ ( n1 -- n2 ) core two_slash
597: ""Arithmetic shift right by 1. For signed numbers this is a floored
598: division by 2 (note that @code{/} not necessarily floors).""
599: n2 = n1>>1;
600: :
601: dup MINI and IF 1 ELSE 0 THEN
602: [ bits/byte cell * 1- ] literal
603: 0 DO 2* swap dup 2* >r MINI and
604: IF 1 ELSE 0 THEN or r> swap
605: LOOP nip ;
606:
607: fm/mod ( d1 n1 -- n2 n3 ) core f_m_slash_mod
608: ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
609: #ifdef BUGGY_LONG_LONG
610: DCell r = fmdiv(d1,n1);
611: n2=r.hi;
612: n3=r.lo;
613: #else
614: /* assumes that the processor uses either floored or symmetric division */
615: n3 = d1/n1;
616: n2 = d1%n1;
617: /* note that this 1%-3>0 is optimized by the compiler */
618: if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
619: n3--;
620: n2+=n1;
621: }
622: #endif
623: :
624: dup >r dup 0< IF negate >r dnegate r> THEN
625: over 0< IF tuck + swap THEN
626: um/mod
627: r> 0< IF swap negate swap THEN ;
628:
629: sm/rem ( d1 n1 -- n2 n3 ) core s_m_slash_rem
630: ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
631: #ifdef BUGGY_LONG_LONG
632: DCell r = smdiv(d1,n1);
633: n2=r.hi;
634: n3=r.lo;
635: #else
636: /* assumes that the processor uses either floored or symmetric division */
637: n3 = d1/n1;
638: n2 = d1%n1;
639: /* note that this 1%-3<0 is optimized by the compiler */
640: if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
641: n3++;
642: n2-=n1;
643: }
644: #endif
645: :
646: over >r dup >r abs -rot
647: dabs rot um/mod
648: r> r@ xor 0< IF negate THEN
649: r> 0< IF swap negate swap THEN ;
650:
651: m* ( n1 n2 -- d ) core m_star
652: #ifdef BUGGY_LONG_LONG
653: d = mmul(n1,n2);
654: #else
655: d = (DCell)n1 * (DCell)n2;
656: #endif
657: :
658: 2dup 0< and >r
659: 2dup swap 0< and >r
660: um* r> - r> - ;
661:
662: um* ( u1 u2 -- ud ) core u_m_star
663: /* use u* as alias */
664: #ifdef BUGGY_LONG_LONG
665: ud = ummul(u1,u2);
666: #else
667: ud = (UDCell)u1 * (UDCell)u2;
668: #endif
669: :
670: >r >r 0 0 r> r> [ 8 cells ] literal 0
671: DO
672: over >r dup >r 0< and d2*+ drop
673: r> 2* r> swap
674: LOOP 2drop ;
675: : d2*+ ( ud n -- ud+n c )
676: over MINI
677: and >r >r 2dup d+ swap r> + swap r> ;
678:
679: um/mod ( ud u1 -- u2 u3 ) core u_m_slash_mod
680: ""ud=u3*u1+u2, u1>u2>=0""
681: #ifdef BUGGY_LONG_LONG
682: UDCell r = umdiv(ud,u1);
683: u2=r.hi;
684: u3=r.lo;
685: #else
686: u3 = ud/u1;
687: u2 = ud%u1;
688: #endif
689: :
690: 0 swap [ 8 cells 1 + ] literal 0
691: ?DO /modstep
692: LOOP drop swap 1 rshift or swap ;
693: : /modstep ( ud c R: u -- ud-?u c R: u )
694: >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ;
695: : d2*+ ( ud n -- ud+n c )
696: over MINI
697: and >r >r 2dup d+ swap r> + swap r> ;
698:
699: m+ ( d1 n -- d2 ) double m_plus
700: #ifdef BUGGY_LONG_LONG
701: d2.lo = d1.lo+n;
702: d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);
703: #else
704: d2 = d1+n;
705: #endif
706: :
707: s>d d+ ;
708:
709: d+ ( d1 d2 -- d ) double d_plus
710: #ifdef BUGGY_LONG_LONG
711: d.lo = d1.lo+d2.lo;
712: d.hi = d1.hi + d2.hi + (d.lo<d1.lo);
713: #else
714: d = d1+d2;
715: #endif
716: :
717: rot + >r tuck + swap over u> r> swap - ;
718:
719: d- ( d1 d2 -- d ) double d_minus
720: #ifdef BUGGY_LONG_LONG
721: d.lo = d1.lo - d2.lo;
722: d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);
723: #else
724: d = d1-d2;
725: #endif
726: :
727: dnegate d+ ;
728:
729: dnegate ( d1 -- d2 ) double d_negate
730: /* use dminus as alias */
731: #ifdef BUGGY_LONG_LONG
732: d2 = dnegate(d1);
733: #else
734: d2 = -d1;
735: #endif
736: :
737: invert swap negate tuck 0= - ;
738:
739: d2* ( d1 -- d2 ) double d_two_star
740: ""Shift left by 1; also works on unsigned numbers""
741: #ifdef BUGGY_LONG_LONG
742: d2.lo = d1.lo<<1;
743: d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
744: #else
745: d2 = 2*d1;
746: #endif
747: :
748: 2dup d+ ;
749:
750: d2/ ( d1 -- d2 ) double d_two_slash
751: ""Arithmetic shift right by 1. For signed numbers this is a floored
752: division by 2.""
753: #ifdef BUGGY_LONG_LONG
754: d2.hi = d1.hi>>1;
755: d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
756: #else
757: d2 = d1>>1;
758: #endif
759: :
760: dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
761: r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ;
762:
763: and ( w1 w2 -- w ) core
764: w = w1&w2;
765:
766: or ( w1 w2 -- w ) core
767: w = w1|w2;
768: :
769: invert swap invert and invert ;
770:
771: xor ( w1 w2 -- w ) core x_or
772: w = w1^w2;
773:
774: invert ( w1 -- w2 ) core
775: w2 = ~w1;
776: :
777: MAXU xor ;
778:
779: rshift ( u1 n -- u2 ) core r_shift
780: ""Logical shift right by @i{n} bits.""
781: u2 = u1>>n;
782: :
783: 0 ?DO 2/ MAXI and LOOP ;
784:
785: lshift ( u1 n -- u2 ) core l_shift
786: u2 = u1<<n;
787: :
788: 0 ?DO 2* LOOP ;
789:
790: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
791: define(comparisons,
792: $1= ( $2 -- f ) $6 $3equals
793: f = FLAG($4==$5);
794: :
795: [ char $1x char 0 = [IF]
796: ] IF false ELSE true THEN [
797: [ELSE]
798: ] xor 0= [
799: [THEN] ] ;
800:
801: $1<> ( $2 -- f ) $7 $3not_equals
802: f = FLAG($4!=$5);
803: :
804: [ char $1x char 0 = [IF]
805: ] IF true ELSE false THEN [
806: [ELSE]
807: ] xor 0<> [
808: [THEN] ] ;
809:
810: $1< ( $2 -- f ) $8 $3less_than
811: f = FLAG($4<$5);
812: :
813: [ char $1x char 0 = [IF]
814: ] MINI and 0<> [
815: [ELSE] char $1x char u = [IF]
816: ] 2dup xor 0< IF nip ELSE - THEN 0< [
817: [ELSE]
818: ] MINI xor >r MINI xor r> u< [
819: [THEN]
820: [THEN] ] ;
821:
822: $1> ( $2 -- f ) $9 $3greater_than
823: f = FLAG($4>$5);
824: :
825: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
826: $1< ;
827:
828: $1<= ( $2 -- f ) gforth $3less_or_equal
829: f = FLAG($4<=$5);
830: :
831: $1> 0= ;
832:
833: $1>= ( $2 -- f ) gforth $3greater_or_equal
834: f = FLAG($4>=$5);
835: :
836: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
837: $1<= ;
838:
839: )
840:
841: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
842: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
843: comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)
844:
845: \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
846: define(dcomparisons,
847: $1= ( $2 -- f ) $6 $3equals
848: #ifdef BUGGY_LONG_LONG
849: f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
850: #else
851: f = FLAG($4==$5);
852: #endif
853:
854: $1<> ( $2 -- f ) $7 $3not_equals
855: #ifdef BUGGY_LONG_LONG
856: f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
857: #else
858: f = FLAG($4!=$5);
859: #endif
860:
861: $1< ( $2 -- f ) $8 $3less_than
862: #ifdef BUGGY_LONG_LONG
863: f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
864: #else
865: f = FLAG($4<$5);
866: #endif
867:
868: $1> ( $2 -- f ) $9 $3greater_than
869: #ifdef BUGGY_LONG_LONG
870: f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
871: #else
872: f = FLAG($4>$5);
873: #endif
874:
875: $1<= ( $2 -- f ) gforth $3less_or_equal
876: #ifdef BUGGY_LONG_LONG
877: f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);
878: #else
879: f = FLAG($4<=$5);
880: #endif
881:
882: $1>= ( $2 -- f ) gforth $3greater_or_equal
883: #ifdef BUGGY_LONG_LONG
884: f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
885: #else
886: f = FLAG($4>=$5);
887: #endif
888:
889: )
890:
891: \+dcomps
892:
893: dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
894: dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
895: dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
896:
897: \+
898:
899: within ( u1 u2 u3 -- f ) core-ext
900: ""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2). This works for
901: unsigned and signed numbers (but not a mixture). Another way to think
902: about this word is to consider the numbers as a circle (wrapping
903: around from @code{max-u} to 0 for unsigned, and from @code{max-n} to
904: min-n for signed numbers); now consider the range from u2 towards
905: increasing numbers up to and excluding u3 (giving an empty range if
906: u2=u3); if u1 is in this range, @code{within} returns true.""
907: f = FLAG(u1-u2 < u3-u2);
908: :
909: over - >r - r> u< ;
910:
911: sp@ ( -- a_addr ) gforth sp_fetch
912: a_addr = sp+1;
913:
914: sp! ( a_addr -- ) gforth sp_store
915: sp = a_addr;
916: /* works with and without spTOS caching */
917:
918: rp@ ( -- a_addr ) gforth rp_fetch
919: a_addr = rp;
920:
921: rp! ( a_addr -- ) gforth rp_store
922: rp = a_addr;
923:
924: \+floating
925:
926: fp@ ( -- f_addr ) gforth fp_fetch
927: f_addr = fp;
928:
929: fp! ( f_addr -- ) gforth fp_store
930: fp = f_addr;
931:
932: \+
933:
934: ;s ( R:w -- ) gforth semis
935: ""The primitive compiled by @code{EXIT}.""
936: SET_IP((Xt *)w);
937:
938: >r ( w -- R:w ) core to_r
939: :
940: (>r) ;
941: : (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ;
942:
943: r> ( R:w -- w ) core r_from
944: :
945: rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
946: Create (rdrop) ' ;s A,
947:
948: rdrop ( R:w -- ) gforth
949: :
950: r> r> drop >r ;
951:
952: 2>r ( w1 w2 -- R:w1 R:w2 ) core-ext two_to_r
953: :
954: swap r> swap >r swap >r >r ;
955:
956: 2r> ( R:w1 R:w2 -- w1 w2 ) core-ext two_r_from
957: :
958: r> r> swap r> swap >r swap ;
959:
960: 2r@ ( R:w1 R:w2 -- R:w1 R:w2 w1 w2 ) core-ext two_r_fetch
961: :
962: i' j ;
963:
964: 2rdrop ( R:w1 R:w2 -- ) gforth two_r_drop
965: :
966: r> r> drop r> drop >r ;
967:
968: over ( w1 w2 -- w1 w2 w1 ) core
969: :
970: sp@ cell+ @ ;
971:
972: drop ( w -- ) core
973: :
974: IF THEN ;
975:
976: swap ( w1 w2 -- w2 w1 ) core
977: :
978: >r (swap) ! r> (swap) @ ;
979: Variable (swap)
980:
981: dup ( w -- w w ) core dupe
982: :
983: sp@ @ ;
984:
985: rot ( w1 w2 w3 -- w2 w3 w1 ) core rote
986: :
987: [ defined? (swap) [IF] ]
988: (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
989: Variable (rot)
990: [ELSE] ]
991: >r swap r> swap ;
992: [THEN]
993:
994: -rot ( w1 w2 w3 -- w3 w1 w2 ) gforth not_rote
995: :
996: rot rot ;
997:
998: nip ( w1 w2 -- w2 ) core-ext
999: :
1000: swap drop ;
1001:
1002: tuck ( w1 w2 -- w2 w1 w2 ) core-ext
1003: :
1004: swap over ;
1005:
1006: ?dup ( w -- w ) core question_dupe
1007: ""Actually the stack effect is: @code{( w -- 0 | w w )}. It performs a
1008: @code{dup} if w is nonzero.""
1009: if (w!=0) {
1010: IF_spTOS(*sp-- = w;)
1011: #ifndef USE_TOS
1012: *--sp = w;
1013: #endif
1014: }
1015: :
1016: dup IF dup THEN ;
1017:
1018: pick ( u -- w ) core-ext
1019: ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
1020: w = sp[u+1];
1021: :
1022: 1+ cells sp@ + @ ;
1023:
1024: 2drop ( w1 w2 -- ) core two_drop
1025: :
1026: drop drop ;
1027:
1028: 2dup ( w1 w2 -- w1 w2 w1 w2 ) core two_dupe
1029: :
1030: over over ;
1031:
1032: 2over ( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 ) core two_over
1033: :
1034: 3 pick 3 pick ;
1035:
1036: 2swap ( w1 w2 w3 w4 -- w3 w4 w1 w2 ) core two_swap
1037: :
1038: rot >r rot r> ;
1039:
1040: 2rot ( w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 ) double-ext two_rote
1041: :
1042: >r >r 2swap r> r> 2swap ;
1043:
1044: 2nip ( w1 w2 w3 w4 -- w3 w4 ) gforth two_nip
1045: :
1046: 2swap 2drop ;
1047:
1048: 2tuck ( w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 ) gforth two_tuck
1049: :
1050: 2swap 2over ;
1051:
1052: \ toggle is high-level: 0.11/0.42%
1053:
1054: @ ( a_addr -- w ) core fetch
1055: ""@i{w} is the cell stored at @i{a_addr}.""
1056: w = *a_addr;
1057:
1058: ! ( w a_addr -- ) core store
1059: ""Store @i{w} into the cell at @i{a-addr}.""
1060: *a_addr = w;
1061:
1062: +! ( n a_addr -- ) core plus_store
1063: ""Add @i{n} to the cell at @i{a-addr}.""
1064: *a_addr += n;
1065: :
1066: tuck @ + swap ! ;
1067:
1068: c@ ( c_addr -- c ) core c_fetch
1069: ""@i{c} is the char stored at @i{c_addr}.""
1070: c = *c_addr;
1071: :
1072: [ bigendian [IF] ]
1073: [ cell>bit 4 = [IF] ]
1074: dup [ 0 cell - ] Literal and @ swap 1 and
1075: IF $FF and ELSE 8>> THEN ;
1076: [ [ELSE] ]
1077: dup [ cell 1- ] literal and
1078: tuck - @ swap [ cell 1- ] literal xor
1079: 0 ?DO 8>> LOOP $FF and
1080: [ [THEN] ]
1081: [ [ELSE] ]
1082: [ cell>bit 4 = [IF] ]
1083: dup [ 0 cell - ] Literal and @ swap 1 and
1084: IF 8>> ELSE $FF and THEN
1085: [ [ELSE] ]
1086: dup [ cell 1- ] literal and
1087: tuck - @ swap
1088: 0 ?DO 8>> LOOP 255 and
1089: [ [THEN] ]
1090: [ [THEN] ]
1091: ;
1092: : 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ;
1093:
1094: c! ( c c_addr -- ) core c_store
1095: ""Store @i{c} into the char at @i{c-addr}.""
1096: *c_addr = c;
1097: :
1098: [ bigendian [IF] ]
1099: [ cell>bit 4 = [IF] ]
1100: tuck 1 and IF $FF and ELSE 8<< THEN >r
1101: dup -2 and @ over 1 and cells masks + @ and
1102: r> or swap -2 and ! ;
1103: Create masks $00FF , $FF00 ,
1104: [ELSE] ]
1105: dup [ cell 1- ] literal and dup
1106: [ cell 1- ] literal xor >r
1107: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
1108: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
1109: [THEN]
1110: [ELSE] ]
1111: [ cell>bit 4 = [IF] ]
1112: tuck 1 and IF 8<< ELSE $FF and THEN >r
1113: dup -2 and @ over 1 and cells masks + @ and
1114: r> or swap -2 and ! ;
1115: Create masks $FF00 , $00FF ,
1116: [ELSE] ]
1117: dup [ cell 1- ] literal and dup >r
1118: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
1119: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
1120: [THEN]
1121: [THEN]
1122: : 8<< 2* 2* 2* 2* 2* 2* 2* 2* ;
1123:
1124: 2! ( w1 w2 a_addr -- ) core two_store
1125: ""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell.""
1126: a_addr[0] = w2;
1127: a_addr[1] = w1;
1128: :
1129: tuck ! cell+ ! ;
1130:
1131: 2@ ( a_addr -- w1 w2 ) core two_fetch
1132: ""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is
1133: the content of the next cell.""
1134: w2 = a_addr[0];
1135: w1 = a_addr[1];
1136: :
1137: dup cell+ @ swap @ ;
1138:
1139: cell+ ( a_addr1 -- a_addr2 ) core cell_plus
1140: ""@code{1 cells +}""
1141: a_addr2 = a_addr1+1;
1142: :
1143: cell + ;
1144:
1145: cells ( n1 -- n2 ) core
1146: "" @i{n2} is the number of address units of @i{n1} cells.""
1147: n2 = n1 * sizeof(Cell);
1148: :
1149: [ cell
1150: 2/ dup [IF] ] 2* [ [THEN]
1151: 2/ dup [IF] ] 2* [ [THEN]
1152: 2/ dup [IF] ] 2* [ [THEN]
1153: 2/ dup [IF] ] 2* [ [THEN]
1154: drop ] ;
1155:
1156: char+ ( c_addr1 -- c_addr2 ) core char_plus
1157: ""@code{1 chars +}.""
1158: c_addr2 = c_addr1 + 1;
1159: :
1160: 1+ ;
1161:
1162: (chars) ( n1 -- n2 ) gforth paren_chars
1163: n2 = n1 * sizeof(Char);
1164: :
1165: ;
1166:
1167: count ( c_addr1 -- c_addr2 u ) core
1168: ""@i{c-addr2} is the first character and @i{u} the length of the
1169: counted string at @i{c-addr1}.""
1170: u = *c_addr1;
1171: c_addr2 = c_addr1+1;
1172: :
1173: dup 1+ swap c@ ;
1174:
1175: (f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find
1176: for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
1177: if ((UCell)F83NAME_COUNT(f83name1)==u &&
1178: memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1179: break;
1180: f83name2=f83name1;
1181: :
1182: BEGIN dup WHILE (find-samelen) dup WHILE
1183: >r 2dup r@ cell+ char+ capscomp 0=
1184: IF 2drop r> EXIT THEN
1185: r> @
1186: REPEAT THEN nip nip ;
1187: : (find-samelen) ( u f83name1 -- u f83name2/0 )
1188: BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
1189:
1190: \+hash
1191:
1192: (hashfind) ( c_addr u a_addr -- f83name2 ) new paren_hashfind
1193: struct F83Name *f83name1;
1194: f83name2=NULL;
1195: while(a_addr != NULL)
1196: {
1197: f83name1=(struct F83Name *)(a_addr[1]);
1198: a_addr=(Cell *)(a_addr[0]);
1199: if ((UCell)F83NAME_COUNT(f83name1)==u &&
1200: memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1201: {
1202: f83name2=f83name1;
1203: break;
1204: }
1205: }
1206: :
1207: BEGIN dup WHILE
1208: 2@ >r >r dup r@ cell+ c@ $1F and =
1209: IF 2dup r@ cell+ char+ capscomp 0=
1210: IF 2drop r> rdrop EXIT THEN THEN
1211: rdrop r>
1212: REPEAT nip nip ;
1213:
1214: (tablefind) ( c_addr u a_addr -- f83name2 ) new paren_tablefind
1215: ""A case-sensitive variant of @code{(hashfind)}""
1216: struct F83Name *f83name1;
1217: f83name2=NULL;
1218: while(a_addr != NULL)
1219: {
1220: f83name1=(struct F83Name *)(a_addr[1]);
1221: a_addr=(Cell *)(a_addr[0]);
1222: if ((UCell)F83NAME_COUNT(f83name1)==u &&
1223: memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1224: {
1225: f83name2=f83name1;
1226: break;
1227: }
1228: }
1229: :
1230: BEGIN dup WHILE
1231: 2@ >r >r dup r@ cell+ c@ $1F and =
1232: IF 2dup r@ cell+ char+ -text 0=
1233: IF 2drop r> rdrop EXIT THEN THEN
1234: rdrop r>
1235: REPEAT nip nip ;
1236:
1237: (hashkey) ( c_addr u1 -- u2 ) gforth paren_hashkey
1238: u2=0;
1239: while(u1--)
1240: u2+=(Cell)toupper(*c_addr++);
1241: :
1242: 0 -rot bounds ?DO I c@ toupper + LOOP ;
1243:
1244: (hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1
1245: ""ukey is the hash key for the string c_addr u fitting in ubits bits""
1246: /* this hash function rotates the key at every step by rot bits within
1247: ubits bits and xors it with the character. This function does ok in
1248: the chi-sqare-test. Rot should be <=7 (preferably <=5) for
1249: ASCII strings (larger if ubits is large), and should share no
1250: divisors with ubits.
1251: */
1252: 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];
1253: Char *cp = c_addr;
1254: for (ukey=0; cp<c_addr+u; cp++)
1255: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
1256: ^ toupper(*cp))
1257: & ((1<<ubits)-1));
1258: :
1259: dup rot-values + c@ over 1 swap lshift 1- >r
1260: tuck - 2swap r> 0 2swap bounds
1261: ?DO dup 4 pick lshift swap 3 pick rshift or
1262: I c@ toupper xor
1263: over and LOOP
1264: nip nip nip ;
1265: Create rot-values
1266: 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c,
1267: 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c,
1268: 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c,
1269: 7 c, 5 c, 5 c,
1270:
1271: \+
1272:
1273: (parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white
1274: /* use !isgraph instead of isspace? */
1275: Char *endp = c_addr1+u1;
1276: while (c_addr1<endp && isspace(*c_addr1))
1277: c_addr1++;
1278: if (c_addr1<endp) {
1279: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
1280: ;
1281: u2 = c_addr1-c_addr2;
1282: }
1283: else {
1284: c_addr2 = c_addr1;
1285: u2 = 0;
1286: }
1287: :
1288: BEGIN dup WHILE over c@ bl <= WHILE 1 /string
1289: REPEAT THEN 2dup
1290: BEGIN dup WHILE over c@ bl > WHILE 1 /string
1291: REPEAT THEN nip - ;
1292:
1293: aligned ( c_addr -- a_addr ) core
1294: "" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}.""
1295: a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
1296: :
1297: [ cell 1- ] Literal + [ -1 cells ] Literal and ;
1298:
1299: faligned ( c_addr -- f_addr ) float f_aligned
1300: "" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}.""
1301: f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
1302: :
1303: [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
1304:
1305: >body ( xt -- a_addr ) core to_body
1306: "" Get the address of the body of the word represented by @i{xt} (the address
1307: of the word's data field).""
1308: a_addr = PFA(xt);
1309: :
1310: 2 cells + ;
1311:
1312: \ threading stuff is currently only interesting if we have a compiler
1313: \fhas? standardthreading has? compiler and [IF]
1314:
1315: >code-address ( xt -- c_addr ) gforth to_code_address
1316: ""@i{c-addr} is the code address of the word @i{xt}.""
1317: /* !! This behaves installation-dependently for DOES-words */
1318: c_addr = (Address)CODE_ADDRESS(xt);
1319: :
1320: @ ;
1321:
1322: >does-code ( xt -- a_addr ) gforth to_does_code
1323: ""If @i{xt} is the execution token of a child of a @code{DOES>} word,
1324: @i{a-addr} is the start of the Forth code after the @code{DOES>};
1325: Otherwise @i{a-addr} is 0.""
1326: a_addr = (Cell *)DOES_CODE(xt);
1327: :
1328: cell+ @ ;
1329:
1330: code-address! ( c_addr xt -- ) gforth code_address_store
1331: ""Create a code field with code address @i{c-addr} at @i{xt}.""
1332: MAKE_CF(xt, c_addr);
1333: CACHE_FLUSH(xt,(size_t)PFA(0));
1334: :
1335: ! ;
1336:
1337: does-code! ( a_addr xt -- ) gforth does_code_store
1338: ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
1339: @i{a-addr} is the start of the Forth code after @code{DOES>}.""
1340: MAKE_DOES_CF(xt, a_addr);
1341: CACHE_FLUSH(xt,(size_t)PFA(0));
1342: :
1343: dodoes: over ! cell+ ! ;
1344:
1345: does-handler! ( a_addr -- ) gforth does_handler_store
1346: ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
1347: @i{a-addr} points just behind a @code{DOES>}.""
1348: MAKE_DOES_HANDLER(a_addr);
1349: CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
1350: :
1351: drop ;
1352:
1353: /does-handler ( -- n ) gforth slash_does_handler
1354: ""The size of a @code{DOES>}-handler (includes possible padding).""
1355: /* !! a constant or environmental query might be better */
1356: n = DOES_HANDLER_SIZE;
1357: :
1358: 2 cells ;
1359:
1360: threading-method ( -- n ) gforth threading_method
1361: ""0 if the engine is direct threaded. Note that this may change during
1362: the lifetime of an image.""
1363: #if defined(DOUBLY_INDIRECT)
1364: n=2;
1365: #else
1366: # if defined(DIRECT_THREADED)
1367: n=0;
1368: # else
1369: n=1;
1370: # endif
1371: #endif
1372: :
1373: 1 ;
1374:
1375: \f[THEN]
1376:
1377: key-file ( wfileid -- n ) gforth paren_key_file
1378: #ifdef HAS_FILE
1379: fflush(stdout);
1380: n = key((FILE*)wfileid);
1381: #else
1382: n = key(stdin);
1383: #endif
1384:
1385: key?-file ( wfileid -- n ) facility key_q_file
1386: #ifdef HAS_FILE
1387: fflush(stdout);
1388: n = key_query((FILE*)wfileid);
1389: #else
1390: n = key_query(stdin);
1391: #endif
1392:
1393: \+os
1394:
1395: stdin ( -- wfileid ) gforth
1396: wfileid = (Cell)stdin;
1397:
1398: stdout ( -- wfileid ) gforth
1399: wfileid = (Cell)stdout;
1400:
1401: stderr ( -- wfileid ) gforth
1402: wfileid = (Cell)stderr;
1403:
1404: form ( -- urows ucols ) gforth
1405: ""The number of lines and columns in the terminal. These numbers may change
1406: with the window size.""
1407: /* we could block SIGWINCH here to get a consistent size, but I don't
1408: think this is necessary or always beneficial */
1409: urows=rows;
1410: ucols=cols;
1411:
1412: flush-icache ( c_addr u -- ) gforth flush_icache
1413: ""Make sure that the instruction cache of the processor (if there is
1414: one) does not contain stale data at @i{c-addr} and @i{u} bytes
1415: afterwards. @code{END-CODE} performs a @code{flush-icache}
1416: automatically. Caveat: @code{flush-icache} might not work on your
1417: installation; this is usually the case if direct threading is not
1418: supported on your machine (take a look at your @file{machine.h}) and
1419: your machine has a separate instruction cache. In such cases,
1420: @code{flush-icache} does nothing instead of flushing the instruction
1421: cache.""
1422: FLUSH_ICACHE(c_addr,u);
1423:
1424: (bye) ( n -- ) gforth paren_bye
1425: return (Label *)n;
1426:
1427: (system) ( c_addr u -- wretval wior ) gforth peren_system
1428: #ifndef MSDOS
1429: int old_tp=terminal_prepped;
1430: deprep_terminal();
1431: #endif
1432: wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
1433: wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
1434: #ifndef MSDOS
1435: if (old_tp)
1436: prep_terminal();
1437: #endif
1438:
1439: getenv ( c_addr1 u1 -- c_addr2 u2 ) gforth
1440: ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
1441: is the host operating system's expansion of that environment variable. If the
1442: environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
1443: in length.""
1444: /* close ' to keep fontify happy */
1445: c_addr2 = getenv(cstr(c_addr1,u1,1));
1446: u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
1447:
1448: open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe
1449: wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */
1450: wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
1451:
1452: close-pipe ( wfileid -- wretval wior ) gforth close_pipe
1453: wretval = pclose((FILE *)wfileid);
1454: wior = IOR(wretval==-1);
1455:
1456: time&date ( -- nsec nmin nhour nday nmonth nyear ) facility-ext time_and_date
1457: ""Report the current time of day. Seconds, minutes and hours are numbered from 0.
1458: Months are numbered from 1.""
1459: struct timeval time1;
1460: struct timezone zone1;
1461: struct tm *ltime;
1462: gettimeofday(&time1,&zone1);
1463: /* !! Single Unix specification:
1464: If tzp is not a null pointer, the behaviour is unspecified. */
1465: ltime=localtime((time_t *)&time1.tv_sec);
1466: nyear =ltime->tm_year+1900;
1467: nmonth=ltime->tm_mon+1;
1468: nday =ltime->tm_mday;
1469: nhour =ltime->tm_hour;
1470: nmin =ltime->tm_min;
1471: nsec =ltime->tm_sec;
1472:
1473: ms ( n -- ) facility-ext
1474: ""Wait at least @i{n} milli-second.""
1475: struct timeval timeout;
1476: timeout.tv_sec=n/1000;
1477: timeout.tv_usec=1000*(n%1000);
1478: (void)select(0,0,0,0,&timeout);
1479:
1480: allocate ( u -- a_addr wior ) memory
1481: ""Allocate @i{u} address units of contiguous data space. The initial
1482: contents of the data space is undefined. If the allocation is successful,
1483: @i{a-addr} is the start address of the allocated region and @i{wior}
1484: is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
1485: is a non-zero I/O result code.""
1486: a_addr = (Cell *)malloc(u?u:1);
1487: wior = IOR(a_addr==NULL);
1488:
1489: free ( a_addr -- wior ) memory
1490: ""Return the region of data space starting at @i{a-addr} to the system.
1491: The region must originally have been obtained using @code{allocate} or
1492: @code{resize}. If the operational is successful, @i{wior} is 0.
1493: If the operation fails, @i{wior} is a non-zero I/O result code.""
1494: free(a_addr);
1495: wior = 0;
1496:
1497: resize ( a_addr1 u -- a_addr2 wior ) memory
1498: ""Change the size of the allocated area at @i{a-addr1} to @i{u}
1499: address units, possibly moving the contents to a different
1500: area. @i{a-addr2} is the address of the resulting area.
1501: If the operation is successful, @i{wior} is 0.
1502: If the operation fails, @i{wior} is a non-zero
1503: I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard)
1504: @code{resize} @code{allocate}s @i{u} address units.""
1505: /* the following check is not necessary on most OSs, but it is needed
1506: on SunOS 4.1.2. */
1507: /* close ' to keep fontify happy */
1508: if (a_addr1==NULL)
1509: a_addr2 = (Cell *)malloc(u);
1510: else
1511: a_addr2 = (Cell *)realloc(a_addr1, u);
1512: wior = IOR(a_addr2==NULL); /* !! Define a return code */
1513:
1514: strerror ( n -- c_addr u ) gforth
1515: c_addr = strerror(n);
1516: u = strlen(c_addr);
1517:
1518: strsignal ( n -- c_addr u ) gforth
1519: c_addr = strsignal(n);
1520: u = strlen(c_addr);
1521:
1522: call-c ( w -- ) gforth call_c
1523: ""Call the C function pointed to by @i{w}. The C function has to
1524: access the stack itself. The stack pointers are exported in the global
1525: variables @code{SP} and @code{FP}.""
1526: /* This is a first attempt at support for calls to C. This may change in
1527: the future */
1528: IF_fpTOS(fp[0]=fpTOS);
1529: FP=fp;
1530: SP=sp;
1531: ((void (*)())w)();
1532: sp=SP;
1533: fp=FP;
1534: IF_spTOS(spTOS=sp[0]);
1535: IF_fpTOS(fpTOS=fp[0]);
1536:
1537: \+
1538: \+file
1539:
1540: close-file ( wfileid -- wior ) file close_file
1541: wior = IOR(fclose((FILE *)wfileid)==EOF);
1542:
1543: open-file ( c_addr u wfam -- wfileid wior ) file open_file
1544: wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);
1545: wior = IOR(wfileid == 0);
1546:
1547: create-file ( c_addr u wfam -- wfileid wior ) file create_file
1548: Cell fd;
1549: fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);
1550: if (fd != -1) {
1551: wfileid = (Cell)fdopen(fd, fileattr[wfam]);
1552: wior = IOR(wfileid == 0);
1553: } else {
1554: wfileid = 0;
1555: wior = IOR(1);
1556: }
1557:
1558: delete-file ( c_addr u -- wior ) file delete_file
1559: wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
1560:
1561: rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file
1562: ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
1563: char *s1=tilde_cstr(c_addr2, u2, 1);
1564: wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
1565:
1566: file-position ( wfileid -- ud wior ) file file_position
1567: /* !! use tell and lseek? */
1568: ud = LONG2UD(ftell((FILE *)wfileid));
1569: wior = IOR(UD2LONG(ud)==-1);
1570:
1571: reposition-file ( ud wfileid -- wior ) file reposition_file
1572: wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
1573:
1574: file-size ( wfileid -- ud wior ) file file_size
1575: struct stat buf;
1576: wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
1577: ud = LONG2UD(buf.st_size);
1578:
1579: resize-file ( ud wfileid -- wior ) file resize_file
1580: wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1);
1581:
1582: read-file ( c_addr u1 wfileid -- u2 wior ) file read_file
1583: /* !! fread does not guarantee enough */
1584: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1585: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1586: /* !! is the value of ferror errno-compatible? */
1587: if (wior)
1588: clearerr((FILE *)wfileid);
1589:
1590: read-line ( c_addr u1 wfileid -- u2 flag wior ) file read_line
1591: ""this is only for backward compatibility""
1592: Cell c;
1593: flag=-1;
1594: for(u2=0; u2<u1; u2++)
1595: {
1596: c = getc((FILE *)wfileid);
1597: if (c=='\n') break;
1598: if (c=='\r') {
1599: if ((c = getc((FILE *)wfileid))!='\n')
1600: ungetc(c,(FILE *)wfileid);
1601: break;
1602: }
1603: if (c==EOF) {
1604: flag=FLAG(u2!=0);
1605: break;
1606: }
1607: c_addr[u2] = (Char)c;
1608: }
1609: wior=FILEIO(ferror((FILE *)wfileid));
1610:
1611: \+
1612:
1613: write-file ( c_addr u1 wfileid -- wior ) file write_file
1614: /* !! fwrite does not guarantee enough */
1615: #ifdef HAS_FILE
1616: {
1617: UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1618: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1619: if (wior)
1620: clearerr((FILE *)wfileid);
1621: }
1622: #else
1623: TYPE(c_addr, u1);
1624: #endif
1625:
1626: emit-file ( c wfileid -- wior ) gforth emit_file
1627: #ifdef HAS_FILE
1628: wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
1629: if (wior)
1630: clearerr((FILE *)wfileid);
1631: #else
1632: PUTC(c);
1633: #endif
1634:
1635: \+file
1636:
1637: flush-file ( wfileid -- wior ) file-ext flush_file
1638: wior = IOR(fflush((FILE *) wfileid)==EOF);
1639:
1640: file-status ( c_addr u -- wfam wior ) file-ext file_status
1641: char *filename=tilde_cstr(c_addr, u, 1);
1642: if (access (filename, F_OK) != 0) {
1643: wfam=0;
1644: wior=IOR(1);
1645: }
1646: else if (access (filename, R_OK | W_OK) == 0) {
1647: wfam=2; /* r/w */
1648: wior=0;
1649: }
1650: else if (access (filename, R_OK) == 0) {
1651: wfam=0; /* r/o */
1652: wior=0;
1653: }
1654: else if (access (filename, W_OK) == 0) {
1655: wfam=4; /* w/o */
1656: wior=0;
1657: }
1658: else {
1659: wfam=1; /* well, we cannot access the file, but better deliver a legal
1660: access mode (r/o bin), so we get a decent error later upon open. */
1661: wior=0;
1662: }
1663:
1664: \+
1665: \+floating
1666:
1667: comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
1668: comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
1669:
1670: d>f ( d -- r ) float d_to_f
1671: #ifdef BUGGY_LONG_LONG
1672: extern double ldexp(double x, int exp);
1673: r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
1674: #else
1675: r = d;
1676: #endif
1677:
1678: f>d ( r -- d ) float f_to_d
1679: #ifdef BUGGY_LONG_LONG
1680: d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
1681: d.lo = r-ldexp((Float)d.hi,CELL_BITS);
1682: #else
1683: d = r;
1684: #endif
1685:
1686: f! ( r f_addr -- ) float f_store
1687: ""Store @i{r} into the float at address @i{f-addr}.""
1688: *f_addr = r;
1689:
1690: f@ ( f_addr -- r ) float f_fetch
1691: ""@i{r} is the float at address @i{f-addr}.""
1692: r = *f_addr;
1693:
1694: df@ ( df_addr -- r ) float-ext d_f_fetch
1695: ""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
1696: #ifdef IEEE_FP
1697: r = *df_addr;
1698: #else
1699: !! df@
1700: #endif
1701:
1702: df! ( r df_addr -- ) float-ext d_f_store
1703: ""Store @i{r} as double-precision IEEE floating-point value to the
1704: address @i{df-addr}.""
1705: #ifdef IEEE_FP
1706: *df_addr = r;
1707: #else
1708: !! df!
1709: #endif
1710:
1711: sf@ ( sf_addr -- r ) float-ext s_f_fetch
1712: ""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
1713: #ifdef IEEE_FP
1714: r = *sf_addr;
1715: #else
1716: !! sf@
1717: #endif
1718:
1719: sf! ( r sf_addr -- ) float-ext s_f_store
1720: ""Store @i{r} as single-precision IEEE floating-point value to the
1721: address @i{sf-addr}.""
1722: #ifdef IEEE_FP
1723: *sf_addr = r;
1724: #else
1725: !! sf!
1726: #endif
1727:
1728: f+ ( r1 r2 -- r3 ) float f_plus
1729: r3 = r1+r2;
1730:
1731: f- ( r1 r2 -- r3 ) float f_minus
1732: r3 = r1-r2;
1733:
1734: f* ( r1 r2 -- r3 ) float f_star
1735: r3 = r1*r2;
1736:
1737: f/ ( r1 r2 -- r3 ) float f_slash
1738: r3 = r1/r2;
1739:
1740: f** ( r1 r2 -- r3 ) float-ext f_star_star
1741: ""@i{r3} is @i{r1} raised to the @i{r2}th power.""
1742: r3 = pow(r1,r2);
1743:
1744: fnegate ( r1 -- r2 ) float f_negate
1745: r2 = - r1;
1746:
1747: fdrop ( r -- ) float f_drop
1748:
1749: fdup ( r -- r r ) float f_dupe
1750:
1751: fswap ( r1 r2 -- r2 r1 ) float f_swap
1752:
1753: fover ( r1 r2 -- r1 r2 r1 ) float f_over
1754:
1755: frot ( r1 r2 r3 -- r2 r3 r1 ) float f_rote
1756:
1757: fnip ( r1 r2 -- r2 ) gforth f_nip
1758:
1759: ftuck ( r1 r2 -- r2 r1 r2 ) gforth f_tuck
1760:
1761: float+ ( f_addr1 -- f_addr2 ) float float_plus
1762: ""@code{1 floats +}.""
1763: f_addr2 = f_addr1+1;
1764:
1765: floats ( n1 -- n2 ) float
1766: ""@i{n2} is the number of address units of @i{n1} floats.""
1767: n2 = n1*sizeof(Float);
1768:
1769: floor ( r1 -- r2 ) float
1770: ""Round towards the next smaller integral value, i.e., round toward negative infinity.""
1771: /* !! unclear wording */
1772: r2 = floor(r1);
1773:
1774: fround ( r1 -- r2 ) float f_round
1775: ""Round to the nearest integral value.""
1776: /* !! unclear wording */
1777: #ifdef HAVE_RINT
1778: r2 = rint(r1);
1779: #else
1780: r2 = floor(r1+0.5);
1781: /* !! This is not quite true to the rounding rules given in the standard */
1782: #endif
1783:
1784: fmax ( r1 r2 -- r3 ) float f_max
1785: if (r1<r2)
1786: r3 = r2;
1787: else
1788: r3 = r1;
1789:
1790: fmin ( r1 r2 -- r3 ) float f_min
1791: if (r1<r2)
1792: r3 = r1;
1793: else
1794: r3 = r2;
1795:
1796: represent ( r c_addr u -- n f1 f2 ) float
1797: char *sig;
1798: int flag;
1799: int decpt;
1800: sig=ecvt(r, u, &decpt, &flag);
1801: n=(r==0 ? 1 : decpt);
1802: f1=FLAG(flag!=0);
1803: f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
1804: memmove(c_addr,sig,u);
1805:
1806: >float ( c_addr u -- flag ) float to_float
1807: ""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the
1808: character string @i{c-addr u} to internal floating-point
1809: representation. If the string represents a valid floating-point number
1810: @i{r} is placed on the floating-point stack and @i{flag} is
1811: true. Otherwise, @i{flag} is false. A string of blanks is a special
1812: case and represents the floating-point number 0.""
1813: /* real signature: c_addr u -- r t / f */
1814: Float r;
1815: char *number=cstr(c_addr, u, 1);
1816: char *endconv;
1817: int sign = 0;
1818: if(number[0]=='-') {
1819: sign = 1;
1820: number++;
1821: u--;
1822: }
1823: while(isspace((unsigned)(number[--u])) && u>0);
1824: switch(number[u])
1825: {
1826: case 'd':
1827: case 'D':
1828: case 'e':
1829: case 'E': break;
1830: default : u++; break;
1831: }
1832: number[u]='\0';
1833: r=strtod(number,&endconv);
1834: if((flag=FLAG(!(Cell)*endconv)))
1835: {
1836: IF_fpTOS(fp[0] = fpTOS);
1837: fp += -1;
1838: fpTOS = sign ? -r : r;
1839: }
1840: else if(*endconv=='d' || *endconv=='D')
1841: {
1842: *endconv='E';
1843: r=strtod(number,&endconv);
1844: if((flag=FLAG(!(Cell)*endconv)))
1845: {
1846: IF_fpTOS(fp[0] = fpTOS);
1847: fp += -1;
1848: fpTOS = sign ? -r : r;
1849: }
1850: }
1851:
1852: fabs ( r1 -- r2 ) float-ext f_abs
1853: r2 = fabs(r1);
1854:
1855: facos ( r1 -- r2 ) float-ext f_a_cos
1856: r2 = acos(r1);
1857:
1858: fasin ( r1 -- r2 ) float-ext f_a_sine
1859: r2 = asin(r1);
1860:
1861: fatan ( r1 -- r2 ) float-ext f_a_tan
1862: r2 = atan(r1);
1863:
1864: fatan2 ( r1 r2 -- r3 ) float-ext f_a_tan_two
1865: ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably
1866: intends this to be the inverse of @code{fsincos}. In gforth it is.""
1867: r3 = atan2(r1,r2);
1868:
1869: fcos ( r1 -- r2 ) float-ext f_cos
1870: r2 = cos(r1);
1871:
1872: fexp ( r1 -- r2 ) float-ext f_e_x_p
1873: r2 = exp(r1);
1874:
1875: fexpm1 ( r1 -- r2 ) float-ext f_e_x_p_m_one
1876: ""@i{r2}=@i{e}**@i{r1}@minus{}1""
1877: #ifdef HAVE_EXPM1
1878: extern double
1879: #ifdef NeXT
1880: const
1881: #endif
1882: expm1(double);
1883: r2 = expm1(r1);
1884: #else
1885: r2 = exp(r1)-1.;
1886: #endif
1887:
1888: fln ( r1 -- r2 ) float-ext f_l_n
1889: r2 = log(r1);
1890:
1891: flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one
1892: ""@i{r2}=ln(@i{r1}+1)""
1893: #ifdef HAVE_LOG1P
1894: extern double
1895: #ifdef NeXT
1896: const
1897: #endif
1898: log1p(double);
1899: r2 = log1p(r1);
1900: #else
1901: r2 = log(r1+1.);
1902: #endif
1903:
1904: flog ( r1 -- r2 ) float-ext f_log
1905: ""The decimal logarithm.""
1906: r2 = log10(r1);
1907:
1908: falog ( r1 -- r2 ) float-ext f_a_log
1909: ""@i{r2}=10**@i{r1}""
1910: extern double pow10(double);
1911: r2 = pow10(r1);
1912:
1913: fsin ( r1 -- r2 ) float-ext f_sine
1914: r2 = sin(r1);
1915:
1916: fsincos ( r1 -- r2 r3 ) float-ext f_sine_cos
1917: ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
1918: r2 = sin(r1);
1919: r3 = cos(r1);
1920:
1921: fsqrt ( r1 -- r2 ) float-ext f_square_root
1922: r2 = sqrt(r1);
1923:
1924: ftan ( r1 -- r2 ) float-ext f_tan
1925: r2 = tan(r1);
1926: :
1927: fsincos f/ ;
1928:
1929: fsinh ( r1 -- r2 ) float-ext f_cinch
1930: r2 = sinh(r1);
1931: :
1932: fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
1933:
1934: fcosh ( r1 -- r2 ) float-ext f_cosh
1935: r2 = cosh(r1);
1936: :
1937: fexp fdup 1/f f+ f2/ ;
1938:
1939: ftanh ( r1 -- r2 ) float-ext f_tan_h
1940: r2 = tanh(r1);
1941: :
1942: f2* fexpm1 fdup 2. d>f f+ f/ ;
1943:
1944: fasinh ( r1 -- r2 ) float-ext f_a_cinch
1945: r2 = asinh(r1);
1946: :
1947: fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
1948:
1949: facosh ( r1 -- r2 ) float-ext f_a_cosh
1950: r2 = acosh(r1);
1951: :
1952: fdup fdup f* 1. d>f f- fsqrt f+ fln ;
1953:
1954: fatanh ( r1 -- r2 ) float-ext f_a_tan_h
1955: r2 = atanh(r1);
1956: :
1957: fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/
1958: r> IF fnegate THEN ;
1959:
1960: sfloats ( n1 -- n2 ) float-ext s_floats
1961: ""@i{n2} is the number of address units of @i{n1}
1962: single-precision IEEE floating-point numbers.""
1963: n2 = n1*sizeof(SFloat);
1964:
1965: dfloats ( n1 -- n2 ) float-ext d_floats
1966: ""@i{n2} is the number of address units of @i{n1}
1967: double-precision IEEE floating-point numbers.""
1968: n2 = n1*sizeof(DFloat);
1969:
1970: sfaligned ( c_addr -- sf_addr ) float-ext s_f_aligned
1971: ""@i{sf-addr} is the first single-float-aligned address greater
1972: than or equal to @i{c-addr}.""
1973: sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
1974: :
1975: [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
1976:
1977: dfaligned ( c_addr -- df_addr ) float-ext d_f_aligned
1978: ""@i{df-addr} is the first double-float-aligned address greater
1979: than or equal to @i{c-addr}.""
1980: df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
1981: :
1982: [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
1983:
1984: \ The following words access machine/OS/installation-dependent
1985: \ Gforth internals
1986: \ !! how about environmental queries DIRECT-THREADED,
1987: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
1988:
1989: \ local variable implementation primitives
1990: \+
1991: \+glocals
1992:
1993: @local# ( #noffset -- w ) gforth fetch_local_number
1994: w = *(Cell *)(lp+noffset);
1995:
1996: @local0 ( -- w ) new fetch_local_zero
1997: w = *(Cell *)(lp+0*sizeof(Cell));
1998:
1999: @local1 ( -- w ) new fetch_local_four
2000: w = *(Cell *)(lp+1*sizeof(Cell));
2001:
2002: @local2 ( -- w ) new fetch_local_eight
2003: w = *(Cell *)(lp+2*sizeof(Cell));
2004:
2005: @local3 ( -- w ) new fetch_local_twelve
2006: w = *(Cell *)(lp+3*sizeof(Cell));
2007:
2008: \+floating
2009:
2010: f@local# ( #noffset -- r ) gforth f_fetch_local_number
2011: r = *(Float *)(lp+noffset);
2012:
2013: f@local0 ( -- r ) new f_fetch_local_zero
2014: r = *(Float *)(lp+0*sizeof(Float));
2015:
2016: f@local1 ( -- r ) new f_fetch_local_eight
2017: r = *(Float *)(lp+1*sizeof(Float));
2018:
2019: \+
2020:
2021: laddr# ( #noffset -- c_addr ) gforth laddr_number
2022: /* this can also be used to implement lp@ */
2023: c_addr = (Char *)(lp+noffset);
2024:
2025: lp+!# ( #noffset -- ) gforth lp_plus_store_number
2026: ""used with negative immediate values it allocates memory on the
2027: local stack, a positive immediate argument drops memory from the local
2028: stack""
2029: lp += noffset;
2030:
2031: lp- ( -- ) new minus_four_lp_plus_store
2032: lp += -sizeof(Cell);
2033:
2034: lp+ ( -- ) new eight_lp_plus_store
2035: lp += sizeof(Float);
2036:
2037: lp+2 ( -- ) new sixteen_lp_plus_store
2038: lp += 2*sizeof(Float);
2039:
2040: lp! ( c_addr -- ) gforth lp_store
2041: lp = (Address)c_addr;
2042:
2043: >l ( w -- ) gforth to_l
2044: lp -= sizeof(Cell);
2045: *(Cell *)lp = w;
2046:
2047: \+floating
2048:
2049: f>l ( r -- ) gforth f_to_l
2050: lp -= sizeof(Float);
2051: *(Float *)lp = r;
2052:
2053: fpick ( u -- r ) gforth
2054: ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""
2055: r = fp[u+1]; /* +1, because update of fp happens before this fragment */
2056: :
2057: floats fp@ + f@ ;
2058:
2059: \+
2060: \+
2061:
2062: \+OS
2063:
2064: define(`uploop',
2065: `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
2066: define(`_uploop',
2067: `ifelse($1, `$3', `$5',
2068: `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')
2069: \ argflist(argnum): Forth argument list
2070: define(argflist,
2071: `ifelse($1, 0, `',
2072: `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')')
2073: \ argdlist(argnum): declare C's arguments
2074: define(argdlist,
2075: `ifelse($1, 0, `',
2076: `uploop(`_i', 1, $1, `Cell, ', `Cell')')')
2077: \ argclist(argnum): pass C's arguments
2078: define(argclist,
2079: `ifelse($1, 0, `',
2080: `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')
2081: \ icall(argnum)
2082: define(icall,
2083: `icall$1 ( argflist($1)u -- uret ) gforth
2084: uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
2085:
2086: ')
2087: define(fcall,
2088: `fcall$1 ( argflist($1)u -- rret ) gforth
2089: rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
2090:
2091: ')
2092:
2093: \ close ' to keep fontify happy
2094:
2095: open-lib ( c_addr1 u1 -- u2 ) gforth open_lib
2096: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
2097: #ifndef RTLD_GLOBAL
2098: #define RTLD_GLOBAL 0
2099: #endif
2100: u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
2101: #else
2102: # ifdef _WIN32
2103: u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
2104: # else
2105: #warning Define open-lib!
2106: u2 = 0;
2107: # endif
2108: #endif
2109:
2110: lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym
2111: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
2112: u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
2113: #else
2114: # ifdef _WIN32
2115: u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
2116: # else
2117: #warning Define lib-sym!
2118: u3 = 0;
2119: # endif
2120: #endif
2121:
2122: uploop(i, 0, 7, `icall(i)')
2123: icall(20)
2124: uploop(i, 0, 7, `fcall(i)')
2125: fcall(20)
2126:
2127: \+
2128:
2129: up! ( a_addr -- ) gforth up_store
2130: UP=up=(char *)a_addr;
2131: :
2132: up ! ;
2133: Variable UP
2134:
2135: wcall ( u -- ) gforth
2136: IF_fpTOS(fp[0]=fpTOS);
2137: FP=fp;
2138: sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
2139: fp=FP;
2140: IF_spTOS(spTOS=sp[0];)
2141: IF_fpTOS(fpTOS=fp[0]);
2142:
2143: \+file
2144:
2145: open-dir ( c_addr u -- wdirid wior ) gforth open_dir
2146: wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
2147: wior = IOR(wdirid == 0);
2148:
2149: read-dir ( c_addr u1 wdirid -- u2 flag wior ) gforth read_dir
2150: struct dirent * dent;
2151: dent = readdir((DIR *)wdirid);
2152: wior = 0;
2153: flag = -1;
2154: if(dent == NULL) {
2155: u2 = 0;
2156: flag = 0;
2157: } else {
2158: u2 = strlen(dent->d_name);
2159: if(u2 > u1) {
2160: u2 = u1;
2161: wior = -512-ENAMETOOLONG;
2162: }
2163: memmove(c_addr, dent->d_name, u2);
2164: }
2165:
2166: close-dir ( wdirid -- wior ) gforth close_dir
2167: wior = IOR(closedir((DIR *)wdirid));
2168:
2169: filename-match ( c_addr1 u1 c_addr2 u2 -- flag ) gforth match_file
2170: char * string = cstr(c_addr1, u1, 1);
2171: char * pattern = cstr(c_addr2, u2, 0);
2172: flag = FLAG(!fnmatch(pattern, string, 0));
2173:
2174: \+
2175:
2176: newline ( -- c_addr u ) gforth
2177: ""String containing the newline sequence of the host OS""
2178: char newline[] = {
2179: #if defined(unix) || defined(__MACH__)
2180: /* Darwin/MacOS X sets __MACH__, but not unix. */
2181: '\n'
2182: #else
2183: '\r','\n'
2184: #endif
2185: };
2186: c_addr=newline;
2187: u=sizeof(newline);
2188: :
2189: "newline count ;
2190: Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
2191:
2192: \+os
2193:
2194: utime ( -- dtime ) gforth
2195: ""Report the current time in microseconds since some epoch.""
2196: struct timeval time1;
2197: gettimeofday(&time1,NULL);
2198: dtime = timeval2us(&time1);
2199:
2200: cputime ( -- duser dsystem ) gforth
2201: ""duser and dsystem are the respective user- and system-level CPU
2202: times used since the start of the Forth system (excluding child
2203: processes), in microseconds (the granularity may be much larger,
2204: however). On platforms without the getrusage call, it reports elapsed
2205: time (since some epoch) for duser and 0 for dsystem.""
2206: #ifdef HAVE_GETRUSAGE
2207: struct rusage usage;
2208: getrusage(RUSAGE_SELF, &usage);
2209: duser = timeval2us(&usage.ru_utime);
2210: dsystem = timeval2us(&usage.ru_stime);
2211: #else
2212: struct timeval time1;
2213: gettimeofday(&time1,NULL);
2214: duser = timeval2us(&time1);
2215: #ifndef BUGGY_LONG_LONG
2216: dsystem = (DCell)0;
2217: #else
2218: dsystem=(DCell){0,0};
2219: #endif
2220: #endif
2221:
2222: \+
2223:
2224: \+floating
2225:
2226: v* ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
2227: ""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the
2228: next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
2229: ucount elements.""
2230: for (r=0.; ucount>0; ucount--) {
2231: r += *f_addr1 * *f_addr2;
2232: f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
2233: f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
2234: }
2235: :
2236: >r swap 2swap swap 0e r> 0 ?DO
2237: dup f@ over + 2swap dup f@ f* f+ over + 2swap
2238: LOOP 2drop 2drop ;
2239:
2240: faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth
2241: ""vy=ra*vx+vy""
2242: for (; ucount>0; ucount--) {
2243: *f_y += ra * *f_x;
2244: f_x = (Float *)(((Address)f_x)+nstridex);
2245: f_y = (Float *)(((Address)f_y)+nstridey);
2246: }
2247: :
2248: >r swap 2swap swap r> 0 ?DO
2249: fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
2250: LOOP 2drop 2drop fdrop ;
2251:
2252: \+
2253:
2254: \+file
2255:
2256: (read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line
2257: Cell c;
2258: flag=-1;
2259: u3=0;
2260: for(u2=0; u2<u1; u2++)
2261: {
2262: c = getc((FILE *)wfileid);
2263: u3++;
2264: if (c=='\n') break;
2265: if (c=='\r') {
2266: if ((c = getc((FILE *)wfileid))!='\n')
2267: ungetc(c,(FILE *)wfileid);
2268: else
2269: u3++;
2270: break;
2271: }
2272: if (c==EOF) {
2273: flag=FLAG(u2!=0);
2274: break;
2275: }
2276: c_addr[u2] = (Char)c;
2277: }
2278: wior=FILEIO(ferror((FILE *)wfileid));
2279:
2280: \+
2281:
2282: (listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind
2283: for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
2284: if ((UCell)LONGNAME_COUNT(longname1)==u &&
2285: memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
2286: break;
2287: longname2=longname1;
2288: :
2289: BEGIN dup WHILE (findl-samelen) dup WHILE
2290: >r 2dup r@ cell+ cell+ capscomp 0=
2291: IF 2drop r> EXIT THEN
2292: r> @
2293: REPEAT THEN nip nip ;
2294: : (findl-samelen) ( u longname1 -- u longname2/0 )
2295: BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ;
2296:
2297: \+hash
2298:
2299: (hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind
2300: struct Longname *longname1;
2301: longname2=NULL;
2302: while(a_addr != NULL)
2303: {
2304: longname1=(struct Longname *)(a_addr[1]);
2305: a_addr=(Cell *)(a_addr[0]);
2306: if ((UCell)LONGNAME_COUNT(longname1)==u &&
2307: memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
2308: {
2309: longname2=longname1;
2310: break;
2311: }
2312: }
2313: :
2314: BEGIN dup WHILE
2315: 2@ >r >r dup r@ cell+ @ lcount-mask and =
2316: IF 2dup r@ cell+ cell+ capscomp 0=
2317: IF 2drop r> rdrop EXIT THEN THEN
2318: rdrop r>
2319: REPEAT nip nip ;
2320:
2321: (tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind
2322: ""A case-sensitive variant of @code{(hashfind)}""
2323: struct Longname *longname1;
2324: longname2=NULL;
2325: while(a_addr != NULL)
2326: {
2327: longname1=(struct Longname *)(a_addr[1]);
2328: a_addr=(Cell *)(a_addr[0]);
2329: if ((UCell)LONGNAME_COUNT(longname1)==u &&
2330: memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)
2331: {
2332: longname2=longname1;
2333: break;
2334: }
2335: }
2336: :
2337: BEGIN dup WHILE
2338: 2@ >r >r dup r@ cell+ @ lcount-mask and =
2339: IF 2dup r@ cell+ cell+ -text 0=
2340: IF 2drop r> rdrop EXIT THEN THEN
2341: rdrop r>
2342: REPEAT nip nip ;
2343:
2344: \+
2345:
2346: primtable ( -- wprimtable ) new
2347: ""wprimtable is a table containing the xts of the primitives indexed
2348: by sequence-number in prim (for use in prepare-peephole-table).""
2349: wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1);
2350:
2351: prepare-peephole-table ( wprimtable -- wpeeptable ) new prepare_peephole_opt
2352: ""wpeeptable is a data structure used by @code{peephole-opt}; it is
2353: constructed by combining a primitives table with a simple peephole
2354: optimization table.""
2355: wpeeptable = prepare_peephole_table((Xt *)wprimtable);
2356:
2357: peephole-opt ( xt1 xt2 wpeeptable -- xt ) new peephole_opt
2358: ""xt is the combination of xt1 and xt2 (according to wpeeptable); if
2359: they cannot be combined, xt is 0.""
2360: xt = peephole_opt(xt1, xt2, wpeeptable);
2361:
2362: lit_plus = lit +
2363:
2364: call ( #a_callee -- R:a_retaddr )
2365: ""Call callee (a variant of docol with inline argument).""
2366: a_retaddr = (Cell *)IP;
2367: SET_IP((Xt *)a_callee);
2368:
2369: useraddr ( #u -- a_addr )
2370: a_addr = (Cell *)(up+u);
2371:
2372:
2373:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>