### Diff for /gforth/prim between versions 1.266 and 1.278

version 1.266, 2012/03/10 20:33:31 version 1.278, 2012/09/18 15:21:08
Line 1109  if (u1<u2) Line 1109  if (u1<u2)
else  else
u = u1;    u = u1;
:  :
2dup u< IF swap THEN drop ;   2dup u> select ;

umin    ( u1 u2 -- u )  core  umin    ( u1 u2 -- u )  core
if (u1<u2)  if (u1<u2)
Line 1117  if (u1<u2) Line 1117  if (u1<u2)
else  else
u = u2;    u = u2;
:  :
2dup u> IF swap THEN drop ;   2dup u< select ;

mux   ( u1 u2 u3 -- u )    gforth
""multiplex @i{u1} for 1 bits in @i{u3}, @i{u2} for 0 bits in @i{u3} into @i{u}""
u = (u3 & u1) | (~u3 & u2);
:
tuck and >r invert and r> ;

select ( u1 u2 f -- u )    gforth
""select @i{u1} if @i{f} is true, @i{u2} if false.""
u = f ? u1 : u2;
:
IF swap THEN nip ;

\g compare  \g compare

:  :
dup 1+ swap c@ ;   dup 1+ swap c@ ;

cell/ ( n1 -- n2 )      gforth cell_divide
""@i{n2} is the number of cells that fit into @i{n1}""
n2 = n1 / sizeof(Cell);
:
[ cell
2/ dup [IF] ] 2/ [ [THEN]
2/ dup [IF] ] 2/ [ [THEN]
2/ dup [IF] ] 2/ [ [THEN]
2/ dup [IF] ] 2/ [ [THEN]
drop ] ;

\g compiler  \g compiler

Line 1700  wfileid = (Cell)stderr; Line 1723  wfileid = (Cell)stderr;

\+os  \+os

form    ( -- urows ucols )      gforth  (form)  ( -- urows ucols )      gforth  paren_form
""The number of lines and columns in the terminal. These numbers may  ""The number of lines and columns in the terminal. These numbers may
change with the window size.  Note that it depends on the OS whether  change with the window size.  Note that it depends on the OS whether
this reflects the actual size and changes with the window size  this reflects the actual size and changes with the window size

(bye)   ( n -- )        gforth  paren_bye  (bye)   ( n -- )        gforth  paren_bye
SUPER_END;  SUPER_END;
gforth_FP=fp;
gforth_SP=sp;
gforth_RP=rp;
gforth_LP=lp;
return (Label *)n;  return (Label *)n;

(system)        ( c_addr u -- wretval wior )    gforth  paren_system  (system)        ( c_addr u -- wretval wior )    gforth  paren_system
Line 1747  is the host operating system's expansion Line 1774  is the host operating system's expansion
environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters  environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
in length.""  in length.""
/* close ' to keep fontify happy */  /* close ' to keep fontify happy */
free(string);

open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe  open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe
fflush(stdout);  fflush(stdout);
wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */  wfileid=(Cell)popen(string,pfileattr[wfam]); /* ~ expansion of 1st arg? */
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
free(string);

close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
wretval = pclose((FILE *)wfileid);  wretval = pclose((FILE *)wfileid);
Line 1845  gforth_LP=lp; Line 1876  gforth_LP=lp;
((void (*)())w)();  ((void (*)())w)();
#else  #else
((void (*)(void *))w)(gforth_pointers);  ((void (*)(void *))w)(&gforth_pointers);
#endif  #endif
sp=gforth_SP;  sp=gforth_SP;
fp=gforth_FP;  fp=gforth_FP;
Line 1860  close-file ( wfileid -- wior )  file clo Line 1891  close-file ( wfileid -- wior )  file clo
wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);

open-file       ( c_addr u wfam -- wfileid wior )       file    open_file  open-file       ( c_addr u wfam -- wfileid wior )       file    open_file
wfileid = opencreate_file(string, wfam, 0, &wior);
free(string);

create-file     ( c_addr u wfam -- wfileid wior )       file    create_file  create-file     ( c_addr u wfam -- wfileid wior )       file    create_file
wfileid = opencreate_file(string, wfam, O_CREAT|O_TRUNC, &wior);
free(string);

delete-file     ( c_addr u -- wior )            file    delete_file  delete-file     ( c_addr u -- wior )            file    delete_file
free(string);

Line 1945  flag = FLAG(feof((FILE *) wfileid)); Line 1982  flag = FLAG(feof((FILE *) wfileid));
open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
""Open the directory specified by @i{c-addr, u}  ""Open the directory specified by @i{c-addr, u}
wdirid = (Cell)opendir(string);
wior =  IOR(wdirid == 0);  wior =  IOR(wdirid == 0);
free(string);

""Attempt to read the next entry from the directory specified  ""Attempt to read the next entry from the directory specified
Line 1981  close-dir ( wdirid -- wior ) gforth clos Line 2020  close-dir ( wdirid -- wior ) gforth clos
wior = IOR(closedir((DIR *)wdirid));  wior = IOR(closedir((DIR *)wdirid));

char * string = cstr(c_addr1, u1, 1);  char * string = cstr(c_addr1, u1);
char * pattern = cstr(c_addr2, u2, 0);  char * pattern = cstr(c_addr2, u2);
flag = FLAG(!fnmatch(pattern, string, 0));  flag = FLAG(!fnmatch(pattern, string, 0));
free(string);
free(pattern);

set-dir ( c_addr u -- wior )    gforth set_dir  set-dir ( c_addr u -- wior )    gforth set_dir
""Change the current directory to @i{c-addr, u}.  ""Change the current directory to @i{c-addr, u}.
Return an error if this is not possible""  Return an error if this is not possible""
wior = IOR(chdir(string));
free(string);

