dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* configure.in: check for hstrerror.

Browse source 
* socket.c (scm_htons, scm_ntohs, scm_htonl, scm_ntohl): new
	functions for network data conversion.

	* numbers.c (scm_num2long, scm_num2longlong):
	throw out-of-range instead of wrong-type-arg if appropriate.
	(scm_iint2str): handle -2^31 correctly.
	(scm_num2long): handle -2^31 bignum correctly.
	(scm_num2long_long): rewrite the bigdig case: basically copied
	from scm_num2long.
	numbers.h: (SCM_BITSPERLONGLONG): deleted.

	* unif.c (rapr1): use sprintf instead of intprint for unsigned
	longs: intprint can't cope with large values.

	* numbers.c (scm_num2ulong): check more consistently that the
	input is not negative.  if it is, throw out-of-range instead of
	wrong-type-arg.

	* ramap.c (scm_array_fill_int): don't limit fill to INUM for
	uvect, ivect or llvect.
	Check that fill doesn't overflow short uniform array.

	* __scm.h: add another long to the definition of long_long and
	ulong_long.

	* unif.c (scm_raprin1): use 'l' instead of "long_long" in the
	print representation of llvect.  read can't handle more than
	one character.
	(scm_dimensions_to_uniform_array): make "fill" an optional argument
	instead of a rest argument.

	* tags.h (scm_tc7_llvect): wasn't defined anywhere, so use the free
	tag 29 for now.

	* __scm.h: don't mention LONGLONGS.

	* unif.c, numbers.c, eq.c, gc.c, print.c, eval.c, ramap.c:
	replace LONGLONGS with HAVE_LONG_LONGS as set by configure.

	* net_db.c (scm_inet_aton): throw errors using the misc-error key
	instead of system-error.  inet_aton doesn't set errno.
	system-error isn't right in gethost either, since it's throwing
	the value of h_errno instead of errno. so:
	(scm_host_not_found_key, scm_try_again_key,
	scm_no_recovery_key, scm_no_data_key): new error keys.
	(scm_resolv_error): new procedure, use the new keys.
	(scm_gethost): call scm_resolv_error not scm_syserror_msg.

	* error.c: (various): use scm_cons instead of scm_listify
	to build short lists.

	* boot-9.scm (read-hash-extend to set up arrays): add 'l' for
	long_long uniform vectors.

	* networking.scm (sethostent, setnetent, setprotoent, setservent):
	take an optional argument STAYOPEN.  default is #f.

	* readline.c (scm_init_readline): set rl_readline_name to Guile,
	to allow conditionals in  .inputrc.
This commit is contained in:
Gary Houston 1999-11-18 22:36:28 +00:00
commit 5c11cc9deb
22 changed files with 594 additions and 337 deletions
Download patch file Download diff file Expand all files Collapse all files

4
ChangeLog
View file

@ -1,3 +1,7 @@
1999-11-17 Gary Houston <ghouston@freewire.co.uk>
* configure.in: check for hstrerror.
1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
* autogen.sh: Don't call autoreconf at all; it's not reliable.

33
NEWS
View file

@ -107,6 +107,39 @@ although to actually avoid resetting the buffers and discard unread
chars requires further hacking that depends on the characteristics
of the ptob.
* Changes to the networking interfaces:
** New functions: htons, ntohs, htonl, ntohl: for converting short and
long integers between network and host format. For now, it's not
particularly convenient to do this kind of thing, but consider:
(define write-network-long
(lambda (value port)
(let ((v (make-uniform-vector 1 1 0)))
(uniform-vector-set! v 0 (htonl value))
(uniform-vector-write v port))))
(define read-network-long
(lambda (port)
(let ((v (make-uniform-vector 1 1 0)))
(uniform-vector-read! v port)
(ntohl (uniform-vector-ref v 0)))))
** If inet-aton fails, it now throws an error with key 'misc-error
instead of 'system-error, since errno is not relevant.
** Certain gethostbyname/gethostbyaddr failures now throw errors with
specific keys instead of 'system-error. The latter is inappropriate
since errno will not have been set. The keys are:
'dns-host-not-found, 'dns-try-again, 'dns-no-recovery and
'dns-no-data.
** sethostent, setnetent, setprotoent, setservent: now take an
optional argument STAYOPEN, which specifies whether the database
remains open after a database entry is accessed randomly (e.g., using
gethostbyname for the hosts database.) The default is #f. Previously
#t was always used.
Changes since Guile 1.3.2:

5
configure.in
View file

@ -219,7 +219,7 @@ dnl AC_CHECK_FUNCS...
dnl restore confdefs.h
dnl cp confdefs.h confdefs.h.bak
dnl for func in gethostent sethostent endhostent getnetent setnetent endnetent getprotoent setprotoent endprotoent getservent setservent endservent getnetbyaddr getnetbyname inet_lnaof inet_makeaddr inet_netof ; do
dnl for func in gethostent sethostent endhostent getnetent setnetent endnetent getprotoent setprotoent endprotoent getservent setservent endservent getnetbyaddr getnetbyname inet_lnaof inet_makeaddr inet_netof hstrerror; do
dnl cp confdefs.h.bak confdefs.h
dnl cat >> confdefs.h << EOF
dnl #ifdef __CYGWIN32__
@ -234,7 +234,8 @@ AC_CHECK_FUNCS(sethostent gethostent endhostent dnl
setnetent getnetent endnetent dnl
setprotoent getprotoent endprotoent dnl
setservent getservent endservent dnl
getnetbyaddr getnetbyname inet_lnaof inet_makeaddr inet_netof)
getnetbyaddr getnetbyname dnl
inet_lnaof inet_makeaddr inet_netof hstrerror)
dnl </GNU-WIN32 hacks>

5
guile-readline/ChangeLog
View file

