version 1.41, 1999/12/03 18:24:22
|
version 1.46, 2000/05/31 14:37:40
|
Line 488 the first string is smaller, @i{n} is -1
|
Line 488 the first string is smaller, @i{n} is -1
|
is 1. Currently this is based on the machine's character |
is 1. Currently this is based on the machine's character |
comparison. In the future, this may change to consider the current |
comparison. In the future, this may change to consider the current |
locale and its collation order."" |
locale and its collation order."" |
|
/* close ' to keep fontify happy */ |
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
if (n==0) |
if (n==0) |
n = u1-u2; |
n = u1-u2; |
Line 496 if (n<0)
|
Line 497 if (n<0)
|
else if (n>0) |
else if (n>0) |
n = 1; |
n = 1; |
: |
: |
rot 2dup - >r min swap -text dup |
rot 2dup swap - >r min swap -text dup |
IF rdrop |
IF rdrop ELSE drop r> sgn THEN ; |
ELSE drop r@ 0> |
: sgn ( n -- -1/0/1 ) |
IF rdrop -1 |
dup 0= IF EXIT THEN 0< 2* 1+ ; |
ELSE r> 1 and |
|
THEN |
|
THEN ; |
|
|
|
-text c_addr1 u c_addr2 -- n new dash_text |
-text c_addr1 u c_addr2 -- n new dash_text |
n = memcmp(c_addr1, c_addr2, u); |
n = memcmp(c_addr1, c_addr2, u); |
Line 514 else if (n>0)
|
Line 512 else if (n>0)
|
swap bounds |
swap bounds |
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
ELSE c@ I c@ - unloop THEN -text-flag ; |
ELSE c@ I c@ - unloop THEN -text-flag ; |
: -text-flag ( n -- -1/0/1 ) |
: sgn ( n -- -1/0/1 ) |
dup 0< IF drop -1 ELSE 0> 1 and THEN ; |
dup 0= IF EXIT THEN 0< 2* 1+ ; |
|
|
toupper c1 -- c2 gforth |
toupper c1 -- c2 gforth |
""If @i{c1} is a lower-case character (in the current locale), @i{c2} |
""If @i{c1} is a lower-case character (in the current locale), @i{c2} |
Line 1487 getenv c_addr1 u1 -- c_addr2 u2 gforth
|
Line 1485 getenv c_addr1 u1 -- c_addr2 u2 gforth
|
is the host operating system's expansion of that environment variable. If the |
is the host operating system's expansion of that environment variable. If the |
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 */ |
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
c_addr2 = getenv(cstr(c_addr1,u1,1)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
|
|
Line 1499 wretval = pclose((FILE *)wfileid);
|
Line 1498 wretval = pclose((FILE *)wfileid);
|
wior = IOR(wretval==-1); |
wior = IOR(wretval==-1); |
|
|
time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date |
time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date |
|
""Report the current time of day. Seconds, minutes and hours are numbered from 0. |
|
Months are numbered from 1."" |
struct timeval time1; |
struct timeval time1; |
struct timezone zone1; |
struct timezone zone1; |
struct tm *ltime; |
struct tm *ltime; |
Line 1512 nmin =ltime->tm_min;
|
Line 1513 nmin =ltime->tm_min;
|
nsec =ltime->tm_sec; |
nsec =ltime->tm_sec; |
|
|
ms n -- facility-ext |
ms n -- facility-ext |
|
""Wait at least @i{n} milli-second."" |
struct timeval timeout; |
struct timeval timeout; |
timeout.tv_sec=n/1000; |
timeout.tv_sec=n/1000; |
timeout.tv_usec=1000*(n%1000); |
timeout.tv_usec=1000*(n%1000); |
Line 1545 I/O result code. If @i{a-addr1} is 0, Gf
|
Line 1547 I/O result code. If @i{a-addr1} is 0, Gf
|
@code{resize} @code{allocate}s @i{u} address units."" |
@code{resize} @code{allocate}s @i{u} address units."" |
/* the following check is not necessary on most OSs, but it is needed |
/* the following check is not necessary on most OSs, but it is needed |
on SunOS 4.1.2. */ |
on SunOS 4.1.2. */ |
|
/* close ' to keep fontify happy */ |
if (a_addr1==NULL) |
if (a_addr1==NULL) |
a_addr2 = (Cell *)malloc(u); |
a_addr2 = (Cell *)malloc(u); |
else |
else |
Line 1636 if (wior)
|
Line 1639 if (wior)
|
clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
|
|
read-line c_addr u1 wfileid -- u2 flag wior file read_line |
read-line c_addr u1 wfileid -- u2 flag wior file read_line |
/* |
#if 1 |
Cell c; |
Cell c; |
flag=-1; |
flag=-1; |
for(u2=0; u2<u1; u2++) |
for(u2=0; u2<u1; u2++) |
{ |
{ |
*c_addr++ = (Char)(c = getc((FILE *)wfileid)); |
c = getc((FILE *)wfileid); |
if(c=='\n') break; |
if (c=='\n') break; |
if(c==EOF) |
if (c=='\r') { |
{ |
if ((c = getc((FILE *)wfileid))!='\n') |
|
ungetc(c,(FILE *)wfileid); |
|
break; |
|
} |
|
if (c==EOF) { |
flag=FLAG(u2!=0); |
flag=FLAG(u2!=0); |
break; |
break; |
} |
} |
|
c_addr[u2] = (Char)c; |
} |
} |
wior=FILEIO(ferror((FILE *)wfileid)); |
wior=FILEIO(ferror((FILE *)wfileid)); |
*/ |
#else |
if ((flag=FLAG(!feof((FILE *)wfileid) && |
if ((flag=FLAG(!feof((FILE *)wfileid) && |
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */ |
wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */ |
Line 1663 else {
|
Line 1671 else {
|
wior=0; |
wior=0; |
u2=0; |
u2=0; |
} |
} |
|
#endif |
|
|
\+ |
\+ |
|
|
Line 1869 and represents the floating-point number
|
Line 1878 and represents the floating-point number
|
Float r; |
Float r; |
char *number=cstr(c_addr, u, 1); |
char *number=cstr(c_addr, u, 1); |
char *endconv; |
char *endconv; |
|
int sign = 0; |
|
if(number[0]=='-') { |
|
sign = 1; |
|
number++; |
|
u--; |
|
} |
while(isspace((unsigned)(number[--u])) && u>0); |
while(isspace((unsigned)(number[--u])) && u>0); |
switch(number[u]) |
switch(number[u]) |
{ |
{ |
Line 1884 if((flag=FLAG(!(Cell)*endconv)))
|
Line 1899 if((flag=FLAG(!(Cell)*endconv)))
|
{ |
{ |
IF_FTOS(fp[0] = FTOS); |
IF_FTOS(fp[0] = FTOS); |
fp += -1; |
fp += -1; |
FTOS = r; |
FTOS = sign ? -r : r; |
} |
} |
else if(*endconv=='d' || *endconv=='D') |
else if(*endconv=='d' || *endconv=='D') |
{ |
{ |
Line 1894 else if(*endconv=='d' || *endconv=='D')
|
Line 1909 else if(*endconv=='d' || *endconv=='D')
|
{ |
{ |
IF_FTOS(fp[0] = FTOS); |
IF_FTOS(fp[0] = FTOS); |
fp += -1; |
fp += -1; |
FTOS = r; |
FTOS = sign ? -r : r; |
} |
} |
} |
} |
|
|
Line 2142 rret = (SYSCALL(Float(*)(argdlist($1)))u
|
Line 2157 rret = (SYSCALL(Float(*)(argdlist($1)))u
|
|
|
') |
') |
|
|
|
\ close ' to keep fontify happy |
|
|
open-lib c_addr1 u1 -- u2 gforth open_lib |
open-lib c_addr1 u1 -- u2 gforth open_lib |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
Line 2191 fp=FP;
|
Line 2207 fp=FP;
|
IF_TOS(TOS=sp[0];) |
IF_TOS(TOS=sp[0];) |
IF_FTOS(FTOS=fp[0]); |
IF_FTOS(FTOS=fp[0]); |
|
|
|
\+file |
|
|
|
open-dir c_addr u -- wdirid wior gforth open_dir |
|
wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1)); |
|
wior = IOR(wdirid == 0); |
|
|
|
read-dir c_addr u1 wdirid -- u2 flag wior gforth read_dir |
|
struct dirent * dent; |
|
dent = readdir((DIR *)wdirid); |
|
wior = 0; |
|
flag = -1; |
|
if(dent == NULL) { |
|
u2 = 0; |
|
flag = 0; |
|
} else { |
|
u2 = strlen(dent->d_name); |
|
if(u2 > u1) |
|
u2 = u1; |
|
memmove(c_addr, dent->d_name, u2); |
|
} |
|
|
|
close-dir wdirid -- wior gforth close_dir |
|
wior = IOR(closedir((DIR *)wdirid)); |
|
|
|
filename-match c_addr1 u1 c_addr2 u2 -- flag gforth match_file |
|
char * string = cstr(c_addr1, u1, 1); |
|
char * pattern = cstr(c_addr2, u2, 0); |
|
flag = FLAG(!fnmatch(pattern, string, 0)); |
|
|
|
\+ |
|
|
|
newline -- c_addr u gforth |
|
""String containing the newline sequence of the host OS"" |
|
char newline[] = { |
|
#ifdef unix |
|
'\n' |
|
#else |
|
'\r','\n' |
|
#endif |
|
}; |
|
c_addr=newline; |
|
u=sizeof(newline); |