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