""Store the current directory in the buffer specified by @i{c-addr1, u1}.  ""Store the current directory in the buffer specified by @i{c-addr1, u1}.
Line 2002  if(c_addr2 != NULL) { Line 2045  if(c_addr2 != NULL) {

=mkdir ( c_addr u wmode -- wior )        gforth equals_mkdir  =mkdir ( c_addr u wmode -- wior )        gforth equals_mkdir
""Create directory @i{c-addr u} with mode @i{wmode}.""  ""Create directory @i{c-addr u} with mode @i{wmode}.""
wior = IOR(mkdir(string,wmode));
free(string);

\+  \+

newline ( -- c_addr u ) gforth  newline ( -- c_addr u ) gforth
""String containing the newline sequence of the host OS""  ""String containing the newline sequence of the host OS""
char newline[] = {  static const char newline[] = {
#if DIRSEP=='/'  #if DIRSEP=='/'
/* Unix */  /* Unix */
'\n'  '\n'
Line 2244  representation. If the string represents Line 2289  representation. If the string represents
true. Otherwise, @i{flag} is false. A string of blanks is a special  true. Otherwise, @i{flag} is false. A string of blanks is a special
case and represents the floating-point number 0.""  case and represents the floating-point number 0.""
Float r;  Float r;
if (flag) {  if (flag) {
fp--;    fp--;
fp[0]=r;    fp[0]=r;
Line 2307  CLOBBER_TOS_WORKAROUND_END; Line 2352  CLOBBER_TOS_WORKAROUND_END;

flnp1   ( r1 -- r2 )    float-ext       f_l_n_p_one  flnp1   ( r1 -- r2 )    float-ext       f_l_n_p_one
""@i{r2}=ln(@i{r1}+1)""  ""@i{r2}=ln(@i{r1}+1)""
CLOBBER_TOS_WORKAROUND_START;
#ifdef HAVE_LOG1P  #ifdef HAVE_LOG1P
extern double  extern double
#ifdef NeXT  #ifdef NeXT
Line 2317  r2 = log1p(r1); Line 2363  r2 = log1p(r1);
#else  #else
r2 = log(r1+1.);  r2 = log(r1+1.);
#endif  #endif
CLOBBER_TOS_WORKAROUND_END;

flog    ( r1 -- r2 )    float-ext       f_log  flog    ( r1 -- r2 )    float-ext       f_log
""The decimal logarithm.""  ""The decimal logarithm.""
Line 2339  CLOBBER_TOS_WORKAROUND_END; Line 2386  CLOBBER_TOS_WORKAROUND_END;
fsincos ( r1 -- r2 r3 ) float-ext       f_sine_cos  fsincos ( r1 -- r2 r3 ) float-ext       f_sine_cos
""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""  ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
CLOBBER_TOS_WORKAROUND_START;  CLOBBER_TOS_WORKAROUND_START;
r2 = sin(r1);  sincos(r1, &r2, &r3);
r3 = cos(r1);
CLOBBER_TOS_WORKAROUND_END;  CLOBBER_TOS_WORKAROUND_END;

fsqrt   ( r1 -- r2 )    float-ext       f_square_root  fsqrt   ( r1 -- r2 )    float-ext       f_square_root
Line 2438  faxpy(ra, f_x, nstridex, f_y, nstridey, Line 2484  faxpy(ra, f_x, nstridex, f_y, nstridey,
fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap       fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
LOOP 2drop 2drop fdrop ;   LOOP 2drop 2drop fdrop ;

>float1 ( c_addr u c -- f:... flag )    gforth  to_float1
""Actual stack effect: ( c_addr u c -- r t | f ).  Attempt to convert the
character string @i{c-addr u} to internal floating-point
representation. If the string represents a valid floating-point number
@i{r} is placed on the floating-point stack and @i{flag} is
true. Otherwise, @i{flag} is false. A string of blanks is a special
case and represents the floating-point number 0.""
Float r;
flag = to_float(c_addr, u, &r, c);
if (flag) {
fp--;
fp[0]=r;
}

float/ ( n1 -- n2 )     gforth  float_divide
n2 = n1 / sizeof(Float);

dfloat/ ( n1 -- n2 )    gforth  sfloat_divide
n2 = n1 / sizeof(DFloat);

sfloat/ ( n1 -- n2 )    gforth  dfloat_divide
n2 = n1 / sizeof(SFloat);

\+  \+

\ The following words access machine/OS/installation-dependent  \ The following words access machine/OS/installation-dependent
Line 2528  open-lib ( c_addr1 u1 -- u2 ) gforth ope Line 2597  open-lib ( c_addr1 u1 -- u2 ) gforth ope

lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym  lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym
char * string = cstr(c_addr1, u1);
#ifdef HAVE_LIBLTDL  #ifdef HAVE_LIBLTDL
u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1));  u3 = (UCell) lt_dlsym((lt_dlhandle)u2, string);
#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  u3 = (UCell) dlsym((void*)u2,string);
#else  #else
#  ifdef _WIN32  #  ifdef _WIN32
#  else  #  else
#warning Define lib-sym!  #warning Define lib-sym!
u3 = 0;  u3 = 0;
#  endif  #  endif
#endif  #endif
free(string);

wcall   ( ... u -- ... )        gforth  wcall   ( ... u -- ... )        gforth
gforth_FP=fp;  gforth_FP=fp;
Line 2758  ip=IP; Line 2829  ip=IP;
SUPER_END;  SUPER_END;

\+objects
\g object_pointer

>o ( c_addr -- r:c_old )        new     to_o
c_old = op;

o> ( r:c_addr -- )              new     o_restore