File:  [gforth] / gforth / Attic / primitives
Revision 1.7: download - view: text, annotated - select for diffs
Wed May 18 17:29:58 1994 UTC (29 years, 10 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Fixed problem with ?dup
Deleted noop output like sp+=0 from prims2x.fs
Made wordinfo.fs work with DTC on i386
Added a faster (???) relocater

    1: \ Copyright 1992 by the ANSI figForth Development Group
    2: \ 
    3: \ WARNING: This file is processed by m4. Make sure your identifiers
    4: \ don't collide with m4's (e.g. by undefining them).
    5: \ 
    6: \ This file contains instructions in the following format:
    7: \ 
    8: \ forth name	stack effect	category	[pronounciation]
    9: \ [""glossary entry""]
   10: \ C code
   11: \ [:
   12: \ Forth code]
   13: \ 
   14: \ The pronounciataion is also used for forming C names.
   15: \ 
   16: \ These informations are automagically translated into C-code for the
   17: \ interpreter and into some other files. The forth name of a word is
   18: \ automatically turned into upper case. I hope that your C compiler has
   19: \ decent optimization, otherwise the automatically generated code will
   20: \ be somewhat slow. The Forth version of the code is included for manual
   21: \ compilers, so they will need to compile only the important words.
   22: \ 
   23: \ Note that stack pointer adjustment is performed according to stack
   24: \ effect by automatically generated code and NEXT is automatically
   25: \ appended to the C code. Also, you can use the names in the stack
   26: \ effect in the C code. Stack access is automatic. One exception: if
   27: \ your code does not fall through, the results are not stored into the
   28: \ stack. Use different names on both sides of the '--', if you change a
   29: \ value (some stores to the stack are optimized away).
   30: \ 
   31: \ The stack variables have the following types:
   32: \ name matches	type
   33: \ f.*		Bool
   34: \ c.*		Char
   35: \ [nw].*		Cell
   36: \ u.*		UCell
   37: \ d.*		DCell
   38: \ ud.*		UDCell
   39: \ r.*		Float
   40: \ a_.*		Cell *
   41: \ c_.*		Char *
   42: \ f_.*		Float *
   43: \ df_.*		DFloat *
   44: \ sf_.*		SFloat *
   45: \ xt.*		XT
   46: \ wid.*		WID
   47: \ f83name.*	F83Name *
   48: \ 
   49: \ In addition the following names can be used:
   50: \ ip	the instruction pointer
   51: \ sp	the data stack pointer
   52: \ rp	the parameter stack pointer
   53: \ NEXT	executes NEXT
   54: \ cfa	
   55: \ NEXT1	executes NEXT1
   56: \ FLAG(x)	makes a Forth flag from a C flag
   57: \ 
   58: \ Percentages in comments are from Koopmans book: average/maximum use
   59: \ (taken from four, not very representattive benchmarks)
   60: \ 
   61: \ To do:
   62: \ make sensible error returns for file words
   63: \ 
   64: \ throw execute, cfa and NEXT1 out?
   65: \ macroize *ip, ip++, *ip++ (pipelining)?
   66: 
   67: \ these m4 macros would collide with identifiers
   68: undefine(`index')
   69: undefine(`shift')
   70: 
   71: noop	--		fig
   72: ;
   73: 
   74: lit	-- w		fig
   75: w = (Cell)*ip++;
   76: 
   77: execute		xt --		core,fig
   78: cfa = xt;
   79: IF_TOS(TOS = sp[0]);
   80: NEXT1;
   81: 
   82: branch	--		fig
   83: branch:
   84: ip = (Xt *)(((int)ip)+(int)*ip);
   85: 
   86: ?branch		f --		f83	question_branch
   87: ""also known as 0branch""
   88: if (f==0) {
   89:     IF_TOS(TOS = sp[0]);
   90:     goto branch;
   91:     }
   92: else
   93:     ip++;
   94: 
   95: (next)	--		cmFORTH	paren_next
   96: if ((*rp)--) {
   97:     goto branch;
   98: } else {
   99:     ip++;
  100: }
  101: 
  102: (loop)	--		fig	paren_loop
  103: int index = *rp+1;
  104: int limit = rp[1];
  105: if (index != limit) {
  106:     *rp = index;
  107:     goto branch;
  108: } else {
  109:     ip++;
  110: }
  111: 
  112: (+loop)		n --		fig	paren_plus_loop
  113: /* !! check this thoroughly */
  114: int index = *rp;
  115: int olddiff = index-rp[1];
  116: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
  117: /* dependent upon two's complement arithmetic */
  118: if ((olddiff^(olddiff+n))<0   /* the limit is crossed */
  119:     && (olddiff^n)<0          /* it is not a wrap-around effect */) {
  120:     /* break */
  121:     ip++;
  122: } else {
  123:     /* continue */
  124:     *rp = index+n;
  125:     IF_TOS(TOS = sp[0]);
  126:     goto branch;
  127: }
  128: 
  129: (s+loop)	n --		new	paren_symmetric_plus_loop
  130: ""The run-time procedure compiled by S+LOOP. It loops until the index
  131: crosses the boundary between limit and limit-sign(n). I.e. a symmetric
  132: version of (+LOOP).""
  133: /* !! check this thoroughly */
  134: int oldindex = *rp;
  135: int diff = oldindex-rp[1];
  136: int newdiff = diff+n;
  137: if (n<0) {
  138:     diff = -diff;
  139:     newdiff = - newdiff;
  140: }
  141: if (diff>=0 || newdiff<0) {
  142:     *rp = oldindex+n;
  143:     IF_TOS(TOS = sp[0]);
  144:     goto branch;
  145: } else {
  146:     ip++;
  147: }
  148: 
  149: unloop		--	core
  150: rp += 2;
  151: 
  152: (for)	ncount --		cmFORTH		paren_for
  153: /* or (for) = >r -- collides with unloop! */
  154: *--rp = 0;
  155: *--rp = ncount;
  156: 
  157: (do)	nlimit nstart --		fig		paren_do
  158: /* or do it in high-level? 0.09/0.23% */
  159: *--rp = nlimit;
  160: *--rp = nstart;
  161: :
  162:  swap >r >r ;
  163: 
  164: (?do)	nlimit nstart --	core-ext	paren_question_do
  165: *--rp = nlimit;
  166: *--rp = nstart;
  167: if (nstart == nlimit) {
  168:     IF_TOS(TOS = sp[0]);
  169:     goto branch;
  170:     }
  171: else {
  172:     ip++;
  173: }
  174: 
  175: i	-- n		core,fig
  176: n = *rp;
  177: 
  178: j	-- n		core
  179: n = rp[2];
  180: 
  181: \ digit is high-level: 0/0%
  182: 
  183: emit	c --		fig
  184: putchar(c);
  185: emitcounter++;
  186: 
  187: key	-- n		fig
  188: fflush(stdout);
  189: /* !! noecho */
  190: n = key();
  191: 
  192: key?	-- n		fig	key_q
  193: fflush(stdout);
  194: n = key_query;
  195: 
  196: cr	--		fig
  197: puts("");
  198: 
  199: move	c_from c_to ucount --		core
  200: memmove(c_to,c_from,ucount);
  201: /* make an Ifdef for bsd and others? */
  202: 
  203: cmove	c_from c_to u --	string
  204: while (u-- > 0)
  205:   *c_to++ = *c_from++;
  206: 
  207: cmove>	c_from c_to u --	string	c_move_up
  208: while (u-- > 0)
  209:   c_to[u] = c_from[u];
  210: 
  211: fill	c_addr u c --	core
  212: memset(c_addr,c,u);
  213: 
  214: compare		c_addr1 u1 c_addr2 u2 -- n	string
  215: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
  216: if (n==0)
  217:   n = u1-u2;
  218: if (n<0)
  219:   n = -1;
  220: else if (n>0)
  221:   n = 1;
  222: 
  223: -text		c_addr1 u c_addr2 -- n	new	dash_text
  224: n = memcmp(c_addr1, c_addr2, u);
  225: if (n<0)
  226:   n = -1;
  227: else if (n>0)
  228:   n = 1;
  229: 
  230: capscomp	c_addr1 u c_addr2 -- n	new
  231: Char c1, c2;
  232: for (;; u--, c_addr1++, c_addr2++) {
  233:   if (u == 0) {
  234:     n = 0;
  235:     break;
  236:   }
  237:   c1 = toupper(*c_addr1);
  238:   c2 = toupper(*c_addr2);
  239:   if (c1 != c2) {
  240:     if (c1 < c2)
  241:       n = -1;
  242:     else
  243:       n = 1;
  244:     break;
  245:   }
  246: }
  247: 
  248: -trailing	c_addr u1 -- c_addr u2		string	dash_trailing
  249: u2 = u1;
  250: while (c_addr[u2-1] == ' ')
  251:   u2--;
  252: 
  253: /string		c_addr1 u1 n -- c_addr2 u2	string	slash_string
  254: c_addr2 = c_addr1+n;
  255: u2 = u1-n;
  256: 
  257: +	n1 n2 -- n		core,fig	plus
  258: n = n1+n2;
  259: 
  260: -	n1 n2 -- n		core,fig	minus
  261: n = n1-n2;
  262: 
  263: negate	n1 -- n2		core,fig
  264: /* use minus as alias */
  265: n2 = -n1;
  266: 
  267: 1+	n1 -- n2		core		one_plus
  268: n2 = n1+1;
  269: 
  270: 1-	n1 -- n2		core		one_minus
  271: n2 = n1-1;
  272: 
  273: max	n1 n2 -- n	core
  274: if (n1<n2)
  275:   n = n2;
  276: else
  277:   n = n1;
  278: :
  279:  2dup < if
  280:   swap drop
  281:  else
  282:   drop
  283:  endif ;
  284: 
  285: min	n1 n2 -- n	core
  286: if (n1<n2)
  287:   n = n1;
  288: else
  289:   n = n2;
  290: 
  291: abs	n1 -- n2	core
  292: if (n1<0)
  293:   n2 = -n1;
  294: else
  295:   n2 = n1;
  296: 
  297: *	n1 n2 -- n		core,fig	star
  298: n = n1*n2;
  299: 
  300: /	n1 n2 -- n		core,fig	slash
  301: n = n1/n2;
  302: 
  303: mod	n1 n2 -- n		core
  304: n = n1%n2;
  305: 
  306: /mod	n1 n2 -- n3 n4		core		slash_mod
  307: n4 = n1/n2;
  308: n3 = n1%n2; /* !! is this correct? look into C standard! */
  309: 
  310: 2*	n1 -- n2		core		two_star
  311: n2 = 2*n1;
  312: 
  313: 2/	n1 -- n2		core		two_slash
  314: /* !! is this still correct? */
  315: n2 = n1>>1;
  316: 
  317: fm/mod	d1 n1 -- n2 n3		core		f_m_slash_mod
  318: ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
  319: /* assumes that the processor uses either floored or symmetric division */
  320: n3 = d1/n1;
  321: n2 = d1%n1;
  322: /* note that this 1%-3>0 is optimized by the compiler */
  323: if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
  324:   n3--;
  325:   n2+=n1;
  326: }
  327: 
  328: sm/rem	d1 n1 -- n2 n3		core		s_m_slash_rem
  329: ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""
  330: /* assumes that the processor uses either floored or symmetric division */
  331: n3 = d1/n1;
  332: n2 = d1%n1;
  333: /* note that this 1%-3<0 is optimized by the compiler */
  334: if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
  335:   n3++;
  336:   n2-=n1;
  337: }
  338: 
  339: m*	n1 n2 -- d		core	m_star
  340: d = (DCell)n1 * (DCell)n2;
  341: 
  342: um*	u1 u2 -- ud		core	u_m_star
  343: /* use u* as alias */
  344: ud = (UDCell)u1 * (UDCell)u2;
  345: 
  346: um/mod	ud u1 -- u2 u3		core	u_m_slash_mod
  347: u3 = ud/u1;
  348: u2 = ud%u1;
  349: 
  350: m+	d1 n -- d2		double		m_plus
  351: d2 = d1+n;
  352: 
  353: d+	d1 d2 -- d		double,fig	d_plus
  354: d = d1+d2;
  355: 
  356: d-	d1 d2 -- d		double		d_minus
  357: d = d1-d2;
  358: 
  359: dnegate	d1 -- d2		double
  360: /* use dminus as alias */
  361: d2 = -d1;
  362: 
  363: dmax	d1 d2 -- d	double
  364: if (d1<d2)
  365:   d = d2;
  366: else
  367:   d = d1;
  368: 
  369: dmin	d1 d2 -- d	double
  370: if (d1<d2)
  371:   d = d1;
  372: else
  373:   d = d2;
  374: 
  375: dabs	d1 -- d2	double
  376: if (d1<0)
  377:   d2 = -d1;
  378: else
  379:   d2 = d1;
  380: 
  381: d2*	d1 -- d2		double		d_two_star
  382: d2 = 2*d1;
  383: 
  384: d2/	d1 -- d2		double		d_two_slash
  385: /* !! is this still correct? */
  386: d2 = d1/2;
  387: 
  388: d>s	d -- n			double		d_to_s
  389: /* make this an alias for drop? */
  390: n = d;
  391: 
  392: and	w1 w2 -- w		core,fig
  393: w = w1&w2;
  394: 
  395: or	w1 w2 -- w		core,fig
  396: w = w1|w2;
  397: 
  398: xor	w1 w2 -- w		core,fig
  399: w = w1^w2;
  400: 
  401: invert	w1 -- w2		core
  402: w2 = ~w1;
  403: 
  404: rshift	u1 n -- u2		core
  405:   u2 = u1>>n;
  406: 
  407: lshift	u1 n -- u2		core
  408:   u2 = u1<<n;
  409: 
  410: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
  411: define(comparisons,
  412: $1=	$2 -- f		$6	$3equals
  413: f = FLAG($4==$5);
  414: 
  415: $1<>	$2 -- f		$7	$3different
  416: /* use != as alias ? */
  417: f = FLAG($4!=$5);
  418: 
  419: $1<	$2 -- f		$8	$3less
  420: f = FLAG($4<$5);
  421: 
  422: $1>	$2 -- f		$9	$3greater
  423: f = FLAG($4>$5);
  424: 
  425: $1<=	$2 -- f		new	$3less_or_equal
  426: f = FLAG($4<=$5);
  427: 
  428: $1>=	$2 -- f		new	$3greater_or_equal
  429: f = FLAG($4>=$5);
  430: 
  431: )
  432: 
  433: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
  434: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
  435: comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext)
  436: comparisons(d, d1 d2, d_, d1, d2, double, new, double, new)
  437: comparisons(d0, d, d_zero_, d, 0, double, new, double, new)
  438: comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new)
  439: 
  440: within	u1 u2 u3 -- f		core-ext
  441: f = FLAG(u1-u2 < u3-u2);
  442: 
  443: sp@	-- a_addr		fig		spat
  444: a_addr = sp;
  445: 
  446: sp!	a_addr --		fig		spstore
  447: sp = a_addr+1;
  448: /* works with and without TOS caching */
  449: 
  450: rp@	-- a_addr		fig		rpat
  451: a_addr = rp;
  452: 
  453: rp!	a_addr --		fig		rpstore
  454: rp = a_addr;
  455: 
  456: fp@	-- f_addr	new	fp_fetch
  457: f_addr = fp;
  458: 
  459: fp!	f_addr --	new	fp_store
  460: fp = f_addr;
  461: 
  462: ;s	--		core	exit
  463: /* use ;s as alias */
  464: ip = (Xt *)(*rp++);
  465: 
  466: ?exit	w --		core		question_exit
  467: /* use ;s as alias */
  468: if(w)
  469: 	ip = (Xt *)(*rp++);
  470: 
  471: >r	w --		core,fig	to_r
  472: *--rp = w;
  473: 
  474: r>	-- w		core,fig	r_from
  475: w = *rp++;
  476: 
  477: r@	-- w		core,fig	r_fetch
  478: /* use r as alias */
  479: /* make r@ an alias for i */
  480: w = *rp;
  481: 
  482: rdrop	--		fig
  483: rp++;
  484: 
  485: i'	-- w		fig		i_tick
  486: w=rp[1];
  487: 
  488: over	w1 w2 -- w1 w2 w1		core,fig
  489: 
  490: drop	w --		core,fig
  491: 
  492: swap	w1 w2 -- w2 w1		core,fig
  493: 
  494: dup	w -- w w		core,fig
  495: 
  496: rot	w1 w2 w3 -- w2 w3 w1	core	rote
  497: 
  498: -rot	w1 w2 w3 -- w3 w1 w2	fig	not_rote
  499: 
  500: nip	w1 w2 -- w2		core-ext
  501: 
  502: tuck	w1 w2 -- w2 w1 w2	core-ext
  503: 
  504: ?dup	w -- w			core	question_dupe
  505: if (w!=0) {
  506:   IF_TOS(*sp-- = w;)
  507: #ifndef USE_TOS
  508:   *--sp = w;
  509: #endif
  510: }
  511: 
  512: pick	u -- w			core-ext
  513: w = sp[u+1];
  514: 
  515: 2drop	w1 w2 --		core	two_drop
  516: 
  517: 2dup	w1 w2 -- w1 w2 w1 w2	core	two_dupe
  518: 
  519: 2over	w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2	core	two_over
  520: 
  521: 2swap	w1 w2 w3 w4 -- w3 w4 w1 w2	core	two_swap
  522: 
  523: 2rot	w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2	double	two_rote
  524: 
  525: \ toggle is high-level: 0.11/0.42%
  526: 
  527: @	a_addr -- w		fig	fetch
  528: w = *a_addr;
  529: 
  530: !	w a_addr --		core,fig	store
  531: *a_addr = w;
  532: 
  533: +!	n a_addr --		core,fig	plus_store
  534: *a_addr += n;
  535: 
  536: c@	c_addr -- c		fig	cfetch
  537: c = *c_addr;
  538: 
  539: c!	c c_addr --		fig	cstore
  540: *c_addr = c;
  541: 
  542: 2!	w1 w2 a_addr --		core	two_store
  543: a_addr[0] = w2;
  544: a_addr[1] = w1;
  545: 
  546: 2@	a_addr -- w1 w2		core	two_fetch
  547: w2 = a_addr[0];
  548: w1 = a_addr[1];
  549: 
  550: d!	d a_addr --		double	d_store
  551: /* !! alignment problems on some machines */
  552: *(DCell *)a_addr = d;
  553: 
  554: d@	a_addr -- d		double	d_fetch
  555: d = *(DCell *)a_addr;
  556: 
  557: cell+	a_addr1 -- a_addr2	core	cell_plus
  558: a_addr2 = a_addr1+1;
  559: 
  560: cells	n1 -- n2		core
  561: n2 = n1 * sizeof(Cell);
  562: 
  563: char+	c_addr1 -- c_addr2	core	care_plus
  564: c_addr2 = c_addr1+1;
  565: 
  566: chars	n1 -- n2		core	cares
  567: n2 = n1 * sizeof(Char);
  568: 
  569: count	c_addr1 -- c_addr2 u	core
  570: u = *c_addr1;
  571: c_addr2 = c_addr1+1;
  572: 
  573: (bye)	n --	toolkit-ext	paren_bye
  574: deprep_terminal();
  575: exit(n);
  576: 
  577: system	c_addr u -- n	own
  578: char pname[u+1];
  579: cstr(pname,c_addr,u);
  580: n=system(pname);
  581: 
  582: popen	c_addr u n -- wfileid	own
  583: char pname[u+1];
  584: static char* mode[2]={"r","w"};
  585: cstr(pname,c_addr,u);
  586: wfileid=(Cell)popen(pname,mode[n]);
  587: 
  588: pclose	wfileid -- wior	own
  589: wior=pclose((FILE *)wfileid);
  590: 
  591: time&date	-- nyear nmonth nday nhour nmin nsec	ansi	time_and_date
  592: struct timeval time1;
  593: struct timezone zone1;
  594: struct tm *ltime;
  595: gettimeofday(&time1,&zone1);
  596: ltime=localtime(&time1.tv_sec);
  597: nyear =ltime->tm_year+1900;
  598: nmonth=ltime->tm_mon;
  599: nday  =ltime->tm_mday;
  600: nhour =ltime->tm_hour;
  601: nmin  =ltime->tm_min;
  602: nsec  =ltime->tm_sec;
  603: 
  604: ms	n --	ansi
  605: struct timeval timeout;
  606: timeout.tv_sec=n/1000;
  607: timeout.tv_usec=1000*(n%1000);
  608: (void)select(0,0,0,0,&timeout);
  609: 
  610: allocate	u -- a_addr wior	memory
  611: a_addr = (Cell *)malloc(u);
  612: wior = a_addr==NULL;	/* !! Define a return code */
  613: 
  614: free		a_addr -- wior		memory
  615: free(a_addr);
  616: wior = 0;
  617: 
  618: resize		a_addr1 u -- a_addr2 wior	memory
  619: a_addr2 = realloc(a_addr1, u);
  620: wior = a_addr2==NULL;	/* !! Define a return code */
  621: 
  622: (f83find)	c_addr u f83name1 -- f83name2	new	paren_f83find
  623: for (; f83name1 != NULL; f83name1 = f83name1->next)
  624:   if (F83NAME_COUNT(f83name1)==u && !F83NAME_SMUDGE(f83name1) &&
  625:       strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
  626:     break;
  627: f83name2=f83name1;
  628: 
  629: (parse-white)	c_addr1 u1 -- c_addr2 u2	new	paren_parse_white
  630: /* use !isgraph instead of isspace? */
  631: Char *endp = c_addr1+u1;
  632: while (c_addr1<endp && isspace(*c_addr1))
  633:   c_addr1++;
  634: if (c_addr1<endp) {
  635:   for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
  636:     ;
  637:   u2 = c_addr1-c_addr2;
  638: }
  639: else {
  640:   c_addr2 = c_addr1;
  641:   u2 = 0;
  642: }
  643: 
  644: close-file	wfileid -- wior	file	close_file
  645: wior = FILEIO(fclose((FILE *)wfileid)==EOF);
  646: 
  647: open-file	c_addr u ntype -- w2 wior	file	open_file
  648: char fname[u+1];
  649: cstr(fname, c_addr, u);
  650: w2 = (Cell)fopen(fname, fileattr[ntype]);
  651: wior =  FILEEXIST(w2 == NULL);
  652: 
  653: create-file	c_addr u ntype -- w2 wior	file	create_file
  654: int	fd;
  655: char fname[u+1];
  656: cstr(fname, c_addr, u);
  657: fd = creat(fname, 0666);
  658: if (fd > -1) {
  659:   w2 = (Cell)fdopen(fd, fileattr[ntype]);
  660:   assert(w2 != NULL);
  661:   wior = 0;
  662: } else {
  663:   assert(fd == -1);
  664:   wior = FILEIO(fd);
  665:   w2 = 0;
  666: }
  667: 
  668: delete-file	c_addr u -- wior		file	delete_file
  669: char fname[u+1];
  670: cstr(fname, c_addr, u);
  671: wior = FILEEXIST(unlink(fname));
  672: 
  673: rename-file	c_addr1 u1 c_addr2 u2 -- wior	file-ext	rename_file
  674: char fname1[u1+1];
  675: char fname2[u2+1];
  676: cstr(fname1, c_addr1, u1);
  677: cstr(fname2, c_addr2, u2);
  678: wior = FILEEXIST(rename(fname1, fname2));
  679: 
  680: file-position	wfileid -- ud wior	file	file_position
  681: /* !! use tell and lseek? */
  682: ud = ftell((FILE *)wfileid);
  683: wior = 0; /* !! or wior = FLAG(ud<0) */
  684: 
  685: reposition-file	ud wfileid -- wior	file	reposition_file
  686: wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET));
  687: 
  688: file-size	wfileid -- ud wior	file	file_size
  689: struct stat buf;
  690: wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));
  691: ud = buf.st_size;
  692: 
  693: resize-file	ud wfileid -- wior	file	resize_file
  694: wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud));
  695: 
  696: read-file	c_addr u1 wfileid -- u2 wior	file	read_file
  697: /* !! fread does not guarantee enough */
  698: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
  699: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
  700: /* !! who performs clearerr((FILE *)wfileid); ? */
  701: 
  702: read-line	c_addr u1 wfileid -- u2 flag wior	file	read_line
  703: wior=(Cell)fgets(c_addr,u1+1,(FILE *)wfileid);
  704: flag=FLAG(!feof((FILE *)wfileid) && wior);
  705: wior=FILEIO(ferror((FILE *)wfileid)) & flag;
  706: u2=(flag & strlen(c_addr));
  707: u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
  708: 
  709: write-file	c_addr u1 wfileid -- wior	file	write_file
  710: /* !! fwrite does not guarantee enough */
  711: {
  712:   int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
  713:   wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
  714: }
  715: 
  716: flush-file	wfileid -- wior		file-ext	flush_file
  717: wior = FILEIO(fflush((FILE *) wfileid));
  718: 
  719: comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
  720: comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
  721: 
  722: d>f		d -- r		float	d_to_f
  723: r = d;
  724: 
  725: f>d		r -- d		float	f_to_d
  726: /* !! basis 15 is not very specific */
  727: d = r;
  728: 
  729: f!		r f_addr --	float	f_store
  730: *f_addr = r;
  731: 
  732: f@		f_addr -- r	float	f_fetch
  733: r = *f_addr;
  734: 
  735: df@		df_addr -- r	float-ext	d_f_fetch
  736: #ifdef IEEE_FP
  737: r = *df_addr;
  738: #else
  739: !! df@
  740: #endif
  741: 
  742: df!		r df_addr --	float-ext	d_f_store
  743: #ifdef IEEE_FP
  744: *df_addr = r;
  745: #else
  746: !! df!
  747: #endif
  748: 
  749: sf@		sf_addr -- r	float-ext	s_f_fetch
  750: #ifdef IEEE_FP
  751: r = *sf_addr;
  752: #else
  753: !! sf@
  754: #endif
  755: 
  756: sf!		r sf_addr --	float-ext	s_f_store
  757: #ifdef IEEE_FP
  758: *sf_addr = r;
  759: #else
  760: !! sf!
  761: #endif
  762: 
  763: f+		r1 r2 -- r3	float	f_plus
  764: r3 = r1+r2;
  765: 
  766: f-		r1 r2 -- r3	float	f_minus
  767: r3 = r1-r2;
  768: 
  769: f*		r1 r2 -- r3	float	f_star
  770: r3 = r1*r2;
  771: 
  772: f/		r1 r2 -- r3	float	f_slash
  773: r3 = r1/r2;
  774: 
  775: f**		r1 r2 -- r3	float-ext	f_star_star
  776: r3 = pow(r1,r2);
  777: 
  778: fnegate		r1 -- r2	float
  779: r2 = - r1;
  780: 
  781: fdrop		r --		float
  782: 
  783: fdup		r -- r r	float
  784: 
  785: fswap		r1 r2 -- r2 r1	float
  786: 
  787: fover		r1 r2 -- r1 r2 r1	float
  788: 
  789: frot		r1 r2 r3 -- r2 r3 r1	float
  790: 
  791: float+		f_addr1 -- f_addr2	float	float_plus
  792: f_addr2 = f_addr1+1;
  793: 
  794: floats		n1 -- n2	float
  795: n2 = n1*sizeof(Float);
  796: 
  797: floor		r1 -- r2	float
  798: /* !! unclear wording */
  799: r2 = floor(r1);
  800: 
  801: fround		r1 -- r2	float
  802: /* !! unclear wording */
  803: r2 = rint(r1);
  804: 
  805: fmax		r1 r2 -- r3	float
  806: if (r1<r2)
  807:   r3 = r2;
  808: else
  809:   r3 = r1;
  810: 
  811: fmin		r1 r2 -- r3	float
  812: if (r1<r2)
  813:   r3 = r1;
  814: else
  815:   r3 = r2;
  816: 
  817: represent		r c_addr u -- n f1 f2	float
  818: char *sig;
  819: int flag;
  820: sig=ecvt(r, u, &n, &flag);
  821: f1=FLAG(flag!=0);
  822: f2=FLAG(isdigit(sig[0])!=0);
  823: memmove(c_addr,sig,u);
  824: 
  825: >float	c_addr u -- flag	float	to_float
  826: /* real signature: c_addr u -- r t / f */
  827: Float r;
  828: char number[u+1];
  829: char *endconv;
  830: cstr(number, c_addr, u);
  831: r=strtod(number,&endconv);
  832: if(flag=FLAG(!(int)*endconv))
  833: {
  834: 	IF_FTOS(fp[0] = FTOS);
  835: 	fp += -1;
  836: 	FTOS = r;
  837: }
  838: else if(*endconv=='d' || *endconv=='D')
  839: {
  840: 	*endconv='E';
  841: 	r=strtod(number,&endconv);
  842: 	if(flag=FLAG(!(int)*endconv))
  843: 	{
  844: 		IF_FTOS(fp[0] = FTOS);
  845: 		fp += -1;
  846: 		FTOS = r;
  847: 	}
  848: }
  849: 
  850: fabs		r1 -- r2	float-ext
  851: r2 = fabs(r1);
  852: 
  853: facos		r1 -- r2	float-ext
  854: r2 = acos(r1);
  855: 
  856: fasin		r1 -- r2	float-ext
  857: r2 = asin(r1);
  858: 
  859: fatan		r1 -- r2	float-ext
  860: r2 = atan(r1);
  861: 
  862: fatan2		r1 r2 -- r3	float-ext
  863: r3 = atan2(r1,r2);
  864: 
  865: fcos		r1 -- r2	float-ext
  866: r2 = cos(r1);
  867: 
  868: fexp		r1 -- r2	float-ext
  869: r2 = exp(r1);
  870: 
  871: fexpm1		r1 -- r2	float-ext
  872: r2 =
  873: #ifdef expm1
  874: 	expm1(r1);
  875: #else
  876: 	exp(r1)-1;
  877: #endif
  878: 
  879: fln		r1 -- r2	float-ext
  880: r2 = log(r1);
  881: 
  882: flnp1		r1 -- r2	float-ext
  883: r2 =
  884: #ifdef log1p
  885: 	log1p(r1);
  886: #else
  887: 	log(r1+1);
  888: #endif
  889: 
  890: flog		r1 -- r2	float-ext
  891: r2 = log10(r1);
  892: 
  893: fsin		r1 -- r2	float-ext
  894: r2 = sin(r1);
  895: 
  896: fsincos		r1 -- r2 r3	float-ext
  897: r2 = sin(r1);
  898: r3 = cos(r1);
  899: 
  900: fsqrt		r1 -- r2	float-ext
  901: r2 = sqrt(r1);
  902: 
  903: ftan		r1 -- r2	float-ext
  904: r2 = tan(r1);
  905: 
  906: \ The following words access machine/OS/installation-dependent ANSI
  907: \   figForth internals
  908: \ !! how about environmental queries DIRECT-THREADED,
  909: \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
  910: 
  911: >body		xt -- a_addr	core	to_body
  912: a_addr = PFA(xt);
  913: 
  914: >code-address		xt -- c_addr		new	to_code_address
  915: ""c_addr is the code address of the word xt""
  916: /* !! This behaves installation-dependently for DOES-words */
  917: c_addr = CODE_ADDRESS(xt);
  918: 
  919: >does-code	xt -- a_addr		new	to_does_code
  920: ""If xt ist the execution token of a defining-word-defined word,
  921: a_addr is the start of the Forth code after the DOES>; Otherwise the
  922: behaviour is uundefined""
  923: /* !! there is currently no way to determine whether a word is
  924: defining-word-defined */
  925: a_addr = DOES_CODE(xt);
  926: 
  927: code-address!		n xt --	new	code_address_store
  928: ""Creates a code field with code address c_addr at xt""
  929: MAKE_CF(xt, symbols[CF(n)]);
  930: CACHE_FLUSH(xt,PFA(0));
  931: 
  932: does-code!	a_addr xt --		new	does_code_store
  933: ""creates a code field at xt for a defining-word-defined word; a_addr
  934: is the start of the Forth code after DOES>""
  935: MAKE_DOES_CF(xt, a_addr);
  936: CACHE_FLUSH(xt,PFA(0));
  937: 
  938: does-handler!	a_addr --	new	does_jump_store
  939: ""creates a DOES>-handler at address a_addr. a_addr usually points
  940: just behind a DOES>.""
  941: MAKE_DOES_HANDLER(a_addr);
  942: CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
  943: 
  944: /does-handler	-- n	new	slash_does_handler
  945: ""the size of a does-handler (includes possible padding)""
  946: /* !! a constant or environmental query might be better */
  947: n = DOES_HANDLER_SIZE;
  948: 
  949: toupper	c1 -- c2	new
  950: c2 = toupper(c1);
  951: 
  952: \ local variable implementation primitives
  953: @local#		-- w	new	fetch_local_number
  954: w = *(Cell *)(lp+(int)(*ip++));
  955: 
  956: f@local#	-- r	new	f_fetch_local_number
  957: r = *(Float *)(lp+(int)(*ip++));
  958: 
  959: laddr#		-- c_addr	new	laddr_number
  960: /* this can also be used to implement lp@ */
  961: c_addr = (Char *)(lp+(int)(*ip++));
  962: 
  963: lp+!#	--	new	lp_plus_store_number
  964: ""used with negative immediate values it allocates memory on the
  965: local stack, a positive immediate argument drops memory from the local
  966: stack""
  967: lp += (int)(*ip++);
  968: 
  969: lp!	c_addr --	new	lp_store
  970: lp = (Address)c_addr;
  971: 
  972: >l	w --	new	to_l
  973: lp -= sizeof(Cell);
  974: *(Cell *)lp = w;
  975: 
  976: f>l	r --	new	f_to_l
  977: lp -= sizeof(Float);
  978: *(Float *)lp = r;
  979: 
  980: up!	a_addr --	new	up_store
  981: up=a_addr;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>