+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.
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.
+
\f
Changes since Guile 1.3.2:
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__
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>
+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.
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
+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
(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))
(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))
+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
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:
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);
}
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
subr,
message,
args,
- scm_listify (SCM_MAKINUM (eno), SCM_UNDEFINED));
+ scm_cons (SCM_MAKINUM (eno), SCM_EOL));
}
void
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
}
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);
}
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);
}
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);
}
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 ()
{
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:
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
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;
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));
}
}
#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);
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);
return ans;
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
SCM
scm_long_long2big (n)
}
#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);
}
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
SCM
scm_long_long2num (sl)
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)
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
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);
}
# 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)
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);
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:
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:
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;
{
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 */
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:
+ 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:
+ {
+ 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)
- scm_array_set_x (ra, fill, SCM_MAKINUM (i));
+ ve[i] = f;
break;
- case scm_tc7_vector:
- case scm_tc7_wvect:
+ }
+ 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)
- SCM_VELTS (ra)[i] = fill;
+ ve[i] = f;
break;
- case scm_tc7_string:
- SCM_ASRTGO (SCM_ICHRP (fill), badarg2);
+ }
+ 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)
- SCM_CHARS (ra)[i] = SCM_ICHR (fill);
+ ve[i] = f;
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);
+ }
+#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)
- SCM_CHARS (ra)[i] = SCM_INUM (fill);
+ ve[i] = f;
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
- 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;
- }
+ }
#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;
- }
+ 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_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;
}
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:
return 0;
return 1;
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
{
long long *v0 = (long long *) SCM_VELTS (ra0) + i0;
\f
+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));
\f
-
-
-\f
-
-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 */
#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
* double dvect
* complex double cvect
* short svect
- * long_long llvect
+ * long long llvect
*/
long scm_tc16_array;
case scm_tc7_svect:
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
i = sizeof (short) * k;
type = scm_tc7_svect;
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
else if (s == 'l')
{
i = sizeof (long_long) * k;
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))
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;
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));
&& 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)
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:
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);
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)
{
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
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));
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)),
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;
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:
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
scm_sizet pos;
SCM last;
{
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
# 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
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;
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;
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;
case scm_tc7_svect:
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
case scm_tc7_svect:
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
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);
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);
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);
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);
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);
long n = SCM_LENGTH (ra);
int enclosed = 0;
tail:
- switch SCM_TYP7
- (ra)
+ switch SCM_TYP7 (ra)
{
case scm_tc7_smob:
if (enclosed++)
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)
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);
scm_sizet base = 0;
scm_putc ('#', port);
tail:
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
case scm_tc7_smob:
{
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
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
HCoop / bpt / guile.git / commitdiff