@ -1,3 +1,8 @@
1999-11-18 Gary Houston <ghouston@freewire.co.uk>
* readline.c (scm_init_readline): set rl_readline_name to Guile,
to allow conditionals in .inputrc.
1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
* Makefile.in, configure, aclocal.m4: Deleted from CVS repository.

2
guile-readline/readline.c
View file

@ -494,6 +494,8 @@ scm_init_readline ()
rl_redisplay_function = redisplay;
rl_completion_entry_function = (Function*) completion_function;
rl_basic_word_break_characters = "\t\n\"'`;()";
rl_readline_name = "Guile";
#ifdef USE_THREADS
scm_mutex_init (&reentry_barrier_mutex);
#endif

10
ice-9/ChangeLog
View file

@ -1,3 +1,13 @@
1999-11-18 Gary Houston <ghouston@freewire.co.uk>
* boot-9.scm (read-hash-extend to set up arrays): add 'l' for
long_long uniform vectors.
1999-11-17 Gary Houston <ghouston@freewire.co.uk>
* networking.scm (sethostent, setnetent, setprotoent, setservent):
take an optional argument STAYOPEN. default is #f.
1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
* Makefile.in: Deleted from CVS repository. Run the autogen.sh

4
ice-9/boot-9.scm
View file

@ -910,8 +910,8 @@
(for-each (lambda (char template)
(read-hash-extend char
(make-array-proc template)))
'(#\b #\a #\u #\e #\s #\i #\c #\y #\h)
'(#t #\a 1 -1 1.0 1/3 0+i #\nul s)))
'(#\b #\a #\u #\e #\s #\i #\c #\y #\h #\l)
'(#t #\a 1 -1 1.0 1/3 0+i #\nul s l)))
(let ((array-proc (lambda (c port)
(read:array c port))))
(for-each (lambda (char) (read-hash-extend char array-proc))

20
ice-9/networking.scm
View file

@ -30,10 +30,22 @@
(define (getservbyname name proto) (getserv name proto))
(define (getservbyport port proto) (getserv port proto))
(define (sethostent) (sethost #t))
(define (setnetent) (setnet #t))
(define (setprotoent) (setproto #t))
(define (setservent) (setserv #t))
(define (sethostent . stayopen)
(if (pair? stayopen)
(sethost (car stayopen))
(sethost #f)))
(define (setnetent . stayopen)
(if (pair? stayopen)
(setnet (car stayopen))
(setnet #f)))
(define (setprotoent . stayopen)
(if (pair? stayopen)
(setproto (car stayopen))
(setproto #f)))
(define (setservent . stayopen)
(if (pair? stayopen)
(setserv (car stayopen))
(setserv #f)))
(define (gethostent) (gethost))
(define (getnetent) (getnet))

57
libguile/ChangeLog
View file

@ -1,3 +1,60 @@
1999-11-18 Gary Houston <ghouston@freewire.co.uk>
* socket.c (scm_htons, scm_ntohs, scm_htonl, scm_ntohl): new
functions for network data conversion.
* numbers.c (scm_num2long, scm_num2longlong):
throw out-of-range instead of wrong-type-arg if appropriate.
(scm_iint2str): handle -2^31 correctly.
(scm_num2long): handle -2^31 bignum correctly.
(scm_num2long_long): rewrite the bigdig case: basically copied
from scm_num2long.
numbers.h: (SCM_BITSPERLONGLONG): deleted.
* unif.c (rapr1): use sprintf instead of intprint for unsigned
longs: intprint can't cope with large values.
* numbers.c (scm_num2ulong): check more consistently that the
input is not negative. if it is, throw out-of-range instead of
wrong-type-arg.
* ramap.c (scm_array_fill_int): don't limit fill to INUM for
uvect, ivect or llvect.
Check that fill doesn't overflow short uniform array.
* __scm.h: add another long to the definition of long_long and
ulong_long.
* unif.c (scm_raprin1): use 'l' instead of "long_long" in the
print representation of llvect. read can't handle more than
one character.
(scm_dimensions_to_uniform_array): make "fill" an optional argument
instead of a rest argument.
* tags.h (scm_tc7_llvect): wasn't defined anywhere, so use the free
tag 29 for now.
* __scm.h: don't mention LONGLONGS.
* unif.c, numbers.c, eq.c, gc.c, print.c, eval.c, ramap.c:
replace LONGLONGS with HAVE_LONG_LONGS as set by configure.
1999-11-17 Gary Houston <ghouston@freewire.co.uk>
* net_db.c (scm_inet_aton): throw errors using the misc-error key
instead of system-error. inet_aton doesn't set errno.
system-error isn't right in gethost either, since it's throwing
the value of h_errno instead of errno. so:
(scm_host_not_found_key, scm_try_again_key,
scm_no_recovery_key, scm_no_data_key): new error keys.
(scm_resolv_error): new procedure, use the new keys.
(scm_gethost): call scm_resolv_error not scm_syserror_msg.
1999-11-16 Gary Houston <ghouston@freewire.co.uk>
* error.c: (various): use scm_cons instead of scm_listify
to build short lists.
1999-11-03 Gary Houston <ghouston@freewire.co.uk>
* socket.c (scm_fill_sockaddr): zero the address structure before

2
libguile/eq.c
View file

@ -127,7 +127,7 @@ scm_equal_p (x, y)
case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect:
case scm_tc7_fvect: case scm_tc7_cvect: case scm_tc7_dvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_byvect:

30
libguile/error.c
View file

@ -78,9 +78,11 @@ scm_error (key, subr, message, args, rest)
scm_ithrow (key, arg_list, 1);
/* No return, but just in case: */
{
const char msg[] = "guile:scm_error:scm_ithrow returned!\n";
write (2, "unhandled system error\n",
sizeof ("unhandled system error\n") - 1);
write (2, msg, (sizeof msg) - 1);
}
exit (1);
}
@ -127,9 +129,8 @@ scm_syserror (subr)
scm_error (scm_system_error_key,
subr,
"%s",
scm_listify (scm_makfrom0str (strerror (errno)),
SCM_UNDEFINED),
scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
scm_cons (scm_makfrom0str (strerror (errno)), SCM_EOL),
scm_cons (SCM_MAKINUM (errno), SCM_EOL));
}
void
@ -143,7 +144,7 @@ scm_syserror_msg (subr, message, args, eno)
subr,
message,
args,
scm_listify (SCM_MAKINUM (eno), SCM_UNDEFINED));
scm_cons (SCM_MAKINUM (eno), SCM_EOL));
}
void
@ -154,14 +155,14 @@ scm_sysmissing (subr)
scm_error (scm_system_error_key,
subr,
"%s",
scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
scm_cons (scm_makfrom0str (strerror (ENOSYS)), SCM_EOL),
scm_cons (SCM_MAKINUM (ENOSYS), SCM_EOL));
#else
scm_error (scm_system_error_key,
subr,
"Missing function",
SCM_BOOL_F,
scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED));
scm_cons (SCM_MAKINUM (0), SCM_EOL));
#endif
}
@ -186,7 +187,7 @@ scm_out_of_range (subr, bad_value)
scm_error (scm_out_of_range_key,
subr,
"Argument out of range: %S",
scm_listify (bad_value, SCM_UNDEFINED),
scm_cons (bad_value, SCM_EOL),
SCM_BOOL_F);
}
@ -198,7 +199,7 @@ scm_wrong_num_args (proc)
scm_error (scm_args_number_key,
NULL,
"Wrong number of arguments to %s",
scm_listify (proc, SCM_UNDEFINED),
scm_cons (proc, SCM_EOL),
SCM_BOOL_F);
}
@ -213,8 +214,8 @@ scm_wrong_type_arg (subr, pos, bad_value)
subr,
(pos == 0) ? "Wrong type argument: %S"
: "Wrong type argument in position %s: %S",
(pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
: scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
(pos == 0) ? scm_cons (bad_value, SCM_EOL)
: scm_cons (SCM_MAKINUM (pos), scm_cons (bad_value, SCM_EOL)),
SCM_BOOL_F);
}
@ -291,9 +292,6 @@ scm_wta (arg, pos, s_subr)
return SCM_UNSPECIFIED;
}
/* obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
was equivalent to scm_wta (arg, pos, s_subr) */
void
scm_init_error ()
{

2
libguile/eval.c
View file

@ -2539,7 +2539,7 @@ dispatch:
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_string:

4
libguile/gc.c
View file

@ -754,7 +754,7 @@ gc_mark_nimp:
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
@ -1189,7 +1189,7 @@ scm_gc_sweep ()
goto c8mrkcontinue;
m += SCM_HUGE_LENGTH (scmptr) * sizeof (short);
goto freechars;
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;

71
libguile/net_db.c
View file

@ -89,7 +89,7 @@ scm_inet_aton (address)
if (SCM_SUBSTRP (address))
address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
scm_syserror (s_inet_aton);
scm_misc_error (s_inet_aton, "bad address", SCM_EOL);
return scm_ulong2num (ntohl (soka.s_addr));
}
@ -154,9 +154,55 @@ scm_inet_makeaddr (net, lna)
}
#endif
SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
SCM_SYMBOL (scm_try_again_key, "try-again");
SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
SCM_SYMBOL (scm_no_data_key, "no-data");
/* !!! Doesn't take address format.
* Assumes hostent stream isn't reused.
static void scm_resolv_error (const char *subr, SCM bad_value)
{
if (h_errno == NETDB_INTERNAL)
{
/* errno supposedly contains a useful value. */
scm_syserror (subr);
}
else
{
SCM key;
const char *errmsg;
switch (h_errno)
{
case HOST_NOT_FOUND:
key = scm_host_not_found_key;
errmsg = "Unknown host";
break;
case TRY_AGAIN:
key = scm_try_again_key;
errmsg = "Host name lookup failure";
break;
case NO_RECOVERY:
key = scm_no_recovery_key;
errmsg = "Unknown server error";
break;
case NO_DATA:
key = scm_no_data_key;
errmsg = "No address associated with name";
break;
default:
scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
errmsg = NULL;
}
#ifdef HAVE_HSTRERROR
errmsg = hstrerror (h_errno);
#endif
scm_error (key, subr, errmsg, scm_cons (bad_value, SCM_EOL), SCM_EOL);
}
}
/* Should take an extra arg for address format (will be needed for IPv6).
Should use reentrant facilities if available.
*/
SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost);
@ -201,21 +247,10 @@ scm_gethost (name)
entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
}
if (!entry)
{
char *errmsg;
SCM args;
args = scm_listify (name, SCM_UNDEFINED);
switch (h_errno)
{
case HOST_NOT_FOUND: errmsg = "host %s not found"; break;
case TRY_AGAIN: errmsg = "nameserver failure (try later)"; break;
case NO_RECOVERY: errmsg = "non-recoverable error"; break;
case NO_DATA: errmsg = "no address associated with %s"; break;
default: errmsg = "undefined error"; break;
}
scm_syserror_msg (s_gethost, errmsg, args, h_errno);
}
ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
scm_resolv_error (s_gethost, name);
ve[0] = scm_makfromstr (entry->h_name,
(scm_sizet) strlen (entry->h_name), 0);
ve[1] = scm_makfromstrs (-1, entry->h_aliases);
ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
ve[3] = SCM_MAKINUM (entry->h_length + 0L);

175
libguile/numbers.c
View file

@ -972,7 +972,7 @@ scm_long2big (n)
return ans;
}
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
SCM
scm_long_long2big (n)
@ -1720,34 +1720,34 @@ iflo2str (flt, str)
}
#endif /* SCM_FLOATS */
/* convert a long to a string (unterminated). returns the number of
characters in the result. */
scm_sizet
scm_iint2str (num, rad, p)
long num;
int rad;
char *p;
int rad; /* output base. */
char *p; /* destination: worst case (base 2) is SCM_INTBUFLEN. */
{
scm_sizet j;
register int i = 1, d;
register long n = num;
if (n < 0)
{
n = -n;
i++;
}
scm_sizet j = 1;
scm_sizet i;
unsigned long n = (num < 0) ? -num : num;
for (n /= rad; n > 0; n /= rad)
i++;
j = i;
n = num;
if (n < 0)
j++;
i = j;
if (num < 0)
{
n = -n;
*p++ = '-';
i--;
j++;
n = -num;
}
else
n = num;
while (i--)
{
d = n % rad;
int d = n % rad;
n /= rad;
p[i] = d + ((d < 10) ? '0' : 'a' - 10);
}
@ -4584,7 +4584,7 @@ scm_long2num (sl)
}
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
SCM
scm_long_long2num (sl)
@ -4635,51 +4635,64 @@ scm_num2long (num, pos, s_caller)
const char *s_caller;
{
long res;
if (SCM_INUMP (num))
{
res = SCM_INUM (num);
return res;
}
SCM_ASRTGO (SCM_NIMP (num), errout);
SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
#ifdef SCM_FLOATS
if (SCM_REALP (num))
{
double u = SCM_REALPART (num);
volatile double u = SCM_REALPART (num);
res = u;
if ((double) res == u)
{
return res;
}
if (res != u)
goto out_of_range;
return res;
}
#endif
#ifdef SCM_BIGDIG
if (SCM_BIGP (num))
{
long oldres;
unsigned long oldres = 0;
scm_sizet l;
res = 0;
oldres = 0;
/* can't use res directly in case num is -2^31. */
unsigned long pos_res = 0;
for (l = SCM_NUMDIGS (num); l--;)
{
res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l];
if (res < oldres)
goto errout;
oldres = res;
pos_res = SCM_BIGUP (pos_res) + SCM_BDIGITS (num)[l];
/* check for overflow. */
if (pos_res < oldres)
goto out_of_range;
oldres = pos_res;
}
if (SCM_TYP16 (num) == scm_tc16_bigpos)
return res;
{
res = pos_res;
if (res < 0)
goto out_of_range;
}
else
return -res;
{
res = -pos_res;
if (res > 0)
goto out_of_range;
}
return res;
}
#endif
errout:
scm_wta (num, pos, s_caller);
return SCM_UNSPECIFIED;
wrong_type_arg:
scm_wrong_type_arg (s_caller, (int) pos, num);
out_of_range:
scm_out_of_range (s_caller, num);
}
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
long_long
scm_num2long_long (num, pos, s_caller)
@ -4688,38 +4701,60 @@ scm_num2long_long (num, pos, s_caller)
const char *s_caller;
{
long_long res;
if (SCM_INUMP (num))
{
res = SCM_INUM ((long_long) num);
res = SCM_INUM (num);
return res;
}
SCM_ASRTGO (SCM_NIMP (num), errout);
SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
#ifdef SCM_FLOATS
if (SCM_REALP (num))
{
double u = SCM_REALPART (num);
if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
&& (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3)))
{
res = u;
return res;
}
res = u;
if ((res < 0 && u > 0) || (res > 0 && u < 0)) /* check for overflow. */
goto out_of_range;
return res;
}
#endif
#ifdef SCM_BIGDIG
if (SCM_BIGP (num))
{
scm_sizet l = SCM_NUMDIGS (num);
SCM_ASRTGO (SCM_DIGSPERLONGLONG >= l, errout);
res = 0;
for (; l--;)
res = SCM_LONGLONGBIGUP (res) + SCM_BDIGITS (num)[l];
unsigned long long oldres = 0;
scm_sizet l;
/* can't use res directly in case num is -2^63. */
unsigned long long pos_res = 0;
for (l = SCM_NUMDIGS (num); l--;)
{
pos_res = SCM_LONGLONGBIGUP (pos_res) + SCM_BDIGITS (num)[l];
/* check for overflow. */
if (pos_res < oldres)
goto out_of_range;
oldres = pos_res;
}
if (SCM_TYP16 (num) == scm_tc16_bigpos)
{
res = pos_res;
if (res < 0)
goto out_of_range;
}
else
{
res = -pos_res;
if (res > 0)
goto out_of_range;
}
return res;
}
#endif
errout:
scm_wta (num, pos, s_caller);
return SCM_UNSPECIFIED;
wrong_type_arg:
scm_wrong_type_arg (s_caller, (int) pos, num);
out_of_range:
scm_out_of_range (s_caller, num);
}
#endif
@ -4732,43 +4767,47 @@ scm_num2ulong (num, pos, s_caller)
const char *s_caller;
{
unsigned long res;
if (SCM_INUMP (num))
{
res = SCM_INUM ((unsigned long) num);
if (SCM_INUM (num) < 0)
goto out_of_range;
res = SCM_INUM (num);
return res;
}
SCM_ASRTGO (SCM_NIMP (num), errout);
SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
#ifdef SCM_FLOATS
if (SCM_REALP (num))
{
double u = SCM_REALPART (num);
if ((0 <= u) && (u <= (unsigned long) ~0L))
{
res = u;
return res;
}
res = u;
if (res != u)
goto out_of_range;
return res;
}
#endif
#ifdef SCM_BIGDIG
if (SCM_BIGP (num))
{
unsigned long oldres;
unsigned long oldres = 0;
scm_sizet l;
res = 0;
oldres = 0;
for (l = SCM_NUMDIGS (num); l--;)
{
res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l];
if (res < oldres)
goto errout;
goto out_of_range;
oldres = res;
}
return res;
}
#endif
errout:
scm_wta (num, pos, s_caller);
return SCM_UNSPECIFIED;
wrong_type_arg:
scm_wrong_type_arg (s_caller, (int) pos, num);
out_of_range:
scm_out_of_range (s_caller, num);
}

1
libguile/numbers.h
View file

@ -167,7 +167,6 @@
# define SCM_BIGRAD (1L << SCM_BITSPERDIG)
# define SCM_DIGSPERLONG ((scm_sizet)((sizeof(long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG))
# define SCM_DIGSPERLONGLONG ((scm_sizet)((sizeof(long long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG))
# define SCM_BIGUP(x) ((unsigned long)(x) << SCM_BITSPERDIG)
# define SCM_LONGLONGBIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG)
# define SCM_BIGDN(x) ((x) >> SCM_BITSPERDIG)

2
libguile/print.c
View file

@ -600,7 +600,7 @@ taloop:
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
scm_raprin1 (exp, port, pstate);

296
libguile/ramap.c
View file

@ -165,7 +165,7 @@ scm_ra_matchp (ra0, ras)
case scm_tc7_uvect:
case scm_tc7_ivect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_fvect:
@ -202,7 +202,7 @@ scm_ra_matchp (ra0, ras)
case scm_tc7_uvect:
case scm_tc7_ivect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_fvect:
@ -255,15 +255,16 @@ scm_ra_matchp (ra0, ras)
return exact;
}
static char s_ra_mismatch[] = "array shape mismatch";
/* array mapper: apply cproc to each dimension of the given arrays. */
int
scm_ramapc (cproc, data, ra0, lra, what)
int (*cproc) ();
SCM data;
SCM ra0;
SCM lra;
const char *what;
int (*cproc) (); /* procedure to call on normalised arrays:
cproc (dest, source list) or
cproc (dest, data, source list). */
SCM data; /* data to give to cproc or unbound. */
SCM ra0; /* destination array. */
SCM lra; /* list of source arrays. */
const char *what; /* caller, for error reporting. */
{
SCM inds, z;
SCM vra0, ra1, vra1;
@ -274,7 +275,7 @@ scm_ramapc (cproc, data, ra0, lra, what)
{
default:
case 0:
scm_wta (ra0, s_ra_mismatch, what);
scm_wta (ra0, "array shape mismatch", what);
case 2:
case 3:
case 4: /* Try unrolling arrays */
@ -416,148 +417,165 @@ scm_array_fill_x (ra, fill)
return SCM_UNSPECIFIED;
}
/* to be used as cproc in scm_ramapc to fill an array dimension with
"fill". */
int
scm_array_fill_int (ra, fill, ignore)
SCM ra;
SCM fill;
SCM ignore;
{
scm_sizet i, n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1;
scm_sizet i;
scm_sizet n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1;
long inc = SCM_ARRAY_DIMS (ra)->inc;
scm_sizet base = SCM_ARRAY_BASE (ra);
ra = SCM_ARRAY_V (ra);
switch SCM_TYP7
(ra)
switch SCM_TYP7 (ra)
{
default:
for (i = base; n--; i += inc)
scm_array_set_x (ra, fill, SCM_MAKINUM (i));
break;
case scm_tc7_vector:
case scm_tc7_wvect:
for (i = base; n--; i += inc)
SCM_VELTS (ra)[i] = fill;
break;
case scm_tc7_string:
SCM_ASRTGO (SCM_ICHRP (fill), badarg2);
for (i = base; n--; i += inc)
SCM_CHARS (ra)[i] = SCM_ICHR (fill);
break;
case scm_tc7_byvect:
if (SCM_ICHRP (fill))
fill = SCM_MAKINUM ((char) SCM_ICHR (fill));
SCM_ASRTGO (SCM_INUMP (fill)
&& -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128,
badarg2);
for (i = base; n--; i += inc)
SCM_CHARS (ra)[i] = SCM_INUM (fill);
break;
case scm_tc7_bvect:
{
default:
for (i = base; n--; i += inc)
scm_array_set_x (ra, fill, SCM_MAKINUM (i));
break;
case scm_tc7_vector:
case scm_tc7_wvect:
for (i = base; n--; i += inc)
SCM_VELTS (ra)[i] = fill;
break;
case scm_tc7_string:
SCM_ASRTGO (SCM_ICHRP (fill), badarg2);
for (i = base; n--; i += inc)
SCM_CHARS (ra)[i] = SCM_ICHR (fill);
break;
case scm_tc7_byvect:
if (SCM_ICHRP (fill))
fill = SCM_MAKINUM ((char) SCM_ICHR (fill));
SCM_ASRTGO (SCM_INUMP (fill)
&& -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128,
badarg2);
for (i = base; n--; i += inc)
SCM_CHARS (ra)[i] = SCM_INUM (fill);
break;
case scm_tc7_bvect:
{
long *ve = (long *) SCM_VELTS (ra);
if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra)))
{
i = base / SCM_LONG_BIT;
if (SCM_BOOL_F == fill)
{
if (base % SCM_LONG_BIT) /* leading partial word */
ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
for (; i < (base + n) / SCM_LONG_BIT; i++)
ve[i] = 0L;
if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
}
else if (SCM_BOOL_T == fill)
{
if (base % SCM_LONG_BIT)
ve[i++] |= ~0L << (base % SCM_LONG_BIT);
for (; i < (base + n) / SCM_LONG_BIT; i++)
ve[i] = ~0L;
if ((base + n) % SCM_LONG_BIT)
ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
}
else
long *ve = (long *) SCM_VELTS (ra);
if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra)))
{
i = base / SCM_LONG_BIT;
if (SCM_BOOL_F == fill)
{
if (base % SCM_LONG_BIT) /* leading partial word */
ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
for (; i < (base + n) / SCM_LONG_BIT; i++)
ve[i] = 0L;
if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
}
else if (SCM_BOOL_T == fill)
{
if (base % SCM_LONG_BIT)
ve[i++] |= ~0L << (base % SCM_LONG_BIT);
for (; i < (base + n) / SCM_LONG_BIT; i++)
ve[i] = ~0L;
if ((base + n) % SCM_LONG_BIT)
ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
}
else
badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x);
}
else
{
if (SCM_BOOL_F == fill)
for (i = base; n--; i += inc)
ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
else if (SCM_BOOL_T == fill)
for (i = base; n--; i += inc)
ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
else
goto badarg2;
}
break;
}
case scm_tc7_uvect:
SCM_ASRTGO (0 <= SCM_INUM (fill), badarg2);
case scm_tc7_ivect:
SCM_ASRTGO (SCM_INUMP (fill), badarg2);
{
long f = SCM_INUM (fill), *ve = (long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
case scm_tc7_svect:
SCM_ASRTGO (SCM_INUMP (fill), badarg2);
{
short f = SCM_INUM (fill), *ve = (short *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
#ifdef LONGLONGS
case scm_tc7_llvect:
SCM_ASRTGO (SCM_INUMP (fill), badarg2);
{
long long f = SCM_INUM (fill), *ve = (long long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
}
else
{
if (SCM_BOOL_F == fill)
for (i = base; n--; i += inc)
ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
else if (SCM_BOOL_T == fill)
for (i = base; n--; i += inc)
ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
else
goto badarg2;
}
break;
}
case scm_tc7_uvect:
{
unsigned long f = scm_num2ulong (fill, (char *) SCM_ARG2,
s_array_fill_x);
unsigned long *ve = (long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
case scm_tc7_ivect:
{
long f = scm_num2long (fill, (char *) SCM_ARG2, s_array_fill_x);
long *ve = (long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
case scm_tc7_svect:
SCM_ASRTGO (SCM_INUMP (fill), badarg2);
{
short f = SCM_INUM (fill);
short *ve = (short *) SCM_VELTS (ra);
if (f != SCM_INUM (fill))
scm_out_of_range (s_array_fill_x, fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
{
long long f = scm_num2long_long (fill, (char *) SCM_ARG2,
s_array_fill_x);
long long *ve = (long long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
{
float f, *ve = (float *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
#endif /* SCM_SINGLES */
case scm_tc7_dvect:
{
double f, *ve = (double *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
case scm_tc7_cvect:
{
double fr, fi;
double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2);
fr = SCM_REALPART (fill);
fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0);
for (i = base; n--; i += inc)
{
ve[i][0] = fr;
ve[i][1] = fi;
}
break;
}
#endif /* SCM_FLOATS */
case scm_tc7_fvect:
{
float f, *ve = (float *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
#endif /* SCM_SINGLES */
case scm_tc7_dvect:
{
double f, *ve = (double *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
case scm_tc7_cvect:
{
double fr, fi;
double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2);
fr = SCM_REALPART (fill);
fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0);
for (i = base; n--; i += inc)
{
ve[i][0] = fr;
ve[i][1] = fi;
}
break;
}
#endif /* SCM_FLOATS */
}
return 1;
}
@ -1830,7 +1848,7 @@ scm_array_index_map_x (ra, proc)
case scm_tc7_uvect:
case scm_tc7_ivect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_fvect:
@ -1963,7 +1981,7 @@ raeql_1 (ra0, as_equal, ra1)
return 0;
return 1;
}
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
{
long long *v0 = (long long *) SCM_VELTS (ra0) + i0;

46
libguile/socket.c
View file

@ -66,6 +66,52 @@
SCM_PROC (s_htons, "htons", 1, 0, 0, scm_htons);
SCM
scm_htons (SCM in)
{
unsigned short c_in;
SCM_ASSERT (SCM_INUMP (in), in, SCM_ARG1, s_htons);
c_in = SCM_INUM (in);
if (c_in != SCM_INUM (in))
scm_out_of_range (s_htons, in);
return SCM_MAKINUM (htons (c_in));
}
SCM_PROC (s_ntohs, "ntohs", 1, 0, 0, scm_ntohs);
SCM
scm_ntohs (SCM in)
{
unsigned short c_in;
SCM_ASSERT (SCM_INUMP (in), in, SCM_ARG1, s_ntohs);
c_in = SCM_INUM (in);
if (c_in != SCM_INUM (in))
scm_out_of_range (s_ntohs, in);
return SCM_MAKINUM (ntohs (c_in));
}
SCM_PROC (s_htonl, "htonl", 1, 0, 0, scm_htonl);
SCM
scm_htonl (SCM in)
{
unsigned long c_in = scm_num2ulong (in, (char *) SCM_ARG1, s_htonl);
return scm_ulong2num (htonl (c_in));
}
SCM_PROC (s_ntohl, "ntohl", 1, 0, 0, scm_ntohl);
SCM
scm_ntohl (SCM in)
{
unsigned long c_in = scm_num2ulong (in, (char *) SCM_ARG1, s_ntohl);
return scm_ulong2num (ntohl (c_in));
}
SCM_SYMBOL (sym_socket, "socket");
static SCM scm_sock_fd_to_port SCM_P ((int fd, const char *proc));

40
libguile/socket.h
View file

@ -48,25 +48,25 @@
extern SCM scm_socket SCM_P ((SCM family, SCM style, SCM proto));
extern SCM scm_socketpair SCM_P ((SCM family, SCM style, SCM proto));
extern SCM scm_getsockopt SCM_P ((SCM sfd, SCM level, SCM optname));
extern SCM scm_setsockopt SCM_P ((SCM sfd, SCM level, SCM optname, SCM value));
extern SCM scm_shutdown SCM_P ((SCM sfd, SCM how));
extern SCM scm_connect SCM_P ((SCM sockfd, SCM fam, SCM address, SCM args));
extern SCM scm_bind SCM_P ((SCM sockfd, SCM fam, SCM address, SCM args));
extern SCM scm_listen SCM_P ((SCM sfd, SCM backlog));
extern SCM scm_accept SCM_P ((SCM sockfd));
extern SCM scm_getsockname SCM_P ((SCM sockfd));
extern SCM scm_getpeername SCM_P ((SCM sockfd));
extern SCM scm_recv SCM_P ((SCM sockfd, SCM buff_or_size, SCM flags));
extern SCM scm_send SCM_P ((SCM sockfd, SCM message, SCM flags));
extern SCM scm_recvfrom SCM_P ((SCM sockfd, SCM buff_or_size, SCM flags, SCM offset, SCM length));
extern SCM scm_sendto SCM_P ((SCM sockfd, SCM message, SCM fam, SCM address, SCM args_and_flags));
extern void scm_init_socket SCM_P ((void));
extern SCM scm_htons (SCM in);
extern SCM scm_ntohs (SCM in);
extern SCM scm_htonl (SCM in);
extern SCM scm_ntohl (SCM in);
extern SCM scm_socket (SCM family, SCM style, SCM proto);
extern SCM scm_socketpair (SCM family, SCM style, SCM proto);
extern SCM scm_getsockopt (SCM sfd, SCM level, SCM optname);
extern SCM scm_setsockopt (SCM sfd, SCM level, SCM optname, SCM value);
extern SCM scm_shutdown (SCM sfd, SCM how);
extern SCM scm_connect (SCM sockfd, SCM fam, SCM address, SCM args);
extern SCM scm_bind (SCM sockfd, SCM fam, SCM address, SCM args);
extern SCM scm_listen (SCM sfd, SCM backlog);
extern SCM scm_accept (SCM sockfd);
extern SCM scm_getsockname (SCM sockfd);
extern SCM scm_getpeername (SCM sockfd);
extern SCM scm_recv (SCM sockfd, SCM buff_or_size, SCM flags);
extern SCM scm_send (SCM sockfd, SCM message, SCM flags);
extern SCM scm_recvfrom (SCM sockfd, SCM buff_or_size, SCM flags, SCM offset, SCM length);
extern SCM scm_sendto (SCM sockfd, SCM message, SCM fam, SCM address, SCM args_and_flags);
extern void scm_init_socket (void);
#endif /* SOCKETH */

3
libguile/tags.h
View file

@ -333,12 +333,11 @@ typedef long SCM;
#define scm_tc7_string 21
#define scm_tc7_substring 23
/* 29 is free! */
/* Many of the following should be turned
* into structs or smobs. We need back some
* of these 7 bit tags!
*/
#define scm_tc7_llvect 29
#define scm_tc7_pws 31
#define scm_tc7_uvect 37
#define scm_tc7_lvector 39

119
libguile/unif.c
View file

@ -68,7 +68,7 @@
* double dvect
* complex double cvect
* short svect
* long_long llvect
* long long llvect
*/
long scm_tc16_array;
@ -122,7 +122,7 @@ scm_vector_set_length_x (vect, len)
case scm_tc7_svect:
sz = sizeof (short);
break;
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
@ -233,7 +233,7 @@ scm_make_uve (k, prot)
i = sizeof (short) * k;
type = scm_tc7_svect;
}
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
else if (s == 'l')
{
i = sizeof (long_long) * k;
@ -250,7 +250,8 @@ scm_make_uve (k, prot)
if (SCM_IMP (prot) || !SCM_INEXP (prot))
#endif
/* Huge non-unif vectors are NOT supported. */
return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); /* no special scm_vector */
/* no special scm_vector */
return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
else if (SCM_SINGP (prot))
@ -274,11 +275,7 @@ scm_make_uve (k, prot)
SCM_NEWCELL (v);
SCM_DEFER_INTS;
{
char *m;
m = scm_must_malloc ((i ? i : 1L), "vector");
SCM_SETCHARS (v, (char *) m);
}
SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector"));
SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type);
SCM_ALLOW_INTS;
return v;
@ -307,7 +304,7 @@ scm_uniform_vector_length (v)
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
return SCM_MAKINUM (SCM_LENGTH (v));
@ -355,7 +352,7 @@ loop:
&& SCM_SYMBOLP (prot)
&& (1 == SCM_LENGTH (prot))
&& ('s' == SCM_CHARS (prot)[0])));
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return ( nprot
|| (SCM_NIMP (prot)
@ -403,7 +400,7 @@ scm_array_rank (ra)
case scm_tc7_fvect:
case scm_tc7_cvect:
case scm_tc7_dvect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_svect:
@ -442,7 +439,7 @@ scm_array_dimensions (ra)
case scm_tc7_cvect:
case scm_tc7_dvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL);
@ -556,7 +553,7 @@ scm_shap2ra (args, what)
return ra;
}
SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array);
SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, scm_dimensions_to_uniform_array);
SCM
scm_dimensions_to_uniform_array (dims, prot, fill)
@ -572,15 +569,10 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
{
if (SCM_INUM (dims) < SCM_LENGTH_MAX)
{
SCM answer;
answer = scm_make_uve (SCM_INUM (dims), prot);
if (SCM_NNULLP (fill))
{
SCM_ASSERT (1 == scm_ilength (fill),
scm_makfrom0str (s_dimensions_to_uniform_array),
SCM_WNA, NULL);
scm_array_fill_x (answer, SCM_CAR (fill));
}
SCM answer = scm_make_uve (SCM_INUM (dims), prot);
if (!SCM_UNBNDP (fill))
scm_array_fill_x (answer, fill);
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
scm_array_fill_x (answer, SCM_MAKINUM (0));
else
@ -633,12 +625,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
*((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen;
}
if (SCM_NNULLP (fill))
if (!SCM_UNBNDP (fill))
{
SCM_ASSERT (1 == scm_ilength (fill),
scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
NULL);
scm_array_fill_x (ra, SCM_CAR (fill));
scm_array_fill_x (ra, fill);
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
scm_array_fill_x (ra, SCM_MAKINUM (0));
@ -815,7 +804,7 @@ scm_transpose_array (args)
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
@ -917,7 +906,7 @@ scm_enclose_array (axes)
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
s->lbnd = 0;
@ -1035,7 +1024,7 @@ tail:
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_vector:
@ -1129,7 +1118,7 @@ scm_uniform_vector_ref (v, args)
case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
#endif
@ -1160,8 +1149,7 @@ scm_cvref (v, pos, last)
scm_sizet pos;
SCM last;
{
switch SCM_TYP7
(v)
switch SCM_TYP7 (v)
{
default:
scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
@ -1186,7 +1174,7 @@ scm_cvref (v, pos, last)
# endif
case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
#endif
@ -1319,7 +1307,7 @@ scm_array_set_x (v, obj, args)
SCM_ASRTGO (SCM_INUMP (obj), badobj);
((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
break;
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x);
break;
@ -1349,18 +1337,19 @@ scm_array_set_x (v, obj, args)
return SCM_UNSPECIFIED;
}
/* extract an array from "ra" (regularised?), which may be an smob type.
returns #f on failure. */
SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);
SCM
scm_array_contents (ra, strict)
SCM ra;
SCM strict;
SCM strict; /* more checks if not SCM_UNDEFINED. */
{
SCM sra;
if (SCM_IMP (ra))
return SCM_BOOL_F;
switch SCM_TYP7
(ra)
switch SCM_TYP7 (ra)
{
default:
return SCM_BOOL_F;
@ -1375,7 +1364,7 @@ scm_array_contents (ra, strict)
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
return ra;
@ -1500,7 +1489,7 @@ loop:
case scm_tc7_svect:
sz = sizeof (short);
break;
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
@ -1650,7 +1639,7 @@ loop:
case scm_tc7_svect:
sz = sizeof (short);
break;
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
@ -1725,8 +1714,7 @@ scm_bit_count (item, seq)
long i;
register unsigned long cnt = 0, w;
SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count);
switch SCM_TYP7
(seq)
switch SCM_TYP7 (seq)
{
default:
scm_wta (seq, (char *) SCM_ARG2, s_bit_count);
@ -1768,8 +1756,7 @@ scm_bit_position (item, v, k)
k, SCM_OUTOFRANGE, s_bit_position);
if (pos == SCM_LENGTH (v))
return SCM_BOOL_F;
switch SCM_TYP7
(v)
switch SCM_TYP7 (v)
{
default:
scm_wta (v, (char *) SCM_ARG2, s_bit_position);
@ -1832,14 +1819,12 @@ scm_bit_set_star_x (v, kv, obj)
register long i, k, vlen;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
switch SCM_TYP7
(kv)
switch SCM_TYP7 (kv)
{
default:
badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x);
case scm_tc7_uvect:
switch SCM_TYP7
(v)
switch SCM_TYP7 (v)
{
default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x);
@ -1891,8 +1876,7 @@ scm_bit_count_star (v, kv, obj)
register unsigned long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
switch SCM_TYP7
(kv)
switch SCM_TYP7 (kv)
{
default:
badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star);
@ -2099,7 +2083,7 @@ scm_array_to_list (v)
res = scm_cons(SCM_MAKINUM (data[k]), res);
return res;
}
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: {
long_long *data;
data = (long_long *)SCM_VELTS(v);
@ -2243,8 +2227,7 @@ rapr1 (ra, j, k, port, pstate)
long n = SCM_LENGTH (ra);
int enclosed = 0;
tail:
switch SCM_TYP7
(ra)
switch SCM_TYP7 (ra)
{
case scm_tc7_smob:
if (enclosed++)
@ -2290,6 +2273,7 @@ tail:
ra = SCM_ARRAY_V (ra);
goto tail;
default:
/* scm_tc7_bvect and scm_tc7_llvect only? */
if (n-- > 0)
scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
for (j += inc; n-- > 0; j += inc)
@ -2322,6 +2306,22 @@ tail:
break;
case scm_tc7_uvect:
{
char str[11];
if (n-- > 0)
{
/* intprint can't handle >= 2^31. */
sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
scm_puts (str, port);
}
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
scm_puts (str, port);
}
}
case scm_tc7_ivect:
if (n-- > 0)
scm_intprint (SCM_VELTS (ra)[j], 10, port);
@ -2405,8 +2405,7 @@ scm_raprin1 (exp, port, pstate)
scm_sizet base = 0;
scm_putc ('#', port);
tail:
switch SCM_TYP7
(v)
switch SCM_TYP7 (v)
{
case scm_tc7_smob:
{
@ -2471,9 +2470,9 @@ tail:
case scm_tc7_svect:
scm_putc ('h', port);
break;
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
scm_puts ("long_long", port);
scm_putc ('l', port);
break;
#endif
#ifdef SCM_FLOATS
@ -2531,7 +2530,7 @@ loop:
return SCM_MAKINUM (-1L);
case scm_tc7_svect:
return SCM_CDR (scm_intern ("s", 1));
#ifdef LONGLONGS
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return SCM_CDR (scm_intern ("l", 1));
#endif