mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +02:00
Code Activity

* *.c: Pervasive software-engineering-motivated rewrite of

Browse source 
function headers and argument checking.  Switched SCM_PROC,
SCM_PROC1 macros to be GUILE_PROC, GUILE_PROC1 (may change names
later, but was useful to keep old versions around while migrate)
that has docstrings and argument lists embedded in the GUILE_PROC
macro invocations that expand into a function header.  Use lots of
new SCM_VALIDATE_* macros to simplify error checking and reduce
tons of redundancy.  This is very similar to what I did for Scwm.

Note that none of the extraction of the docstrings, nor software
engineering checks of Scwm is yet added to Guile.  I'll work on
that tomorrow, I expect.

* Makefile.am: Added scm_validate.h to modinclude_HEADERS.

* chars.c: Added docstrings for the primitives defined in here.

* snarf.h:  Added GUILE_PROC, GUILE_PROC1.  Added
SCM_REGISTER_PROC to be like old SCM_PROC, though old SCM_PROC
still remains for now.  Changed naming convention for the s_foo
string name of the primitive to be s_scm_foo for ease of use with
the macro.

* scm_validate.h: Lots of new SCM_VALIDATE macros to simplify
argument checking through guile.  Maybe some of these should be
folded into the header file for the types they check, but for now
it was easiest to just stick them all in one place.
This commit is contained in:
Greg J. Badros 1999-12-12 02:36:16 +00:00
parent 6e7069385d
commit 1bbd0b849f
78 changed files with 5264 additions and 6035 deletions
Download patch file Download diff file Expand all files Collapse all files

41
libguile/ChangeLog
View file

@ -1,3 +1,44 @@
Sat Dec 11 18:34:12 1999 Greg J. Badros <gjb@cs.washington.edu>
* Makefile.am: Added scm_validate.h to modinclude_HEADERS.
* *.c: Pervasive software-engineering-motivated rewrite of
function headers and argument checking. Switched SCM_PROC,
SCM_PROC1 macros to be GUILE_PROC, GUILE_PROC1 (may change names
later, but was useful to keep old versions around while migrate)
that has docstrings and argument lists embedded in the GUILE_PROC
macro invocations that expand into a function header. Use lots of
new SCM_VALIDATE_* macros to simplify error checking and reduce
tons of redundancy. This is very similar to what I did for Scwm.
Note that none of the extraction of the docstrings, nor software
engineering checks of Scwm is yet added to Guile. I'll work on
that tomorrow, I expect.
* chars.c: Added docstrings for the primitives defined in here.
* snarf.h: Added GUILE_PROC, GUILE_PROC1. Added
SCM_REGISTER_PROC to be like old SCM_PROC, though old SCM_PROC
still remains for now. Changed naming convention for the s_foo
string name of the primitive to be s_scm_foo for ease of use with
the macro.
* scm_validate.h: Lots of new SCM_VALIDATE macros to simplify
argument checking through guile. Maybe some of these should be
folded into the header file for the types they check, but for now
it was easiest to just stick them all in one place.
1999-12-10 Greg Harvey <Greg.Harvey@thezone.net> (applied --12/10/99 gjb)
* smob.c (scm_smob_prehistory): initialize allocated smob
* tags.h: new tag: scm_tc16_allocated
* gc.c (scm_gc_for_newcell): set the car of the new cell
to scm_tc16_allocated
* pairs.h (SCM_NEWCELL): set the car to scm_tc16_allocated
(scm_gc_mark): mark allocated cells.
1999-12-09 Greg J. Badros <gjb@cs.washington.edu>
* strports.h, strports.c (scm_eval_0str): Fix constness. Some

2
libguile/Makefile.am
View file

@ -93,7 +93,7 @@ modinclude_HEADERS = \
ioext.h keywords.h kw.h lang.h list.h load.h macros.h mallocs.h \
modules.h net_db.h numbers.h objects.h objprop.h options.h pairs.h \
ports.h posix.h regex-posix.h print.h procprop.h procs.h random.h \
ramap.h read.h root.h scmsigs.h script.h simpos.h smob.h socket.h \
ramap.h read.h root.h scmsigs.h scm_validate.h script.h simpos.h smob.h socket.h \
sort.h srcprop.h stackchk.h stacks.h stime.h strings.h strop.h \
strorder.h strports.h struct.h symbols.h tag.h tags.h throw.h \
unif.h variable.h vectors.h version.h vports.h weaks.h snarf.h \

219
libguile/alist.c
View file

@ -38,23 +38,25 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "eq.h"
#include "list.h"
#include "scm_validate.h"
#include "alist.h"
SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons);
SCM
scm_acons (w, x, y)
SCM w;
SCM x;
SCM y;
GUILE_PROC(scm_acons, "acons", 3, 0, 0,
(SCM w, SCM x, SCM y),
"")
#define FUNC_NAME s_scm_acons
{
register SCM z;
SCM_NEWCELL (z);
@ -66,15 +68,14 @@ scm_acons (w, x, y)
SCM_SETCDR (z, y);
return z;
}
#undef FUNC_NAME
SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq);
SCM
scm_sloppy_assq(x, alist)
SCM x;
SCM alist;
GUILE_PROC (scm_sloppy_assq, "sloppy-assq", 2, 0, 0,
(SCM x, SCM alist),
"")
#define FUNC_NAME s_scm_sloppy_assq
{
for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
@ -85,15 +86,14 @@ scm_sloppy_assq(x, alist)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_sloppy_assv, "sloppy-assv", 2, 0, 0, scm_sloppy_assv);
SCM
scm_sloppy_assv(x, alist)
SCM x;
SCM alist;
GUILE_PROC (scm_sloppy_assv, "sloppy-assv", 2, 0, 0,
(SCM x, SCM alist),
"")
#define FUNC_NAME s_scm_sloppy_assv
{
for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
{
@ -105,14 +105,13 @@ scm_sloppy_assv(x, alist)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_sloppy_assoc, "sloppy-assoc", 2, 0, 0, scm_sloppy_assoc);
SCM
scm_sloppy_assoc(x, alist)
SCM x;
SCM alist;
GUILE_PROC (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0,
(SCM x, SCM alist),
"")
#define FUNC_NAME s_scm_sloppy_assoc
{
for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
{
@ -124,35 +123,31 @@ scm_sloppy_assoc(x, alist)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC(s_assq, "assq", 2, 0, 0, scm_assq);
SCM
scm_assq(x, alist)
SCM x;
SCM alist;
GUILE_PROC(scm_assq, "assq", 2, 0, 0,
(SCM x, SCM alist),
"")
#define FUNC_NAME s_scm_assq
{
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assq);
tmp = SCM_CAR(alist);
SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assq);
if (SCM_CAR(tmp)==x) return tmp;
}
SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assq);
return SCM_BOOL_F;
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
SCM_VALIDATE_ALISTCELL_COPYSCM(2,alist,tmp);
if (SCM_CAR(tmp)==x) return tmp;
}
SCM_VALIDATE_NULL(2,alist);
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC(s_assv, "assv", 2, 0, 0, scm_assv);
SCM
scm_assv(x, alist)
SCM x;
SCM alist;
GUILE_PROC(scm_assv, "assv", 2, 0, 0,
(SCM x, SCM alist),
"")
#define FUNC_NAME s_scm_assv
{
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
@ -163,39 +158,35 @@ scm_assv(x, alist)
}
# ifndef SCM_RECKLESS
if (!(SCM_NULLP(alist)))
badlst: scm_wta(alist, (char *)SCM_ARG2, s_assv);
badlst: scm_wta(alist, (char *)SCM_ARG2, FUNC_NAME);
# endif
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC(s_assoc, "assoc", 2, 0, 0, scm_assoc);
SCM
scm_assoc(x, alist)
SCM x;
SCM alist;
GUILE_PROC(scm_assoc, "assoc", 2, 0, 0,
(SCM x, SCM alist),
"")
#define FUNC_NAME s_scm_assoc
{
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assoc);
tmp = SCM_CAR(alist);
SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assoc);
if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp;
}
SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assoc);
return SCM_BOOL_F;
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
SCM_VALIDATE_ALISTCELL_COPYSCM(2,alist,tmp);
if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp;
}
SCM_VALIDATE_NULL(2,alist);
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_assq_ref, "assq-ref", 2, 0, 0, scm_assq_ref);
SCM
scm_assq_ref (alist, key)
SCM alist;
SCM key;
GUILE_PROC (scm_assq_ref, "assq-ref", 2, 0, 0,
(SCM alist, SCM key),
"")
#define FUNC_NAME s_scm_assq_ref
{
SCM handle;
@ -206,14 +197,13 @@ scm_assq_ref (alist, key)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_assv_ref, "assv-ref", 2, 0, 0, scm_assv_ref);
SCM
scm_assv_ref (alist, key)
SCM alist;
SCM key;
GUILE_PROC (scm_assv_ref, "assv-ref", 2, 0, 0,
(SCM alist, SCM key),
"")
#define FUNC_NAME s_scm_assv_ref
{
SCM handle;
@ -224,14 +214,13 @@ scm_assv_ref (alist, key)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_assoc_ref, "assoc-ref", 2, 0, 0, scm_assoc_ref);
SCM
scm_assoc_ref (alist, key)
SCM alist;
SCM key;
GUILE_PROC (scm_assoc_ref, "assoc-ref", 2, 0, 0,
(SCM alist, SCM key),
"")
#define FUNC_NAME s_scm_assoc_ref
{
SCM handle;
@ -242,19 +231,17 @@ scm_assoc_ref (alist, key)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_assq_set_x, "assq-set!", 3, 0, 0, scm_assq_set_x);
SCM
scm_assq_set_x (alist, key, val)
SCM alist;
SCM key;
SCM val;
GUILE_PROC (scm_assq_set_x, "assq-set!", 3, 0, 0,
(SCM alist, SCM key, SCM val),
"")
#define FUNC_NAME s_scm_assq_set_x
{
SCM handle;
@ -267,14 +254,12 @@ scm_assq_set_x (alist, key, val)
else
return scm_acons (key, val, alist);
}
#undef FUNC_NAME
SCM_PROC (s_assv_set_x, "assv-set!", 3, 0, 0, scm_assv_set_x);
SCM
scm_assv_set_x (alist, key, val)
SCM alist;
SCM key;
SCM val;
GUILE_PROC (scm_assv_set_x, "assv-set!", 3, 0, 0,
(SCM alist, SCM key, SCM val),
"")
#define FUNC_NAME s_scm_assv_set_x
{
SCM handle;
@ -287,14 +272,12 @@ scm_assv_set_x (alist, key, val)
else
return scm_acons (key, val, alist);
}
#undef FUNC_NAME
SCM_PROC (s_assoc_set_x, "assoc-set!", 3, 0, 0, scm_assoc_set_x);
SCM
scm_assoc_set_x (alist, key, val)
SCM alist;
SCM key;
SCM val;
GUILE_PROC (scm_assoc_set_x, "assoc-set!", 3, 0, 0,
(SCM alist, SCM key, SCM val),
"")
#define FUNC_NAME s_scm_assoc_set_x
{
SCM handle;
@ -307,16 +290,15 @@ scm_assoc_set_x (alist, key, val)
else
return scm_acons (key, val, alist);
}
#undef FUNC_NAME
SCM_PROC (s_assq_remove_x, "assq-remove!", 2, 0, 0, scm_assq_remove_x);
SCM
scm_assq_remove_x (alist, key)
SCM alist;
SCM key;
GUILE_PROC (scm_assq_remove_x, "assq-remove!", 2, 0, 0,
(SCM alist, SCM key),
"")
#define FUNC_NAME s_scm_assq_remove_x
{
SCM handle;
@ -328,14 +310,13 @@ scm_assq_remove_x (alist, key)
else
return alist;
}
#undef FUNC_NAME
SCM_PROC (s_assv_remove_x, "assv-remove!", 2, 0, 0, scm_assv_remove_x);
SCM
scm_assv_remove_x (alist, key)
SCM alist;
SCM key;
GUILE_PROC (scm_assv_remove_x, "assv-remove!", 2, 0, 0,
(SCM alist, SCM key),
"")
#define FUNC_NAME s_scm_assv_remove_x
{
SCM handle;
@ -347,14 +328,13 @@ scm_assv_remove_x (alist, key)
else
return alist;
}
#undef FUNC_NAME
SCM_PROC (s_assoc_remove_x, "assoc-remove!", 2, 0, 0, scm_assoc_remove_x);
SCM
scm_assoc_remove_x (alist, key)
SCM alist;
SCM key;
GUILE_PROC (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0,
(SCM alist, SCM key),
"")
#define FUNC_NAME s_scm_assoc_remove_x
{
SCM handle;
@ -366,6 +346,7 @@ scm_assoc_remove_x (alist, key)
else
return alist;
}
#undef FUNC_NAME

44
libguile/arbiters.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -45,6 +49,7 @@
#include "smob.h"
#include "genio.h"
#include "scm_validate.h"
#include "arbiters.h"
@ -59,10 +64,7 @@ static long scm_tc16_arbiter;
static int
prinarb (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
prinarb (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<arbiter ", port);
if (SCM_CAR (exp) & (1L << 16))
@ -72,22 +74,21 @@ prinarb (exp, port, pstate)
return !0;
}
SCM_PROC(s_make_arbiter, "make-arbiter", 1, 0, 0, scm_make_arbiter);
SCM
scm_make_arbiter (name)
SCM name;
GUILE_PROC(scm_make_arbiter, "make-arbiter", 1, 0, 0,
(SCM name),
"")
#define FUNC_NAME s_scm_make_arbiter
{
SCM_RETURN_NEWSMOB (scm_tc16_arbiter, name);
}
#undef FUNC_NAME
SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter);
SCM
scm_try_arbiter (arb)
SCM arb;
GUILE_PROC(scm_try_arbiter, "try-arbiter", 1, 0, 0,
(SCM arb),
"")
#define FUNC_NAME s_scm_try_arbiter
{
SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_try_arbiter);
SCM_VALIDATE_SMOB(1,arb,arbiter);
SCM_DEFER_INTS;
if (SCM_CAR (arb) & (1L << 16))
arb = SCM_BOOL_F;
@ -99,20 +100,21 @@ scm_try_arbiter (arb)
SCM_ALLOW_INTS;
return arb;
}
#undef FUNC_NAME
SCM_PROC(s_release_arbiter, "release-arbiter", 1, 0, 0, scm_release_arbiter);
SCM
scm_release_arbiter (arb)
SCM arb;
GUILE_PROC(scm_release_arbiter, "release-arbiter", 1, 0, 0,
(SCM arb),
"")
#define FUNC_NAME s_scm_release_arbiter
{
SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_release_arbiter);
SCM_VALIDATE_SMOB(1,arb,arbiter);
if (!(SCM_CAR (arb) & (1L << 16)))
return SCM_BOOL_F;
SCM_SETCAR (arb, scm_tc16_arbiter);
return SCM_BOOL_T;
}
#undef FUNC_NAME

136
libguile/async.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -47,6 +51,7 @@
#include "throw.h"
#include "smob.h"
#include "scm_validate.h"
#include "async.h"
#ifdef HAVE_STRING_H
@ -123,9 +128,8 @@ scm_asyncs_pending ()
}
#if 0
static SCM scm_sys_tick_async_thunk SCM_P ((void));
static SCM
scm_sys_tick_async_thunk ()
scm_sys_tick_async_thunk (void)
{
scm_deliver_signal (SCM_TICK_SIGNAL);
return SCM_BOOL_F;
@ -263,11 +267,8 @@ scm_switch ()
static SCM mark_async SCM_P ((SCM obj));
static SCM
mark_async (obj)
SCM obj;
mark_async (SCM obj)
{
struct scm_async * it;
it = SCM_ASYNC (obj);
@ -276,24 +277,23 @@ mark_async (obj)
SCM_PROC(s_async, "async", 1, 0, 0, scm_async);
SCM
scm_async (thunk)
SCM thunk;
GUILE_PROC(scm_async, "async", 1, 0, 0,
(SCM thunk),
"")
#define FUNC_NAME s_scm_async
{
struct scm_async * async
= (struct scm_async *) scm_must_malloc (sizeof (*async), s_async);
= (struct scm_async *) scm_must_malloc (sizeof (*async), FUNC_NAME);
async->got_it = 0;
async->thunk = thunk;
SCM_RETURN_NEWSMOB (scm_tc16_async, async);
}
#undef FUNC_NAME
SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async);
SCM
scm_system_async (thunk)
SCM thunk;
GUILE_PROC(scm_system_async, "system-async", 1, 0, 0,
(SCM thunk),
"")
#define FUNC_NAME s_scm_system_async
{
SCM it;
SCM list;
@ -303,30 +303,28 @@ scm_system_async (thunk)
scm_asyncs = list;
return it;
}
#undef FUNC_NAME
SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark);
SCM
scm_async_mark (a)
SCM a;
GUILE_PROC(scm_async_mark, "async-mark", 1, 0, 0,
(SCM a),
"")
#define FUNC_NAME s_scm_async_mark
{
struct scm_async * it;
SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
it = SCM_ASYNC (a);
SCM_VALIDATE_ASYNC_COPY(1,a,it);
it->got_it = 1;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark);
SCM
scm_system_async_mark (a)
SCM a;
GUILE_PROC(scm_system_async_mark, "system-async-mark", 1, 0, 0,
(SCM a),
"")
#define FUNC_NAME s_scm_system_async_mark
{
struct scm_async * it;
SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
it = SCM_ASYNC (a);
SCM_VALIDATE_ASYNC_COPY(1,a,it);
SCM_REDEFER_INTS;
it->got_it = 1;
scm_async_rate = 1 + scm_async_rate - scm_async_clock;
@ -334,26 +332,23 @@ scm_system_async_mark (a)
SCM_REALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs);
SCM
scm_run_asyncs (list_of_a)
SCM list_of_a;
GUILE_PROC(scm_run_asyncs, "run-asyncs", 1, 0, 0,
(SCM list_of_a),
"")
#define FUNC_NAME s_scm_run_asyncs
{
SCM pos;
if (scm_mask_ints)
return SCM_BOOL_F;
pos = list_of_a;
while (pos != SCM_EOL)
while (list_of_a != SCM_EOL)
{
SCM a;
struct scm_async * it;
SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs);
a = SCM_CAR (pos);
SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs);
SCM_VALIDATE_NIMCONS(1,list_of_a);
a = SCM_CAR (list_of_a);
SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, FUNC_NAME);
it = SCM_ASYNC (a);
scm_mask_ints = 1;
if (it->got_it)
@ -362,60 +357,61 @@ scm_run_asyncs (list_of_a)
scm_apply (it->thunk, SCM_EOL, SCM_EOL);
}
scm_mask_ints = 0;
pos = SCM_CDR (pos);
list_of_a = SCM_CDR (list_of_a);
}
return SCM_BOOL_T;
}
#undef FUNC_NAME
SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop);
SCM
scm_noop (args)
SCM args;
GUILE_PROC(scm_noop, "noop", 0, 0, 1,
(SCM args),
"")
#define FUNC_NAME s_scm_noop
{
return (SCM_NULLP (args)
? SCM_BOOL_F
: SCM_CAR (args));
}
#undef FUNC_NAME
SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate);
SCM
scm_set_tick_rate (n)
SCM n;
GUILE_PROC(scm_set_tick_rate, "set-tick-rate", 1, 0, 0,
(SCM n),
"")
#define FUNC_NAME s_scm_set_tick_rate
{
unsigned int old_n;
SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate);
SCM_VALIDATE_INT(1,n);
old_n = scm_tick_rate;
scm_desired_tick_rate = SCM_INUM (n);
scm_async_rate = 1 + scm_async_rate - scm_async_clock;
scm_async_clock = 1;
return SCM_MAKINUM (old_n);
}
#undef FUNC_NAME
SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate);
SCM
scm_set_switch_rate (n)
SCM n;
GUILE_PROC(scm_set_switch_rate, "set-switch-rate", 1, 0, 0,
(SCM n),
"")
#define FUNC_NAME s_scm_set_switch_rate
{
unsigned int old_n;
SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate);
SCM_VALIDATE_INT(1,n);
old_n = scm_switch_rate;
scm_desired_switch_rate = SCM_INUM (n);
scm_async_rate = 1 + scm_async_rate - scm_async_clock;
scm_async_clock = 1;
return SCM_MAKINUM (old_n);
}
#undef FUNC_NAME
@ -442,24 +438,26 @@ scm_sys_gc_async_thunk (void)
SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals);
SCM
scm_unmask_signals ()
GUILE_PROC(scm_unmask_signals, "unmask-signals", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_unmask_signals
{
scm_mask_ints = 0;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals);
SCM
scm_mask_signals ()
GUILE_PROC(scm_mask_signals, "mask-signals", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_mask_signals
{
scm_mask_ints = 1;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

112
libguile/backtrace.c
View file

@ -43,6 +43,10 @@
* The author can be reached at djurfeldt@nada.kth.se
* Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include <ctype.h>
@ -77,11 +81,8 @@
SCM scm_the_last_stack_fluid;
static void display_header SCM_P ((SCM source, SCM port));
static void
display_header (source, port)
SCM source;
SCM port;
display_header (SCM source, SCM port)
{
SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source)
? scm_source_property (source, scm_sym_filename)
@ -147,13 +148,8 @@ scm_display_error_message (message, args, port)
scm_putc ('\n', port);
}
static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
static void
display_expression (frame, pname, source, port)
SCM frame;
SCM pname;
SCM source;
SCM port;
display_expression (SCM frame,SCM pname,SCM source,SCM port)
{
SCM print_state = scm_make_print_state ();
scm_print_state *pstate = SCM_PRINT_STATE (print_state);
@ -255,15 +251,10 @@ display_error_handler (struct display_error_handler_data *data,
return SCM_UNSPECIFIED;
}
SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
SCM
scm_display_error (stack, port, subr, message, args, rest)
SCM stack;
SCM port;
SCM subr;
SCM message;
SCM args;
SCM rest;
GUILE_PROC(scm_display_error, "display-error", 6, 0, 0,
(SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest),
"")
#define FUNC_NAME s_scm_display_error
{
struct display_error_args a;
struct display_error_handler_data data;
@ -280,6 +271,7 @@ scm_display_error (stack, port, subr, message, args, rest)
(scm_catch_handler_t) display_error_handler, &data);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
typedef struct {
int level;
@ -296,15 +288,14 @@ static print_params_t default_print_params[] = {
static print_params_t *print_params = default_print_params;
#ifdef GUILE_DEBUG
SCM_PROC (s_set_print_params_x, "set-print-params!", 1, 0, 0, scm_set_print_params_x);
SCM
scm_set_print_params_x (SCM params)
GUILE_PROC(set_print_params_x, "set-print-params!", 1, 0, 0,
(SCM params)
#define FUNC_NAME s_set_print_params_x
{
int i, n = scm_ilength (params);
SCM ls;
print_params_t *new_params;
SCM_ASSERT (n >= 1, params, SCM_ARG2, s_set_print_params_x);
SCM_ASSERT (n >= 1, params, SCM_ARG2, FUNC_NAME);
for (ls = params; SCM_NIMP (ls); ls = SCM_CDR (ls))
SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2
&& SCM_INUMP (SCM_CAAR (ls))
@ -315,7 +306,7 @@ scm_set_print_params_x (SCM params)
SCM_ARG2,
s_set_print_params_x);
new_params = scm_must_malloc (n * sizeof (print_params_t),
s_set_print_params_x);
FUNC_NAME);
if (print_params != default_print_params)
scm_must_free (print_params);
print_params = new_params;
@ -328,29 +319,19 @@ scm_set_print_params_x (SCM params)
n_print_params = n;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif
static void indent SCM_P ((int n, SCM port));
static void
indent (n, port)
int n;
SCM port;
indent (int n, SCM port)
{
int i;
for (i = 0; i < n; ++i)
scm_putc (' ', port);
}
static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
static void
display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
char *hdr;
SCM exp;
char *tlr;
int indentation;
SCM sport;
SCM port;
scm_print_state *pstate;
display_frame_expr (char *hdr,SCM exp,char *tlr,int indentation,SCM sport,SCM port,scm_print_state *pstate)
{
SCM string;
int i = 0, n;
@ -391,14 +372,8 @@ display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
scm_lfwrite (SCM_CHARS (string), n, port);
}
static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate));
static void
display_application (frame, indentation, sport, port, pstate)
SCM frame;
int indentation;
SCM sport;
SCM port;
scm_print_state *pstate;
display_application (SCM frame,int indentation,SCM sport,SCM port,scm_print_state *pstate)
{
SCM proc = SCM_FRAME_PROC (frame);
SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
@ -414,10 +389,10 @@ display_application (frame, indentation, sport, port, pstate)
pstate);
}
SCM_PROC(s_display_application, "display-application", 1, 2, 0, scm_display_application);
SCM
scm_display_application (SCM frame, SCM port, SCM indent)
GUILE_PROC(scm_display_application, "display-application", 1, 2, 0,
(SCM frame, SCM port, SCM indent),
"")
#define FUNC_NAME s_scm_display_application
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame, SCM_ARG1, s_display_application);
@ -442,7 +417,7 @@ scm_display_application (SCM frame, SCM port, SCM indent)
scm_make_string (SCM_MAKINUM (240),
SCM_UNDEFINED),
SCM_OPN | SCM_WRTNG,
s_display_application);
FUNC_NAME);
/* Create a print state for printing of frames. */
print_state = scm_make_print_state ();
@ -456,16 +431,10 @@ scm_display_application (SCM frame, SCM port, SCM indent)
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
static void
display_frame (frame, nfield, indentation, sport, port, pstate)
SCM frame;
int nfield;
int indentation;
SCM sport;
SCM port;
scm_print_state *pstate;
display_frame (SCM frame,int nfield,int indentation,SCM sport,SCM port,scm_print_state *pstate)
{
int n, i, j;
@ -530,10 +499,9 @@ struct display_backtrace_args {
SCM depth;
};
SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
static SCM
display_backtrace_body (struct display_backtrace_args *a)
display_backtrace_body(struct display_backtrace_args *a)
#define FUNC_NAME "display_backtrace_body"
{
int n_frames, beg, end, n, i, j;
int nfield, indent_p, indentation;
@ -586,7 +554,7 @@ display_backtrace_body (struct display_backtrace_args *a)
sport = scm_mkstrport (SCM_INUM0,
scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
SCM_OPN | SCM_WRTNG,
s_display_backtrace);
FUNC_NAME);
/* Create a print state for printing of frames. */
print_state = scm_make_print_state ();
@ -635,13 +603,12 @@ display_backtrace_body (struct display_backtrace_args *a)
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM
scm_display_backtrace (stack, port, first, depth)
SCM stack;
SCM port;
SCM first;
SCM depth;
GUILE_PROC(scm_display_backtrace, "display-backtrace", 2, 2, 0,
(SCM stack, SCM port, SCM first, SCM depth),
"")
#define FUNC_NAME s_scm_display_backtrace
{
struct display_backtrace_args a;
struct display_error_handler_data data;
@ -656,12 +623,14 @@ scm_display_backtrace (stack, port, first, depth)
(scm_catch_handler_t) display_error_handler, &data);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
SCM
scm_backtrace ()
GUILE_PROC(scm_backtrace, "backtrace", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_backtrace
{
SCM the_last_stack = scm_fluid_ref (SCM_CDR (scm_the_last_stack_fluid));
if (SCM_NFALSEP (the_last_stack))
@ -689,6 +658,7 @@ scm_backtrace ()
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

31
libguile/boolean.c
View file

@ -38,35 +38,38 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "scm_validate.h"
#include "boolean.h"
SCM_PROC(s_not, "not", 1, 0, 0, scm_not);
SCM
scm_not(x)
SCM x;
GUILE_PROC(scm_not, "not", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_not
{
return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC(s_boolean_p, "boolean?", 1, 0, 0, scm_boolean_p);
SCM
scm_boolean_p(obj)
SCM obj;
GUILE_PROC(scm_boolean_p, "boolean?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_boolean_p
{
if (SCM_BOOL_F==obj) return SCM_BOOL_T;
if (SCM_BOOL_T==obj) return SCM_BOOL_T;
return SCM_BOOL_F;
return SCM_BOOL(SCM_BOOL_F == obj || SCM_BOOL_T == obj);
}
#undef FUNC_NAME

332
libguile/chars.c
View file

@ -38,263 +38,259 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include <ctype.h>
#include "_scm.h"
#include "scm_validate.h"
#include "chars.h"
SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p);
SCM
scm_char_p(x)
SCM x;
GUILE_PROC (scm_char_p, "char?", 1, 0, 0,
(SCM x),
"Return #t iff X is a character, else #f.")
#define FUNC_NAME s_scm_char_p
{
return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p);
SCM
scm_char_eq_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is the same character as Y, else #f.")
#define FUNC_NAME s_scm_char_eq_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p);
return (SCM_ICHR(x) == SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(SCM_ICHR(x) == SCM_ICHR(y));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_less_p, "char<?", scm_tc7_rpsubr, scm_char_less_p);
SCM
scm_char_less_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is less than Y in the Ascii sequence, else #f.")
#define FUNC_NAME s_scm_char_less_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_p);
return (SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(SCM_ICHR(x) < SCM_ICHR(y));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p);
SCM
scm_char_leq_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is less than or equal to Y in the Ascii sequence, else #f.")
#define FUNC_NAME s_scm_char_leq_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_p);
return (SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(SCM_ICHR(x) <= SCM_ICHR(y));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_gr_p, "char>?", scm_tc7_rpsubr, scm_char_gr_p);
SCM
scm_char_gr_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is greater than Y in the Ascii sequence, else #f.")
#define FUNC_NAME s_scm_char_gr_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p);
return (SCM_ICHR(x) > SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(SCM_ICHR(x) > SCM_ICHR(y));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p);
SCM
scm_char_geq_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is greater than or equal to Y in the Ascii sequence, else #f.")
#define FUNC_NAME s_scm_char_geq_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p);
return (SCM_ICHR(x) >= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(SCM_ICHR(x) >= SCM_ICHR(y));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p);
SCM
scm_char_ci_eq_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is the same character as Y ignoring case, else #f.")
#define FUNC_NAME s_scm_char_ci_eq_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p);
return (scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y)));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, scm_char_ci_less_p);
SCM
scm_char_ci_less_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is less than Y in the Ascii sequence ignoring case, else #f.")
#define FUNC_NAME s_scm_char_ci_less_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_p);
return (scm_upcase(SCM_ICHR(x)) < scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL((scm_upcase(SCM_ICHR(x))) < scm_upcase(SCM_ICHR(y)));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p);
SCM
scm_char_ci_leq_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is less than or equal to Y in the Ascii sequence ignoring case, else #f.")
#define FUNC_NAME s_scm_char_ci_leq_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_p);
return (scm_upcase(SCM_ICHR(x)) <= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(scm_upcase(SCM_ICHR(x)) <= scm_upcase(SCM_ICHR(y)));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, scm_char_ci_gr_p);
SCM
scm_char_ci_gr_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is greater than Y in the Ascii sequence ignoring case, else #f.")
#define FUNC_NAME s_scm_char_ci_gr_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p);
return (scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y)));
}
#undef FUNC_NAME
SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p);
SCM
scm_char_ci_geq_p(x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return #t iff X is greater than or equal to Y in the Ascii sequence ignoring case, else #f.")
#define FUNC_NAME s_scm_char_ci_geq_p
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p);
return (scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,x);
SCM_VALIDATE_CHAR(2,y);
return SCM_BOOL(scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y)));
}
#undef FUNC_NAME
SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p);
SCM
scm_char_alphabetic_p(chr)
SCM chr;
GUILE_PROC(scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0,
(SCM chr),
"Return #t iff CHR is alphabetic, else #f.
Alphabetic means the same thing as the isalpha C library function.")
#define FUNC_NAME s_scm_char_alphabetic_p
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p);
return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,chr);
return SCM_BOOL(isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr)));
}
#undef FUNC_NAME
SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p);
SCM
scm_char_numeric_p(chr)
SCM chr;
GUILE_PROC(scm_char_numeric_p, "char-numeric?", 1, 0, 0,
(SCM chr),
"Return #t iff CHR is numeric, else #f.
Numeric means the same thing as the isdigit C library function.")
#define FUNC_NAME s_scm_char_numeric_p
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p);
return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,chr);
return SCM_BOOL(isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr)));
}
#undef FUNC_NAME
SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p);
SCM
scm_char_whitespace_p(chr)
SCM chr;
GUILE_PROC(scm_char_whitespace_p, "char-whitespace?", 1, 0, 0,
(SCM chr),
"Return #t iff CHR is whitespace, else #f.
Whitespace means the same thing as the isspace C library function.")
#define FUNC_NAME s_scm_char_whitespace_p
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p);
return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,chr);
return SCM_BOOL(isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr)));
}
#undef FUNC_NAME
SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p);
SCM
scm_char_upper_case_p(chr)
SCM chr;
GUILE_PROC(scm_char_upper_case_p, "char-upper-case?", 1, 0, 0,
(SCM chr),
"Return #t iff CHR is uppercase, else #f.
Uppercase means the same thing as the isupper C library function.")
#define FUNC_NAME s_scm_char_upper_case_p
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,chr);
return SCM_BOOL(isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr)));
}
#undef FUNC_NAME
SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p);
SCM
scm_char_lower_case_p(chr)
SCM chr;
GUILE_PROC(scm_char_lower_case_p, "char-lower-case?", 1, 0, 0,
(SCM chr),
"Return #t iff CHR is lowercase, else #f.
Lowercase means the same thing as the islower C library function.")
#define FUNC_NAME s_scm_char_lower_case_p
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p);
return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_CHAR(1,chr);
return SCM_BOOL(isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr)));
}
#undef FUNC_NAME
SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p);
SCM
scm_char_is_both_p (chr)
SCM chr;
GUILE_PROC (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
(SCM chr),
"Return #t iff CHR is either uppercase or lowercase, else #f.
Uppercase and lowercase are as defined by the isupper and islower
C library functions.")
#define FUNC_NAME s_scm_char_is_both_p
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr))))
? SCM_BOOL_T
: SCM_BOOL_F);
SCM_VALIDATE_CHAR(1,chr);
return SCM_BOOL(isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr))));
}
#undef FUNC_NAME
SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer);
SCM
scm_char_to_integer(chr)
SCM chr;
GUILE_PROC (scm_char_to_integer, "char->integer", 1, 0, 0,
(SCM chr),
"Return the number corresponding to ordinal position of CHR in the Ascii sequence.")
#define FUNC_NAME s_scm_char_to_integer
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer);
SCM_VALIDATE_CHAR(1,chr);
return scm_ulong2num((unsigned long)SCM_ICHR(chr));
}
#undef FUNC_NAME
SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char);
SCM
scm_integer_to_char(n)
SCM n;
GUILE_PROC(scm_integer_to_char, "integer->char", 1, 0, 0,
(SCM n),
"Return the character at position N in the Ascii sequence.")
#define FUNC_NAME s_scm_integer_to_char
{
unsigned long ni;
ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, s_integer_to_char);
return SCM_MAKICHR(SCM_INUM(n));
unsigned long ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, FUNC_NAME);
return SCM_MAKICHR(ni);
}
#undef FUNC_NAME
SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase);
SCM
scm_char_upcase(chr)
SCM chr;
GUILE_PROC(scm_char_upcase, "char-upcase", 1, 0, 0,
(SCM chr),
"Return the uppercase character version of CHR.")
#define FUNC_NAME s_scm_char_upcase
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase);
SCM_VALIDATE_CHAR(1,chr);
return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr)));
}
#undef FUNC_NAME
SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase);
SCM
scm_char_downcase(chr)
SCM chr;
GUILE_PROC(scm_char_downcase, "char-downcase", 1, 0, 0,
(SCM chr),
"Return the lowercase character version of CHR.")
#define FUNC_NAME s_scm_char_downcase
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase);
SCM_VALIDATE_CHAR(1,chr);
return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr)));
}
#undef FUNC_NAME

9
libguile/continuations.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -123,11 +127,8 @@ scm_make_cont (answer)
/* to copy in the continuation. Then */
#ifndef CHEAP_CONTINUATIONS
static void grow_throw SCM_P ((SCM *a));
static void
grow_throw (a)
SCM *a;
grow_throw (SCM *a)
{ /* retry the throw. */
SCM growth[100];
growth[0] = a[0];

281
libguile/debug.c
View file

@ -43,6 +43,10 @@
* The author can be reached at djurfeldt@nada.kth.se
* Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "eval.h"
@ -61,29 +65,29 @@
#include "dynwind.h"
#include "modules.h"
#include "scm_validate.h"
#include "debug.h"
/* {Run time control of the debugging evaluator}
*/
SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options);
SCM
scm_debug_options (setting)
SCM setting;
GUILE_PROC (scm_debug_options, "debug-options-interface", 0, 1, 0,
(SCM setting),
"")
#define FUNC_NAME s_scm_debug_options
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_debug_opts,
SCM_N_DEBUG_OPTIONS,
s_debug_options);
FUNC_NAME);
#ifndef SCM_RECKLESS
if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
{
scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options);
scm_out_of_range (s_debug_options, setting);
scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
scm_out_of_range (FUNC_NAME, setting);
}
#endif
SCM_RESET_DEBUG_MODE;
@ -92,8 +96,7 @@ scm_debug_options (setting)
SCM_ALLOW_INTS;
return ans;
}
SCM_PROC (s_with_traps, "with-traps", 1, 0, 0, scm_with_traps);
#undef FUNC_NAME
static void
with_traps_before (void *data)
@ -117,20 +120,20 @@ with_traps_inner (void *data)
return scm_apply (thunk, SCM_EOL, SCM_EOL);
}
SCM
scm_with_traps (SCM thunk)
GUILE_PROC (scm_with_traps, "with-traps", 1, 0, 0,
(SCM thunk),
"")
#define FUNC_NAME s_scm_with_traps
{
int trap_flag;
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
thunk,
SCM_ARG1,
s_with_traps);
SCM_VALIDATE_THUNK(1,thunk);
return scm_internal_dynamic_wind (with_traps_before,
with_traps_inner,
with_traps_after,
(void *) thunk,
&trap_flag);
}
#undef FUNC_NAME
static SCM scm_sym_source, scm_sym_dots;
@ -142,13 +145,8 @@ static SCM scm_sym_procname;
long scm_tc16_memoized;
static int prinmemoized SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
static int
prinmemoized (obj, port, pstate)
SCM obj;
SCM port;
scm_print_state *pstate;
prinmemoized (SCM obj,SCM port,scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<memoized ", port);
@ -163,19 +161,17 @@ prinmemoized (obj, port, pstate)
return 1;
}
SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p);
SCM
scm_memoized_p (obj)
SCM obj;
GUILE_PROC (scm_memoized_p, "memoized?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_memoized_p
{
return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_NIMP (obj) && SCM_MEMOIZEDP (obj));
}
#undef FUNC_NAME
SCM
scm_make_memoized (exp, env)
SCM exp;
SCM env;
scm_make_memoized (SCM exp, SCM env)
{
/* *fixme* Check that env is a valid environment. */
register SCM z, ans;
@ -254,77 +250,63 @@ scm_make_memoized (exp, env)
#include "variable.h"
#include "procs.h"
SCM_PROC (s_make_gloc, "make-gloc", 1, 1, 0, scm_make_gloc);
SCM
scm_make_gloc (var, env)
SCM var;
SCM env;
GUILE_PROC (scm_make_gloc, "make-gloc", 1, 1, 0,
(SCM var, SCM env),
"")
#define FUNC_NAME s_scm_make_gloc
{
#if 1 /* Unsafe */
if (SCM_NIMP (var) && SCM_CONSP (var))
var = scm_cons (SCM_BOOL_F, var);
else
#endif
SCM_ASSERT (SCM_NIMP (var) && SCM_VARIABLEP (var),
var,
SCM_ARG1,
s_make_gloc);
SCM_VALIDATE_VARIABLE(1,var);
if (SCM_UNBNDP (env))
env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
else
SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
env,
SCM_ARG2,
s_make_gloc);
SCM_VALIDATE_NULLORCONS(2,env);
return scm_make_memoized (SCM_VARVCELL (var) + 1, env);
}
#undef FUNC_NAME
SCM_PROC (s_gloc_p, "gloc?", 1, 0, 0, scm_gloc_p);
SCM
scm_gloc_p (obj)
SCM obj;
GUILE_PROC (scm_gloc_p, "gloc?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_gloc_p
{
return ((SCM_NIMP (obj)
&& SCM_MEMOIZEDP (obj)
&& (SCM_MEMOIZED_EXP (obj) & 7) == 1)
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL((SCM_NIMP (obj)
&& SCM_MEMOIZEDP (obj)
&& (SCM_MEMOIZED_EXP (obj) & 7) == 1));
}
#undef FUNC_NAME
SCM_PROC (s_make_iloc, "make-iloc", 3, 0, 0, scm_make_iloc);
SCM
scm_make_iloc (frame, binding, cdrp)
SCM frame;
SCM binding;
SCM cdrp;
GUILE_PROC (scm_make_iloc, "make-iloc", 3, 0, 0,
(SCM frame, SCM binding, SCM cdrp),
"")
#define FUNC_NAME s_scm_make_iloc
{
SCM_ASSERT (SCM_INUMP (frame), frame, SCM_ARG1, s_make_iloc);
SCM_ASSERT (SCM_INUMP (binding), binding, SCM_ARG2, s_make_iloc);
SCM_VALIDATE_INT(1,frame);
SCM_VALIDATE_INT(2,binding)
return (SCM_ILOC00
+ SCM_IFRINC * SCM_INUM (frame)
+ (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0)
+ SCM_IDINC * SCM_INUM (binding));
}
#undef FUNC_NAME
SCM_PROC (s_iloc_p, "iloc?", 1, 0, 0, scm_iloc_p);
SCM
scm_iloc_p (obj)
SCM obj;
GUILE_PROC (scm_iloc_p, "iloc?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_iGUILE_p
{
return SCM_ILOCP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_ILOCP (obj));
}
#undef FUNC_NAME
SCM_PROC (s_memcons, "memcons", 2, 1, 0, scm_memcons);
SCM
scm_memcons (car, cdr, env)
SCM car;
SCM cdr;
SCM env;
GUILE_PROC (scm_memcons, "memcons", 2, 1, 0,
(SCM car, SCM cdr, SCM env),
"")
#define FUNC_NAME s_scm_memcons
{
if (SCM_NIMP (car) && SCM_MEMOIZEDP (car))
{
@ -356,18 +338,15 @@ scm_memcons (car, cdr, env)
s_make_iloc);
return scm_make_memoized (scm_cons (car, cdr), env);
}
#undef FUNC_NAME
SCM_PROC (s_mem_to_proc, "mem->proc", 1, 0, 0, scm_mem_to_proc);
SCM
scm_mem_to_proc (obj)
SCM obj;
GUILE_PROC (scm_mem_to_proc, "mem->proc", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_mem_to_proc
{
SCM env;
SCM_ASSERT (SCM_NIMP (obj) && SCM_MEMOIZEDP (obj),
obj,
SCM_ARG1,
s_mem_to_proc);
SCM_VALIDATE_MEMOIZED(1,obj);
env = SCM_MEMOIZED_ENV (obj);
obj = SCM_MEMOIZED_EXP (obj);
if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA))
@ -376,53 +355,47 @@ scm_mem_to_proc (obj)
scm_cons (obj, SCM_EOL));
return scm_closure (SCM_CDR (obj), env);
}
#undef FUNC_NAME
SCM_PROC (s_proc_to_mem, "proc->mem", 1, 0, 0, scm_proc_to_mem);
SCM
scm_proc_to_mem (obj)
SCM obj;
GUILE_PROC (scm_proc_to_mem, "proc->mem", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_proc_to_mem
{
SCM_ASSERT (SCM_NIMP (obj) && SCM_CLOSUREP (obj),
obj,
SCM_ARG1,
s_proc_to_mem);
SCM_VALIDATE_CLOSURE(1,obj)
return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)),
SCM_ENV (obj));
}
#undef FUNC_NAME
#endif /* GUILE_DEBUG */
SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize);
SCM
scm_unmemoize (m)
SCM m;
GUILE_PROC (scm_unmemoize, "unmemoize", 1, 0, 0,
(SCM m),
"")
#define FUNC_NAME s_scm_unmemoize
{
SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
SCM_VALIDATE_MEMOIZED(1,m);
return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
}
#undef FUNC_NAME
SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment);
SCM
scm_memoized_environment (m)
SCM m;
GUILE_PROC (scm_memoized_environment, "memoized-environment", 1, 0, 0,
(SCM m),
"")
#define FUNC_NAME s_scm_memoized_environment
{
SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
SCM_VALIDATE_MEMOIZED(1,m);
return SCM_MEMOIZED_ENV (m);
}
#undef FUNC_NAME
SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name);
SCM
scm_procedure_name (proc)
SCM proc;
GUILE_PROC (scm_procedure_name, "procedure-name", 1, 0, 0,
(SCM proc),
"")
#define FUNC_NAME s_scm_procedure_name
{
SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T,
proc,
SCM_ARG1,
s_procedure_name);
SCM_VALIDATE_PROC(1,proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_subrs:
return SCM_SNAME (proc);
@ -441,14 +414,14 @@ scm_procedure_name (proc)
}
}
}
#undef FUNC_NAME
SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source);
SCM
scm_procedure_source (proc)
SCM proc;
GUILE_PROC (scm_procedure_source, "procedure-source", 1, 0, 0,
(SCM proc),
"")
#define FUNC_NAME s_scm_procedure_source
{
SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source);
SCM_VALIDATE_NIMP(1,proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
{
@ -472,18 +445,18 @@ scm_procedure_source (proc)
built in procedures! */
return scm_procedure_property (proc, scm_sym_source);
default:
scm_wta (proc, (char *) SCM_ARG1, s_procedure_source);
SCM_WTA(1,proc);
return 0;
}
}
#undef FUNC_NAME
SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment);
SCM
scm_procedure_environment (proc)
SCM proc;
GUILE_PROC (scm_procedure_environment, "procedure-environment", 1, 0, 0,
(SCM proc),
"")
#define FUNC_NAME s_scm_procedure_environment
{
SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment);
SCM_VALIDATE_NIMP(1,proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
return SCM_ENV (proc);
@ -494,10 +467,11 @@ scm_procedure_environment (proc)
#endif
return SCM_EOL;
default:
scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment);
SCM_WTA(1,proc);
return 0;
}
}
#undef FUNC_NAME
@ -507,23 +481,22 @@ scm_procedure_environment (proc)
* the code before evaluating. One solution would be to have eval.c
* generate yet another evaluator. They are not very big actually.
*/
SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval);
SCM
scm_local_eval (exp, env)
SCM exp;
SCM env;
GUILE_PROC (scm_local_eval, "local-eval", 1, 1, 0,
(SCM exp, SCM env),
"")
#define FUNC_NAME s_scm_local_eval
{
if (SCM_UNBNDP (env))
{
SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval);
SCM_VALIDATE_MEMOIZED(1,exp);
return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp));
}
return scm_eval_3 (exp, 1, env);
}
#undef FUNC_NAME
#if 0
SCM_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
#endif
SCM
@ -593,13 +566,8 @@ scm_m_start_stack (exp, env)
long scm_tc16_debugobj;
static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
static int
prindebugobj (obj, port, pstate)
SCM obj;
SCM port;
scm_print_state *pstate;
prindebugobj (SCM obj,SCM port,scm_print_state *pstate)
{
scm_puts ("#<debug-object ", port);
scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port);
@ -607,19 +575,18 @@ prindebugobj (obj, port, pstate)
return 1;
}
SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p);
SCM
scm_debug_object_p (obj)
SCM obj;
GUILE_PROC (scm_debug_object_p, "debug-object?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_debug_object_p
{
return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_NIMP (obj) && SCM_DEBUGOBJP (obj));
}
#undef FUNC_NAME
SCM
scm_make_debugobj (frame)
scm_debug_frame *frame;
scm_make_debugobj (scm_debug_frame *frame)
{
register SCM z;
SCM_NEWCELL (z);
@ -634,16 +601,16 @@ scm_make_debugobj (frame)
/* Undocumented debugging procedure */
#ifdef GUILE_DEBUG
SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang);
SCM
scm_debug_hang (obj)
SCM obj;
GUILE_PROC (scm_debug_hang, "debug-hang", 0, 1, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_debug_hang
{
int go = 0;
while (!go) ;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

122
libguile/dynl-dl.c
View file

@ -1,122 +0,0 @@
/* dynl-dl.c - dynamic linking for dlopen/dlsym
*
* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
Modified for libguile by Marius Vollmer */
#include <dlfcn.h>
#ifdef RTLD_LAZY /* Solaris 2. */
# define DLOPEN_MODE RTLD_LAZY
#else
# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
#endif
#ifndef RTLD_GLOBAL /* Some systems have no such flag. */
# define RTLD_GLOBAL 0
#endif
static void *
sysdep_dynl_link (fname, flags, subr)
const char *fname;
int flags;
const char *subr;
{
void *handle = dlopen (fname, (DLOPEN_MODE
| ((flags & DYNL_GLOBAL)? RTLD_GLOBAL : 0)));
if (NULL == handle)
{
SCM_ALLOW_INTS;
scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
}
return handle;
}
static void
sysdep_dynl_unlink (handle, subr)
void *handle;
const char *subr;
{
if (dlclose (handle))
{
SCM_ALLOW_INTS;
scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
}
}
static void *
sysdep_dynl_func (symb, handle, subr)
const char *symb;
void *handle;
const char *subr;
{
void *fptr;
char *err;
#if defined(USCORE) && !defined(DLSYM_ADDS_USCORE)
char *usymb;
#endif
#if defined(USCORE) && !defined(DLSYM_ADDS_USCORE)
usymb = (char *) malloc (strlen (symb) + 2);
*usymb = '_';
strcpy (usymb + 1, symb);
fptr = dlsym (handle, usymb);
free (usymb);
#else
fptr = dlsym (handle, symb);
#endif
err = (char *)dlerror ();
if (!fptr)
{
SCM_ALLOW_INTS;
scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL);
}
return fptr;
}
static void
sysdep_dynl_init ()
{
}

132
libguile/dynl-dld.c
View file

@ -1,132 +0,0 @@
/* dynl-dld.c - dynamic linking with dld
*
* Copyright (C) 1990-1997, 1999 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
Modified for libguile by Marius Vollmer */
#include "dld.h"
static void listundef SCM_P ((void));
static void
listundefs ()
{
int i;
char **undefs = dld_list_undefined_sym();
puts(" undefs:");
for(i = dld_undefined_sym_count;i--;) {
putc('"', stdout);
fputs(undefs[i], stdout);
puts("\"");
}
free(undefs);
}
static void *
sysdep_dynl_link (fname, int flags, subr)
const char *fname;
int flags;
const char *subr;
{
int status;
status = dld_link (fname);
if (status)
{
SCM_ALLOW_INTS;
scm_misc_error (subr, dld_strerror (status), SCM_EOL);
}
return fname;
}
static void
sysdep_dynl_unlink (handle, subr)
void *handle;
const char *subr;
{
int status;
status = dld_unlink_by_file ((char *)fname, 1);
if (status)
{
SCM_ALLOW_INTS;
scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL);
}
}
static void *
sysdep_dynl_func (symb, handle, subr)
const char *symb;
void *handle;
const char *subr;
{
void *func;
func = (void *) dld_get_func (func);
if (func == 0)
scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL);
if (!dld_function_executable_p (func)) {
listundefs ();
SCM_ALLOW_INTS;
scm_misc_error (subr, "unresolved symbols remain", SCM_EOL);
}
return func;
}
static void
sysdep_dynl_init ()
{
#ifndef RTL
if (!execpath)
execpath = dld_find_executable (SCM_CHARS (SCM_CAR (progargs)));
if (dld_init (SCM_CHARS (SCM_CAR (progargs)))) {
dld_perror("DLD");
return;
}
#endif
#ifdef DLD_DYNCM /* XXX - what's this? */
add_feature("dld:dyncm");
#endif
}

108
libguile/dynl-shl.c
View file

@ -1,108 +0,0 @@
/* dynl-shl.c - dynamic linking with shl_load (HP-UX)
*
* Copyright (C) 1990-1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
Modified for libguile by Marius Vollmer */
#include "dl.h"
#include <stdio.h>
#include <string.h>
static void *
sysdep_dynl_link (fname, flags, subr)
const char *fname;
int flags;
const char *subr;
{
shl_t shl;
/* Probably too much BIND_* flags */
shl = shl_load (fname, BIND_IMMEDIATE || BIND_FIRST ||
BIND_TOGETHER ||
BIND_VERBOSE || DYNAMIC_PATH, 0L);
if (NULL==shl)
{
SCM_ALLOW_INTS;
scm_misc_error (subr, "dynamic linking failed", SCM_EOL);
}
return shl;
}
static void
sysdep_dynl_unlink (handle, subr)
void *handle;
const char *subr;
{
if (shl_unload ((shl_t) handle))
{
SCM_ALLOW_INTS;
scm_misc_error (subr, "dynamic unlinking failed", SCM_EOL);
}
}
static void *
sysdep_dynl_func (symb, handle, subr)
const char *symb;
void *handle;
const char *subr;
{
int status, i;
struct shl_symbol *sym;
status = shl_getsymbols((shl_t) handle, TYPE_PROCEDURE,
EXPORT_SYMBOLS, malloc, &sym);
for (i=0; i<status; ++i) {
if (strcmp(symb, sym[i].name) == 0) return sym[i].value;
}
SCM_ALLOW_INTS;
scm_misc_error (subr, "undefined function",
scm_cons (scm_makfrom0str (symb), SCM_EOL));
}
static void
sysdep_dynl_init ()
{
}

156
libguile/dynl.c
View file

@ -41,6 +41,10 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
Modified for libguile by Marius Vollmer */
@ -75,15 +79,8 @@ maybe_drag_in_eprintf ()
This code probably belongs into strings.c */
static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp,
const char *subr, int argn));
static char **
scm_make_argv_from_stringlist (args, argcp, subr, argn)
SCM args;
int *argcp;
const char *subr;
int argn;
scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn)
{
char **argv;
int argc, i;
@ -110,11 +107,8 @@ scm_make_argv_from_stringlist (args, argcp, subr, argn)
return argv;
}
static void scm_must_free_argv SCM_P ((char **argv));
static void
scm_must_free_argv(argv)
char **argv;
scm_must_free_argv(char **argv)
{
char **av = argv;
while (*av)
@ -125,13 +119,8 @@ scm_must_free_argv(argv)
/* Coerce an arbitrary readonly-string into a zero-terminated string.
*/
static SCM scm_coerce_rostring SCM_P ((SCM rostr, const char *subr, int argn));
static SCM
scm_coerce_rostring (rostr, subr, argn)
SCM rostr;
const char *subr;
int argn;
scm_coerce_rostring (SCM rostr,const char *subr,int argn)
{
SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr);
if (SCM_SUBSTRP (rostr))
@ -184,10 +173,10 @@ scm_register_module_xxx (module_name, init_func)
registered_mods = md;
}
SCM_PROC (s_registered_modules, "c-registered-modules", 0, 0, 0, scm_registered_modules);
SCM
scm_registered_modules ()
GUILE_PROC (scm_registered_modules, "c-registered-modules", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_registered_modules
{
SCM res;
struct moddata *md;
@ -199,11 +188,12 @@ scm_registered_modules ()
res);
return res;
}
#undef FUNC_NAME
SCM_PROC (s_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, scm_clear_registered_modules);
SCM
scm_clear_registered_modules ()
GUILE_PROC (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_clear_registered_modules
{
struct moddata *md1, *md2;
@ -218,6 +208,7 @@ scm_clear_registered_modules ()
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Dispatch to the system dependent files
*
@ -231,13 +222,6 @@ scm_clear_registered_modules ()
#define DYNL_GLOBAL 0x0001
static void sysdep_dynl_init SCM_P ((void));
static void *sysdep_dynl_link SCM_P ((const char *filename, int flags,
const char *subr));
static void sysdep_dynl_unlink SCM_P ((void *handle, const char *subr));
static void *sysdep_dynl_func SCM_P ((const char *symbol, void *handle,
const char *subr));
#ifdef HAVE_DLOPEN
#include "dynl-dl.c"
#else
@ -251,7 +235,7 @@ static void *sysdep_dynl_func SCM_P ((const char *symbol, void *handle,
/* no dynamic linking available, throw errors. */
static void
sysdep_dynl_init ()
sysdep_dynl_init (void)
{
}
@ -298,30 +282,22 @@ struct dynl_obj {
void *handle;
};
static SCM mark_dynl_obj SCM_P ((SCM ptr));
static SCM
mark_dynl_obj (ptr)
SCM ptr;
mark_dynl_obj (SCM ptr)
{
struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr);
return d->filename;
}
static scm_sizet free_dynl_obj SCM_P ((SCM ptr));
static scm_sizet
free_dynl_obj (ptr)
SCM ptr;
free_dynl_obj (SCM ptr)
{
scm_must_free ((char *)SCM_CDR (ptr));
return sizeof (struct dynl_obj);
}
static int print_dynl_obj SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
print_dynl_obj (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
print_dynl_obj (SCM exp,SCM port,scm_print_state *pstate)
{
struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
scm_puts ("#<dynamic-object ", port);
@ -335,19 +311,17 @@ print_dynl_obj (exp, port, pstate)
static SCM kw_global;
SCM_SYMBOL (sym_global, "-global");
SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 1, scm_dynamic_link);
SCM
scm_dynamic_link (fname, rest)
SCM fname;
SCM rest;
GUILE_PROC (scm_dynamic_link, "dynamic-link", 1, 0, 1,
(SCM fname, SCM rest),
"")
#define FUNC_NAME s_scm_dynamic_link
{
SCM z;
void *handle;
struct dynl_obj *d;
int flags = DYNL_GLOBAL;
fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
fname = scm_coerce_rostring (fname, FUNC_NAME, SCM_ARG1);
/* collect flags */
while (SCM_NIMP (rest) && SCM_CONSP (rest))
@ -358,7 +332,7 @@ scm_dynamic_link (fname, rest)
rest = SCM_CDR (rest);
if (!(SCM_NIMP (rest) && SCM_CONSP (rest)))
scm_misc_error (s_dynamic_link, "keyword without value", SCM_EOL);
scm_misc_error (FUNC_NAME, "keyword without value", SCM_EOL);
val = SCM_CAR (rest);
rest = SCM_CDR (rest);
@ -369,15 +343,15 @@ scm_dynamic_link (fname, rest)
flags &= ~DYNL_GLOBAL;
}
else
scm_misc_error (s_dynamic_link, "unknown keyword argument: %s",
scm_misc_error (FUNC_NAME, "unknown keyword argument: %s",
scm_cons (kw, SCM_EOL));
}
SCM_DEFER_INTS;
handle = sysdep_dynl_link (SCM_CHARS (fname), flags, s_dynamic_link);
handle = sysdep_dynl_link (SCM_CHARS (fname), flags, FUNC_NAME);
d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj),
s_dynamic_link);
FUNC_NAME);
d->filename = fname;
d->handle = handle;
@ -388,13 +362,10 @@ scm_dynamic_link (fname, rest)
return z;
}
#undef FUNC_NAME
static struct dynl_obj *get_dynl_obj SCM_P ((SCM obj, const char *subr, int argn));
static struct dynl_obj *
get_dynl_obj (dobj, subr, argn)
SCM dobj;
const char *subr;
int argn;
get_dynl_obj (SCM dobj,const char *subr,int argn)
{
struct dynl_obj *d;
SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
@ -404,69 +375,71 @@ get_dynl_obj (dobj, subr, argn)
return d;
}
SCM_PROC (s_dynamic_object_p, "dynamic-object?", 1, 0, 0, scm_dynamic_object_p);
SCM
scm_dynamic_object_p (SCM obj)
GUILE_PROC (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_dynamic_object_p
{
return (SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj)?
SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
SCM
scm_dynamic_unlink (dobj)
SCM dobj;
GUILE_PROC (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
(SCM dobj),
"")
#define FUNC_NAME s_scm_dynamic_unlink
{
struct dynl_obj *d = get_dynl_obj (dobj, s_dynamic_unlink, SCM_ARG1);
struct dynl_obj *d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG1);
SCM_DEFER_INTS;
sysdep_dynl_unlink (d->handle, s_dynamic_unlink);
sysdep_dynl_unlink (d->handle, FUNC_NAME);
d->handle = NULL;
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_dynamic_func, "dynamic-func", 2, 0, 0, scm_dynamic_func);
SCM
scm_dynamic_func (SCM symb, SCM dobj)
GUILE_PROC (scm_dynamic_func, "dynamic-func", 2, 0, 0,
(SCM symb, SCM dobj),
"")
#define FUNC_NAME s_scm_dynamic_func
{
struct dynl_obj *d;
void (*func) ();
symb = scm_coerce_rostring (symb, s_dynamic_func, SCM_ARG1);
d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
symb = scm_coerce_rostring (symb, FUNC_NAME, SCM_ARG1);
d = get_dynl_obj (dobj, FUNC_NAME, SCM_ARG2);
SCM_DEFER_INTS;
func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), d->handle,
s_dynamic_func);
FUNC_NAME);
SCM_ALLOW_INTS;
return scm_ulong2num ((unsigned long)func);
}
#undef FUNC_NAME
SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
SCM
scm_dynamic_call (SCM func, SCM dobj)
GUILE_PROC (scm_dynamic_call, "dynamic-call", 2, 0, 0,
(SCM func, SCM dobj),
"")
#define FUNC_NAME s_scm_dynamic_call
{
void (*fptr)();
if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
func = scm_dynamic_func (func, dobj);
fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, s_dynamic_call);
fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, FUNC_NAME);
SCM_DEFER_INTS;
fptr ();
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
SCM
scm_dynamic_args_call (func, dobj, args)
SCM func, dobj, args;
GUILE_PROC (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
(SCM func, SCM dobj, SCM args),
"")
#define FUNC_NAME s_scm_dynamic_args_call
{
int (*fptr) (int argc, char **argv);
int result, argc;
@ -476,9 +449,9 @@ scm_dynamic_args_call (func, dobj, args)
func = scm_dynamic_func (func, dobj);
fptr = (int (*)(int, char **)) scm_num2ulong (func, (char *)SCM_ARG1,
s_dynamic_args_call);
FUNC_NAME);
SCM_DEFER_INTS;
argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME,
SCM_ARG3);
result = (*fptr) (argc, argv);
scm_must_free_argv (argv);
@ -486,6 +459,7 @@ scm_dynamic_args_call (func, dobj, args)
return SCM_MAKINUM(0L+result);
}
#undef FUNC_NAME
void
scm_init_dynamic_linking ()

27
libguile/dynwind.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -66,18 +70,15 @@
SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind);
SCM
scm_dynamic_wind (thunk1, thunk2, thunk3)
SCM thunk1;
SCM thunk2;
SCM thunk3;
GUILE_PROC(scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
(SCM thunk1, SCM thunk2, SCM thunk3),
"")
#define FUNC_NAME s_scm_dynamic_wind
{
SCM ans;
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk3)),
thunk3,
SCM_ARG3, s_dynamic_wind);
SCM_ARG3, FUNC_NAME);
scm_apply (thunk1, SCM_EOL, SCM_EOL);
scm_dynwinds = scm_acons (thunk1, thunk3, scm_dynwinds);
ans = scm_apply (thunk2, SCM_EOL, SCM_EOL);
@ -85,6 +86,7 @@ scm_dynamic_wind (thunk1, thunk2, thunk3)
scm_apply (thunk3, SCM_EOL, SCM_EOL);
return ans;
}
#undef FUNC_NAME
/* The implementation of a C-callable dynamic-wind,
* scm_internal_dynamic_wind, requires packaging of C pointers in a
@ -144,13 +146,14 @@ scm_internal_dynamic_wind (scm_guard_t before,
}
#ifdef GUILE_DEBUG
SCM_PROC (s_wind_chain, "wind-chain", 0, 0, 0, scm_wind_chain);
SCM
scm_wind_chain ()
GUILE_PROC (scm_wind_chain, "wind-chain", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_wind_chain
{
return scm_dynwinds;
}
#undef FUNC_NAME
#endif
static void

42
libguile/eq.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
@ -47,27 +51,23 @@
#include "smob.h"
#include "unif.h"
#include "scm_validate.h"
#include "eq.h"
SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p);
SCM
scm_eq_p (x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
(SCM x, SCM y),
"")
#define FUNC_NAME s_scm_eq_p
{
return ((x==y)
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(x==y);
}
#undef FUNC_NAME
SCM_PROC1 (s_eqv_p, "eqv?", scm_tc7_rpsubr, scm_eqv_p);
SCM
scm_eqv_p (x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
(SCM x, SCM y),
"")
#define FUNC_NAME s_scm_eqv_p
{
if (x==y) return SCM_BOOL_T;
if (SCM_IMP(x)) return SCM_BOOL_F;
@ -86,14 +86,13 @@ scm_eqv_p (x, y)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC1 (s_equal_p, "equal?", scm_tc7_rpsubr, scm_equal_p);
SCM
scm_equal_p (x, y)
SCM x;
SCM y;
GUILE_PROC1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
(SCM x, SCM y),
"")
#define FUNC_NAME s_scm_equal_p
{
SCM_CHECK_STACK;
tailrecurse: SCM_TICK;
@ -139,6 +138,7 @@ scm_equal_p (x, y)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME

93
libguile/error.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -46,6 +50,7 @@
#include "genio.h"
#include "throw.h"
#include "scm_validate.h"
#include "error.h"
#ifdef HAVE_UNISTD_H
@ -62,12 +67,7 @@ extern int errno;
/* All errors should pass through here. */
void
scm_error (key, subr, message, args, rest)
SCM key;
const char *subr;
const char *message;
SCM args;
SCM rest;
scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest)
{
SCM arg_list;
arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
@ -87,44 +87,36 @@ scm_error (key, subr, message, args, rest)
}
/* Scheme interface to scm_error. */
SCM_PROC(s_error_scm, "scm-error", 5, 0, 0, scm_error_scm);
SCM
scm_error_scm (key, subr, message, args, rest)
SCM key;
SCM subr;
SCM message;
SCM args;
SCM rest;
GUILE_PROC(scm_error_scm, "scm-error", 5, 0, 0,
(SCM key, SCM subr, SCM message, SCM args, SCM rest),
"")
#define FUNC_NAME s_scm_error_scm
{
SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_error_scm);
SCM_ASSERT (SCM_FALSEP (subr) || (SCM_NIMP (subr) && SCM_ROSTRINGP (subr)),
subr, SCM_ARG2, s_error_scm);
SCM_ASSERT (SCM_FALSEP (message)
|| (SCM_NIMP (message) && SCM_ROSTRINGP (message)),
message, SCM_ARG3, s_error_scm);
char *szSubr;
char *szMessage;
SCM_VALIDATE_SYMBOL(1,key);
SCM_VALIDATE_NULLORROSTRING_COPY(2,subr,szSubr);
SCM_VALIDATE_NULLORROSTRING_COPY(3,message,szMessage);
SCM_COERCE_SUBSTR (message);
scm_error (key,
(SCM_FALSEP (subr)) ? NULL : SCM_ROCHARS (subr),
(SCM_FALSEP (message)) ? NULL : SCM_ROCHARS (message),
args,
rest);
scm_error (key, szSubr, szMessage, args, rest);
/* not reached. */
}
#undef FUNC_NAME
SCM_PROC (s_strerror, "strerror", 1, 0, 0, scm_strerror);
SCM
scm_strerror (SCM err)
GUILE_PROC (scm_strerror, "strerror", 1, 0, 0,
(SCM err),
"")
#define FUNC_NAME s_scm_strerror
{
SCM_ASSERT (SCM_INUMP (err), err, SCM_ARG1, s_strerror);
SCM_VALIDATE_INT(1,err);
return scm_makfrom0str (strerror (SCM_INUM (err)));
}
#undef FUNC_NAME
SCM_SYMBOL (scm_system_error_key, "system-error");
void
scm_syserror (subr)
const char *subr;
scm_syserror (const char *subr)
{
scm_error (scm_system_error_key,
subr,
@ -134,11 +126,7 @@ scm_syserror (subr)
}
void
scm_syserror_msg (subr, message, args, eno)
const char *subr;
const char *message;
SCM args;
int eno;
scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
{
scm_error (scm_system_error_key,
subr,
@ -148,8 +136,7 @@ scm_syserror_msg (subr, message, args, eno)
}
void
scm_sysmissing (subr)
const char *subr;
scm_sysmissing (const char *subr)
{
#ifdef ENOSYS
scm_error (scm_system_error_key,
@ -168,8 +155,7 @@ scm_sysmissing (subr)
SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow");
void
scm_num_overflow (subr)
const char *subr;
scm_num_overflow (const char *subr)
{
scm_error (scm_num_overflow_key,
subr,
@ -180,9 +166,7 @@ scm_num_overflow (subr)
SCM_SYMBOL (scm_out_of_range_key, "out-of-range");
void
scm_out_of_range (subr, bad_value)
const char *subr;
SCM bad_value;
scm_out_of_range (const char *subr, SCM bad_value)
{
scm_error (scm_out_of_range_key,
subr,
@ -193,8 +177,7 @@ scm_out_of_range (subr, bad_value)
SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args");
void
scm_wrong_num_args (proc)
SCM proc;
scm_wrong_num_args (SCM proc)
{
scm_error (scm_args_number_key,
NULL,
@ -205,10 +188,7 @@ scm_wrong_num_args (proc)
SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg");
void
scm_wrong_type_arg (subr, pos, bad_value)
const char *subr;
int pos;
SCM bad_value;
scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
{
scm_error (scm_arg_type_key,
subr,
@ -221,8 +201,7 @@ scm_wrong_type_arg (subr, pos, bad_value)
SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
void
scm_memory_error (subr)
const char *subr;
scm_memory_error (const char *subr)
{
scm_error (scm_memory_alloc_key,
subr,
@ -233,20 +212,14 @@ scm_memory_error (subr)
SCM_SYMBOL (scm_misc_error_key, "misc-error");
void
scm_misc_error (subr, message, args)
const char *subr;
const char *message;
SCM args;
scm_misc_error (const char *subr, const char *message, SCM args)
{
scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
}
/* implements the SCM_ASSERT interface. */
SCM
scm_wta (arg, pos, s_subr)
SCM arg;
const char *pos;
const char *s_subr;
scm_wta (SCM arg, const char *pos, const char *s_subr)
{
if (!s_subr || !*s_subr)
s_subr = NULL;

170
libguile/eval.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* This file is read twice in order to produce debugging versions of
@ -92,6 +96,7 @@ char *alloca ();
#include "feature.h"
#include "modules.h"
#include "scm_validate.h"
#include "eval.h"
SCM (*scm_memoize_method) (SCM, SCM);
@ -831,7 +836,7 @@ scm_m_do (xorig, env)
#define evalcar scm_eval_car
static SCM iqq SCM_P ((SCM form, SCM env, int depth));
static SCM iqq (SCM form, SCM env, int depth);
SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote);
@ -848,10 +853,7 @@ scm_m_quasiquote (xorig, env)
static SCM
iqq (form, env, depth)
SCM form;
SCM env;
int depth;
iqq (SCM form,SCM env,int depth)
{
SCM tmp;
int edepth = depth;
@ -1350,12 +1352,8 @@ scm_macroexp (SCM x, SCM env)
* readable style... :)
*/
static SCM unmemocopy SCM_P ((SCM x, SCM env));
static SCM
unmemocopy (x, env)
SCM x;
SCM env;
unmemocopy (SCM x, SCM env)
{
SCM ls, z;
#ifdef DEBUG_EXTENSIONS
@ -1714,7 +1712,7 @@ scm_eval_body (SCM code, SCM env)
*/
SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env));
SCM (*scm_ceval_ptr) (SCM x, SCM env);
/* scm_last_debug_frame contains a pointer to the last debugging
* information stack frame. It is accessed very often from the
@ -1769,38 +1767,39 @@ scm_option scm_evaluator_trap_table[] = {
{ SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
};
SCM_PROC (s_eval_options_interface, "eval-options-interface", 0, 1, 0, scm_eval_options_interface);
SCM
scm_eval_options_interface (SCM setting)
GUILE_PROC (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
(SCM setting),
"")
#define FUNC_NAME s_scm_eval_options_interface
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_eval_opts,
SCM_N_EVAL_OPTIONS,
s_eval_options_interface);
FUNC_NAME);
scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
SCM_ALLOW_INTS;
return ans;
}
#undef FUNC_NAME
SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps);
SCM
scm_evaluator_traps (setting)
SCM setting;
GUILE_PROC (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
(SCM setting),
"")
#define FUNC_NAME s_scm_evaluator_traps
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS,
s_evaluator_traps);
FUNC_NAME);
SCM_RESET_DEBUG_MODE;
SCM_ALLOW_INTS;
return ans;
}
#undef FUNC_NAME
SCM
scm_deval_args (l, env, proc, lloc)
@ -1866,24 +1865,18 @@ scm_deval_args (l, env, proc, lloc)
#if 0
SCM
scm_ceval (x, env)
SCM x;
SCM env;
scm_ceval (SCM x, SCM env)
{}
#endif
#if 0
SCM
scm_deval (x, env)
SCM x;
SCM env;
scm_deval (SCM x, SCM env)
{}
#endif
SCM
SCM_CEVAL (x, env)
SCM x;
SCM env;
SCM_CEVAL (SCM x, SCM env)
{
union
{
@ -3256,21 +3249,21 @@ ret:
you if you do (scm_apply scm_apply '( ... ))" If you know what
they're referring to, send me a patch to this comment. */
SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);
SCM
scm_nconc2last (lst)
SCM lst;
GUILE_PROC(scm_nconc2last, "apply:nconc2last", 1, 0, 0,
(SCM lst),
"")
#define FUNC_NAME s_scm_nconc2last
{
SCM *lloc;
SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last);
SCM_VALIDATE_LIST(1,lst);
lloc = &lst;
while (SCM_NNULLP (SCM_CDR (*lloc)))
lloc = SCM_CDRLOC (*lloc);
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last);
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
*lloc = SCM_CAR (*lloc);
return lst;
}
#undef FUNC_NAME
#endif /* !DEVAL */
@ -3311,10 +3304,7 @@ scm_dapply (proc, arg1, args)
onto the front of your argument list, and pass that as ARGS. */
SCM
SCM_APPLY (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
SCM_APPLY (SCM proc, SCM arg1, SCM args)
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
@ -3662,10 +3652,7 @@ SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
*/
SCM
scm_map (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
scm_map (SCM proc, SCM arg1, SCM args)
{
long i, len;
SCM res = SCM_EOL;
@ -3713,10 +3700,7 @@ scm_map (proc, arg1, args)
SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
SCM
scm_for_each (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
scm_for_each (SCM proc, SCM arg1, SCM args)
{
SCM *ve = &args; /* Keep args from being optimized away. */
long i, len;
@ -3781,13 +3765,8 @@ scm_makprom (code)
static int prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
prinprom (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
prinprom (SCM exp,SCM port,scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<promise ", port);
@ -3799,14 +3778,12 @@ prinprom (exp, port, pstate)
}
SCM_PROC(s_force, "force", 1, 0, 0, scm_force);
SCM
scm_force (x)
SCM x;
GUILE_PROC(scm_force, "force", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_force
{
SCM_ASSERT (SCM_NIMP(x) && SCM_TYP16 (x) == scm_tc16_promise,
x, SCM_ARG1, s_force);
SCM_VALIDATE_SMOB(1,x,promise);
if (!((1L << 16) & SCM_CAR (x)))
{
SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL);
@ -3820,22 +3797,21 @@ scm_force (x)
}
return SCM_CDR (x);
}
#undef FUNC_NAME
SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p);
SCM
scm_promise_p (x)
SCM x;
GUILE_PROC (scm_promise_p, "promise?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_promise_p
{
return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise));
}
#undef FUNC_NAME
SCM_PROC (s_cons_source, "cons-source", 3, 0, 0, scm_cons_source);
SCM
scm_cons_source (SCM xorig, SCM x, SCM y)
GUILE_PROC (scm_cons_source, "cons-source", 3, 0, 0,
(SCM xorig, SCM x, SCM y),
"")
#define FUNC_NAME s_scm_cons_source
{
SCM p, z;
SCM_NEWCELL (z);
@ -3847,12 +3823,12 @@ scm_cons_source (SCM xorig, SCM x, SCM y)
scm_whash_insert (scm_source_whash, z, p);
return z;
}
#undef FUNC_NAME
SCM_PROC (s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree);
SCM
scm_copy_tree (obj)
SCM obj;
GUILE_PROC (scm_copy_tree, "copy-tree", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_copy_tree
{
SCM ans, tl;
if (SCM_IMP (obj))
@ -3880,13 +3856,11 @@ scm_copy_tree (obj)
SCM_SETCDR (tl, obj);
return ans;
}
#undef FUNC_NAME
SCM
scm_eval_3 (obj, copyp, env)
SCM obj;
int copyp;
SCM env;
scm_eval_3 (SCM obj, int copyp, SCM env)
{
if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
@ -3895,33 +3869,33 @@ scm_eval_3 (obj, copyp, env)
return SCM_XEVAL (obj, env);
}
SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2);
SCM
scm_eval2 (obj, env_thunk)
SCM obj;
SCM env_thunk;
GUILE_PROC(scm_eval2, "eval2", 2, 0, 0,
(SCM obj, SCM env_thunk),
"")
#define FUNC_NAME s_scm_eval2
{
return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk));
}
#undef FUNC_NAME
SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval);
SCM
scm_eval (obj)
SCM obj;
GUILE_PROC(scm_eval, "eval", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_eval
{
return scm_eval_3 (obj,
1,
scm_top_level_env
(SCM_CDR (scm_top_level_lookup_closure_var)));
}
#undef FUNC_NAME
/* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
/*
SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
*/
SCM
scm_eval_x (obj)
SCM obj;
scm_eval_x (SCM obj)
{
return scm_eval_3 (obj,
0,

24
libguile/evalext.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "_scm.h"
@ -45,6 +49,7 @@
#include "macros.h"
#include "modules.h"
#include "scm_validate.h"
#include "evalext.h"
SCM_SYMBOL (scm_sym_setter, "setter");
@ -62,14 +67,14 @@ scm_m_generalized_set_x (SCM xorig, SCM env)
return scm_wta (xorig, scm_s_variable, scm_s_set_x);
}
SCM_PROC (s_definedp, "defined?", 1, 1, 0, scm_definedp);
SCM
scm_definedp (SCM sym, SCM env)
GUILE_PROC (scm_definedp, "defined?", 1, 1, 0,
(SCM sym, SCM env),
"")
#define FUNC_NAME s_scm_definedp
{
SCM vcell;
SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG1, s_definedp);
SCM_VALIDATE_SYMBOL(1,sym);
if (SCM_UNBNDP (env))
vcell = scm_sym2vcell(sym,
@ -81,12 +86,12 @@ scm_definedp (SCM sym, SCM env)
register SCM b;
for (; SCM_NIMP (frames); frames = SCM_CDR (frames))
{
SCM_ASSERT (SCM_CONSP (frames), env, SCM_ARG2, s_definedp);
SCM_ASSERT (SCM_CONSP (frames), env, SCM_ARG2, FUNC_NAME);
b = SCM_CAR (frames);
if (SCM_NFALSEP (scm_procedure_p (b)))
break;
SCM_ASSERT (SCM_NIMP (b) && SCM_CONSP (b),
env, SCM_ARG2, s_definedp);
env, SCM_ARG2, FUNC_NAME);
for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b))
{
if (SCM_NCONSP (b))
@ -109,6 +114,7 @@ scm_definedp (SCM sym, SCM env)
? SCM_BOOL_F
: SCM_BOOL_T);
}
#undef FUNC_NAME
SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
@ -145,9 +151,9 @@ scm_m_undefine (x, env)
}
/* This name is obsolete. Will be removed in 1.5. */
SCM_PROC (s_serial_map, "serial-map", 2, 0, 1, scm_map);
SCM_REGISTER_PROC (s_serial_map, "serial-map", 2, 0, 1, scm_map);
SCM_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
void
scm_init_evalext ()

131
libguile/feature.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -47,6 +51,7 @@
#include "procprop.h"
#include "smob.h"
#include "scm_validate.h"
#include "feature.h"
#ifdef HAVE_STRING_H
@ -66,13 +71,15 @@ scm_add_feature (str)
SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments);
SCM
scm_program_arguments ()
GUILE_PROC(scm_program_arguments, "program-arguments", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_program_arguments
{
return scm_progargs;
}
#undef FUNC_NAME
/* Set the value returned by program-arguments, given ARGC and ARGV.
@ -81,10 +88,7 @@ scm_program_arguments ()
arguments, but we still want the script name to be the first
element. */
void
scm_set_program_arguments (argc, argv, first)
int argc;
char **argv;
char *first;
scm_set_program_arguments (int argc, char **argv, char *first)
{
scm_progargs = scm_makfromstrs (argc, argv);
if (first)
@ -176,61 +180,63 @@ scm_make_named_hook (const char* name, int n_args)
}
SCM_PROC (s_make_hook_with_name, "make-hook-with-name", 1, 1, 0, scm_make_hook_with_name);
SCM
scm_make_hook_with_name (SCM name, SCM n_args)
GUILE_PROC (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0,
(SCM name, SCM n_args),
"")
#define FUNC_NAME s_scm_make_hook_with_name
{
return make_hook (name, n_args, s_make_hook_with_name);
return make_hook (name, n_args, FUNC_NAME);
}
#undef FUNC_NAME
SCM_PROC (s_make_hook, "make-hook", 0, 1, 0, scm_make_hook);
SCM
scm_make_hook (SCM n_args)
GUILE_PROC (scm_make_hook, "make-hook", 0, 1, 0,
(SCM n_args),
"")
#define FUNC_NAME s_scm_make_hook
{
return make_hook (SCM_BOOL_F, n_args, s_make_hook);
return make_hook (SCM_BOOL_F, n_args, FUNC_NAME);
}
#undef FUNC_NAME
SCM_PROC (s_hook_p, "hook?", 1, 0, 0, scm_hook_p);
SCM
scm_hook_p (SCM x)
GUILE_PROC (scm_hook_p, "hook?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_hook_p
{
return SCM_NIMP (x) && SCM_HOOKP (x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_NIMP (x) && SCM_HOOKP (x));
}
#undef FUNC_NAME
SCM_PROC (s_hook_empty_p, "hook-empty?", 1, 0, 0, scm_hook_empty_p);
SCM
scm_hook_empty_p (SCM hook)
GUILE_PROC (scm_hook_empty_p, "hook-empty?", 1, 0, 0,
(SCM hook),
"")
#define FUNC_NAME s_scm_hook_empty_p
{
SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
hook, SCM_ARG1, s_hook_empty_p);
return SCM_NULLP (SCM_HOOK_PROCEDURES (hook)) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_HOOK(1,hook);
return SCM_BOOL(SCM_NULLP (SCM_HOOK_PROCEDURES (hook)));
}
#undef FUNC_NAME
SCM_PROC (s_add_hook_x, "add-hook!", 2, 1, 0, scm_add_hook_x);
SCM
scm_add_hook_x (SCM hook, SCM proc, SCM append_p)
GUILE_PROC (scm_add_hook_x, "add-hook!", 2, 1, 0,
(SCM hook, SCM proc, SCM append_p),
"")
#define FUNC_NAME s_scm_add_hook_x
{
SCM arity, rest;
int n_args;
SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
hook, SCM_ARG1, s_add_hook_x);
SCM_VALIDATE_HOOK(1,hook);
SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)),
proc, SCM_ARG2, s_add_hook_x);
proc, SCM_ARG2, FUNC_NAME);
n_args = SCM_HOOK_ARITY (hook);
if (SCM_INUM (SCM_CAR (arity)) > n_args
|| (SCM_FALSEP (SCM_CADDR (arity))
&& (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity))
< n_args)))
scm_misc_error (s_add_hook_x,
scm_misc_error (FUNC_NAME,
"This hook requires %s arguments",
SCM_LIST1 (SCM_MAKINUM (SCM_HOOK_ARITY (hook))));
rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
@ -240,49 +246,50 @@ scm_add_hook_x (SCM hook, SCM proc, SCM append_p)
: scm_cons (proc, rest)));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_remove_hook_x, "remove-hook!", 2, 0, 0, scm_remove_hook_x);
SCM
scm_remove_hook_x (SCM hook, SCM proc)
GUILE_PROC (scm_remove_hook_x, "remove-hook!", 2, 0, 0,
(SCM hook, SCM proc),
"")
#define FUNC_NAME s_scm_remove_hook_x
{
SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
hook, SCM_ARG1, s_remove_hook_x);
SCM_VALIDATE_HOOK(1,hook);
SCM_SET_HOOK_PROCEDURES (hook,
scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_reset_hook_x, "reset-hook!", 1, 0, 0, scm_reset_hook_x);
SCM
scm_reset_hook_x (SCM hook)
GUILE_PROC (scm_reset_hook_x, "reset-hook!", 1, 0, 0,
(SCM hook),
"")
#define FUNC_NAME s_scm_reset_hook_x
{
SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
hook, SCM_ARG1, s_reset_hook_x);
SCM_VALIDATE_HOOK(1,hook);
SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_run_hook, "run-hook", 1, 0, 1, scm_run_hook);
SCM
scm_run_hook (SCM hook, SCM args)
GUILE_PROC (scm_run_hook, "run-hook", 1, 0, 1,
(SCM hook, SCM args),
"")
#define FUNC_NAME s_scm_run_hook
{
SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
hook, SCM_ARG1, s_run_hook);
SCM_VALIDATE_HOOK(1,hook);
if (SCM_UNBNDP (args))
args = SCM_EOL;
if (scm_ilength (args) != SCM_HOOK_ARITY (hook))
scm_misc_error (s_add_hook_x,
scm_misc_error (FUNC_NAME,
"This hook requires %s arguments",
SCM_LIST1 (SCM_MAKINUM (SCM_HOOK_ARITY (hook))));
scm_c_run_hook (hook, args);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void
@ -297,15 +304,15 @@ scm_c_run_hook (SCM hook, SCM args)
}
SCM_PROC (s_hook_to_list, "hook->list", 1, 0, 0, scm_hook_to_list);
SCM
scm_hook_to_list (SCM hook)
GUILE_PROC (scm_hook_to_list, "hook->list", 1, 0, 0,
(SCM hook),
"")
#define FUNC_NAME s_scm_hook_to_list
{
SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
hook, SCM_ARG1, s_hook_to_list);
SCM_VALIDATE_HOOK(1,hook);
return scm_list_copy (SCM_HOOK_PROCEDURES (hook));
}
#undef FUNC_NAME

495
libguile/filesys.c
View file

File diff suppressed because it is too large Load diff

107
libguile/fluids.c
View file

@ -39,6 +39,10 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "_scm.h"
#include "print.h"
#include "smob.h"
@ -49,6 +53,7 @@
#include "eval.h"
#define INITIAL_FLUIDS 10
#include "scm_validate.h"
static volatile int n_fluids;
long scm_tc16_fluid;
@ -60,11 +65,8 @@ scm_make_initial_fluids ()
SCM_BOOL_F);
}
static void grow_fluids SCM_P ((scm_root_state *, int new_length));
static void
grow_fluids (root_state, new_length)
scm_root_state *root_state;
int new_length;
grow_fluids (scm_root_state *root_state,int new_length)
{
SCM old_fluids, new_fluids;
int old_length, i;
@ -94,12 +96,8 @@ scm_copy_fluids (root_state)
grow_fluids (root_state, SCM_LENGTH(root_state->fluids));
}
static int print_fluid SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
print_fluid (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
print_fluid (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<fluid ", port);
scm_intprint (SCM_FLUID_NUM (exp), 10, port);
@ -121,10 +119,10 @@ int next_fluid_num ()
return n;
}
SCM_PROC (s_make_fluid, "make-fluid", 0, 0, 0, scm_make_fluid);
SCM
scm_make_fluid ()
GUILE_PROC (scm_make_fluid, "make-fluid", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_make_fluid
{
int n;
@ -132,25 +130,25 @@ scm_make_fluid ()
n = next_fluid_num ();
SCM_RETURN_NEWSMOB (scm_tc16_fluid, n);
}
#undef FUNC_NAME
SCM_PROC (s_fluid_p, "fluid?", 1, 0, 0, scm_fluid_p);
SCM
scm_fluid_p (fl)
SCM fl;
GUILE_PROC (scm_fluid_p, "fluid?", 1, 0, 0,
(SCM fl),
"")
#define FUNC_NAME s_scm_fluid_p
{
return (SCM_NIMP (fl) && SCM_FLUIDP (fl))? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_NIMP (fl) && SCM_FLUIDP (fl));
}
#undef FUNC_NAME
SCM_PROC (s_fluid_ref, "fluid-ref", 1, 0, 0, scm_fluid_ref);
SCM
scm_fluid_ref (fl)
SCM fl;
GUILE_PROC (scm_fluid_ref, "fluid-ref", 1, 0, 0,
(SCM fl),
"")
#define FUNC_NAME s_scm_fluid_ref
{
int n;
SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_ref);
SCM_VALIDATE_FLUID(1,fl);
n = SCM_FLUID_NUM (fl);
@ -158,18 +156,16 @@ scm_fluid_ref (fl)
grow_fluids (scm_root, n+1);
return SCM_VELTS(scm_root->fluids)[n];
}
#undef FUNC_NAME
SCM_PROC (s_fluid_set_x, "fluid-set!", 2, 0, 0, scm_fluid_set_x);
SCM
scm_fluid_set_x (fl, val)
SCM fl;
SCM val;
GUILE_PROC (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
(SCM fl, SCM val),
"")
#define FUNC_NAME s_scm_fluid_set_x
{
int n;
SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_set_x);
SCM_VALIDATE_FLUID(1,fl);
n = SCM_FLUID_NUM (fl);
if (SCM_LENGTH (scm_root->fluids) <= n)
@ -177,10 +173,10 @@ scm_fluid_set_x (fl, val)
SCM_VELTS(scm_root->fluids)[n] = val;
return val;
}
#undef FUNC_NAME
void
scm_swap_fluids (fluids, vals)
SCM fluids, vals;
scm_swap_fluids (SCM fluids, SCM vals)
{
while (SCM_NIMP (fluids))
{
@ -197,8 +193,7 @@ scm_swap_fluids (fluids, vals)
same fluid appears multiple times in the fluids list. */
void
scm_swap_fluids_reverse (fluids, vals)
SCM fluids, vals;
scm_swap_fluids_reverse (SCM fluids, SCM vals)
{
if (SCM_NIMP (fluids))
{
@ -212,22 +207,33 @@ scm_swap_fluids_reverse (fluids, vals)
}
}
SCM_PROC (s_with_fluids, "with-fluids*", 3, 0, 0, scm_with_fluids);
static SCM
apply_thunk (void *thunk)
{
return scm_apply ((SCM) thunk, SCM_EOL, SCM_EOL);
}
GUILE_PROC (scm_with_fluids, "with-fluids*", 3, 0, 0,
(SCM fluids, SCM vals, SCM thunk),
"")
#define FUNC_NAME s_scm_with_fluids
{
return scm_internal_with_fluids (fluids, vals, apply_thunk, (void *)thunk);
}
#undef FUNC_NAME
SCM
scm_internal_with_fluids (fluids, vals, cproc, cdata)
SCM fluids, vals;
SCM (*cproc) ();
void *cdata;
scm_internal_with_fluids (SCM fluids, SCM vals, SCM (*cproc) (), void *cdata)
{
SCM ans;
int flen = scm_ilength (fluids);
int vlen = scm_ilength (vals);
SCM_ASSERT (flen >= 0, fluids, SCM_ARG1, s_with_fluids);
SCM_ASSERT (vlen >= 0, vals, SCM_ARG2, s_with_fluids);
SCM_ASSERT (flen >= 0, fluids, SCM_ARG1, s_scm_with_fluids);
SCM_ASSERT (vlen >= 0, vals, SCM_ARG2, s_scm_with_fluids);
if (flen != vlen)
scm_out_of_range (s_with_fluids, vals);
scm_out_of_range (s_scm_with_fluids, vals);
scm_swap_fluids (fluids, vals);
scm_dynwinds = scm_acons (fluids, vals, scm_dynwinds);
@ -237,18 +243,7 @@ scm_internal_with_fluids (fluids, vals, cproc, cdata)
return ans;
}
static SCM
apply_thunk (void *thunk)
{
return scm_apply ((SCM) thunk, SCM_EOL, SCM_EOL);
}
SCM
scm_with_fluids (fluids, vals, thunk)
SCM fluids, vals, thunk;
{
return scm_internal_with_fluids (fluids, vals, apply_thunk, (void *)thunk);
}
void
scm_init_fluids ()

54
libguile/fports.c
View file

@ -38,12 +38,17 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include <fcntl.h>
#include "_scm.h"
#include "scm_validate.h"
#include "fports.h"
#ifdef HAVE_STRING_H
@ -124,21 +129,20 @@ scm_fport_buffer_add (SCM port, int read_size, int write_size)
SCM_SETCAR (port, (SCM_CAR (port) | SCM_BUF0));
}
SCM_PROC (s_setvbuf, "setvbuf", 2, 1, 0, scm_setvbuf);
SCM
scm_setvbuf (SCM port, SCM mode, SCM size)
GUILE_PROC (scm_setvbuf, "setvbuf", 2, 1, 0,
(SCM port, SCM mode, SCM size),
"")
#define FUNC_NAME s_scm_setvbuf
{
int cmode, csize;
scm_port *pt;
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1,
s_setvbuf);
SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_setvbuf);
cmode = SCM_INUM (mode);
SCM_VALIDATE_OPFPORT(1,port);
SCM_VALIDATE_INT_COPY(2,mode,cmode);
if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
scm_out_of_range (s_setvbuf, mode);
scm_out_of_range (FUNC_NAME, mode);
if (cmode == _IOLBF)
{
@ -159,10 +163,9 @@ scm_setvbuf (SCM port, SCM mode, SCM size)
}
else
{
SCM_ASSERT (SCM_INUMP (size), size, SCM_ARG3, s_setvbuf);
csize = SCM_INUM (size);
SCM_VALIDATE_INT_COPY(3,size,csize);
if (csize < 0 || (cmode == _IONBF && csize > 0))
scm_out_of_range (s_setvbuf, size);
scm_out_of_range (FUNC_NAME, size);
}
pt = SCM_PTAB_ENTRY (port);
@ -176,6 +179,7 @@ scm_setvbuf (SCM port, SCM mode, SCM size)
scm_fport_buffer_add (port, csize, csize);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Move ports with the specified file descriptor to new descriptors,
* reseting the revealed count to 0.
@ -214,12 +218,10 @@ scm_evict_ports (fd)
*
* Return the new port.
*/
SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
SCM
scm_open_file (filename, modes)
SCM filename;
SCM modes;
GUILE_PROC(scm_open_file, "open-file", 2, 0, 0,
(SCM filename, SCM modes),
"")
#define FUNC_NAME s_scm_open_file
{
SCM port;
int fdes;
@ -228,8 +230,8 @@ scm_open_file (filename, modes)
char *mode;
char *ptr;
SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
SCM_VALIDATE_ROSTRING(1,filename);
SCM_VALIDATE_ROSTRING(2,modes);
if (SCM_SUBSTRP (filename))
filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
if (SCM_SUBSTRP (modes))
@ -250,7 +252,7 @@ scm_open_file (filename, modes)
flags |= O_WRONLY | O_CREAT | O_APPEND;
break;
default:
scm_out_of_range (s_open_file, modes);
scm_out_of_range (FUNC_NAME, modes);
}
ptr = mode + 1;
while (*ptr != '\0')
@ -265,7 +267,7 @@ scm_open_file (filename, modes)
case 'l': /* line buffered: handled during output. */
break;
default:
scm_out_of_range (s_open_file, modes);
scm_out_of_range (FUNC_NAME, modes);
}
ptr++;
}
@ -274,7 +276,7 @@ scm_open_file (filename, modes)
{
int en = errno;
scm_syserror_msg (s_open_file, "%s: %S",
scm_syserror_msg (FUNC_NAME, "%s: %S",
scm_cons (scm_makfrom0str (strerror (en)),
scm_cons (filename, SCM_EOL)),
en);
@ -282,6 +284,7 @@ scm_open_file (filename, modes)
port = scm_fdes_to_port (fdes, mode, filename);
return port;
}
#undef FUNC_NAME
/* Building Guile ports from a file descriptor. */
@ -361,13 +364,8 @@ fport_input_waiting (SCM port)
}
static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
prinfport (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
prinfport (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts ("#<", port);
scm_print_port_mode (exp, port);

82
libguile/gc.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
@ -51,6 +55,7 @@
#include "unif.h"
#include "async.h"
#include "scm_validate.h"
#include "gc.h"
#ifdef HAVE_MALLOC_H
@ -212,9 +217,9 @@ struct scm_heap_seg_data
static void scm_mark_weak_vector_spines SCM_P ((void));
static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *));
static void alloc_some_heap SCM_P ((int, SCM *));
static void scm_mark_weak_vector_spines(void);
static scm_sizet init_heap_seg(SCM_CELLPTR, scm_sizet, int, SCM *);
static void alloc_some_heap(int, SCM *);
@ -238,9 +243,10 @@ which_seg (SCM cell)
}
SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list);
SCM
scm_map_free_list ()
GUILE_PROC (scm_map_free_list, "map-free-list", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_map_free_list
{
int last_seg = -1, count = 0;
SCM f;
@ -266,6 +272,7 @@ scm_map_free_list ()
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Number of calls to SCM_NEWCELL since startup. */
@ -291,15 +298,15 @@ scm_check_freelist ()
static int scm_debug_check_freelist = 0;
SCM_PROC (s_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, scm_gc_set_debug_check_freelist_x);
SCM
scm_gc_set_debug_check_freelist_x (SCM flag)
GUILE_PROC (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
(SCM flag),
"")
#define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
{
SCM_ASSERT(SCM_BOOL_T == flag || SCM_BOOL_F == flag,
flag, 1, s_gc_set_debug_check_freelist_x);
scm_debug_check_freelist = (SCM_BOOL_T==flag)? 1: 0;
SCM_VALIDATE_BOOL_COPY(1,flag,scm_debug_check_freelist);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM
@ -334,9 +341,10 @@ scm_debug_newcell (void)
/* {Scheme Interface to GC}
*/
SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats);
SCM
scm_gc_stats ()
GUILE_PROC (scm_gc_stats, "gc-stats", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_gc_stats
{
int i;
int n;
@ -377,6 +385,7 @@ scm_gc_stats ()
SCM_ALLOW_INTS;
return answer;
}
#undef FUNC_NAME
void
@ -398,24 +407,27 @@ scm_gc_end ()
}
SCM_PROC (s_object_address, "object-address", 1, 0, 0, scm_object_address);
SCM
scm_object_address (obj)
SCM obj;
GUILE_PROC (scm_object_address, "object-address", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_object_address
{
return scm_ulong2num ((unsigned long)obj);
}
#undef FUNC_NAME
SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc);
SCM
scm_gc ()
GUILE_PROC(scm_gc, "gc", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_gc
{
SCM_DEFER_INTS;
scm_igc ("call");
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -423,9 +435,7 @@ scm_gc ()
*/
void
scm_gc_for_alloc (ncells, freelistp)
int ncells;
SCM * freelistp;
scm_gc_for_alloc (int ncells, SCM *freelistp)
{
SCM_REDEFER_INTS;
scm_igc ("cells");
@ -444,12 +454,12 @@ scm_gc_for_newcell ()
scm_gc_for_alloc (1, &scm_freelist);
fl = scm_freelist;
scm_freelist = SCM_CDR (fl);
SCM_SETCAR(fl, scm_tc16_allocated);
return fl;
}
void
scm_igc (what)
const char *what;
scm_igc (const char *what)
{
int j;
@ -609,8 +619,7 @@ scm_igc (what)
/* Mark an object precisely.
*/
void
scm_gc_mark (p)
SCM p;
scm_gc_mark (SCM p)
{
register long i;
register SCM ptr;
@ -873,7 +882,9 @@ gc_mark_nimp:
{ /* should be faster than going through scm_smobs */
case scm_tc_free_cell:
/* printf("found free_cell %X ", ptr); fflush(stdout); */
SCM_SETCDR (ptr, SCM_EOL);
break;
case scm_tc16_allocated:
SCM_SETGC8MARK (ptr);
break;
case scm_tcs_bignums:
case scm_tc16_flo:
@ -1757,14 +1768,14 @@ alloc_some_heap (ncells, freelistp)
SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name);
SCM
scm_unhash_name (name)
SCM name;
GUILE_PROC (scm_unhash_name, "unhash-name", 1, 0, 0,
(SCM name),
"")
#define FUNC_NAME s_scm_unhash_name
{
int x;
int bound;
SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name);
SCM_VALIDATE_SYMBOL(1,name);
SCM_DEFER_INTS;
bound = scm_n_heap_segs;
for (x = 0; x < bound; ++x)
@ -1793,6 +1804,7 @@ scm_unhash_name (name)
SCM_ALLOW_INTS;
return name;
}
#undef FUNC_NAME

14
libguile/gdbint.c
View file

@ -43,6 +43,10 @@
* The author can be reached at djurfeldt@nada.kth.se
* Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "_scm.h"
#include <stdio.h>
@ -132,11 +136,8 @@ static SCM gdb_output_port;
static int old_ints, old_gc;
static void unmark_port SCM_P ((SCM port));
static void
unmark_port (port)
SCM port;
unmark_port (SCM port)
{
SCM stream, string;
port_mark_p = SCM_GC8MARKP (port);
@ -150,11 +151,8 @@ unmark_port (port)
}
static void remark_port SCM_P ((SCM port));
static void
remark_port (port)
SCM port;
remark_port (SCM port)
{
SCM stream = SCM_STREAM (port);
SCM string = SCM_CDR (stream);

29
libguile/gsubr.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -59,12 +63,7 @@ SCM scm_sym_name;
SCM scm_f_gsubr_apply;
SCM
scm_make_gsubr(name, req, opt, rst, fcn)
const char *name;
int req;
int opt;
int rst;
SCM (*fcn)();
scm_make_gsubr(const char *name,int req,int opt,int rst,SCM (*fcn)())
{
switch SCM_GSUBR_MAKTYPE(req, opt, rst) {
case SCM_GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn);
@ -130,11 +129,10 @@ scm_make_gsubr_with_generic (const char *name,
}
SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply);
SCM
scm_gsubr_apply(args)
SCM args;
GUILE_PROC(scm_gsubr_apply, "gsubr-apply", 0, 0, 1,
(SCM args),
"")
#define FUNC_NAME s_scm_gsubr_apply
{
SCM self = SCM_CAR(args);
SCM (*fcn)() = SCM_SUBRF(SCM_GSUBR_PROC(self));
@ -143,7 +141,7 @@ scm_gsubr_apply(args)
int i, n = SCM_GSUBR_REQ(typ) + SCM_GSUBR_OPT(typ) + SCM_GSUBR_REST(typ);
#if 0
SCM_ASSERT(n <= sizeof(v)/sizeof(SCM),
self, "internal programming error", s_gsubr_apply);
self, "internal programming error", FUNC_NAME);
#endif
args = SCM_CDR(args);
for (i = 0; i < SCM_GSUBR_REQ(typ); i++) {
@ -179,6 +177,7 @@ scm_gsubr_apply(args)
}
return 0; /* Never reached. */
}
#undef FUNC_NAME
#ifdef GSUBR_TEST
@ -186,8 +185,7 @@ scm_gsubr_apply(args)
a scm_list of rest args
*/
SCM
gsubr_21l(req1, req2, opt, rst)
SCM req1, req2, opt, rst;
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
{
scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
scm_display(req1, scm_cur_outp);
@ -207,7 +205,8 @@ gsubr_21l(req1, req2, opt, rst)
void
scm_init_gsubr()
{
scm_f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply);
/* GJB:FIXME:: why is this file not including the .x file? */
scm_f_gsubr_apply = scm_make_subr(s_scm_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply);
scm_sym_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
scm_permanent_object (scm_sym_name);
#ifdef GSUBR_TEST

16
libguile/guardians.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* This is an implementation of guardians as described in
@ -58,6 +62,7 @@
#include "smob.h"
#include "genio.h"
#include "scm_validate.h"
#include "guardians.h"
static long scm_tc16_guardian;
@ -144,13 +149,13 @@ guard (SCM cclo, SCM arg)
static SCM guard1;
SCM_PROC (s_make_guardian, "make-guardian", 0, 0, 0, scm_make_guardian);
SCM
scm_make_guardian ()
GUILE_PROC (scm_make_guardian, "make-guardian", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_make_guardian
{
SCM cclo = scm_makcclo (guard1, 2L);
guardian_t *g = (guardian_t *) scm_must_malloc (sizeof (guardian_t),
s_make_guardian);
guardian_t *g = SCM_MUST_MALLOC_TYPE(guardian_t);
SCM z1 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
SCM z2 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
SCM z;
@ -164,6 +169,7 @@ scm_make_guardian ()
return cclo;
}
#undef FUNC_NAME
void
scm_guardian_gc_init()

61
libguile/hash.c
View file

@ -38,12 +38,17 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "chars.h"
#include "scm_validate.h"
#include "hash.h"
@ -53,10 +58,7 @@ extern double floor();
unsigned long
scm_hasher(obj, n, d)
SCM obj;
unsigned long n;
scm_sizet d;
scm_hasher(SCM obj, unsigned long n, scm_sizet d)
{
switch (7 & (int) obj) {
case 2: case 6: /* SCM_INUMP(obj) */
@ -136,33 +138,28 @@ scm_hasher(obj, n, d)
unsigned int
scm_ihashq (obj, n)
SCM obj;
unsigned int n;
scm_ihashq (SCM obj, unsigned int n)
{
return (((unsigned int) obj) >> 1) % n;
}
SCM_PROC(s_hashq, "hashq", 2, 0, 0, scm_hashq);
SCM
scm_hashq(obj, n)
SCM obj;
SCM n;
GUILE_PROC(scm_hashq, "hashq", 2, 0, 0,
(SCM obj, SCM n),
"")
#define FUNC_NAME s_scm_hashq
{
SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashq);
SCM_VALIDATE_INT_MIN(2,n,0);
return SCM_MAKINUM(scm_ihashq (obj, SCM_INUM (n)));
}
#undef FUNC_NAME
unsigned int
scm_ihashv (obj, n)
SCM obj;
unsigned int n;
scm_ihashv (SCM obj, unsigned int n)
{
if (SCM_ICHRP(obj))
return ((unsigned int)(scm_downcase(SCM_ICHR(obj)))) % n; /* downcase!?!! */
@ -174,39 +171,35 @@ scm_ihashv (obj, n)
}
SCM_PROC(s_hashv, "hashv", 2, 0, 0, scm_hashv);
SCM
scm_hashv(obj, n)
SCM obj;
SCM n;
GUILE_PROC(scm_hashv, "hashv", 2, 0, 0,
(SCM obj, SCM n),
"")
#define FUNC_NAME s_scm_hashv
{
SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashv);
SCM_VALIDATE_INT_MIN(2,n,0);
return SCM_MAKINUM(scm_ihashv (obj, SCM_INUM (n)));
}
#undef FUNC_NAME
unsigned int
scm_ihash (obj, n)
SCM obj;
unsigned int n;
scm_ihash (SCM obj, unsigned int n)
{
return (unsigned int)scm_hasher (obj, n, 10);
}
SCM_PROC(s_hash, "hash", 2, 0, 0, scm_hash);
SCM
scm_hash(obj, n)
SCM obj;
SCM n;
GUILE_PROC(scm_hash, "hash", 2, 0, 0,
(SCM obj, SCM n),
"")
#define FUNC_NAME s_scm_hash
{
SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hash);
SCM_VALIDATE_INT_MIN(2,n,0);
return SCM_MAKINUM(scm_ihash(obj, SCM_INUM(n)));
}
#undef FUNC_NAME

324
libguile/hashtab.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -46,17 +50,13 @@
#include "hash.h"
#include "eval.h"
#include "scm_validate.h"
#include "hashtab.h"
SCM
scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure)
SCM table;
SCM obj;
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure)
{
unsigned int k;
SCM h;
@ -76,13 +76,8 @@ scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure)
SCM
scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure)
SCM table;
SCM obj;
SCM init;
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)(),
SCM (*assoc_fn)(),void * closure)
{
unsigned int k;
SCM it;
@ -116,13 +111,8 @@ scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure)
SCM
scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure)
SCM table;
SCM obj;
SCM dflt;
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(),
SCM (*assoc_fn)(),void * closure)
{
SCM it;
@ -137,13 +127,8 @@ scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure)
SCM
scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure)
SCM table;
SCM obj;
SCM val;
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
scm_hash_fn_set_x (SCM table,SCM obj,SCM val,unsigned int (*hash_fn)(),
SCM (*assoc_fn)(),void * closure)
{
SCM it;
@ -157,13 +142,8 @@ scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure)
SCM
scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure)
SCM table;
SCM obj;
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
SCM (*delete_fn)();
void * closure;
scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),
SCM (*delete_fn)(),void * closure)
{
unsigned int k;
SCM h;
@ -184,192 +164,168 @@ scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure)
SCM_PROC (s_hashq_get_handle, "hashq-get-handle", 2, 0, 0, scm_hashq_get_handle);
SCM
scm_hashq_get_handle (table, obj)
SCM table;
SCM obj;
GUILE_PROC (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
(SCM table, SCM obj),
"")
#define FUNC_NAME s_scm_hashq_get_handle
{
return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, scm_hashq_create_handle_x);
SCM
scm_hashq_create_handle_x (table, obj, init)
SCM table;
SCM obj;
SCM init;
GUILE_PROC (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
(SCM table, SCM obj, SCM init),
"")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashq_ref, "hashq-ref", 2, 1, 0, scm_hashq_ref);
SCM
scm_hashq_ref (table, obj, dflt)
SCM table;
SCM obj;
SCM dflt;
GUILE_PROC (scm_hashq_ref, "hashq-ref", 2, 1, 0,
(SCM table, SCM obj, SCM dflt),
"")
#define FUNC_NAME s_scm_hashq_ref
{
if (dflt == SCM_UNDEFINED)
dflt = SCM_BOOL_F;
return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashq_set_x, "hashq-set!", 3, 0, 0, scm_hashq_set_x);
SCM
scm_hashq_set_x (table, obj, val)
SCM table;
SCM obj;
SCM val;
GUILE_PROC (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
(SCM table, SCM obj, SCM val),
"")
#define FUNC_NAME s_scm_hashq_set_x
{
return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashq_remove_x, "hashq-remove!", 2, 0, 0, scm_hashq_remove_x);
SCM
scm_hashq_remove_x (table, obj)
SCM table;
SCM obj;
GUILE_PROC (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
(SCM table, SCM obj),
"")
#define FUNC_NAME s_scm_hashq_remove_x
{
return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashv_get_handle, "hashv-get-handle", 2, 0, 0, scm_hashv_get_handle);
SCM
scm_hashv_get_handle (table, obj)
SCM table;
SCM obj;
GUILE_PROC (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
(SCM table, SCM obj),
"")
#define FUNC_NAME s_scm_hashv_get_handle
{
return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, scm_hashv_create_handle_x);
SCM
scm_hashv_create_handle_x (table, obj, init)
SCM table;
SCM obj;
SCM init;
GUILE_PROC (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
(SCM table, SCM obj, SCM init),
"")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashv_ref, "hashv-ref", 2, 1, 0, scm_hashv_ref);
SCM
scm_hashv_ref (table, obj, dflt)
SCM table;
SCM obj;
SCM dflt;
GUILE_PROC (scm_hashv_ref, "hashv-ref", 2, 1, 0,
(SCM table, SCM obj, SCM dflt),
"")
#define FUNC_NAME s_scm_hashv_ref
{
if (dflt == SCM_UNDEFINED)
dflt = SCM_BOOL_F;
return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashv_set_x, "hashv-set!", 3, 0, 0, scm_hashv_set_x);
SCM
scm_hashv_set_x (table, obj, val)
SCM table;
SCM obj;
SCM val;
GUILE_PROC (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
(SCM table, SCM obj, SCM val),
"")
#define FUNC_NAME s_scm_hashv_set_x
{
return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hashv_remove_x, "hashv-remove!", 2, 0, 0, scm_hashv_remove_x);
SCM
scm_hashv_remove_x (table, obj)
SCM table;
SCM obj;
GUILE_PROC (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
(SCM table, SCM obj),
"")
#define FUNC_NAME s_scm_hashv_remove_x
{
return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hash_get_handle, "hash-get-handle", 2, 0, 0, scm_hash_get_handle);
SCM
scm_hash_get_handle (table, obj)
SCM table;
SCM obj;
GUILE_PROC (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
(SCM table, SCM obj),
"")
#define FUNC_NAME s_scm_hash_get_handle
{
return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, scm_hash_create_handle_x);
SCM
scm_hash_create_handle_x (table, obj, init)
SCM table;
SCM obj;
SCM init;
GUILE_PROC (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
(SCM table, SCM obj, SCM init),
"")
#define FUNC_NAME s_scm_hash_create_handle_x
{
return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hash_ref, "hash-ref", 2, 1, 0, scm_hash_ref);
SCM
scm_hash_ref (table, obj, dflt)
SCM table;
SCM obj;
SCM dflt;
GUILE_PROC (scm_hash_ref, "hash-ref", 2, 1, 0,
(SCM table, SCM obj, SCM dflt),
"")
#define FUNC_NAME s_scm_hash_ref
{
if (dflt == SCM_UNDEFINED)
dflt = SCM_BOOL_F;
return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hash_set_x, "hash-set!", 3, 0, 0, scm_hash_set_x);
SCM
scm_hash_set_x (table, obj, val)
SCM table;
SCM obj;
SCM val;
GUILE_PROC (scm_hash_set_x, "hash-set!", 3, 0, 0,
(SCM table, SCM obj, SCM val),
"")
#define FUNC_NAME s_scm_hash_set_x
{
return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME
SCM_PROC (s_hash_remove_x, "hash-remove!", 2, 0, 0, scm_hash_remove_x);
SCM
scm_hash_remove_x (table, obj)
SCM table;
SCM obj;
GUILE_PROC (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
(SCM table, SCM obj),
"")
#define FUNC_NAME s_scm_hash_remove_x
{
return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0);
}
#undef FUNC_NAME
@ -383,13 +339,8 @@ struct scm_ihashx_closure
static unsigned int scm_ihashx SCM_P ((SCM obj, unsigned int n, struct scm_ihashx_closure * closure));
static unsigned int
scm_ihashx (obj, n, closure)
SCM obj;
unsigned int n;
struct scm_ihashx_closure * closure;
scm_ihashx (SCM obj,unsigned int n,struct scm_ihashx_closure * closure)
{
SCM answer;
SCM_ALLOW_INTS;
@ -402,13 +353,8 @@ scm_ihashx (obj, n, closure)
static SCM scm_sloppy_assx SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
static SCM
scm_sloppy_assx (obj, alist, closure)
SCM obj;
SCM alist;
struct scm_ihashx_closure * closure;
scm_sloppy_assx (SCM obj,SCM alist,struct scm_ihashx_closure * closure)
{
SCM answer;
SCM_ALLOW_INTS;
@ -422,13 +368,8 @@ scm_sloppy_assx (obj, alist, closure)
static SCM scm_delx_x SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
static SCM
scm_delx_x (obj, alist, closure)
SCM obj;
SCM alist;
struct scm_ihashx_closure * closure;
scm_delx_x (SCM obj,SCM alist,struct scm_ihashx_closure * closure)
{
SCM answer;
SCM_ALLOW_INTS;
@ -441,49 +382,37 @@ scm_delx_x (obj, alist, closure)
SCM_PROC (s_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_hashx_get_handle);
SCM
scm_hashx_get_handle (hash, assoc, table, obj)
SCM hash;
SCM assoc;
SCM table;
SCM obj;
GUILE_PROC (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM obj),
"")
#define FUNC_NAME s_scm_hashx_get_handle
{
struct scm_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure);
}
#undef FUNC_NAME
SCM_PROC (s_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_hashx_create_handle_x);
SCM
scm_hashx_create_handle_x (hash, assoc, table, obj, init)
SCM hash;
SCM assoc;
SCM table;
SCM obj;
SCM init;
GUILE_PROC (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
(SCM hash,SCM assoc,SCM table,SCM obj,SCM init),
"")
#define FUNC_NAME s_scm_hashx_create_handle_x
{
struct scm_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure);
}
#undef FUNC_NAME
SCM_PROC (s_hashx_ref, "hashx-ref", 4, 1, 0, scm_hashx_ref);
SCM
scm_hashx_ref (hash, assoc, table, obj, dflt)
SCM hash;
SCM assoc;
SCM table;
SCM obj;
SCM dflt;
GUILE_PROC (scm_hashx_ref, "hashx-ref", 4, 1, 0,
(SCM hash,SCM assoc,SCM table,SCM obj,SCM dflt),
"")
#define FUNC_NAME s_scm_hashx_ref
{
struct scm_ihashx_closure closure;
if (dflt == SCM_UNDEFINED)
@ -492,35 +421,27 @@ scm_hashx_ref (hash, assoc, table, obj, dflt)
closure.assoc = assoc;
return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure);
}
#undef FUNC_NAME
SCM_PROC (s_hashx_set_x, "hashx-set!", 5, 0, 0, scm_hashx_set_x);
SCM
scm_hashx_set_x (hash, assoc, table, obj, val)
SCM hash;
SCM assoc;
SCM table;
SCM obj;
SCM val;
GUILE_PROC (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM obj, SCM val),
"")
#define FUNC_NAME s_scm_hashx_set_x
{
struct scm_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure);
}
#undef FUNC_NAME
SCM
scm_hashx_remove_x (hash, assoc, delete, table, obj)
SCM hash;
SCM assoc;
SCM delete;
SCM table;
SCM obj;
scm_hashx_remove_x (SCM hash,SCM assoc,SCM delete,SCM table,SCM obj)
{
struct scm_ihashx_closure closure;
closure.hash = hash;
@ -535,17 +456,16 @@ fold_proc (void *proc, SCM key, SCM data, SCM value)
return scm_apply ((SCM) proc, SCM_LIST3 (key, data, value), SCM_EOL);
}
SCM_PROC (s_hash_fold, "hash-fold", 3, 0, 0, scm_hash_fold);
SCM
scm_hash_fold (SCM proc, SCM init, SCM table)
GUILE_PROC (scm_hash_fold, "hash-fold", 3, 0, 0,
(SCM proc, SCM init, SCM table),
"")
#define FUNC_NAME s_scm_hash_fold
{
SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table),
table, SCM_ARG1, s_hash_fold);
SCM_ASSERT (SCM_NIMP (proc) && SCM_NFALSEP (scm_procedure_p (proc)),
proc, SCM_ARG2, s_hash_fold);
SCM_VALIDATE_PROC(1,proc);
SCM_VALIDATE_VECTOR(3,table);
return scm_internal_hash_fold (fold_proc, (void *) proc, init, table);
}
#undef FUNC_NAME
SCM
scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
@ -558,10 +478,10 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
while (SCM_NNULLP (ls))
{
SCM_ASSERT (SCM_NIMP (ls) && SCM_CONSP (ls),
table, SCM_ARG1, s_hash_fold);
table, SCM_ARG1, s_scm_hash_fold);
handle = SCM_CAR (ls);
SCM_ASSERT (SCM_NIMP (handle) && SCM_CONSP (handle),
table, SCM_ARG1, s_hash_fold);
table, SCM_ARG1, s_scm_hash_fold);
result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
ls = SCM_CDR (ls);
}

53
libguile/init.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* Include the headers for just about everything.
We call all their initialization functions. */
@ -136,12 +140,21 @@
/* Setting up the stack. */
static void start_stack SCM_P ((void *base));
static void restart_stack SCM_P ((void * base));
static void
restart_stack (void *base)
{
scm_dynwinds = SCM_EOL;
SCM_DYNENV (scm_rootcont) = SCM_EOL;
SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
#ifdef DEBUG_EXTENSIONS
SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
#endif
SCM_BASE (scm_rootcont) = base;
scm_continuation_stack_ptr = SCM_MAKINUM (0);
}
static void
start_stack (base)
void * base;
start_stack (void *base)
{
SCM root;
@ -178,31 +191,12 @@ start_stack (base)
}
static void
restart_stack (base)
void * base;
{
scm_dynwinds = SCM_EOL;
SCM_DYNENV (scm_rootcont) = SCM_EOL;
SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
#ifdef DEBUG_EXTENSIONS
SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
#endif
SCM_BASE (scm_rootcont) = base;
scm_continuation_stack_ptr = SCM_MAKINUM (0);
}
#if 0
static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
static void fixconfig SCM_P ((char *s1, char *s2, int s));
static void
fixconfig (s1, s2, s)
char *s1;
char *s2;
int s;
fixconfig (char *s1,char *s2,int s)
{
fputs (s1, stderr);
fputs (s2, stderr);
@ -213,10 +207,8 @@ fixconfig (s1, s2, s)
}
static void check_config SCM_P ((void));
static void
check_config ()
check_config (void)
{
scm_sizet j;
@ -344,16 +336,15 @@ typedef long setjmp_type;
struct main_func_closure
{
/* the function to call */
void (*main_func) SCM_P ((void *closure, int argc, char **argv));
void (*main_func)(void *closure, int argc, char **argv);
void *closure; /* dummy data to pass it */
int argc;
char **argv; /* the argument list it should receive */
};
static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
struct main_func_closure *closure));
static SCM invoke_main_func SCM_P ((void *body_data));
static void scm_boot_guile_1(SCM_STACKITEM *base, struct main_func_closure *closure);
static SCM invoke_main_func(void *body_data);
/* Fire up the Guile Scheme interpreter.

219
libguile/ioext.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
@ -50,6 +54,7 @@
#include "chars.h"
#include "feature.h"
#include "scm_validate.h"
#include "ioext.h"
#include <fcntl.h>
@ -62,59 +67,36 @@
#endif
SCM_PROC (s_read_delimited_x, "%read-delimited!", 3, 3, 0, scm_read_delimited_x);
SCM
scm_read_delimited_x (delims, buf, gobble, port, start, end)
SCM delims;
SCM buf;
SCM gobble;
SCM port;
SCM start;
SCM end;
GUILE_PROC (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
(SCM delims, SCM buf, SCM gobble, SCM port, SCM start, SCM end),
"")
#define FUNC_NAME s_scm_read_delimited_x
{
long j;
char *cbuf;
long cstart;
long cend;
long cend, tend;
int c;
char *cdelims;
int num_delims;
SCM_ASSERT (SCM_NIMP (delims) && SCM_ROSTRINGP (delims),
delims, SCM_ARG1, s_read_delimited_x);
cdelims = SCM_ROCHARS (delims);
SCM_VALIDATE_ROSTRING_COPY(1,delims,cdelims);
num_delims = SCM_ROLENGTH (delims);
SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf),
buf, SCM_ARG2, s_read_delimited_x);
cbuf = SCM_CHARS (buf);
SCM_VALIDATE_STRING_COPY(2,buf,cbuf);
cend = SCM_LENGTH (buf);
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
{
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
port, SCM_ARG1, s_read_delimited_x);
}
SCM_VALIDATE_OPINPORT(4,port);
if (SCM_UNBNDP (start))
cstart = 0;
else
{
cstart = scm_num2long (start,
(char *) SCM_ARG5, s_read_delimited_x);
if (cstart < 0 || cstart >= cend)
scm_out_of_range (s_read_delimited_x, start);
SCM_VALIDATE_INT_DEF_COPY(5,start,0,cstart);
if (cstart < 0 || cstart >= cend)
scm_out_of_range (FUNC_NAME, start);
if (!SCM_UNBNDP (end))
{
long tend = scm_num2long (end, (char *) SCM_ARG6,
s_read_delimited_x);
if (tend <= cstart || tend > cend)
scm_out_of_range (s_read_delimited_x, end);
cend = tend;
}
}
SCM_VALIDATE_INT_DEF_COPY(6,end,cend,tend);
if (tend <= cstart || tend > cend)
scm_out_of_range (FUNC_NAME, end);
cend = tend;
for (j = cstart; j < cend; j++)
{
@ -140,6 +122,7 @@ scm_read_delimited_x (delims, buf, gobble, port, start, end)
}
return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart));
}
#undef FUNC_NAME
static unsigned char *
scm_do_read_line (SCM port, int *len_p)
@ -233,11 +216,10 @@ scm_do_read_line (SCM port, int *len_p)
* efficiently in Scheme.
*/
SCM_PROC (s_read_line, "%read-line", 0, 1, 0, scm_read_line);
SCM
scm_read_line (port)
SCM port;
GUILE_PROC (scm_read_line, "%read-line", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_read_line
{
scm_port *pt;
char *s;
@ -246,8 +228,7 @@ scm_read_line (port)
if (SCM_UNBNDP (port))
port = scm_cur_inp;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
port, SCM_ARG1, s_read_line);
SCM_VALIDATE_OPINPORT(1,port);
pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
@ -281,55 +262,50 @@ scm_read_line (port)
return scm_cons (line, term);
}
#undef FUNC_NAME
SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
SCM
scm_write_line (obj, port)
SCM obj;
SCM port;
GUILE_PROC (scm_write_line, "write-line", 1, 1, 0,
(SCM obj, SCM port),
"")
#define FUNC_NAME s_scm_write_line
{
scm_display (obj, port);
return scm_newline (port);
}
#undef FUNC_NAME
SCM_PROC (s_ftell, "ftell", 1, 0, 0, scm_ftell);
SCM
scm_ftell (object)
SCM object;
GUILE_PROC (scm_ftell, "ftell", 1, 0, 0,
(SCM object),
"")
#define FUNC_NAME s_scm_ftell
{
return scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
}
#undef FUNC_NAME
SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek);
SCM
scm_fseek (object, offset, whence)
SCM object;
SCM offset;
SCM whence;
GUILE_PROC (scm_fseek, "fseek", 3, 0, 0,
(SCM object, SCM offset, SCM whence),
"")
#define FUNC_NAME s_scm_fseek
{
scm_seek (object, offset, whence);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_redirect_port, "redirect-port", 2, 0, 0, scm_redirect_port);
SCM
scm_redirect_port (old, new)
SCM old;
SCM new;
GUILE_PROC (scm_redirect_port, "redirect-port", 2, 0, 0,
(SCM old, SCM new),
"")
#define FUNC_NAME s_scm_redirect_port
{
int ans, oldfd, newfd;
struct scm_fport *fp;
old = SCM_COERCE_OUTPORT (old);
new = SCM_COERCE_OUTPORT (new);
SCM_ASSERT (SCM_NIMP (old) && SCM_OPFPORTP (old), old, SCM_ARG1, s_redirect_port);
SCM_ASSERT (SCM_NIMP (new) && SCM_OPFPORTP (new), new, SCM_ARG2, s_redirect_port);
SCM_VALIDATE_OPFPORT(1,old);
SCM_VALIDATE_OPFPORT(2,new);
oldfd = SCM_FPORT_FDES (old);
fp = SCM_FSTREAM (new);
newfd = fp->fdes;
@ -346,16 +322,18 @@ scm_redirect_port (old, new)
scm_end_input (new);
ans = dup2 (oldfd, newfd);
if (ans == -1)
scm_syserror (s_redirect_port);
SCM_SYSERROR;
pt->rw_random = old_pt->rw_random;
/* continue using existing buffers, even if inappropriate. */
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_dup_to_fdes, "dup->fdes", 1, 1, 0, scm_dup_to_fdes);
SCM
scm_dup_to_fdes (SCM fd_or_port, SCM fd)
GUILE_PROC (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
(SCM fd_or_port, SCM fd),
"")
#define FUNC_NAME s_scm_dup_to_fdes
{
int oldfd, newfd, rv;
@ -365,8 +343,7 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd)
oldfd = SCM_INUM (fd_or_port);
else
{
SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPFPORTP (fd_or_port),
fd_or_port, SCM_ARG1, s_dup_to_fdes);
SCM_VALIDATE_OPFPORT(1,fd_or_port);
oldfd = SCM_FPORT_FDES (fd_or_port);
}
@ -374,41 +351,44 @@ scm_dup_to_fdes (SCM fd_or_port, SCM fd)
{
newfd = dup (oldfd);
if (newfd == -1)
scm_syserror (s_dup_to_fdes);
SCM_SYSERROR;
fd = SCM_MAKINUM (newfd);
}
else
{
SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_dup_to_fdes);
SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, FUNC_NAME);
newfd = SCM_INUM (fd);
if (oldfd != newfd)
{
scm_evict_ports (newfd); /* see scsh manual. */
rv = dup2 (oldfd, newfd);
if (rv == -1)
scm_syserror (s_dup_to_fdes);
SCM_SYSERROR;
}
}
return fd;
}
#undef FUNC_NAME
SCM_PROC (s_fileno, "fileno", 1, 0, 0, scm_fileno);
SCM
scm_fileno (port)
SCM port;
GUILE_PROC (scm_fileno, "fileno", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_fileno
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1,
s_fileno);
SCM_VALIDATE_OPFPORT(1,port);
return SCM_MAKINUM (SCM_FPORT_FDES (port));
}
#undef FUNC_NAME
SCM_PROC (s_isatty, "isatty?", 1, 0, 0, scm_isatty_p);
SCM
scm_isatty_p (port)
SCM port;
/* GJB:FIXME:: why does this not throw
an error if the arg is not a port?
This proc as is would be better names isattyport?
if it is not going to assume that the arg is a port */
GUILE_PROC (scm_isatty_p, "isatty?", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_isatty_p
{
int rv;
@ -418,27 +398,26 @@ scm_isatty_p (port)
return SCM_BOOL_F;
rv = isatty (SCM_FPORT_FDES (port));
return rv ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(rv);
}
#undef FUNC_NAME
SCM_PROC (s_fdopen, "fdopen", 2, 0, 0, scm_fdopen);
SCM
scm_fdopen (fdes, modes)
SCM fdes;
SCM modes;
GUILE_PROC (scm_fdopen, "fdopen", 2, 0, 0,
(SCM fdes, SCM modes),
"")
#define FUNC_NAME s_scm_fdopen
{
SCM port;
SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_fdopen);
SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
s_fdopen);
SCM_VALIDATE_INT(1,fdes);
SCM_VALIDATE_ROSTRING(2,modes);
SCM_COERCE_SUBSTR (modes);
port = scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F);
return port;
}
#undef FUNC_NAME
@ -447,12 +426,10 @@ scm_fdopen (fdes, modes)
* #t if fdes moved.
* MOVE->FDES is implemented in Scheme and calls this primitive.
*/
SCM_PROC (s_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_primitive_move_to_fdes);
SCM
scm_primitive_move_to_fdes (port, fd)
SCM port;
SCM fd;
GUILE_PROC (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
(SCM port, SCM fd),
"")
#define FUNC_NAME s_scm_primitive_move_to_fdes
{
struct scm_fport *stream;
int old_fd;
@ -461,8 +438,8 @@ scm_primitive_move_to_fdes (port, fd)
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_primitive_move_to_fdes);
SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_move_to_fdes);
SCM_VALIDATE_OPFPORT(1,port);
SCM_VALIDATE_INT(2,fd);
stream = SCM_FSTREAM (port);
old_fd = stream->fdes;
new_fd = SCM_INUM (fd);
@ -473,25 +450,24 @@ scm_primitive_move_to_fdes (port, fd)
scm_evict_ports (new_fd);
rv = dup2 (old_fd, new_fd);
if (rv == -1)
scm_syserror (s_primitive_move_to_fdes);
SCM_SYSERROR;
stream->fdes = new_fd;
SCM_SYSCALL (close (old_fd));
return SCM_BOOL_T;
}
#undef FUNC_NAME
/* Return a list of ports using a given file descriptor. */
SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports);
SCM
scm_fdes_to_ports (fd)
SCM fd;
GUILE_PROC(scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
(SCM fd),
"")
#define FUNC_NAME s_scm_fdes_to_ports
{
SCM result = SCM_EOL;
int int_fd;
int i;
SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports);
int_fd = SCM_INUM (fd);
SCM_VALIDATE_INT_COPY(1,fd,int_fd);
for (i = 0; i < scm_port_table_size; i++)
{
@ -500,7 +476,8 @@ scm_fdes_to_ports (fd)
result = scm_cons (scm_port_table[i]->port, result);
}
return result;
}
}
#undef FUNC_NAME
void

54
libguile/keywords.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -45,16 +49,12 @@
#include "genio.h"
#include "smob.h"
#include "scm_validate.h"
#include "keywords.h"
static int prin_keyword SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
prin_keyword (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
prin_keyword (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts ("#:", port);
scm_puts(1 + SCM_CHARS (SCM_CDR (exp)), port);
@ -68,18 +68,17 @@ int scm_tc16_keyword;
int scm_tc16_kw;
SCM_PROC (s_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, scm_make_keyword_from_dash_symbol);
SCM
scm_make_keyword_from_dash_symbol (symbol)
SCM symbol;
GUILE_PROC (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
(SCM symbol),
"")
#define FUNC_NAME s_scm_make_keyword_from_dash_symbol
{
SCM vcell;
SCM_ASSERT (SCM_NIMP (symbol)
&& SCM_SYMBOLP (symbol)
&& ('-' == SCM_CHARS(symbol)[0]),
symbol, SCM_ARG1, s_make_keyword_from_dash_symbol);
symbol, SCM_ARG1, FUNC_NAME);
SCM_DEFER_INTS;
vcell = scm_sym2ovcell_soft (symbol, scm_keyword_obarray);
@ -94,6 +93,7 @@ scm_make_keyword_from_dash_symbol (symbol)
SCM_ALLOW_INTS;
return SCM_CDR (vcell);
}
#undef FUNC_NAME
SCM
scm_c_make_keyword (char *s)
@ -107,31 +107,25 @@ scm_c_make_keyword (char *s)
return scm_make_keyword_from_dash_symbol (SCM_CAR (vcell));
}
SCM_PROC(s_keyword_p, "keyword?", 1, 0, 0, scm_keyword_p);
SCM
scm_keyword_p (obj)
SCM obj;
GUILE_PROC(scm_keyword_p, "keyword?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_keyword_p
{
return ( (SCM_NIMP(obj) && SCM_KEYWORDP (obj))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP(obj) && SCM_KEYWORDP (obj));
}
#undef FUNC_NAME
SCM_PROC(s_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, scm_keyword_dash_symbol);
SCM
scm_keyword_dash_symbol (keyword)
SCM keyword;
GUILE_PROC(scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
(SCM keyword),
"")
#define FUNC_NAME s_scm_keyword_dash_symbol
{
SCM_ASSERT (SCM_NIMP (keyword) && SCM_KEYWORDP (keyword),
keyword, SCM_ARG1, s_keyword_dash_symbol);
SCM_VALIDATE_KEYWORD(1,keyword);
return SCM_CDR (keyword);
}
#undef FUNC_NAME

58
libguile/lang.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "_scm.h"
@ -45,6 +49,7 @@
#include "eval.h"
#include "macros.h"
#include "scm_validate.h"
#include "lang.h"
@ -58,10 +63,10 @@
* in all data structures.
*/
SCM_PROC (s_nil_cons, "nil-cons", 2, 0, 0, scm_nil_cons);
SCM
scm_nil_cons (SCM x, SCM y)
GUILE_PROC (scm_nil_cons, "nil-cons", 2, 0, 0,
(SCM x, SCM y),
"")
#define FUNC_NAME s_scm_nil_cons
{
register SCM z;
SCM_NEWCELL (z);
@ -69,37 +74,43 @@ scm_nil_cons (SCM x, SCM y)
SCM_SETCDR (z, SCM_NIL2EOL (y, y));
return z;
}
#undef FUNC_NAME
SCM_PROC (s_nil_car, "nil-car", 1, 0, 0, scm_nil_car);
SCM
scm_nil_car (SCM x)
GUILE_PROC (scm_nil_car, "nil-car", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_nil_car
{
if (SCM_NILP (x))
return scm_nil;
SCM_ASSERT (SCM_NIMP (x) && SCM_CONSP (x), x, SCM_ARG1, s_nil_car);
SCM_VALIDATE_NIMCONS(1,x);
return SCM_CAR (x);
}
#undef FUNC_NAME
SCM_PROC (s_nil_cdr, "nil-cdr", 1, 0, 0, scm_nil_cdr);
SCM
scm_nil_cdr (SCM x)
GUILE_PROC (scm_nil_cdr, "nil-cdr", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_nil_cdr
{
if (SCM_NILP (x))
return scm_nil;
SCM_ASSERT (SCM_NIMP (x) && SCM_CONSP (x), x, SCM_ARG1, s_nil_cdr);
SCM_VALIDATE_NIMCONS(1,x);
return SCM_EOL2NIL (SCM_CDR (x), x);
}
#undef FUNC_NAME
SCM_PROC (s_null, "null", 1, 0, 0, scm_null);
SCM
scm_null (SCM x)
/* GJB:FIXME:: why does this return scm_nil instead of SCM_BOOL_F?
Could use SCM_BOOL, below, otherwise */
GUILE_PROC (scm_null, "null", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_null
{
return (SCM_NILP (x) || SCM_NULLP (x) || SCM_FALSEP (x)) ? scm_t : scm_nil;
}
#undef FUNC_NAME
SCM
scm_m_while (SCM exp, SCM env)
@ -118,10 +129,12 @@ scm_m_while (SCM exp, SCM env)
return scm_nil;
}
SCM_PROC1 (s_nil_eq, "nil-eq", scm_tc7_rpsubr, scm_nil_eq);
SCM
scm_nil_eq (SCM x, SCM y)
/* GJB:FIXME:: why does this return scm_nil instead of SCM_BOOL_F?
Could use SCM_BOOL, below, otherwise */
GUILE_PROC1 (scm_nil_eq, "nil-eq", scm_tc7_rpsubr,
(SCM x, SCM y),
"")
#define FUNC_NAME s_scm_nil_eq
{
return (((x==y)
|| (SCM_NILP (x) && (SCM_NULLP (y) || SCM_FALSEP (y)))
@ -129,6 +142,7 @@ scm_nil_eq (SCM x, SCM y)
? scm_t
: scm_nil);
}
#undef FUNC_NAME

464
libguile/list.c
View file

@ -38,11 +38,16 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "eq.h"
#include "scm_validate.h"
#include "list.h"
#ifdef __STDC__
@ -84,19 +89,20 @@ scm_listify (elt, va_alist)
}
SCM_PROC(s_list, "list", 0, 0, 1, scm_list);
SCM
scm_list(objs)
SCM objs;
GUILE_PROC(scm_list, "list", 0, 0, 1,
(SCM objs),
"")
#define FUNC_NAME s_scm_list
{
return objs;
}
#undef FUNC_NAME
SCM_PROC (s_list_star, "list*", 1, 0, 1, scm_list_star);
SCM
scm_list_star (SCM arg, SCM rest)
GUILE_PROC (scm_list_star, "list*", 1, 0, 1,
(SCM arg, SCM rest),
"")
#define FUNC_NAME s_scm_list_star
{
if (SCM_NIMP (rest))
{
@ -110,30 +116,29 @@ scm_list_star (SCM arg, SCM rest)
}
return arg;
}
#undef FUNC_NAME
/* general questions about lists --- null?, list?, length, etc. */
SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p);
SCM
scm_null_p(x)
SCM x;
GUILE_PROC(scm_null_p, "null?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_null_p
{
return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_NULLP(x));
}
#undef FUNC_NAME
SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p);
SCM
scm_list_p(x)
SCM x;
GUILE_PROC(scm_list_p, "list?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_list_p
{
if (scm_ilength(x)<0)
return SCM_BOOL_F;
else
return SCM_BOOL_T;
return SCM_BOOL(scm_ilength(x)>=0);
}
#undef FUNC_NAME
/* Return the length of SX, or -1 if it's not a proper list.
@ -141,8 +146,7 @@ scm_list_p(x)
long" lists (i.e. lists with cycles in their cdrs), and returns -1
if it does find one. */
long
scm_ilength(sx)
SCM sx;
scm_ilength(SCM sx)
{
register long i = 0;
register SCM tortoise = sx;
@ -167,56 +171,57 @@ scm_ilength(sx)
return -1;
}
SCM_PROC(s_length, "length", 1, 0, 0, scm_length);
SCM
scm_length(x)
SCM x;
GUILE_PROC(scm_length, "length", 1, 0, 0,
(SCM lst),
"")
#define FUNC_NAME s_scm_length
{
int i;
i = scm_ilength(x);
SCM_ASSERT(i >= 0, x, SCM_ARG1, s_length);
SCM_VALIDATE_LIST_COPYLEN(1,lst,i);
return SCM_MAKINUM (i);
}
#undef FUNC_NAME
/* appending lists */
SCM_PROC (s_append, "append", 0, 0, 1, scm_append);
SCM
scm_append(args)
SCM args;
GUILE_PROC (scm_append, "append", 0, 0, 1,
(SCM args),
"")
#define FUNC_NAME s_scm_append
{
SCM res = SCM_EOL;
SCM *lloc = &res, arg;
if (SCM_IMP(args)) {
SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_append);
SCM_VALIDATE_NULL(SCM_ARGn, args);
return res;
}
SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_append);
SCM_VALIDATE_CONS(SCM_ARGn, args);
while (1) {
arg = SCM_CAR(args);
args = SCM_CDR(args);
if (SCM_IMP(args)) {
*lloc = arg;
SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_append);
SCM_VALIDATE_NULL(SCM_ARGn, args);
return res;
}
SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_append);
SCM_VALIDATE_CONS(SCM_ARGn, args);
for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) {
SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_append);
SCM_VALIDATE_CONS(SCM_ARGn, arg);
*lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
lloc = SCM_CDRLOC(*lloc);
}
SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_append);
SCM_VALIDATE_NULL(SCM_ARGn, arg);
}
}
#undef FUNC_NAME
SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x);
SCM
scm_append_x(args)
SCM args;
GUILE_PROC (scm_append_x, "append!", 0, 0, 1,
(SCM args),
"")
#define FUNC_NAME s_scm_append_x
{
SCM arg;
tail:
@ -225,16 +230,17 @@ scm_append_x(args)
args = SCM_CDR(args);
if (SCM_NULLP(args)) return arg;
if (SCM_NULLP(arg)) goto tail;
SCM_ASSERT(SCM_NIMP(arg) && SCM_CONSP(arg), arg, SCM_ARG1, s_append_x);
SCM_VALIDATE_NIMCONS(SCM_ARG1,arg);
SCM_SETCDR (scm_last_pair (arg), scm_append_x (args));
return arg;
}
#undef FUNC_NAME
SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
SCM
scm_last_pair(sx)
SCM sx;
GUILE_PROC(scm_last_pair, "last-pair", 1, 0, 0,
(SCM sx),
"")
#define FUNC_NAME s_scm_last_pair
{
register SCM res = sx;
register SCM x;
@ -242,7 +248,7 @@ scm_last_pair(sx)
if (SCM_NULLP (sx))
return SCM_EOL;
SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair);
SCM_VALIDATE_NIMCONS(SCM_ARG1,res);
while (!0) {
x = SCM_CDR(res);
if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
@ -251,50 +257,52 @@ scm_last_pair(sx)
if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
res = x;
sx = SCM_CDR(sx);
SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair);
SCM_ASSERT(x != sx, sx, SCM_ARG1, FUNC_NAME);
}
}
#undef FUNC_NAME
/* reversing lists */
SCM_PROC (s_reverse, "reverse", 1, 0, 0, scm_reverse);
SCM
scm_reverse (SCM ls)
GUILE_PROC (scm_reverse, "reverse", 1, 0, 0,
(SCM ls),
"")
#define FUNC_NAME s_scm_reverse
{
SCM res = SCM_EOL;
SCM p = ls, t = ls;
while (SCM_NIMP (p))
{
SCM_ASSERT (SCM_CONSP (p), ls, SCM_ARG1, s_reverse);
SCM_VALIDATE_CONS(1,ls);
res = scm_cons (SCM_CAR (p), res);
p = SCM_CDR (p);
if (SCM_IMP (p))
break;
SCM_ASSERT (SCM_CONSP (p), ls, SCM_ARG1, s_reverse);
SCM_VALIDATE_CONS(1,ls);
res = scm_cons (SCM_CAR (p), res);
p = SCM_CDR (p);
t = SCM_CDR (t);
if (t == p)
scm_misc_error (s_reverse, "Circular structure: %S", SCM_LIST1 (ls));
scm_misc_error (FUNC_NAME, "Circular structure: %S", SCM_LIST1 (ls));
}
SCM_ASSERT (SCM_NULLP (p), ls, SCM_ARG1, s_reverse);
ls = p;
SCM_VALIDATE_NULL(1,ls);
return res;
}
#undef FUNC_NAME
SCM_PROC (s_reverse_x, "reverse!", 1, 1, 0, scm_reverse_x);
SCM
scm_reverse_x (ls, new_tail)
SCM ls;
SCM new_tail;
GUILE_PROC (scm_reverse_x, "reverse!", 1, 1, 0,
(SCM ls, SCM new_tail),
"")
#define FUNC_NAME s_scm_reverse_x
{
SCM old_tail;
SCM_ASSERT (scm_ilength (ls) >= 0, ls, SCM_ARG1, s_reverse_x);
SCM_ASSERT (scm_ilength (ls) >= 0, ls, SCM_ARG1, FUNC_NAME);
if (SCM_UNBNDP (new_tail))
new_tail = SCM_EOL;
else
SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, s_reverse_x);
SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, FUNC_NAME);
while (SCM_NIMP (ls))
{
@ -305,124 +313,119 @@ scm_reverse_x (ls, new_tail)
}
return new_tail;
}
#undef FUNC_NAME
/* indexing lists by element number */
SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref);
SCM
scm_list_ref(lst, k)
SCM lst;
SCM k;
{
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref);
i = SCM_INUM(k);
SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref);
while (i-- > 0) {
SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
lst = SCM_CDR(lst);
}
erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref);
return SCM_CAR(lst);
}
SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x);
SCM
scm_list_set_x(lst, k, val)
SCM lst;
SCM k;
SCM val;
{
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x);
i = SCM_INUM(k);
SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x);
while (i-- > 0) {
SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
lst = SCM_CDR(lst);
}
erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x);
SCM_SETCAR (lst, val);
return val;
}
SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
SCM
scm_list_tail(lst, k)
SCM lst;
SCM k;
GUILE_PROC(scm_list_ref, "list-ref", 2, 0, 0,
(SCM lst, SCM k),
"")
#define FUNC_NAME s_scm_list_ref
{
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail);
i = SCM_INUM(k);
SCM_VALIDATE_INT_MIN_COPY(2,k,0,i);
while (i-- > 0) {
SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail);
SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
lst = SCM_CDR(lst);
}
erout:
SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
return SCM_CAR(lst);
}
#undef FUNC_NAME
GUILE_PROC(scm_list_set_x, "list-set!", 3, 0, 0,
(SCM lst, SCM k, SCM val),
"")
#define FUNC_NAME s_scm_list_set_x
{
register long i;
SCM_VALIDATE_INT_MIN_COPY(2,k,0,i);
while (i-- > 0) {
SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
lst = SCM_CDR(lst);
}
erout:
SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
SCM_SETCAR (lst, val);
return val;
}
#undef FUNC_NAME
SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
GUILE_PROC(scm_list_tail, "list-tail", 2, 0, 0,
(SCM lst, SCM k),
"")
#define FUNC_NAME s_scm_list_tail
{
register long i;
SCM_VALIDATE_INT_MIN_COPY(2,k,0,i);
while (i-- > 0) {
SCM_VALIDATE_NIMCONS(1,lst);
lst = SCM_CDR(lst);
}
return lst;
}
#undef FUNC_NAME
SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x);
SCM
scm_list_cdr_set_x(lst, k, val)
SCM lst;
SCM k;
SCM val;
GUILE_PROC(scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
(SCM lst, SCM k, SCM val),
"")
#define FUNC_NAME s_scm_list_cdr_set_x
{
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x);
i = SCM_INUM(k);
SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x);
while (i-- > 0) {
SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
lst = SCM_CDR(lst);
}
erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x);
SCM_SETCDR (lst, val);
return val;
register long i;
SCM_VALIDATE_INT_MIN_COPY(2,k,0,i);
while (i-- > 0) {
SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
lst = SCM_CDR(lst);
}
erout:
SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
SCM_SETCDR (lst, val);
return val;
}
#undef FUNC_NAME
/* copying lists, perhaps partially */
SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head);
SCM
scm_list_head(lst, k)
SCM lst;
SCM k;
GUILE_PROC(scm_list_head, "list-head", 2, 0, 0,
(SCM lst, SCM k),
"")
#define FUNC_NAME s_scm_list_head
{
SCM answer;
SCM * pos;
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head);
SCM_VALIDATE_INT_MIN_COPY(2,k,0,i);
answer = SCM_EOL;
pos = &answer;
i = SCM_INUM(k);
while (i-- > 0)
{
SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head);
SCM_VALIDATE_NIMCONS(1,lst);
*pos = scm_cons (SCM_CAR (lst), SCM_EOL);
pos = SCM_CDRLOC (*pos);
lst = SCM_CDR(lst);
}
return answer;
}
#undef FUNC_NAME
SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy);
SCM
scm_list_copy (lst)
SCM lst;
GUILE_PROC (scm_list_copy, "list-copy", 1, 0, 0,
(SCM lst),
"")
#define FUNC_NAME s_scm_list_copy
{
SCM newlst;
SCM * fill_here;
@ -442,15 +445,15 @@ scm_list_copy (lst)
}
return newlst;
}
#undef FUNC_NAME
/* membership tests (memq, memv, etc.) */
SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq);
SCM
scm_sloppy_memq(x, lst)
SCM x;
SCM lst;
GUILE_PROC (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
(SCM x, SCM lst),
"")
#define FUNC_NAME s_scm_sloppy_memq
{
for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
{
@ -459,13 +462,13 @@ scm_sloppy_memq(x, lst)
}
return lst;
}
#undef FUNC_NAME
SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv);
SCM
scm_sloppy_memv(x, lst)
SCM x;
SCM lst;
GUILE_PROC (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
(SCM x, SCM lst),
"")
#define FUNC_NAME s_scm_sloppy_memv
{
for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
{
@ -474,13 +477,13 @@ scm_sloppy_memv(x, lst)
}
return lst;
}
#undef FUNC_NAME
SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member);
SCM
scm_sloppy_member (x, lst)
SCM x;
SCM lst;
GUILE_PROC (scm_sloppy_member, "sloppy-member", 2, 0, 0,
(SCM x, SCM lst),
"")
#define FUNC_NAME s_scm_sloppy_member
{
for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
{
@ -489,57 +492,57 @@ scm_sloppy_member (x, lst)
}
return lst;
}
#undef FUNC_NAME
SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq);
SCM
scm_memq(x, lst)
SCM x;
SCM lst;
GUILE_PROC(scm_memq, "memq", 2, 0, 0,
(SCM x, SCM lst),
"")
#define FUNC_NAME s_scm_memq
{
SCM answer;
SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG2, s_memq);
SCM_VALIDATE_LIST(2,lst);
answer = scm_sloppy_memq (x, lst);
return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
}
#undef FUNC_NAME
SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv);
SCM
scm_memv(x, lst)
SCM x;
SCM lst;
GUILE_PROC(scm_memv, "memv", 2, 0, 0,
(SCM x, SCM lst),
"")
#define FUNC_NAME s_scm_memv
{
SCM answer;
SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG2, s_memv);
SCM_VALIDATE_LIST(2,lst);
answer = scm_sloppy_memv (x, lst);
return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
}
#undef FUNC_NAME
SCM_PROC(s_member, "member", 2, 0, 0, scm_member);
SCM
scm_member(x, lst)
SCM x;
SCM lst;
GUILE_PROC(scm_member, "member", 2, 0, 0,
(SCM x, SCM lst),
"")
#define FUNC_NAME s_scm_member
{
SCM answer;
SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG2, s_member);
SCM_VALIDATE_LIST(2,lst);
answer = scm_sloppy_member (x, lst);
return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
}
#undef FUNC_NAME
/* deleting elements from a list (delq, etc.) */
SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x);
SCM
scm_delq_x (item, lst)
SCM item;
SCM lst;
GUILE_PROC(scm_delq_x, "delq!", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delq_x
{
SCM walk;
SCM *prev;
@ -556,13 +559,13 @@ scm_delq_x (item, lst)
return lst;
}
#undef FUNC_NAME
SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x);
SCM
scm_delv_x (item, lst)
SCM item;
SCM lst;
GUILE_PROC(scm_delv_x, "delv!", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delv_x
{
SCM walk;
SCM *prev;
@ -579,14 +582,14 @@ scm_delv_x (item, lst)
return lst;
}
#undef FUNC_NAME
SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x);
SCM
scm_delete_x (item, lst)
SCM item;
SCM lst;
GUILE_PROC(scm_delete_x, "delete!", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delete_x
{
SCM walk;
SCM *prev;
@ -603,53 +606,47 @@ scm_delete_x (item, lst)
return lst;
}
#undef FUNC_NAME
SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq);
SCM
scm_delq (item, lst)
SCM item;
SCM lst;
GUILE_PROC (scm_delq, "delq", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delq
{
SCM copy;
copy = scm_list_copy (lst);
SCM copy = scm_list_copy (lst);
return scm_delq_x (item, copy);
}
#undef FUNC_NAME
SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv);
SCM
scm_delv (item, lst)
SCM item;
SCM lst;
GUILE_PROC (scm_delv, "delv", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delv
{
SCM copy;
copy = scm_list_copy (lst);
SCM copy = scm_list_copy (lst);
return scm_delv_x (item, copy);
}
#undef FUNC_NAME
SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete);
SCM
scm_delete (item, lst)
SCM item;
SCM lst;
GUILE_PROC (scm_delete, "delete", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delete
{
SCM copy;
copy = scm_list_copy (lst);
SCM copy = scm_list_copy (lst);
return scm_delete_x (item, copy);
}
#undef FUNC_NAME
SCM_PROC(s_delq1_x, "delq1!", 2, 0, 0, scm_delq1_x);
SCM
scm_delq1_x (item, lst)
SCM item;
SCM lst;
GUILE_PROC(scm_delq1_x, "delq1!", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delq1_x
{
SCM walk;
SCM *prev;
@ -669,13 +666,13 @@ scm_delq1_x (item, lst)
return lst;
}
#undef FUNC_NAME
SCM_PROC(s_delv1_x, "delv1!", 2, 0, 0, scm_delv1_x);
SCM
scm_delv1_x (item, lst)
SCM item;
SCM lst;
GUILE_PROC(scm_delv1_x, "delv1!", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delv1_x
{
SCM walk;
SCM *prev;
@ -695,13 +692,13 @@ scm_delv1_x (item, lst)
return lst;
}
#undef FUNC_NAME
SCM_PROC(s_delete1_x, "delete1!", 2, 0, 0, scm_delete1_x);
SCM
scm_delete1_x (item, lst)
SCM item;
SCM lst;
GUILE_PROC(scm_delete1_x, "delete1!", 2, 0, 0,
(SCM item, SCM lst),
"")
#define FUNC_NAME s_scm_delete1_x
{
SCM walk;
SCM *prev;
@ -721,6 +718,7 @@ scm_delete1_x (item, lst)
return lst;
}
#undef FUNC_NAME

115
libguile/load.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -50,6 +54,7 @@
#include "alist.h"
#include "dynwind.h"
#include "scm_validate.h"
#include "load.h"
#include <sys/types.h>
@ -92,23 +97,22 @@ load (void *data)
return SCM_UNSPECIFIED;
}
SCM_PROC(s_primitive_load, "primitive-load", 1, 0, 0, scm_primitive_load);
SCM
scm_primitive_load (filename)
SCM filename;
GUILE_PROC(scm_primitive_load, "primitive-load", 1, 0, 0,
(SCM filename),
"")
#define FUNC_NAME s_scm_primitive_load
{
SCM hook = *scm_loc_load_hook;
SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
SCM_ARG1, s_primitive_load);
SCM_VALIDATE_ROSTRING(1,filename);
SCM_ASSERT (hook == SCM_BOOL_F
|| (scm_procedure_p (hook) == SCM_BOOL_T),
hook, "value of %load-hook is neither a procedure nor #f",
s_primitive_load);
FUNC_NAME);
if (hook != SCM_BOOL_F)
scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL);
{
{ /* scope */
SCM port, save_port;
port = scm_open_file (filename,
scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
@ -122,16 +126,19 @@ scm_primitive_load (filename)
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Builtin path to scheme library files. */
#ifdef SCM_PKGDATA_DIR
SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir);
SCM
scm_sys_package_data_dir ()
GUILE_PROC (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_sys_package_data_dir
{
return scm_makfrom0str (SCM_PKGDATA_DIR);
}
#undef FUNC_NAME
#endif /* SCM_PKGDATA_DIR */
@ -171,21 +178,21 @@ scm_internal_parse_path (char *path, SCM tail)
}
SCM_PROC (s_parse_path, "parse-path", 1, 1, 0, scm_parse_path);
SCM
scm_parse_path (SCM path, SCM tail)
GUILE_PROC (scm_parse_path, "parse-path", 1, 1, 0,
(SCM path, SCM tail),
"")
#define FUNC_NAME s_scm_parse_path
{
SCM_ASSERT (SCM_FALSEP (path) || (SCM_NIMP (path) && SCM_ROSTRINGP (path)),
path,
SCM_ARG1,
s_parse_path);
SCM_ARG1, FUNC_NAME);
if (SCM_UNBNDP (tail))
tail = SCM_EOL;
return (SCM_FALSEP (path)
? tail
: scm_internal_parse_path (SCM_ROCHARS (path), tail));
}
#undef FUNC_NAME
/* Initialize the global variable %load-path, given the value of the
@ -216,26 +223,22 @@ SCM scm_listofnullstr;
If FILENAME is absolute, return it unchanged.
If given, EXTENSIONS is a list of strings; for each directory
in PATH, we search for FILENAME concatenated with each EXTENSION. */
SCM_PROC(s_search_path, "search-path", 2, 1, 0, scm_search_path);
SCM
scm_search_path (path, filename, extensions)
SCM path;
SCM filename;
SCM extensions;
GUILE_PROC(scm_search_path, "search-path", 2, 1, 0,
(SCM path, SCM filename, SCM extensions),
"")
#define FUNC_NAME s_scm_search_path
{
char *filename_chars;
int filename_len;
size_t max_path_len; /* maximum length of any PATH element */
size_t max_ext_len; /* maximum length of any EXTENSIONS element */
SCM_ASSERT (scm_ilength (path) >= 0, path, SCM_ARG1, s_search_path);
SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
SCM_ARG2, s_search_path);
SCM_VALIDATE_LIST(1,path);
SCM_VALIDATE_ROSTRING(2,filename);
if (SCM_UNBNDP (extensions))
extensions = SCM_EOL;
else
SCM_ASSERT (scm_ilength (extensions) >= 0, extensions,
SCM_ARG3, s_search_path);
SCM_VALIDATE_LIST(3,extensions);
filename_chars = SCM_ROCHARS (filename);
filename_len = SCM_ROLENGTH (filename);
@ -254,7 +257,7 @@ scm_search_path (path, filename, extensions)
SCM elt = SCM_CAR (walk);
SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
"path is not a list of strings",
s_search_path);
FUNC_NAME);
if (SCM_ROLENGTH (elt) > max_path_len)
max_path_len = SCM_ROLENGTH (elt);
}
@ -284,7 +287,7 @@ scm_search_path (path, filename, extensions)
/* Find the length of the longest element of the load extensions
list. */
{
{ /* scope */
SCM walk;
max_ext_len = 0;
@ -293,7 +296,7 @@ scm_search_path (path, filename, extensions)
SCM elt = SCM_CAR (walk);
SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
"extension list is not a list of strings",
s_search_path);
FUNC_NAME);
if (SCM_ROLENGTH (elt) > max_ext_len)
max_ext_len = SCM_ROLENGTH (elt);
}
@ -301,10 +304,10 @@ scm_search_path (path, filename, extensions)
SCM_DEFER_INTS;
{
{ /* scope */
SCM result = SCM_BOOL_F;
int buf_size = max_path_len + 1 + filename_len + max_ext_len + 1;
char *buf = scm_must_malloc (buf_size, s_search_path);
char *buf = SCM_MUST_MALLOC (buf_size);
/* This simplifies the loop below a bit. */
if (SCM_NULLP (extensions))
@ -356,41 +359,40 @@ scm_search_path (path, filename, extensions)
return result;
}
}
#undef FUNC_NAME
/* Search %load-path for a directory containing a file named FILENAME.
The file must be readable, and not a directory.
If we find one, return its full filename; otherwise, return #f.
If FILENAME is absolute, return it unchanged. */
SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
SCM
scm_sys_search_load_path (filename)
SCM filename;
GUILE_PROC(scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
(SCM filename),
"")
#define FUNC_NAME s_scm_sys_search_load_path
{
SCM path = *scm_loc_load_path;
SCM exts = *scm_loc_load_extensions;
SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
SCM_ARG1, s_sys_search_load_path);
SCM_VALIDATE_ROSTRING(1,filename);
SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list",
s_sys_search_load_path);
FUNC_NAME);
SCM_ASSERT (scm_ilength (exts) >= 0, exts,
"load extension list is not a proper list",
s_sys_search_load_path);
return scm_search_path (path,
filename,
exts);
FUNC_NAME);
return scm_search_path (path, filename, exts);
}
#undef FUNC_NAME
SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 0, 0, scm_primitive_load_path);
SCM
scm_primitive_load_path (filename)
SCM filename;
GUILE_PROC(scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
(SCM filename),
"")
#define FUNC_NAME s_scm_primitive_load_path
{
SCM full_filename;
SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
SCM_ARG1, s_primitive_load_path);
SCM_VALIDATE_ROSTRING(1,filename);
full_filename = scm_sys_search_load_path (filename);
@ -398,7 +400,7 @@ scm_primitive_load_path (filename)
{
int absolute = (SCM_ROLENGTH (filename) >= 1
&& SCM_ROCHARS (filename)[0] == '/');
scm_misc_error (s_primitive_load_path,
scm_misc_error (FUNC_NAME,
(absolute
? "Unable to load file %S"
: "Unable to find file %S in load path"),
@ -407,6 +409,7 @@ scm_primitive_load_path (filename)
return scm_primitive_load (full_filename);
}
#undef FUNC_NAME
/* The following function seems trivial - and indeed it is. Its
* existence is motivated by its ability to evaluate expressions
@ -415,17 +418,17 @@ scm_primitive_load_path (filename)
SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 1, 0, scm_read_and_eval_x);
SCM
scm_read_and_eval_x (port)
SCM port;
GUILE_PROC (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_read_and_eval_x
{
SCM form = scm_read (port);
if (SCM_EOF_OBJECT_P (form))
scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
return scm_eval_x (form);
}
#undef FUNC_NAME
/* Information about the build environment. */

105
libguile/macros.c
View file

@ -38,72 +38,71 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "_scm.h"
#include "smob.h"
#include "scm_validate.h"
#include "macros.h"
long scm_tc16_macro;
SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro);
SCM
scm_makacro (code)
SCM code;
GUILE_PROC (scm_makacro, "procedure->syntax", 1, 0, 0,
(SCM code),
"")
#define FUNC_NAME s_scm_makacro
{
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)),
code, SCM_ARG1, s_makacro);
SCM_VALIDATE_PROC(1,code);
SCM_RETURN_NEWSMOB (scm_tc16_macro, code);
}
#undef FUNC_NAME
SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro);
SCM
scm_makmacro (code)
SCM code;
GUILE_PROC(scm_makmacro, "procedure->macro", 1, 0, 0,
(SCM code),
"")
#define FUNC_NAME s_scm_makmacro
{
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)),
code, SCM_ARG1, s_makmacro);
SCM_VALIDATE_PROC(1,code);
SCM_RETURN_NEWSMOB (scm_tc16_macro | (1L << 16), code);
}
#undef FUNC_NAME
SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro);
SCM
scm_makmmacro (code)
SCM code;
GUILE_PROC(scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0,
(SCM code),
"")
#define FUNC_NAME s_scm_makmmacro
{
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)),
code, SCM_ARG1, s_makmmacro);
SCM_VALIDATE_PROC(1,code);
SCM_RETURN_NEWSMOB (scm_tc16_macro | (2L << 16), code);
}
#undef FUNC_NAME
SCM_PROC (s_macro_p, "macro?", 1, 0, 0, scm_macro_p);
SCM
scm_macro_p (obj)
SCM obj;
GUILE_PROC (scm_macro_p, "macro?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_macro_p
{
return (SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro);
}
#undef FUNC_NAME
SCM_SYMBOL (scm_sym_syntax, "syntax");
SCM_SYMBOL (scm_sym_macro, "macro");
SCM_SYMBOL (scm_sym_mmacro, "macro!");
SCM_PROC (s_macro_type, "macro-type", 1, 0, 0, scm_macro_type);
SCM
scm_macro_type (m)
SCM m;
GUILE_PROC (scm_macro_type, "macro-type", 1, 0, 0,
(SCM m),
"")
#define FUNC_NAME s_scm_macro_type
{
if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro))
return SCM_BOOL_F;
@ -112,43 +111,35 @@ scm_macro_type (m)
case 0: return scm_sym_syntax;
case 1: return scm_sym_macro;
case 2: return scm_sym_mmacro;
default: scm_wrong_type_arg (s_macro_type, 1, m);
default: scm_wrong_type_arg (FUNC_NAME, 1, m);
}
}
#undef FUNC_NAME
SCM_PROC (s_macro_name, "macro-name", 1, 0, 0, scm_macro_name);
SCM
scm_macro_name (m)
SCM m;
GUILE_PROC (scm_macro_name, "macro-name", 1, 0, 0,
(SCM m),
"")
#define FUNC_NAME s_scm_macro_name
{
SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro,
m,
SCM_ARG1,
s_macro_name);
SCM_VALIDATE_SMOB(1,m,macro);
return scm_procedure_name (SCM_CDR (m));
}
#undef FUNC_NAME
SCM_PROC (s_macro_transformer, "macro-transformer", 1, 0, 0, scm_macro_transformer);
SCM
scm_macro_transformer (m)
SCM m;
GUILE_PROC (scm_macro_transformer, "macro-transformer", 1, 0, 0,
(SCM m),
"")
#define FUNC_NAME s_scm_macro_transformer
{
SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro,
m,
SCM_ARG1,
s_macro_transformer);
SCM_VALIDATE_SMOB(1,m,macro);
return SCM_CLOSUREP (SCM_CDR (m)) ? SCM_CDR (m) : SCM_BOOL_F;
}
#undef FUNC_NAME
SCM
scm_make_synt (name, macroizer, fcn)
const char *name;
SCM (*macroizer) ();
SCM (*fcn) ();
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
SCM symcell = scm_sysintern (name, SCM_UNDEFINED);
long tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);

21
libguile/mallocs.c
View file

@ -1,6 +1,5 @@
/* classes: src_files */
/* Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc.
/* classes: src_files
* Copyright (C) 1995, 1997, 1998 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@ -17,6 +16,10 @@
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -38,11 +41,8 @@
static scm_sizet fmalloc SCM_P ((SCM ptr));
static scm_sizet
fmalloc(ptr)
SCM ptr;
fmalloc(SCM ptr)
{
if (SCM_MALLOCDATA (ptr))
free (SCM_MALLOCDATA (ptr));
@ -50,13 +50,8 @@ fmalloc(ptr)
}
static int prinmalloc SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
prinmalloc (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
prinmalloc (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts("#<malloc ", port);
scm_intprint(SCM_CDR(exp), 16, port);

182
libguile/net_db.c
View file

@ -40,6 +40,10 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* Written in 1994 by Aubrey Jaffer.
* Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
* Rewritten by Gary Houston to be a closer interface to the C socket library.
@ -51,6 +55,7 @@
#include "_scm.h"
#include "feature.h"
#include "scm_validate.h"
#include "net_db.h"
#ifdef HAVE_STRING_H
@ -77,81 +82,80 @@ int close ();
extern int inet_aton ();
SCM_PROC (s_inet_aton, "inet-aton", 1, 0, 0, scm_inet_aton);
SCM
scm_inet_aton (address)
SCM address;
GUILE_PROC (scm_inet_aton, "inet-aton", 1, 0, 0,
(SCM address),
"")
#define FUNC_NAME s_scm_inet_aton
{
struct in_addr soka;
SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_inet_aton);
SCM_VALIDATE_ROSTRING(1,address);
if (SCM_SUBSTRP (address))
address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
scm_misc_error (s_inet_aton, "bad address", SCM_EOL);
SCM_MISC_ERROR ("bad address", SCM_EOL);
return scm_ulong2num (ntohl (soka.s_addr));
}
#undef FUNC_NAME
SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
SCM
scm_inet_ntoa (inetid)
SCM inetid;
GUILE_PROC (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
(SCM inetid),
"")
#define FUNC_NAME s_scm_inet_ntoa
{
struct in_addr addr;
char *s;
SCM answer;
addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
addr.s_addr = htonl (SCM_NUM2ULONG (1,inetid));
s = inet_ntoa (addr);
answer = scm_makfromstr (s, strlen (s), 0);
return answer;
}
#undef FUNC_NAME
#ifdef HAVE_INET_NETOF
SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
SCM
scm_inet_netof (address)
SCM address;
GUILE_PROC (scm_inet_netof, "inet-netof", 1, 0, 0,
(SCM address),
"")
#define FUNC_NAME s_scm_inet_netof
{
struct in_addr addr;
addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
addr.s_addr = htonl (SCM_NUM2ULONG (1,address));
return scm_ulong2num ((unsigned long) inet_netof (addr));
}
#undef FUNC_NAME
#endif
#ifdef HAVE_INET_LNAOF
SCM_PROC (s_lnaof, "inet-lnaof", 1, 0, 0, scm_lnaof);
SCM
scm_lnaof (address)
SCM address;
GUILE_PROC (scm_lnaof, "inet-lnaof", 1, 0, 0,
(SCM address),
"")
#define FUNC_NAME s_scm_lnaof
{
struct in_addr addr;
addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
addr.s_addr = htonl (SCM_NUM2ULONG (1,address));
return scm_ulong2num ((unsigned long) inet_lnaof (addr));
}
#undef FUNC_NAME
#endif
#ifdef HAVE_INET_MAKEADDR
SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
SCM
scm_inet_makeaddr (net, lna)
SCM net;
SCM lna;
GUILE_PROC (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0,
(SCM net, SCM lna),
"")
#define FUNC_NAME s_scm_inet_makeaddr
{
struct in_addr addr;
unsigned long netnum;
unsigned long lnanum;
netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
SCM_VALIDATE_INT_COPY(1,net,netnum);
SCM_VALIDATE_INT_COPY(2,lna,lnanum);
addr = inet_makeaddr (netnum, lnanum);
return scm_ulong2num (ntohl (addr.s_addr));
}
#undef FUNC_NAME
#endif
SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
@ -205,11 +209,10 @@ static void scm_resolv_error (const char *subr, SCM bad_value)
Should use reentrant facilities if available.
*/
SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost);
SCM
scm_gethost (name)
SCM name;
GUILE_PROC (scm_gethost, "gethost", 0, 1, 0,
(SCM name),
"")
#define FUNC_NAME s_scm_gethost
{
SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED);
SCM *ve = SCM_VELTS (ans);
@ -243,11 +246,11 @@ scm_gethost (name)
}
else
{
inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, FUNC_NAME));
entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
}
if (!entry)
scm_resolv_error (s_gethost, name);
scm_resolv_error (FUNC_NAME, name);
ve[0] = scm_makfromstr (entry->h_name,
(scm_sizet) strlen (entry->h_name), 0);
@ -268,6 +271,7 @@ scm_gethost (name)
ve[4] = lst;
return ans;
}
#undef FUNC_NAME
/* In all subsequent getMUMBLE functions, when we're called with no
@ -280,11 +284,10 @@ scm_gethost (name)
operation?), but it seems to work okay. We'll see. */
#if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet);
SCM
scm_getnet (name)
SCM name;
GUILE_PROC (scm_getnet, "getnet", 0, 1, 0,
(SCM name),
"")
#define FUNC_NAME s_scm_getnet
{
SCM ans;
SCM *ve;
@ -299,7 +302,7 @@ scm_getnet (name)
if (! entry)
{
if (errno)
scm_syserror (s_getnet);
SCM_SYSERROR;
else
return SCM_BOOL_F;
}
@ -312,11 +315,11 @@ scm_getnet (name)
else
{
unsigned long netnum;
netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
netnum = scm_num2ulong (name, (char *) SCM_ARG1, FUNC_NAME);
entry = getnetbyaddr (netnum, AF_INET);
}
if (!entry)
scm_syserror_msg (s_getnet, "no such network %s",
scm_syserror_msg (FUNC_NAME, "no such network %s",
scm_listify (name, SCM_UNDEFINED), errno);
ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
ve[1] = scm_makfromstrs (-1, entry->n_aliases);
@ -324,14 +327,14 @@ scm_getnet (name)
ve[3] = scm_ulong2num (entry->n_net + 0L);
return ans;
}
#undef FUNC_NAME
#endif
#ifdef HAVE_GETPROTOENT
SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto);
SCM
scm_getproto (name)
SCM name;
GUILE_PROC (scm_getproto, "getproto", 0, 1, 0,
(SCM name),
"")
#define FUNC_NAME s_scm_getproto
{
SCM ans;
SCM *ve;
@ -346,7 +349,7 @@ scm_getproto (name)
if (! entry)
{
if (errno)
scm_syserror (s_getproto);
SCM_SYSERROR;
else
return SCM_BOOL_F;
}
@ -359,24 +362,22 @@ scm_getproto (name)
else
{
unsigned long protonum;
protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
protonum = SCM_NUM2ULONG (1,name);
entry = getprotobynumber (protonum);
}
if (!entry)
scm_syserror_msg (s_getproto, "no such protocol %s",
SCM_SYSERROR_MSG ("no such protocol %s",
scm_listify (name, SCM_UNDEFINED), errno);
ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
ve[1] = scm_makfromstrs (-1, entry->p_aliases);
ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
return ans;
}
#undef FUNC_NAME
#endif
static SCM scm_return_entry SCM_P ((struct servent *entry));
static SCM
scm_return_entry (entry)
struct servent *entry;
scm_return_entry (struct servent *entry)
{
SCM ans;
SCM *ve;
@ -391,12 +392,10 @@ scm_return_entry (entry)
}
#ifdef HAVE_GETSERVENT
SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv);
SCM
scm_getserv (name, proto)
SCM name;
SCM proto;
GUILE_PROC (scm_getserv, "getserv", 0, 2, 0,
(SCM name, SCM proto),
"")
#define FUNC_NAME s_scm_getserv
{
struct servent *entry;
if (SCM_UNBNDP (name))
@ -406,13 +405,13 @@ scm_getserv (name, proto)
if (!entry)
{
if (errno)
scm_syserror (s_getserv);
SCM_SYSERROR;
else
return SCM_BOOL_F;
}
return scm_return_entry (entry);
}
SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv);
SCM_VALIDATE_ROSTRING(2,proto);
SCM_COERCE_SUBSTR (proto);
if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
@ -421,22 +420,22 @@ scm_getserv (name, proto)
}
else
{
SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
SCM_VALIDATE_INT(1,name);
entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
}
if (!entry)
scm_syserror_msg (s_getserv, "no such service %s",
scm_listify (name, SCM_UNDEFINED), errno);
SCM_SYSERROR_MSG("no such service %s",
scm_listify (name, SCM_UNDEFINED), errno);
return scm_return_entry (entry);
}
#undef FUNC_NAME
#endif
#if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
SCM
scm_sethost (arg)
SCM arg;
GUILE_PROC (scm_sethost, "sethost", 0, 1, 0,
(SCM arg),
"")
#define FUNC_NAME s_scm_sethost
{
if (SCM_UNBNDP (arg))
endhostent ();
@ -444,14 +443,14 @@ scm_sethost (arg)
sethostent (SCM_NFALSEP (arg));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif
#if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
SCM
scm_setnet (arg)
SCM arg;
GUILE_PROC (scm_setnet, "setnet", 0, 1, 0,
(SCM arg),
"")
#define FUNC_NAME s_scm_setnet
{
if (SCM_UNBNDP (arg))
endnetent ();
@ -459,14 +458,14 @@ scm_setnet (arg)
setnetent (SCM_NFALSEP (arg));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif
#if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT)
SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
SCM
scm_setproto (arg)
SCM arg;
GUILE_PROC (scm_setproto, "setproto", 0, 1, 0,
(SCM arg),
"")
#define FUNC_NAME s_scm_setproto
{
if (SCM_UNBNDP (arg))
endprotoent ();
@ -474,14 +473,14 @@ scm_setproto (arg)
setprotoent (SCM_NFALSEP (arg));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif
#if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT)
SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
SCM
scm_setserv (arg)
SCM arg;
GUILE_PROC (scm_setserv, "setserv", 0, 1, 0,
(SCM arg),
"")
#define FUNC_NAME s_scm_setserv
{
if (SCM_UNBNDP (arg))
endservent ();
@ -489,6 +488,7 @@ scm_setserv (arg)
setservent (SCM_NFALSEP (arg));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

667
libguile/numbers.c
View file

File diff suppressed because it is too large Load diff

96
libguile/objects.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* This file and objects.h contains those minimal pieces of the Guile
@ -55,6 +59,7 @@
#include "eval.h"
#include "alist.h"
#include "scm_validate.h"
#include "objects.h"
@ -354,33 +359,31 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
return scm_apply_generic (gf, SCM_LIST3 (a1, a2, a3));
}
SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
SCM
scm_entity_p (SCM obj)
GUILE_PROC (scm_entity_p, "entity?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_entity_p
{
return (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
}
#undef FUNC_NAME
SCM_PROC (s_operator_p, "operator?", 1, 0, 0, scm_operator_p);
SCM
scm_operator_p (SCM obj)
GUILE_PROC (scm_operator_p, "operator?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_operator_p
{
return (SCM_NIMP (obj)
&& SCM_STRUCTP (obj)
&& SCM_I_OPERATORP (obj)
&& !SCM_I_ENTITYP (obj)
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (obj)
&& SCM_STRUCTP (obj)
&& SCM_I_OPERATORP (obj)
&& !SCM_I_ENTITYP (obj));
}
#undef FUNC_NAME
SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, scm_set_object_procedure_x);
SCM
scm_set_object_procedure_x (SCM obj, SCM proc)
GUILE_PROC (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
(SCM obj, SCM proc),
"")
#define FUNC_NAME s_scm_set_object_procedure_x
{
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
&& ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
@ -389,30 +392,31 @@ scm_set_object_procedure_x (SCM obj, SCM proc)
& SCM_CLASSF_PURE_GENERIC))),
obj,
SCM_ARG1,
s_set_object_procedure_x);
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
proc, SCM_ARG2, s_set_object_procedure_x);
FUNC_NAME);
SCM_VALIDATE_PROC(2,proc);
if (SCM_I_ENTITYP (obj))
SCM_ENTITY_PROCEDURE (obj) = proc;
else
SCM_OPERATOR_CLASS (obj)->procedure = proc;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#ifdef GUILE_DEBUG
SCM_PROC (s_object_procedure, "object-procedure", 1, 0, 0, scm_object_procedure);
SCM
scm_object_procedure (SCM obj)
GUILE_PROC (scm_object_procedure, "object-procedure", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_object_procedure
{
SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
&& ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
|| SCM_I_ENTITYP (obj)),
obj, SCM_ARG1, s_object_procedure);
obj, SCM_ARG1, FUNC_NAME);
return (SCM_I_ENTITYP (obj)
? SCM_ENTITY_PROCEDURE (obj)
: SCM_OPERATOR_CLASS (obj)->procedure);
}
#undef FUNC_NAME
#endif /* GUILE_DEBUG */
/* The following procedures are not a part of Goops but a minimal
@ -434,35 +438,28 @@ scm_i_make_class_object (SCM meta,
return c;
}
SCM_PROC (s_make_class_object, "make-class-object", 2, 0, 0, scm_make_class_object);
SCM
scm_make_class_object (SCM metaclass, SCM layout)
GUILE_PROC (scm_make_class_object, "make-class-object", 2, 0, 0,
(SCM metaclass, SCM layout),
"")
#define FUNC_NAME s_scm_make_class_object
{
unsigned long flags = 0;
SCM_ASSERT (SCM_NIMP (metaclass) && SCM_STRUCTP (metaclass),
metaclass, SCM_ARG1, s_make_class_object);
SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
layout, SCM_ARG2, s_make_class_object);
SCM_VALIDATE_STRUCT(1,metaclass);
SCM_VALIDATE_STRING(2,layout);
if (metaclass == scm_metaclass_operator)
flags = SCM_CLASSF_OPERATOR;
return scm_i_make_class_object (metaclass, layout, flags);
}
#undef FUNC_NAME
SCM_PROC (s_make_subclass_object, "make-subclass-object", 2, 0, 0, scm_make_subclass_object);
SCM
scm_make_subclass_object (SCM class, SCM layout)
GUILE_PROC (scm_make_subclass_object, "make-subclass-object", 2, 0, 0,
(SCM class, SCM layout),
"")
#define FUNC_NAME s_scm_make_subclass_object
{
SCM pl;
SCM_ASSERT (SCM_NIMP (class) && SCM_STRUCTP (class),
class,
SCM_ARG1,
s_make_subclass_object);
SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
layout,
SCM_ARG2,
s_make_subclass_object);
SCM_VALIDATE_STRUCT(1,class);
SCM_VALIDATE_STRING(2,layout);
pl = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
/* Convert symbol->string */
pl = scm_makfromstr (SCM_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0);
@ -470,6 +467,7 @@ scm_make_subclass_object (SCM class, SCM layout)
scm_string_append (SCM_LIST2 (pl, layout)),
SCM_CLASS_FLAGS (class));
}
#undef FUNC_NAME
void
scm_init_objects ()

48
libguile/objprop.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -52,47 +56,42 @@
/* {Object Properties}
*/
SCM_PROC(s_object_properties, "object-properties", 1, 0, 0, scm_object_properties);
SCM
scm_object_properties (obj)
SCM obj;
GUILE_PROC(scm_object_properties, "object-properties", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_object_properties
{
return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
}
#undef FUNC_NAME
SCM_PROC(s_set_object_properties_x, "set-object-properties!", 2, 0, 0, scm_set_object_properties_x);
SCM
scm_set_object_properties_x (obj, plist)
SCM obj;
SCM plist;
GUILE_PROC(scm_set_object_properties_x, "set-object-properties!", 2, 0, 0,
(SCM obj, SCM plist),
"")
#define FUNC_NAME s_scm_set_object_properties_x
{
SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist);
SCM_SETCDR (handle, plist);
return plist;
}
#undef FUNC_NAME
SCM_PROC(s_object_property, "object-property", 2, 0, 0, scm_object_property);
SCM
scm_object_property (obj, key)
SCM obj;
SCM key;
GUILE_PROC(scm_object_property, "object-property", 2, 0, 0,
(SCM obj, SCM key),
"")
#define FUNC_NAME s_scm_object_property
{
SCM assoc;
assoc = scm_assq (key, scm_object_properties (obj));
return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_PROC(s_set_object_property_x, "set-object-property!", 3, 0, 0, scm_set_object_property_x);
SCM
scm_set_object_property_x (obj, key, val)
SCM obj;
SCM key;
SCM val;
GUILE_PROC(scm_set_object_property_x, "set-object-property!", 3, 0, 0,
(SCM obj, SCM key, SCM val),
"")
#define FUNC_NAME s_scm_set_object_property_x
{
SCM h;
SCM assoc;
@ -109,6 +108,7 @@ scm_set_object_property_x (obj, key, val)
SCM_ALLOW_INTS;
return val;
}
#undef FUNC_NAME
void

62
libguile/pairs.c
View file

@ -38,21 +38,26 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "scm_validate.h"
/* {Pairs}
*/
SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons);
SCM
scm_cons (x, y)
SCM x;
SCM y;
GUILE_PROC(scm_cons, "cons", 2, 0, 0,
(SCM x, SCM y),
"")
#define FUNC_NAME s_scm_cons
{
register SCM z;
SCM_NEWCELL (z);
@ -60,13 +65,11 @@ scm_cons (x, y)
SCM_SETCDR (z, y);
return z;
}
#undef FUNC_NAME
SCM
scm_cons2 (w, x, y)
SCM w;
SCM x;
SCM y;
scm_cons2 (SCM w, SCM x, SCM y)
{
register SCM z;
SCM_NEWCELL (z);
@ -80,41 +83,38 @@ scm_cons2 (w, x, y)
}
SCM_PROC (s_pair_p, "pair?", 1, 0, 0, scm_pair_p);
SCM
scm_pair_p (x)
SCM x;
GUILE_PROC (scm_pair_p, "pair?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_pair_p
{
if (SCM_IMP (x))
return SCM_BOOL_F;
return SCM_CONSP (x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_CONSP (x));
}
#undef FUNC_NAME
SCM_PROC (s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x);
SCM
scm_set_car_x (pair, value)
SCM pair;
SCM value;
GUILE_PROC (scm_set_car_x, "set-car!", 2, 0, 0,
(SCM pair, SCM value),
"")
#define FUNC_NAME s_scm_set_car_x
{
SCM_ASSERT (SCM_NIMP (pair) && SCM_CONSP (pair),
pair, SCM_ARG1, s_set_car_x);
SCM_VALIDATE_NIMCONS(1,pair);
SCM_SETCAR (pair, value);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x);
SCM
scm_set_cdr_x (pair, value)
SCM pair;
SCM value;
GUILE_PROC (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
(SCM pair, SCM value),
"")
#define FUNC_NAME s_scm_set_cdr_x
{
SCM_ASSERT (SCM_NIMP(pair) && SCM_CONSP (pair), pair, SCM_ARG1, s_set_cdr_x);
SCM_VALIDATE_NIMCONS(1,pair);
SCM_SETCDR (pair, value);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

5
libguile/pairs.h
View file

@ -42,6 +42,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "libguile/__scm.h"
@ -155,6 +159,7 @@ typedef SCM huge *SCMPTR;
{ \
_into = scm_freelist; \
scm_freelist = SCM_CDR(scm_freelist);\
SCM_SETCAR(_into, scm_tc16_allocated); \
++scm_cells_allocated; \
} \
} while(0)

446
libguile/ports.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* Headers. */
@ -49,6 +53,7 @@
#include "keywords.h"
#include "scm_validate.h"
#include "ports.h"
#ifdef HAVE_MALLOC_H
@ -207,18 +212,17 @@ scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM))
SCM_PROC(s_char_ready_p, "char-ready?", 0, 1, 0, scm_char_ready_p);
SCM
scm_char_ready_p (SCM port)
GUILE_PROC(scm_char_ready_p, "char-ready?", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_char_ready_p
{
scm_port *pt;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1,
s_char_ready_p);
SCM_VALIDATE_OPINPORT(1,port);
pt = SCM_PTAB_ENTRY (port);
@ -234,24 +238,25 @@ scm_char_ready_p (SCM port)
scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
if (ptob->input_waiting)
return (ptob->input_waiting (port)) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(ptob->input_waiting (port));
else
return SCM_BOOL_T;
}
}
#undef FUNC_NAME
/* Clear a port's read buffers, returning the contents. */
SCM_PROC (s_drain_input, "drain-input", 1, 0, 0, scm_drain_input);
SCM
scm_drain_input (SCM port)
GUILE_PROC (scm_drain_input, "drain-input", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_drain_input
{
SCM result;
scm_port *pt = SCM_PTAB_ENTRY (port);
int count;
char *dst;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1,
s_drain_input);
SCM_VALIDATE_OPINPORT(1,port);
count = pt->read_end - pt->read_pos;
if (pt->read_buf == pt->putback_buf)
@ -271,78 +276,86 @@ scm_drain_input (SCM port)
return result;
}
#undef FUNC_NAME
/* Standard ports --- current input, output, error, and more(!). */
SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port);
SCM
scm_current_input_port ()
GUILE_PROC(scm_current_input_port, "current-input-port", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_current_input_port
{
return scm_cur_inp;
}
#undef FUNC_NAME
SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port);
SCM
scm_current_output_port ()
GUILE_PROC(scm_current_output_port, "current-output-port", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_current_output_port
{
return scm_cur_outp;
}
#undef FUNC_NAME
SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port);
SCM
scm_current_error_port ()
GUILE_PROC(scm_current_error_port, "current-error-port", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_current_error_port
{
return scm_cur_errp;
}
#undef FUNC_NAME
SCM_PROC(s_current_load_port, "current-load-port", 0, 0, 0, scm_current_load_port);
SCM
scm_current_load_port ()
GUILE_PROC(scm_current_load_port, "current-load-port", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_current_load_port
{
return scm_cur_loadp;
}
#undef FUNC_NAME
SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port);
SCM
scm_set_current_input_port (SCM port)
GUILE_PROC(scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_set_current_input_port
{
SCM oinp = scm_cur_inp;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port);
SCM_VALIDATE_OPINPORT(1,port);
scm_cur_inp = port;
return oinp;
}
#undef FUNC_NAME
SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port);
SCM
scm_set_current_output_port (SCM port)
GUILE_PROC(scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_set_current_output_port
{
SCM ooutp = scm_cur_outp;
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port);
SCM_VALIDATE_OPOUTPORT(1,port);
scm_cur_outp = port;
return ooutp;
}
#undef FUNC_NAME
SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port);
SCM
scm_set_current_error_port (SCM port)
GUILE_PROC(scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_set_current_error_port
{
SCM oerrp = scm_cur_errp;
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port);
SCM_VALIDATE_OPOUTPORT(1,port);
scm_cur_errp = port;
return oerrp;
}
#undef FUNC_NAME
/* The port table --- an array of pointers to ports. */
@ -419,26 +432,29 @@ scm_remove_from_port_table (SCM port)
/* Undocumented functions for debugging. */
/* Return the number of ports in the table. */
SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size);
SCM
scm_pt_size ()
GUILE_PROC(scm_pt_size, "pt-size", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_pt_size
{
return SCM_MAKINUM (scm_port_table_size);
}
#undef FUNC_NAME
/* Return the ith member of the port table. */
SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member);
SCM
scm_pt_member (SCM member)
GUILE_PROC(scm_pt_member, "pt-member", 1, 0, 0,
(SCM member),
"")
#define FUNC_NAME s_scm_pt_member
{
int i;
SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member);
i = SCM_INUM (member);
SCM_VALIDATE_INT_copy(1,member,i);
if (i < 0 || i >= scm_port_table_size)
return SCM_BOOL_F;
else
return scm_port_table[i]->port;
}
#undef FUNC_NAME
#endif
@ -459,29 +475,30 @@ scm_revealed_count (SCM port)
/* Return the revealed count for a port. */
SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed);
SCM
scm_port_revealed (SCM port)
GUILE_PROC(scm_port_revealed, "port-revealed", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_port_revealed
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed);
SCM_VALIDATE_PORT(1,port);
return SCM_MAKINUM (scm_revealed_count (port));
}
#undef FUNC_NAME
/* Set the revealed count for a port. */
SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x);
SCM
scm_set_port_revealed_x (SCM port, SCM rcount)
GUILE_PROC(scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
(SCM port, SCM rcount),
"")
#define FUNC_NAME s_scm_set_port_revealed_x
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port),
port, SCM_ARG1, s_set_port_revealed_x);
SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x);
SCM_VALIDATE_PORT(1,port);
SCM_VALIDATE_INT(2,rcount);
SCM_REVEALED (port) = SCM_INUM (rcount);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -510,16 +527,16 @@ scm_mode_bits (char *modes)
* Some modes such as "append" are only used when opening
* a file and are not returned here. */
SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode);
SCM
scm_port_mode (SCM port)
GUILE_PROC(scm_port_mode, "port-mode", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_port_mode
{
char modes[3];
modes[0] = '\0';
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode);
SCM_VALIDATE_OPPORT(1,port);
if (SCM_CAR (port) & SCM_RDNG) {
if (SCM_CAR (port) & SCM_WRTNG)
strcpy (modes, "r+");
@ -532,6 +549,7 @@ scm_port_mode (SCM port)
strcat (modes, "0");
return scm_makfromstr (modes, strlen (modes), 0);
}
#undef FUNC_NAME
@ -541,18 +559,17 @@ scm_port_mode (SCM port)
* Call the close operation on a port object.
* see also scm_close.
*/
SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port);
SCM
scm_close_port (SCM port)
GUILE_PROC(scm_close_port, "close-port", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_close_port
{
scm_sizet i;
int rv;
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1,
s_close_port);
SCM_VALIDATE_PORT(1,port);
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
i = SCM_PTOBNUM (port);
@ -562,16 +579,17 @@ scm_close_port (SCM port)
rv = 0;
scm_remove_from_port_table (port);
SCM_SETAND_CAR (port, ~SCM_OPN);
return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T;
return SCM_NEGATE_BOOL(rv < 0);
}
#undef FUNC_NAME
SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except);
SCM
scm_close_all_ports_except (SCM ports)
GUILE_PROC(scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
(SCM ports),
"")
#define FUNC_NAME s_scm_close_all_ports_except
{
int i = 0;
SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except);
SCM_VALIDATE_NIMCONS(1,ports);
while (i < scm_port_table_size)
{
SCM thisport = scm_port_table[i]->port;
@ -582,7 +600,7 @@ scm_close_all_ports_except (SCM ports)
{
SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr));
if (i == 0)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except);
SCM_VALIDATE_OPPORT(1,port);
if (port == thisport)
found = 1;
ports_ptr = SCM_CDR (ports_ptr);
@ -595,70 +613,76 @@ scm_close_all_ports_except (SCM ports)
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Utter miscellany. Gosh, we should clean this up some time. */
SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p);
SCM
scm_input_port_p (SCM x)
GUILE_PROC(scm_input_port_p, "input-port?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_input_port_p
{
if (SCM_IMP (x))
return SCM_BOOL_F;
return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_INPORTP (x));
}
#undef FUNC_NAME
SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p);
SCM
scm_output_port_p (SCM x)
GUILE_PROC(scm_output_port_p, "output-port?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_output_port_p
{
if (SCM_IMP (x))
return SCM_BOOL_F;
if (SCM_PORT_WITH_PS_P (x))
x = SCM_PORT_WITH_PS_PORT (x);
return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_OUTPORTP (x));
}
#undef FUNC_NAME
SCM_PROC(s_port_closed_p, "port-closed?", 1, 0, 0, scm_port_closed_p);
SCM
scm_port_closed_p (SCM port)
GUILE_PROC(scm_port_closed_p, "port-closed?", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_port_closed_p
{
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1,
s_port_closed_p);
return SCM_OPPORTP (port) ? SCM_BOOL_F : SCM_BOOL_T;
SCM_VALIDATE_OPPORT(1,port);
return SCM_NEGATE_BOOL(SCM_OPPORTP (port));
}
#undef FUNC_NAME
SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p);
SCM
scm_eof_object_p (SCM x)
GUILE_PROC(scm_eof_object_p, "eof-object?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_eof_object_p
{
return SCM_EOF_OBJECT_P (x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_EOF_OBJECT_P (x));
}
#undef FUNC_NAME
SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output);
SCM
scm_force_output (SCM port)
GUILE_PROC(scm_force_output, "force-output", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_force_output
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
else
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1,
s_force_output);
SCM_VALIDATE_OPOUTPORT(1,port);
}
scm_flush (port);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports);
SCM
scm_flush_all_ports ()
GUILE_PROC (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_flush_all_ports
{
int i;
@ -669,21 +693,23 @@ scm_flush_all_ports ()
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char);
SCM
scm_read_char (SCM port)
GUILE_PROC(scm_read_char, "read-char", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_read_char
{
int c;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char);
SCM_VALIDATE_OPINPORT(1,port);
c = scm_getc (port);
if (EOF == c)
return SCM_EOF_VAL;
return SCM_MAKICHR (c);
}
#undef FUNC_NAME
/* this should only be called when the read buffer is empty. it
tries to refill the read buffer. it returns the first char from
@ -891,66 +917,65 @@ scm_ungets (char *s, int n, SCM port)
}
SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char);
SCM
scm_peek_char (SCM port)
GUILE_PROC(scm_peek_char, "peek-char", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_peek_char
{
int c;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char);
SCM_VALIDATE_OPINPORT(1,port);
c = scm_getc (port);
if (EOF == c)
return SCM_EOF_VAL;
scm_ungetc (c, port);
return SCM_MAKICHR (c);
}
#undef FUNC_NAME
SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char);
SCM
scm_unread_char (SCM cobj, SCM port)
GUILE_PROC (scm_unread_char, "unread-char", 2, 0, 0,
(SCM cobj, SCM port),
"")
#define FUNC_NAME s_scm_unread_char
{
int c;
SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char);
SCM_VALIDATE_CHAR(1,cobj);
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char);
SCM_VALIDATE_OPINPORT(1,port);
c = SCM_ICHR (cobj);
scm_ungetc (c, port);
return cobj;
}
#undef FUNC_NAME
SCM_PROC (s_unread_string, "unread-string", 2, 0, 0, scm_unread_string);
SCM
scm_unread_string (SCM str, SCM port)
GUILE_PROC (scm_unread_string, "unread-string", 2, 0, 0,
(SCM str, SCM port),
"")
#define FUNC_NAME s_scm_unread_string
{
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str),
str, SCM_ARG1, s_unread_string);
SCM_VALIDATE_STRING(1,str);
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
port, SCM_ARG2, s_unread_string);
SCM_VALIDATE_OPINPORT(1,port);
scm_ungets (SCM_ROUCHARS (str), SCM_LENGTH (str), port);
return str;
}
#undef FUNC_NAME
SCM_PROC (s_seek, "seek", 3, 0, 0, scm_seek);
SCM
scm_seek (SCM object, SCM offset, SCM whence)
GUILE_PROC (scm_seek, "seek", 3, 0, 0,
(SCM object, SCM offset, SCM whence),
"")
#define FUNC_NAME s_scm_seek
{
off_t off;
off_t rv;
@ -958,35 +983,35 @@ scm_seek (SCM object, SCM offset, SCM whence)
object = SCM_COERCE_OUTPORT (object);
off = scm_num2long (offset, (char *)SCM_ARG2, s_seek);
SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_seek);
how = SCM_INUM (whence);
off = SCM_NUM2LONG (2,offset);
SCM_VALIDATE_INT_COPY(3,whence,how);
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
scm_out_of_range (s_seek, whence);
SCM_OUT_OF_RANGE (3, whence);
if (SCM_NIMP (object) && SCM_OPPORTP (object))
{
scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
if (!ptob->seek)
scm_misc_error (s_seek, "port is not seekable",
scm_cons (object, SCM_EOL));
SCM_MISC_ERROR ("port is not seekable",
scm_cons (object, SCM_EOL));
else
rv = ptob->seek (object, off, how);
}
else /* file descriptor?. */
{
SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_seek);
SCM_VALIDATE_INT(1,object);
rv = lseek (SCM_INUM (object), off, how);
if (rv == -1)
scm_syserror (s_seek);
SCM_SYSERROR;
}
return scm_long2num (rv);
}
#undef FUNC_NAME
SCM_PROC (s_truncate_file, "truncate-file", 1, 1, 0, scm_truncate_file);
SCM
scm_truncate_file (SCM object, SCM length)
GUILE_PROC (scm_truncate_file, "truncate-file", 1, 1, 0,
(SCM object, SCM length),
"")
#define FUNC_NAME s_scm_truncate_file
{
int rv;
off_t c_length;
@ -997,13 +1022,13 @@ scm_truncate_file (SCM object, SCM length)
{
/* must supply length if object is a filename. */
if (SCM_NIMP (object) && SCM_ROSTRINGP (object))
scm_wrong_num_args (scm_makfrom0str (s_truncate_file));
scm_wrong_num_args (SCM_FUNC_NAME);
length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
}
c_length = scm_num2long (length, (char *)SCM_ARG2, s_truncate_file);
c_length = SCM_NUM2LONG (2,length);
if (c_length < 0)
scm_misc_error (s_truncate_file, "negative offset", SCM_EOL);
SCM_MISC_ERROR ("negative offset", SCM_EOL);
object = SCM_COERCE_OUTPORT (object);
if (SCM_INUMP (object))
@ -1016,7 +1041,7 @@ scm_truncate_file (SCM object, SCM length)
scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
if (!ptob->truncate)
scm_misc_error (s_truncate_file, "port is not truncatable", SCM_EOL);
SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
if (pt->rw_active == SCM_PORT_READ)
scm_end_input (object);
else if (pt->rw_active == SCM_PORT_WRITE)
@ -1027,96 +1052,84 @@ scm_truncate_file (SCM object, SCM length)
}
else
{
SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object),
object, SCM_ARG1, s_truncate_file);
SCM_VALIDATE_ROSTRING(1,object);
SCM_COERCE_SUBSTR (object);
SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), c_length));
}
if (rv == -1)
scm_syserror (s_truncate_file);
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_port_line, "port-line", 1, 0, 0, scm_port_line);
SCM
scm_port_line (SCM port)
GUILE_PROC (scm_port_line, "port-line", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_port_line
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
port,
SCM_ARG1,
s_port_line);
SCM_VALIDATE_OPENPORT(1,port);
return SCM_MAKINUM (SCM_LINUM (port));
}
#undef FUNC_NAME
SCM_PROC (s_set_port_line_x, "set-port-line!", 2, 0, 0, scm_set_port_line_x);
SCM
scm_set_port_line_x (SCM port, SCM line)
GUILE_PROC (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
(SCM port, SCM line),
"")
#define FUNC_NAME s_scm_set_port_line_x
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
port,
SCM_ARG1,
s_set_port_line_x);
SCM_ASSERT (SCM_INUMP (line), line, SCM_ARG2, s_set_port_line_x);
SCM_VALIDATE_OPENPORT(1,port);
SCM_VALIDATE_INT(2,line);
return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
}
#undef FUNC_NAME
SCM_PROC (s_port_column, "port-column", 1, 0, 0, scm_port_column);
SCM
scm_port_column (SCM port)
GUILE_PROC (scm_port_column, "port-column", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_port_column
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
port,
SCM_ARG1,
s_port_column);
SCM_VALIDATE_OPENPORT(1,port);
return SCM_MAKINUM (SCM_COL (port));
}
#undef FUNC_NAME
SCM_PROC (s_set_port_column_x, "set-port-column!", 2, 0, 0, scm_set_port_column_x);
SCM
scm_set_port_column_x (SCM port, SCM column)
GUILE_PROC (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
(SCM port, SCM column),
"")
#define FUNC_NAME s_scm_set_port_column_x
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
port,
SCM_ARG1,
s_set_port_column_x);
SCM_ASSERT (SCM_INUMP (column), column, SCM_ARG2, s_set_port_column_x);
SCM_VALIDATE_OPENPORT(1,port);
SCM_VALIDATE_INT(2,column);
return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
}
#undef FUNC_NAME
SCM_PROC (s_port_filename, "port-filename", 1, 0, 0, scm_port_filename);
SCM
scm_port_filename (SCM port)
GUILE_PROC (scm_port_filename, "port-filename", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_port_filename
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
port,
SCM_ARG1,
s_port_filename);
SCM_VALIDATE_OPENPORT(1,port);
return SCM_PTAB_ENTRY (port)->file_name;
}
#undef FUNC_NAME
SCM_PROC (s_set_port_filename_x, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x);
SCM
scm_set_port_filename_x (SCM port, SCM filename)
GUILE_PROC (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
(SCM port, SCM filename),
"")
#define FUNC_NAME s_scm_set_port_filename_x
{
port = SCM_COERCE_OUTPORT (port);
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
port,
SCM_ARG1,
s_set_port_filename_x);
SCM_VALIDATE_OPENPORT(1,port);
/* We allow the user to set the filename to whatever he likes. */
return SCM_PTAB_ENTRY (port)->file_name = filename;
}
#undef FUNC_NAME
#ifndef ttyname
extern char * ttyname();
@ -1211,17 +1224,16 @@ scm_void_port (char *mode_str)
}
SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port);
SCM
scm_sys_make_void_port (SCM mode)
GUILE_PROC (scm_sys_make_void_port, "%make-void-port", 1, 0, 0,
(SCM mode),
"")
#define FUNC_NAME s_scm_sys_make_void_port
{
SCM_ASSERT (SCM_NIMP (mode) && SCM_ROSTRINGP (mode), mode,
SCM_ARG1, s_sys_make_void_port);
SCM_VALIDATE_ROSTRING(1,mode);
SCM_COERCE_SUBSTR (mode);
return scm_void_port (SCM_ROCHARS (mode));
}
#undef FUNC_NAME
/* Initialization. */

588
libguile/posix.c
View file

File diff suppressed because it is too large Load diff

142
libguile/print.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -55,6 +59,7 @@
#include "struct.h"
#include "objects.h"
#include "scm_validate.h"
#include "print.h"
@ -121,18 +126,18 @@ scm_option scm_print_opts[] = {
"Print closures with source." }
};
SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options);
SCM
scm_print_options (setting)
SCM setting;
GUILE_PROC (scm_print_options, "print-options-interface", 0, 1, 0,
(SCM setting),
"")
#define FUNC_NAME s_scm_print_options
{
SCM ans = scm_options (setting,
scm_print_opts,
SCM_N_PRINT_OPTIONS,
s_print_options);
FUNC_NAME);
return ans;
}
#undef FUNC_NAME
/* {Printing of Scheme Objects}
@ -146,14 +151,14 @@ scm_print_options (setting)
* will be O(N).
*/
#define PUSH_REF(pstate, obj) \
{ \
do { \
pstate->ref_stack[pstate->top++] = (obj); \
if (pstate->top == pstate->ceiling) \
grow_ref_stack (pstate); \
}
} while(0)
#define ENTER_NESTED_DATA(pstate, obj, label) \
{ \
do { \
register unsigned long i; \
for (i = 0; i < pstate->top; ++i) \
if (pstate->ref_stack[i] == (obj)) \
@ -167,7 +172,7 @@ scm_print_options (setting)
} \
} \
PUSH_REF(pstate, obj); \
} \
} while(0)
#define EXIT_NESTED_DATA(pstate) { --pstate->top; }
@ -176,21 +181,22 @@ SCM scm_print_state_vtable;
static SCM print_state_pool;
#ifdef GUILE_DEBUG /* Used for debugging purposes */
SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
SCM
scm_current_pstate ()
GUILE_PROC(scm_current_pstate, "current-pstate", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_current_pstate
{
return SCM_CADR (print_state_pool);
}
#undef FUNC_NAME
#endif
#define PSTATE_SIZE 50L
static SCM make_print_state SCM_P ((void));
static SCM
make_print_state ()
make_print_state (void)
{
SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
SCM_INUM0,
@ -241,11 +247,8 @@ scm_free_print_state (print_state)
SCM_ALLOW_INTS;
}
static void grow_ref_stack SCM_P ((scm_print_state *pstate));
static void
grow_ref_stack (pstate)
scm_print_state *pstate;
grow_ref_stack (scm_print_state *pstate)
{
int new_size = 2 * pstate->ceiling;
scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size));
@ -254,13 +257,8 @@ grow_ref_stack (pstate)
}
static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref));
static void
print_circref (port, pstate, ref)
SCM port;
scm_print_state *pstate;
SCM ref;
print_circref (SCM port,scm_print_state *pstate,SCM ref)
{
register int i;
int self = pstate->top - 1;
@ -290,10 +288,7 @@ SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
void
scm_iprin1 (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
taloop:
switch (7 & (int) exp)
@ -703,10 +698,7 @@ taloop:
* useful for continuing a chain of print calls from Scheme. */
void
scm_prin1 (exp, port, writingp)
SCM exp;
SCM port;
int writingp;
scm_prin1 (SCM exp, SCM port, int writingp)
{
SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
SCM pstate_scm;
@ -756,10 +748,7 @@ scm_prin1 (exp, port, writingp)
*/
void
scm_intprint (n, radix, port)
long n;
int radix;
SCM port;
scm_intprint (long n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
@ -769,10 +758,7 @@ scm_intprint (n, radix, port)
*/
void
scm_ipruk (hdr, ptr, port)
char *hdr;
SCM ptr;
SCM port;
scm_ipruk (char *hdr, SCM ptr, SCM port)
{
scm_puts ("#<unknown-", port);
scm_puts (hdr, port);
@ -794,12 +780,7 @@ scm_ipruk (hdr, ptr, port)
void
scm_iprlist (hdr, exp, tlr, port, pstate)
char *hdr;
SCM exp;
int tlr;
SCM port;
scm_print_state *pstate;
scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
{
register SCM hare, tortoise;
int floor = pstate->top - 2;
@ -915,9 +896,7 @@ scm_valid_oport_value_p (SCM val)
/* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */
SCM
scm_write (obj, port)
SCM obj;
SCM port;
scm_write (SCM obj, SCM port)
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
@ -938,9 +917,7 @@ scm_write (obj, port)
/* SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); */
SCM
scm_display (obj, port)
SCM obj;
SCM port;
scm_display (SCM obj, SCM port)
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
@ -957,34 +934,32 @@ scm_display (obj, port)
return SCM_UNSPECIFIED;
}
SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
SCM
scm_newline (port)
SCM port;
GUILE_PROC(scm_newline, "newline", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_newline
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline);
SCM_VALIDATE_OPORT_VALUE(1,port);
scm_putc ('\n', SCM_COERCE_OUTPORT (port));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
SCM
scm_write_char (chr, port)
SCM chr;
SCM port;
GUILE_PROC(scm_write_char, "write-char", 1, 1, 0,
(SCM chr, SCM port),
"")
#define FUNC_NAME s_scm_write_char
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write_char);
SCM_VALIDATE_CHAR(1,chr);
SCM_VALIDATE_OPORT_VALUE(2,port);
SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
scm_putc ((int) SCM_ICHR (chr), SCM_COERCE_OUTPORT (port));
#ifdef HAVE_PIPE
# ifdef EPIPE
@ -994,6 +969,7 @@ scm_write_char (chr, port)
#endif
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -1017,9 +993,7 @@ print_port_with_ps (SCM obj, SCM port, scm_print_state *pstate)
}
SCM
scm_printer_apply (proc, exp, port, pstate)
SCM proc, exp, port;
scm_print_state *pstate;
scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate)
{
SCM pwps;
SCM pair = scm_cons (port, pstate->handle);
@ -1028,25 +1002,24 @@ scm_printer_apply (proc, exp, port, pstate)
return scm_apply (proc, exp, scm_cons (pwps, scm_listofnull));
}
SCM_PROC (s_port_with_print_state, "port-with-print-state", 2, 0, 0, scm_port_with_print_state);
SCM
scm_port_with_print_state (SCM port, SCM pstate)
GUILE_PROC (scm_port_with_print_state, "port-with-print-state", 2, 0, 0,
(SCM port, SCM pstate),
"")
#define FUNC_NAME s_scm_port_with_print_state
{
SCM pwps;
SCM_ASSERT (scm_valid_oport_value_p (port),
port, SCM_ARG1, s_port_with_print_state);
SCM_ASSERT (SCM_NIMP (pstate) && SCM_PRINT_STATE_P (pstate),
pstate, SCM_ARG2, s_port_with_print_state);
SCM_VALIDATE_OPORT_VALUE(1,port);
SCM_VALIDATE_PRINTSTATE(2,pstate);
port = SCM_COERCE_OUTPORT (port);
SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, scm_cons (port, pstate));
return pwps;
}
#undef FUNC_NAME
SCM_PROC (s_get_print_state, "get-print-state", 1, 0, 0, scm_get_print_state);
SCM
scm_get_print_state (SCM port)
GUILE_PROC (scm_get_print_state, "get-print-state", 1, 0, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_get_print_state
{
if (SCM_NIMP (port))
{
@ -1055,8 +1028,9 @@ scm_get_print_state (SCM port)
if (SCM_OUTPORTP (port))
return SCM_BOOL_F;
}
return scm_wta (port, (char *) SCM_ARG1, s_get_print_state);
RETURN_SCM_WTA (1,port);
}
#undef FUNC_NAME

68
libguile/procprop.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -49,6 +53,7 @@
#include "gsubr.h"
#include "objects.h"
#include "scm_validate.h"
#include "procprop.h"
@ -141,8 +146,7 @@ scm_i_procedure_arity (SCM proc)
}
static SCM
scm_stand_in_scm_proc(proc)
SCM proc;
scm_stand_in_scm_proc(SCM proc)
{
SCM answer;
answer = scm_assoc (proc, scm_stand_in_procs);
@ -158,74 +162,65 @@ scm_stand_in_scm_proc(proc)
return answer;
}
SCM_PROC(s_procedure_properties, "procedure-properties", 1, 0, 0, scm_procedure_properties);
SCM
scm_procedure_properties (proc)
SCM proc;
GUILE_PROC(scm_procedure_properties, "procedure-properties", 1, 0, 0,
(SCM proc),
"")
#define FUNC_NAME s_scm_procedure_properties
{
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
proc, SCM_ARG1, s_procedure_properties);
SCM_VALIDATE_PROC(1,proc);
return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
SCM_PROCPROPS (SCM_NIMP (proc) && SCM_CLOSUREP (proc)
? proc
: scm_stand_in_scm_proc (proc)));
}
#undef FUNC_NAME
SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x);
SCM
scm_set_procedure_properties_x (proc, new_val)
SCM proc;
SCM new_val;
GUILE_PROC(scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
(SCM proc, SCM new_val),
"")
#define FUNC_NAME s_scm_set_procedure_properties_x
{
if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
proc = scm_stand_in_scm_proc(proc);
SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x);
SCM_VALIDATE_CLOSURE(1,proc);
SCM_SETPROCPROPS (proc, new_val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property);
SCM
scm_procedure_property (p, k)
SCM p;
SCM k;
GUILE_PROC(scm_procedure_property, "procedure-property", 2, 0, 0,
(SCM p, SCM k),
"")
#define FUNC_NAME s_scm_procedure_property
{
SCM assoc;
if (k == scm_sym_arity)
{
SCM arity;
SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (p)),
p, SCM_ARG1, s_procedure_property);
p, SCM_ARG1, FUNC_NAME);
return arity;
}
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (p)),
p, SCM_ARG1, s_procedure_property);
SCM_VALIDATE_PROC(1,p);
assoc = scm_sloppy_assq (k,
SCM_PROCPROPS (SCM_NIMP (p) && SCM_CLOSUREP (p)
? p
: scm_stand_in_scm_proc (p)));
return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_PROC(s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, scm_set_procedure_property_x);
SCM
scm_set_procedure_property_x (p, k, v)
SCM p;
SCM k;
SCM v;
GUILE_PROC(scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
(SCM p, SCM k, SCM v),
"")
#define FUNC_NAME s_scm_set_procedure_property_x
{
SCM assoc;
if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
p = scm_stand_in_scm_proc(p);
SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x);
SCM_VALIDATE_CLOSURE(1,p);
if (k == scm_sym_arity)
scm_misc_error (s_set_procedure_property_x,
"arity is a read-only property",
SCM_EOL);
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, v);
@ -233,6 +228,7 @@ scm_set_procedure_property_x (p, k, v)
SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

127
libguile/procs.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -45,6 +49,7 @@
#include "objects.h"
#include "scm_validate.h"
#include "procs.h"
@ -60,11 +65,7 @@ int scm_subr_table_size = 0;
int scm_subr_table_room = 750;
SCM
scm_make_subr_opt (name, type, fcn, set)
const char *name;
int type;
SCM (*fcn) ();
int set;
scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
{
SCM symcell;
register SCM z;
@ -115,10 +116,7 @@ scm_free_subr_entry (SCM subr)
}
SCM
scm_make_subr (name, type, fcn)
const char *name;
int type;
SCM (*fcn) ();
scm_make_subr (const char *name, int type, SCM (*fcn) ())
{
return scm_make_subr_opt (name, type, fcn, 1);
}
@ -150,9 +148,7 @@ scm_mark_subr_table ()
#ifdef CCLO
SCM
scm_makcclo (proc, len)
SCM proc;
long len;
scm_makcclo (SCM proc, long len)
{
SCM s;
SCM_NEWCELL (s);
@ -168,25 +164,23 @@ scm_makcclo (proc, len)
/* Undocumented debugging procedure */
#ifdef GUILE_DEBUG
SCM_PROC (s_make_cclo, "make-cclo", 2, 0, 0, scm_make_cclo);
SCM
scm_make_cclo (proc, len)
SCM proc;
SCM len;
GUILE_PROC (scm_make_cclo, "make-cclo", 2, 0, 0,
(SCM proc, SCM len),
"")
#define FUNC_NAME s_scm_make_cclo
{
return scm_makcclo (proc, SCM_INUM (len));
}
#undef FUNC_NAME
#endif
#endif
SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p);
SCM
scm_procedure_p (obj)
SCM obj;
GUILE_PROC(scm_procedure_p, "procedure?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_procedure_p
{
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
@ -207,26 +201,21 @@ scm_procedure_p (obj)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p);
SCM
scm_closure_p (obj)
SCM obj;
GUILE_PROC(scm_closure_p, "closure?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_closure_p
{
return SCM_NIMP (obj) && SCM_CLOSUREP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_NIMP (obj) && SCM_CLOSUREP (obj));
}
#undef FUNC_NAME
SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p);
#ifdef __STDC__
SCM
scm_thunk_p (SCM obj)
#else
SCM
scm_thunk_p (obj)
SCM obj;
#endif
GUILE_PROC(scm_thunk_p, "thunk?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_thunk_p
{
if (SCM_NIMP (obj))
{
@ -254,6 +243,7 @@ scm_thunk_p (obj)
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
/* Only used internally. */
int
@ -270,15 +260,14 @@ scm_subr_p (SCM obj)
return 0;
}
SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
SCM
scm_procedure_documentation (proc)
SCM proc;
GUILE_PROC(scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
(SCM proc),
"")
#define FUNC_NAME s_scm_procedure_documentation
{
SCM code;
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
proc, SCM_ARG1, s_procedure_documentation);
proc, SCM_ARG1, FUNC_NAME);
switch (SCM_TYP7 (proc))
{
case scm_tcs_closures:
@ -300,31 +289,29 @@ scm_procedure_documentation (proc)
*/
}
}
#undef FUNC_NAME
/* Procedure-with-setter
*/
SCM_PROC (s_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, scm_procedure_with_setter_p);
SCM
scm_procedure_with_setter_p (SCM obj)
GUILE_PROC (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_procedure_with_setter_p
{
return (SCM_NIMP (obj) && SCM_PROCEDURE_WITH_SETTER_P (obj)
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (obj) && SCM_PROCEDURE_WITH_SETTER_P (obj));
}
#undef FUNC_NAME
SCM_PROC (s_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0, scm_make_procedure_with_setter);
SCM
scm_make_procedure_with_setter (SCM procedure, SCM setter)
GUILE_PROC (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
(SCM procedure, SCM setter),
"")
#define FUNC_NAME s_scm_make_procedure_with_setter
{
SCM z;
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (procedure)),
procedure, SCM_ARG1, s_make_procedure_with_setter);
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (setter)),
setter, SCM_ARG2, s_make_procedure_with_setter);
SCM_VALIDATE_PROC(1,procedure);
SCM_VALIDATE_PROC(2,setter);
SCM_NEWCELL (z);
SCM_ENTER_A_SECTION;
SCM_SETCDR (z, scm_cons (procedure, setter));
@ -332,23 +319,25 @@ scm_make_procedure_with_setter (SCM procedure, SCM setter)
SCM_EXIT_A_SECTION;
return z;
}
#undef FUNC_NAME
SCM_PROC (s_procedure, "procedure", 1, 0, 0, scm_procedure);
SCM
scm_procedure (SCM proc)
GUILE_PROC (scm_procedure, "procedure", 1, 0, 0,
(SCM proc),
"")
#define FUNC_NAME s_scm_procedure
{
SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure);
SCM_VALIDATE_NIMP(1,proc);
if (SCM_PROCEDURE_WITH_SETTER_P (proc))
return SCM_PROCEDURE (proc);
else if (SCM_STRUCTP (proc))
{
SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, s_procedure);
SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
return proc;
}
scm_wrong_type_arg (s_procedure, SCM_ARG1, proc);
SCM_WRONG_TYPE_ARG (1, proc);
return 0; /* not reached */
}
#undef FUNC_NAME
SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
@ -376,9 +365,7 @@ scm_setter (SCM proc)
void
scm_init_iprocs(subra, type)
const scm_iproc *subra;
int type;
scm_init_iprocs(const scm_iproc *subra, int type)
{
for(;subra->scm_string; subra++)
scm_make_subr(subra->scm_string,

302
libguile/ramap.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
@ -52,9 +56,12 @@
#include "eval.h"
#include "feature.h"
#include "scm_validate.h"
#include "ramap.h"
#define SCM_RAMAPC(ramap,proc,ra0,lra) do { scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); } while (0)
typedef struct
{
char *name;
@ -111,12 +118,8 @@ static ra_iproc ra_asubrs[] =
/* inds must be a uvect or ivect, no check. */
static scm_sizet cind SCM_P ((SCM ra, SCM inds));
static scm_sizet
cind (ra, inds)
SCM ra;
SCM inds;
cind (SCM ra, SCM inds)
{
scm_sizet i;
int k;
@ -253,16 +256,16 @@ scm_ra_matchp (ra0, ras)
return exact;
}
/* array mapper: apply cproc to each dimension of the given arrays?. */
int
scm_ramapc (cproc, data, ra0, lra, what)
int (*cproc) (); /* procedure to call on unrolled arrays?
/* array mapper: apply cproc to each dimension of the given arrays?.
int (*cproc) (); procedure to call on unrolled 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. */
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. */
int
scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
{
SCM inds, z;
SCM vra0, ra1, vra1;
@ -404,24 +407,21 @@ scm_ramapc (cproc, data, ra0, lra, what)
}
SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x);
SCM
scm_array_fill_x (ra, fill)
SCM ra;
SCM fill;
GUILE_PROC(scm_array_fill_x, "array-fill!", 2, 0, 0,
(SCM ra, SCM fill),
"")
#define FUNC_NAME s_scm_array_fill_x
{
scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x);
SCM_RAMAPC (scm_array_fill_int, fill, ra, SCM_EOL);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* 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_array_fill_int (SCM ra, SCM fill, SCM ignore)
#define FUNC_NAME s_scm_array_fill_x
{
scm_sizet i;
scm_sizet n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1;
@ -455,7 +455,7 @@ scm_array_fill_int (ra, fill, ignore)
SCM_CHARS (ra)[i] = SCM_INUM (fill);
break;
case scm_tc7_bvect:
{
{ /* scope */
long *ve = (long *) SCM_VELTS (ra);
if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra)))
{
@ -479,7 +479,7 @@ scm_array_fill_int (ra, fill, ignore)
ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
}
else
badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x);
badarg2:SCM_WTA (2,fill);
}
else
{
@ -495,9 +495,8 @@ scm_array_fill_int (ra, fill, ignore)
break;
}
case scm_tc7_uvect:
{
unsigned long f = scm_num2ulong (fill, (char *) SCM_ARG2,
s_array_fill_x);
{ /* scope */
unsigned long f = SCM_NUM2ULONG (2,fill);
unsigned long *ve = (long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
@ -505,8 +504,8 @@ scm_array_fill_int (ra, fill, ignore)
break;
}
case scm_tc7_ivect:
{
long f = scm_num2long (fill, (char *) SCM_ARG2, s_array_fill_x);
{ /* scope */
long f = SCM_NUM2LONG (2,fill);
long *ve = (long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
@ -515,21 +514,20 @@ scm_array_fill_int (ra, fill, ignore)
}
case scm_tc7_svect:
SCM_ASRTGO (SCM_INUMP (fill), badarg2);
{
{ /* scope */
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);
SCM_OUT_OF_RANGE (2, 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);
{ /* scope */
long long f = SCM_NUM2LONG_LONG (2,fill);
long long *ve = (long long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
@ -540,7 +538,7 @@ scm_array_fill_int (ra, fill, ignore)
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
{
{ /* scope */
float f, *ve = (float *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill);
@ -550,7 +548,7 @@ scm_array_fill_int (ra, fill, ignore)
}
#endif /* SCM_SINGLES */
case scm_tc7_dvect:
{
{ /* scope */
double f, *ve = (double *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill);
@ -559,7 +557,7 @@ scm_array_fill_int (ra, fill, ignore)
break;
}
case scm_tc7_cvect:
{
{ /* scope */
double fr, fi;
double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2);
@ -576,16 +574,11 @@ scm_array_fill_int (ra, fill, ignore)
}
return 1;
}
#undef FUNC_NAME
static int racp SCM_P ((SCM dst, SCM src));
static int
racp (src, dst)
SCM dst;
SCM src;
racp (SCM src, SCM dst)
{
long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1);
long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc;
@ -777,29 +770,29 @@ racp (src, dst)
#endif /* SCM_FLOATS */
return 1;
}
#undef FUNC_NAME
/* This name is obsolete. Will go away in release 1.5. */
SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
SCM_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x);
SCM_REGISTER_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
SCM
scm_array_copy_x (src, dst)
SCM src;
SCM dst;
GUILE_PROC(scm_array_copy_x, "array-copy!", 2, 0, 0,
(SCM src, SCM dst),
"")
#define FUNC_NAME s_scm_array_copy_x
{
scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x);
SCM_RAMAPC (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Functions callable by ARRAY-MAP! */
int
scm_ra_eqp (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_eqp (SCM ra0, SCM ras)
{
SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
@ -857,14 +850,8 @@ scm_ra_eqp (ra0, ras)
/* opt 0 means <, nonzero means >= */
static int ra_compare SCM_P ((SCM ra0, SCM ra1, SCM ra2, int opt));
static int
ra_compare (ra0, ra1, ra2, opt)
SCM ra0;
SCM ra1;
SCM ra2;
int opt;
ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
@ -925,46 +912,35 @@ ra_compare (ra0, ra1, ra2, opt)
int
scm_ra_lessp (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_lessp (SCM ra0, SCM ras)
{
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
}
int
scm_ra_leqp (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_leqp (SCM ra0, SCM ras)
{
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
}
int
scm_ra_grp (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_grp (SCM ra0, SCM ras)
{
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
}
int
scm_ra_greqp (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_greqp (SCM ra0, SCM ras)
{
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
}
int
scm_ra_sum (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_sum (SCM ra0, SCM ras)
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@ -1039,9 +1015,7 @@ scm_ra_sum (ra0, ras)
int
scm_ra_difference (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_difference (SCM ra0, SCM ras)
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@ -1146,9 +1120,7 @@ scm_ra_difference (ra0, ras)
int
scm_ra_product (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_product (SCM ra0, SCM ras)
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@ -1224,9 +1196,7 @@ scm_ra_product (ra0, ras)
int
scm_ra_divide (ra0, ras)
SCM ra0;
SCM ras;
scm_ra_divide (SCM ra0, SCM ras)
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@ -1335,22 +1305,15 @@ scm_ra_divide (ra0, ras)
int
scm_array_identity (dst, src)
SCM src;
SCM dst;
scm_array_identity (SCM dst, SCM src)
{
return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
}
static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
ramap (SCM ra0,SCM proc,SCM ras)
{
long i = SCM_ARRAY_DIMS (ra0)->lbnd;
long inc = SCM_ARRAY_DIMS (ra0)->inc;
@ -1388,13 +1351,8 @@ ramap (ra0, proc, ras)
}
static int ramap_cxr SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_cxr (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
ramap_cxr (SCM ra0,SCM proc,SCM ras)
{
SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED;
@ -1458,13 +1416,8 @@ ramap_cxr (ra0, proc, ras)
static int ramap_rp SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_rp (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
ramap_rp (SCM ra0,SCM proc,SCM ras)
{
SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
@ -1545,13 +1498,8 @@ ramap_rp (ra0, proc, ras)
static int ramap_1 SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_1 (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
ramap_1 (SCM ra0,SCM proc,SCM ras)
{
SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED;
@ -1571,13 +1519,8 @@ ramap_1 (ra0, proc, ras)
static int ramap_2o SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_2o (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
ramap_2o (SCM ra0,SCM proc,SCM ras)
{
SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED;
@ -1623,13 +1566,8 @@ ramap_2o (ra0, proc, ras)
static int ramap_a SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
ramap_a (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
ramap_a (SCM ra0,SCM proc,SCM ras)
{
SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
@ -1653,34 +1591,33 @@ ramap_a (ra0, proc, ras)
}
/* This name is obsolete. Will go away in release 1.5. */
SCM_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x);
SCM_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
SCM_PROC(s_array_map_x, "array-map!", 2, 0, 1, scm_array_map_x);
SCM_REGISTER_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x);
SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
SCM
scm_array_map_x (ra0, proc, lra)
SCM ra0;
SCM proc;
SCM lra;
GUILE_PROC(scm_array_map_x, "array-map!", 2, 0, 1,
(SCM ra0, SCM proc, SCM lra),
"")
#define FUNC_NAME s_scm_array_map_x
{
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map_x);
SCM_VALIDATE_PROC(2,proc);
switch (SCM_TYP7 (proc))
{
default:
gencase:
scm_ramapc (ramap, proc, ra0, lra, s_array_map_x);
SCM_RAMAPC (ramap, proc, ra0, lra);
return SCM_UNSPECIFIED;
case scm_tc7_subr_1:
scm_ramapc (ramap_1, proc, ra0, lra, s_array_map_x);
SCM_RAMAPC (ramap_1, proc, ra0, lra);
return SCM_UNSPECIFIED;
case scm_tc7_subr_2:
case scm_tc7_subr_2o:
scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map_x);
SCM_RAMAPC (ramap_2o, proc, ra0, lra);
return SCM_UNSPECIFIED;
case scm_tc7_cxr:
if (!SCM_SUBRF (proc))
goto gencase;
scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map_x);
SCM_RAMAPC (ramap_cxr, proc, ra0, lra);
return SCM_UNSPECIFIED;
case scm_tc7_rpsubr:
{
@ -1693,14 +1630,14 @@ scm_array_map_x (ra0, proc, lra)
{
while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
{
scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map_x);
SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra);
lra = SCM_CDR (lra);
}
return SCM_UNSPECIFIED;
}
while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
{
scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map_x);
SCM_RAMAPC (ramap_rp, proc, ra0, lra);
lra = SCM_CDR (lra);
}
return SCM_UNSPECIFIED;
@ -1739,34 +1676,30 @@ scm_array_map_x (ra0, proc, lra)
if (proc == p->sproc)
{
if (ra0 != SCM_CAR (lra))
scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), s_array_map_x);
SCM_RAMAPC (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL));
lra = SCM_CDR (lra);
while (1)
{
scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map_x);
SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra);
if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
return SCM_UNSPECIFIED;
lra = SCM_CDR (lra);
}
}
scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map_x);
SCM_RAMAPC (ramap_2o, proc, ra0, lra);
lra = SCM_CDR (lra);
if (SCM_NIMP (lra))
for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
scm_ramapc (ramap_a, proc, ra0, lra, s_array_map_x);
SCM_RAMAPC (ramap_a, proc, ra0, lra);
}
return SCM_UNSPECIFIED;
}
}
#undef FUNC_NAME
static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras));
static int
rafe (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
rafe (SCM ra0,SCM proc,SCM ras)
{
long i = SCM_ARRAY_DIMS (ra0)->lbnd;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@ -1804,34 +1737,29 @@ rafe (ra0, proc, ras)
}
SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each);
SCM
scm_array_for_each (proc, ra0, lra)
SCM proc;
SCM ra0;
SCM lra;
GUILE_PROC(scm_array_for_each, "array-for-each", 2, 0, 1,
(SCM proc, SCM ra0, SCM lra),
"")
#define FUNC_NAME s_scm_array_for_each
{
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each);
scm_ramapc (rafe, proc, ra0, lra, s_array_for_each);
SCM_VALIDATE_PROC(1,proc);
SCM_RAMAPC (rafe, proc, ra0, lra);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x);
SCM
scm_array_index_map_x (ra, proc)
SCM ra;
SCM proc;
GUILE_PROC(scm_array_index_map_x, "array-index-map!", 2, 0, 0,
(SCM ra, SCM proc),
"")
#define FUNC_NAME s_scm_array_index_map_x
{
scm_sizet i;
SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x);
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2,
s_array_index_map_x);
SCM_VALIDATE_NIMP(1,ra);
SCM_VALIDATE_PROC(2,proc);
switch (SCM_TYP7(ra))
{
default:
badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_index_map_x);
badarg:SCM_WTA (1,ra);
case scm_tc7_vector:
case scm_tc7_wvect:
{
@ -1901,15 +1829,11 @@ scm_array_index_map_x (ra, proc)
}
}
}
#undef FUNC_NAME
static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
static int
raeql_1 (ra0, as_equal, ra1)
SCM ra0;
SCM as_equal;
SCM ra1;
raeql_1 (SCM ra0,SCM as_equal,SCM ra1)
{
SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
scm_sizet i0 = 0, i1 = 0;
@ -2030,13 +1954,8 @@ raeql_1 (ra0, as_equal, ra1)
static int raeql SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
static int
raeql (ra0, as_equal, ra1)
SCM ra0;
SCM as_equal;
SCM ra1;
raeql (SCM ra0,SCM as_equal,SCM ra1)
{
SCM v0 = ra0, v1 = ra1;
scm_array_dim dim0, dim1;
@ -2093,9 +2012,7 @@ raeql (ra0, as_equal, ra1)
SCM
scm_raequal (ra0, ra1)
SCM ra0;
SCM ra1;
scm_raequal (SCM ra0, SCM ra1)
{
return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
}
@ -2104,9 +2021,7 @@ static char s_array_equal_p[] = "array-equal?";
SCM
scm_array_equal_p (ra0, ra1)
SCM ra0;
SCM ra1;
scm_array_equal_p (SCM ra0, SCM ra1)
{
if (SCM_IMP (ra0) || SCM_IMP (ra1))
callequal:return scm_equal_p (ra0, ra1);
@ -2154,8 +2069,7 @@ scm_array_equal_p (ra0, ra1)
static void
init_raprocs (subra)
ra_iproc *subra;
init_raprocs (ra_iproc *subra)
{
for (; subra->name; subra++)
subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name)));
@ -2170,5 +2084,5 @@ scm_init_ramap ()
scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal;
#include "ramap.x"
scm_add_feature (s_array_for_each);
scm_add_feature (s_scm_array_for_each);
}

141
libguile/random.c
View file

@ -38,6 +38,10 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* Author: Mikael Djurfeldt <djurfeldt@nada.kth.se> */
#include "_scm.h"
@ -49,6 +53,7 @@
#include "numbers.h"
#include "feature.h"
#include "scm_validate.h"
#include "random.h"
@ -345,85 +350,77 @@ free_rstate (SCM rstate)
SCM_GLOBAL_VCELL_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_makfrom0str ("URL:http://stat.fsu.edu/~geo/diehard.html")));
SCM_PROC (s_random, "random", 1, 1, 0, scm_random);
SCM
scm_random (SCM n, SCM state)
GUILE_PROC (scm_random, "random", 1, 1, 0,
(SCM n, SCM state),
"")
#define FUNC_NAME s_scm_random
{
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state, SCM_ARG2, s_random);
SCM_VALIDATE_RSTATE(2,state);
if (SCM_INUMP (n))
{
unsigned long m = SCM_INUM (n);
SCM_ASSERT (m > 0, n, SCM_ARG1, s_random);
SCM_ASSERT_RANGE (1,n,m > 0);
return SCM_MAKINUM (scm_c_random (SCM_RSTATE (state), m));
}
SCM_ASSERT (SCM_NIMP (n), n, SCM_ARG1, s_random);
SCM_VALIDATE_NIMP(1,n);
if (SCM_REALP (n))
return scm_makdbl (SCM_REALPART (n) * scm_c_uniform01 (SCM_RSTATE (state)),
0.0);
SCM_ASSERT (SCM_TYP16 (n) == scm_tc16_bigpos, n, SCM_ARG1, s_random);
SCM_VALIDATE_SMOB (1,n,bigpos);
return scm_c_random_bignum (SCM_RSTATE (state), n);
}
#undef FUNC_NAME
SCM_PROC (s_copy_random_state, "copy-random-state", 0, 1, 0, scm_copy_random_state);
SCM
scm_copy_random_state (SCM state)
GUILE_PROC (scm_copy_random_state, "copy-random-state", 0, 1, 0,
(SCM state),
"")
#define FUNC_NAME s_scm_copy_random_state
{
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state,
SCM_ARG1,
s_copy_random_state);
SCM_VALIDATE_RSTATE(2,state);
return make_rstate (scm_the_rng.copy_rstate (SCM_RSTATE (state)));
}
#undef FUNC_NAME
SCM_PROC (s_seed_to_random_state, "seed->random-state", 1, 0, 0, scm_seed_to_random_state);
SCM
scm_seed_to_random_state (SCM seed)
GUILE_PROC (scm_seed_to_random_state, "seed->random-state", 1, 0, 0,
(SCM seed),
"")
#define FUNC_NAME s_scm_seed_to_random_state
{
if (SCM_NUMBERP (seed))
seed = scm_number_to_string (seed, SCM_UNDEFINED);
SCM_ASSERT (SCM_NIMP (seed) && SCM_STRINGP (seed),
seed,
SCM_ARG1,
s_seed_to_random_state);
SCM_VALIDATE_STRING(1,seed);
return make_rstate (scm_c_make_rstate (SCM_ROCHARS (seed),
SCM_LENGTH (seed)));
}
#undef FUNC_NAME
SCM_PROC (s_random_uniform, "random:uniform", 0, 1, 0, scm_random_uniform);
SCM
scm_random_uniform (SCM state)
GUILE_PROC (scm_random_uniform, "random:uniform", 0, 1, 0,
(SCM state),
"")
#define FUNC_NAME s_scm_random_uniform
{
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state,
SCM_ARG1,
s_random_uniform);
SCM_VALIDATE_RSTATE(1,state);
return scm_makdbl (scm_c_uniform01 (SCM_RSTATE (state)), 0.0);
}
#undef FUNC_NAME
SCM_PROC (s_random_normal, "random:normal", 0, 1, 0, scm_random_normal);
SCM
scm_random_normal (SCM state)
GUILE_PROC (scm_random_normal, "random:normal", 0, 1, 0,
(SCM state),
"")
#define FUNC_NAME s_scm_random_normal
{
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state,
SCM_ARG1,
s_random_normal);
SCM_VALIDATE_RSTATE(1,state);
return scm_makdbl (scm_c_normal01 (SCM_RSTATE (state)), 0.0);
}
#undef FUNC_NAME
#ifdef HAVE_ARRAYS
@ -464,20 +461,17 @@ vector_sum_squares (SCM v)
* distribution r^n; i.e., u=r^n is uniform [0,1], so r can be
* generated as r=u^(1/n).
*/
SCM_PROC (s_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, scm_random_solid_sphere_x);
SCM
scm_random_solid_sphere_x (SCM v, SCM state)
GUILE_PROC (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0,
(SCM v, SCM state),
"")
#define FUNC_NAME s_scm_random_solid_sphere_x
{
SCM_ASSERT (SCM_NIMP (v)
&& (SCM_VECTORP (v) || SCM_TYP7 (v) == scm_tc7_dvect),
v, SCM_ARG1, s_random_solid_sphere_x);
v, SCM_ARG1, FUNC_NAME);
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state,
SCM_ARG2,
s_random_solid_sphere_x);
SCM_VALIDATE_RSTATE(2,state);
scm_random_normal_vector_x (v, state);
vector_scale (v,
pow (scm_c_uniform01 (SCM_RSTATE (state)),
@ -485,40 +479,38 @@ scm_random_solid_sphere_x (SCM v, SCM state)
/ sqrt (vector_sum_squares (v)));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0, scm_random_hollow_sphere_x);
SCM
scm_random_hollow_sphere_x (SCM v, SCM state)
GUILE_PROC (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0,
(SCM v, SCM state),
"")
#define FUNC_NAME s_scm_random_hollow_sphere_x
{
SCM_ASSERT (SCM_NIMP (v)
&& (SCM_VECTORP (v) || SCM_TYP7 (v) == scm_tc7_dvect),
v, SCM_ARG1, s_random_solid_sphere_x);
v, SCM_ARG1, FUNC_NAME);
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state,
SCM_ARG2,
s_random_hollow_sphere_x);
SCM_VALIDATE_RSTATE(2,state);
scm_random_normal_vector_x (v, state);
vector_scale (v, 1 / sqrt (vector_sum_squares (v)));
return SCM_UNSPECIFIED;
}
SCM_PROC (s_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, scm_random_normal_vector_x);
#undef FUNC_NAME
SCM
scm_random_normal_vector_x (SCM v, SCM state)
GUILE_PROC (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0,
(SCM v, SCM state),
"")
#define FUNC_NAME s_scm_random_normal_vector_x
{
int n;
SCM_ASSERT (SCM_NIMP (v)
&& (SCM_VECTORP (v) || SCM_TYP7 (v) == scm_tc7_dvect),
v, SCM_ARG1, s_random_solid_sphere_x);
v, SCM_ARG1, FUNC_NAME);
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state,
SCM_ARG2,
s_random_normal_vector_x);
SCM_VALIDATE_RSTATE(2,state);
n = SCM_LENGTH (v);
if (SCM_VECTORP (v))
while (--n >= 0)
@ -528,22 +520,21 @@ scm_random_normal_vector_x (SCM v, SCM state)
((double *) SCM_VELTS (v))[n] = scm_c_normal01 (SCM_RSTATE (state));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif /* HAVE_ARRAYS */
SCM_PROC (s_random_exp, "random:exp", 0, 1, 0, scm_random_exp);
SCM
scm_random_exp (SCM state)
GUILE_PROC (scm_random_exp, "random:exp", 0, 1, 0,
(SCM state),
"")
#define FUNC_NAME s_scm_random_exp
{
if (SCM_UNBNDP (state))
state = SCM_CDR (scm_var_random_state);
SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
state,
SCM_ARG1,
s_random_exp);
SCM_VALIDATE_RSTATE(2,state);
return scm_makdbl (scm_c_exp1 (SCM_RSTATE (state)), 0.0);
}
#undef FUNC_NAME
void
scm_init_random ()

66
libguile/read.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -52,6 +56,7 @@
#include "hashtab.h"
#include "hash.h"
#include "scm_validate.h"
#include "read.h"
@ -69,39 +74,35 @@ scm_option scm_read_opts[] = {
"Style of keyword recognition: #f or 'prefix"}
};
SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options);
SCM
scm_read_options (setting)
SCM setting;
GUILE_PROC (scm_read_options, "read-options-interface", 0, 1, 0,
(SCM setting),
"")
#define FUNC_NAME s_scm_read_options
{
SCM ans = scm_options (setting,
scm_read_opts,
SCM_N_READ_OPTIONS,
s_read_options);
FUNC_NAME);
if (SCM_COPY_SOURCE_P)
SCM_RECORD_POSITIONS_P = 1;
return ans;
}
#undef FUNC_NAME
/* An association list mapping extra hash characters to procedures. */
static SCM *scm_read_hash_procedures;
SCM_PROC (s_read, "read", 0, 1, 0, scm_read);
SCM
scm_read (port)
SCM port;
GUILE_PROC (scm_read, "read", 0, 1, 0,
(SCM port),
"")
#define FUNC_NAME s_scm_read
{
int c;
SCM tok_buf, copy;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
port,
SCM_ARG1,
s_read);
SCM_VALIDATE_OPINPORT(1,port);
c = scm_flush_ws (port, (char *) NULL);
if (EOF == c)
@ -111,6 +112,7 @@ scm_read (port)
tok_buf = scm_makstr (30L, 0);
return scm_lreadr (&tok_buf, port, &copy);
}
#undef FUNC_NAME
@ -184,14 +186,8 @@ scm_casei_streq (s1, s2)
#ifndef DEBUG_EXTENSIONS
#define recsexpr(obj, line, column, filename) (obj)
#else
static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename));
static SCM
recsexpr (obj, line, column, filename)
SCM obj;
int line;
int column;
SCM filename;
recsexpr (SCM obj,int line,int column,SCM filename)
{
if (SCM_IMP (obj) || SCM_NCONSP(obj))
return obj;
@ -264,23 +260,19 @@ skip_scsh_block_comment (port)
}
}
static SCM
scm_get_hash_procedure SCM_P ((int c));
static SCM scm_get_hash_procedure(int c);
static char s_list[]="list";
SCM
scm_lreadr (tok_buf, port, copy)
SCM *tok_buf;
SCM port;
SCM *copy;
scm_lreadr (SCM *tok_buf,SCM port,SCM *copy)
{
int c;
scm_sizet j;
SCM p;
tryagain:
c = scm_flush_ws (port, s_read);
c = scm_flush_ws (port, s_scm_read);
tryagain_no_flush_ws:
switch (c)
{
@ -428,7 +420,7 @@ tryagain_no_flush_ws:
}
}
unkshrp:
scm_misc_error (s_read, "Unknown # object: %S",
scm_misc_error (s_scm_read, "Unknown # object: %S",
scm_listify (SCM_MAKICHR (c), SCM_UNDEFINED));
}
@ -727,18 +719,17 @@ exit:
/* Manipulate the read-hash-procedures alist. This could be written in
Scheme, but maybe it will also be used by C code during initialisation. */
SCM_PROC (s_read_hash_extend, "read-hash-extend", 2, 0, 0, scm_read_hash_extend);
SCM
scm_read_hash_extend (chr, proc)
SCM chr;
SCM proc;
GUILE_PROC (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
(SCM chr, SCM proc),
"")
#define FUNC_NAME s_scm_read_hash_extend
{
SCM this;
SCM prev;
SCM_ASSERT (SCM_ICHRP(chr), chr, SCM_ARG1, s_read_hash_extend);
SCM_VALIDATE_CHAR(1,chr);
SCM_ASSERT (SCM_FALSEP (proc) || SCM_NIMP(proc), proc, SCM_ARG2,
s_read_hash_extend);
FUNC_NAME);
/* Check if chr is already in the alist. */
this = *scm_read_hash_procedures;
@ -782,6 +773,7 @@ scm_read_hash_extend (chr, proc)
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Recover the read-hash procedure corresponding to char c. */
static SCM

71
libguile/regex-posix.c
View file

@ -39,6 +39,10 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*/
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* regex-posix.c -- POSIX regular expression support.
@ -79,6 +83,7 @@
#include "ports.h"
#include "feature.h"
#include "scm_validate.h"
#include "regex-posix.h"
/* This is defined by some regex libraries and omitted by others. */
@ -89,8 +94,7 @@
long scm_tc16_regex;
static scm_sizet
free_regex (obj)
SCM obj;
free_regex (SCM obj)
{
regfree (SCM_RGX (obj));
free (SCM_RGX (obj));
@ -129,26 +133,25 @@ scm_regexp_error_msg (int regerrno, regex_t *rx)
return SCM_CHARS (errmsg);
}
SCM_PROC (s_regexp_p, "regexp?", 1, 0, 0, scm_regexp_p);
SCM
scm_regexp_p (x)
SCM x;
GUILE_PROC (scm_regexp_p, "regexp?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_regexp_p
{
return (SCM_NIMP (x) && SCM_RGXP (x) ? SCM_BOOL_T : SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (x) && SCM_RGXP (x));
}
#undef FUNC_NAME
SCM_PROC (s_make_regexp, "make-regexp", 1, 0, 1, scm_make_regexp);
SCM
scm_make_regexp (SCM pat, SCM flags)
GUILE_PROC (scm_make_regexp, "make-regexp", 1, 0, 1,
(SCM pat, SCM flags),
"")
#define FUNC_NAME s_scm_make_regexp
{
SCM flag;
regex_t *rx;
int status, cflags;
SCM_ASSERT (SCM_NIMP(pat) && SCM_ROSTRINGP(pat), pat, SCM_ARG1,
s_make_regexp);
SCM_VALIDATE_ROSTRING(1,pat);
SCM_COERCE_SUBSTR (pat);
/* Examine list of regexp flags. If REG_BASIC is supplied, then
@ -164,7 +167,7 @@ scm_make_regexp (SCM pat, SCM flags)
flag = SCM_CDR (flag);
}
rx = (regex_t *) scm_must_malloc (sizeof (regex_t), s_make_regexp);
rx = SCM_MUST_MALLOC_TYPE(regex_t);
status = regcomp (rx, SCM_ROCHARS (pat),
/* Make sure they're not passing REG_NOSUB;
regexp-exec assumes we're getting match data. */
@ -172,7 +175,7 @@ scm_make_regexp (SCM pat, SCM flags)
if (status != 0)
{
scm_error (scm_regexp_error_key,
s_make_regexp,
FUNC_NAME,
scm_regexp_error_msg (status, rx),
SCM_BOOL_F,
SCM_BOOL_F);
@ -180,34 +183,24 @@ scm_make_regexp (SCM pat, SCM flags)
}
SCM_RETURN_NEWSMOB (scm_tc16_regex, rx);
}
#undef FUNC_NAME
SCM_PROC (s_regexp_exec, "regexp-exec", 2, 2, 0, scm_regexp_exec);
SCM
scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags)
GUILE_PROC (scm_regexp_exec, "regexp-exec", 2, 2, 0,
(SCM rx, SCM str, SCM start, SCM flags),
"")
#define FUNC_NAME s_scm_regexp_exec
{
int status, nmatches, offset;
regmatch_t *matches;
SCM mvec = SCM_BOOL_F;
SCM_ASSERT (SCM_NIMP (rx) && SCM_RGXP (rx), rx, SCM_ARG1, s_regexp_exec);
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG2,
s_regexp_exec);
if (SCM_UNBNDP (start))
offset = 0;
else
{
SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG3, s_regexp_exec);
offset = SCM_INUM (start);
SCM_ASSERT (offset >= 0 && (unsigned) offset <= SCM_LENGTH (str), start,
SCM_OUTOFRANGE, s_regexp_exec);
}
SCM_VALIDATE_RGXP(1,rx);
SCM_VALIDATE_ROSTRING(2,str);
SCM_VALIDATE_INT_DEF_COPY(3,start,0,offset);
SCM_ASSERT_RANGE (3,start,offset >= 0 && (unsigned) offset <= SCM_LENGTH (str));
if (SCM_UNBNDP (flags))
flags = SCM_INUM0;
SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG2, s_regexp_exec);
SCM_VALIDATE_INT(4,flags);
SCM_COERCE_SUBSTR (str);
/* re_nsub doesn't account for the `subexpression' representing the
@ -215,8 +208,7 @@ scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags)
nmatches = SCM_RGX(rx)->re_nsub + 1;
SCM_DEFER_INTS;
matches = (regmatch_t *) scm_must_malloc (sizeof (regmatch_t) * nmatches,
s_regexp_exec);
matches = SCM_MUST_MALLOC_TYPE_NUM (regmatch_t,nmatches);
status = regexec (SCM_RGX (rx), SCM_ROCHARS (str) + offset,
nmatches, matches,
SCM_INUM (flags));
@ -240,12 +232,13 @@ scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags)
if (status != 0 && status != REG_NOMATCH)
scm_error (scm_regexp_error_key,
s_regexp_exec,
FUNC_NAME,
scm_regexp_error_msg (status, SCM_RGX (rx)),
SCM_BOOL_F,
SCM_BOOL_F);
return mvec;
}
#undef FUNC_NAME
void
scm_init_regex_posix ()

49
libguile/root.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -70,11 +74,8 @@ struct scm_root_state *scm_root;
static SCM mark_root SCM_P ((SCM));
static SCM
mark_root (root)
SCM root;
mark_root (SCM root)
{
scm_root_state *s = SCM_ROOT_STATE (root);
@ -98,13 +99,8 @@ mark_root (root)
}
static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
print_root (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
print_root (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts ("#<root ", port);
scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
@ -116,8 +112,7 @@ print_root (exp, port, pstate)
SCM
scm_make_root (parent)
SCM parent;
scm_make_root (SCM parent)
{
SCM root;
scm_root_state *root_state;
@ -340,30 +335,27 @@ cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
stack_start);
}
SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
SCM
scm_call_with_dynamic_root (thunk, handler)
SCM thunk;
SCM handler;
GUILE_PROC(scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
(SCM thunk, SCM handler),
"")
#define FUNC_NAME s_scm_call_with_dynamic_root
{
SCM_STACKITEM stack_place;
return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
}
#undef FUNC_NAME
SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
SCM
scm_dynamic_root ()
GUILE_PROC(scm_dynamic_root, "dynamic-root", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_dynamic_root
{
return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
}
#undef FUNC_NAME
SCM
scm_apply_with_dynamic_root (proc, a1, args, handler)
SCM proc;
SCM a1;
SCM args;
SCM handler;
scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
{
SCM_STACKITEM stack_place;
return cwdr (proc, a1, args, handler, &stack_place);
@ -386,10 +378,7 @@ typedef long setjmp_type;
SCM
scm_call_catching_errors (thunk, err_filter, closure)
SCM (*thunk)();
SCM (*err_filter)();
void *closure;
scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
{
SCM answer;
setjmp_type i;

267
libguile/scm_validate.h Normal file
View file

@ -0,0 +1,267 @@
/* $Id: scm_validate.h,v 1.1 1999-12-12 02:36:16 gjb Exp $
* scm_validate.h
* Copyright (C) 1999, Greg J. Badros
*
*/
#ifndef SCM_VALIDATE_H__
#define SCM_VALIDATE_H__
#define SCM_BOOL(f) ((f)? SCM_BOOL_T : SCM_BOOL_F)
#define SCM_NEGATE_BOOL(f) ((f)? SCM_BOOL_F : SCM_BOOL_T)
#define SCM_FUNC_NAME (scm_makfrom0str(FUNC_NAME))
#define SCM_SYSERROR do { scm_syserror(FUNC_NAME); } while (0)
#define SCM_MEMORY_ERROR do { scm_memory_error(FUNC_NAME); } while (0)
#define SCM_SYSERROR_MSG(str,args,val) \
do { scm_syserror_msg(FUNC_NAME,(str),(args),(val)); } while (0)
#define SCM_SYSMISSING \
do { scm_sysmissing(FUNC_NAME); } while (0)
#define SCM_WTA(pos,scm) \
do { scm_wta(scm,(char *)pos,FUNC_NAME); } while (0)
#define RETURN_SCM_WTA(pos,scm) \
do { return scm_wta(scm,(char *)pos,FUNC_NAME); } while (0)
#define SCM_MISC_ERROR(str,args) \
do { scm_misc_error(FUNC_NAME,str,args); } while (0)
#define SCM_WRONG_TYPE_ARG(pos,obj) \
do { scm_wrong_type_arg(FUNC_NAME,pos,obj); } while (0)
#define SCM_NUM2ULONG(pos,arg) (scm_num2ulong(arg, (char *) pos, FUNC_NAME))
#define SCM_NUM2LONG(pos,arg) (scm_num2long(arg, (char *) pos, FUNC_NAME))
#define SCM_NUM2LONG_LONG(pos,arg) (scm_num2long_long(arg, (char *) pos, FUNC_NAME))
#define SCM_OUT_OF_RANGE(pos,arg) do { scm_out_of_range(FUNC_NAME,arg); } while (0)
#define SCM_ASSERT_RANGE(pos,arg,f) do { SCM_ASSERT(f,arg,SCM_OUTOFRANGE,FUNC_NAME); } while (0)
#define SCM_MUST_MALLOC_TYPE(type) ((type *) scm_must_malloc(sizeof(type), FUNC_NAME))
#define SCM_MUST_MALLOC_TYPE_NUM(type,num) ((type *) scm_must_malloc(sizeof(type)*(num), FUNC_NAME))
#define SCM_MUST_MALLOC(size) (scm_must_malloc((size), FUNC_NAME))
#define SCM_VALIDATE_NIMP(pos,scm) \
do { SCM_ASSERT(SCM_NIMP(scm), scm, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_BOOL(pos,flag) \
do { SCM_ASSERT(SCM_BOOL_T == flag || SCM_BOOL_F == flag, flag, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_BOOL_COPY(pos,flag,cvar) \
do { SCM_ASSERT(SCM_BOOL_T == flag || SCM_BOOL_F == flag, flag, pos, FUNC_NAME); \
cvar = (SCM_BOOL_T == flag)? 1: 0; } while (0)
#define SCM_VALIDATE_CHAR(pos,scm) \
do { SCM_ASSERT(SCM_ICHRP(scm), scm, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_CHAR_COPY(pos,scm,cvar) \
do { SCM_ASSERT(SCM_ICHRP(scm), scm, pos, FUNC_NAME); \
cvar = SCM_ICHR(scm); } while (0)
#define SCM_VALIDATE_ROSTRING(pos,str) \
do { SCM_ASSERT(SCM_NIMP (str) && SCM_ROSTRINGP (str), str, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_ROSTRING_COPY(pos,str,cvar) \
do { SCM_ASSERT(SCM_NIMP (str) && SCM_ROSTRINGP (str), str, pos, FUNC_NAME); \
cvar = SCM_ROCHARS(str); } while (0)
#define SCM_VALIDATE_NULLORROSTRING_COPY(pos,str,cvar) \
do { SCM_ASSERT(SCM_FALSEP(str) || (SCM_NIMP (str) && SCM_ROSTRINGP (str)), str, pos, FUNC_NAME); \
if (SCM_FALSEP(str)) cvar = NULL; else cvar = SCM_ROCHARS(str); } while (0)
#define SCM_VALIDATE_STRING(pos,str) \
do { SCM_ASSERT(SCM_NIMP (str) && SCM_STRINGP (str), str, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_STRINGORSUBSTR(pos,str) \
do { SCM_ASSERT(SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP(str)), str, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_STRING_COPY(pos,str,cvar) \
do { SCM_ASSERT(SCM_NIMP (str) && SCM_STRINGP (str), str, pos, FUNC_NAME); \
cvar = SCM_CHARS(str); } while (0)
#define SCM_VALIDATE_RWSTRING(pos,str) \
do { SCM_ASSERT(SCM_NIMP (str) && SCM_STRINGP (str), str, pos, FUNC_NAME); \
if (!SCM_RWSTRINGP(str)) scm_misc_error(FUNC_NAME, "argument is a read-only string", str); } while (0)
#define SCM_VALIDATE_REAL(pos,z) \
do { SCM_ASSERT (SCM_NIMP (z) && SCM_REALP (z), z, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_INT(pos,k) \
do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_INT_COPY(pos,k,cvar) \
do { cvar = scm_num2ulong(k,(char *)pos,FUNC_NAME); } while (0)
#define SCM_VALIDATE_BIGINT(pos,k) \
do { SCM_ASSERT(SCM_NIMP(k) && SCM_BIGP(k), k, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_INT_MIN(pos,k,min) \
do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \
SCM_ASSERT(SCM_INUM(k) >= min, k, SCM_OUTOFRANGE, FUNC_NAME); } while (0)
#define SCM_VALIDATE_INT_MIN_COPY(pos,k,min,cvar) \
do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \
cvar = SCM_INUM(k); \
SCM_ASSERT(cvar >= min, k, SCM_OUTOFRANGE, FUNC_NAME); } while (0)
#define SCM_VALIDATE_INT_MIN_DEF_COPY(pos,k,min,default,cvar) \
do { if (SCM_UNBNDP(k)) k = SCM_MAKINUM(default); \
SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \
cvar = SCM_INUM(k); \
SCM_ASSERT(cvar >= min, k, SCM_OUTOFRANGE, FUNC_NAME); } while (0)
#define SCM_VALIDATE_INT_DEF(pos,k,default) \
do { if (SCM_UNDEFINED==k) k = SCM_MAKINUM(default); else SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_INT_DEF_COPY(pos,k,default,cvar) \
do { if (SCM_UNDEFINED==k) { k = SCM_MAKINUM(default); cvar=default; } \
else { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); cvar = SCM_INUM(k); } } while (0)
/* [low,high) */
#define SCM_VALIDATE_INT_RANGE(pos,k,low,high) \
do { SCM_ASSERT(SCM_INUMP(k), k, pos, FUNC_NAME); \
SCM_ASSERT(SCM_INUM (k) >= low && ((unsigned) SCM_INUM (k)) < high, \
k, SCM_OUTOFRANGE, FUNC_NAME); } while (0)
#define SCM_VALIDATE_NULL(pos,scm) \
do { SCM_ASSERT(SCM_NULLP(scm), scm, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_CONS(pos,scm) \
do { SCM_ASSERT(SCM_CONSP(scm), scm, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_NIMCONS(pos,scm) \
do { SCM_ASSERT(SCM_CONSP(scm), scm, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_LIST(pos,lst) \
do { SCM_ASSERT (scm_ilength (lst) >= 0, lst, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_LIST_COPYLEN(pos,lst,cvar) \
do { cvar = scm_ilength(lst); SCM_ASSERT(cvar >= 0,lst,pos,FUNC_NAME); } while (0)
#define SCM_VALIDATE_NONEMPTYLIST_COPYLEN(pos,lst,cvar) \
do { cvar = scm_ilength(lst); SCM_ASSERT(cvar >= 1,lst,pos,FUNC_NAME); } while (0)
#define SCM_VALIDATE_ALISTCELL(pos,alist) \
do { \
SCM_ASSERT(SCM_CONSP(alist), alist, pos, FUNC_NAME); \
{ SCM tmp = SCM_CAR(alist); \
SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, pos, FUNC_NAME); } } while (0)
#define SCM_VALIDATE_ALISTCELL_COPYSCM(pos,alist,tmp) \
do { \
SCM_ASSERT(SCM_CONSP(alist), alist, pos, FUNC_NAME); \
tmp = SCM_CAR(alist); \
SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_OPORT_VALUE(pos,port) \
do { SCM_ASSERT (scm_valid_oport_value_p (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_PRINTSTATE(pos,a) \
do { SCM_ASSERT (SCM_NIMP (a) && SCM_PRINT_STATE_P (a), a, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_SMOB(pos,obj,type) \
do { SCM_ASSERT ((SCM_NIMP(obj) && SCM_TYP16 (obj) == scm_tc16_ ## type), obj, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_ASYNC(pos,a) \
do { SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_ASYNC_COPY(pos,a,cvar) \
do { SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, pos, FUNC_NAME); \
cvar = SCM_ASYNC(a); } while (0)
#define SCM_VALIDATE_THUNK(pos,thunk) \
do { SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_SYMBOL(pos,sym) \
do { SCM_ASSERT (SCM_NIMP(sym) && SCM_SYMBOLP(sym), sym, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_VARIABLE(pos,var) \
do { SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_MEMOIZED(pos,obj) \
do { SCM_ASSERT (SCM_NIMP(obj) && SCM_MEMOIZEDP(obj), obj, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_CLOSURE(pos,obj) \
do { SCM_ASSERT (SCM_NIMP(obj) && SCM_CLOSUREP(obj), obj, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_PROC(pos,proc) \
do { SCM_ASSERT ( SCM_BOOL_T == scm_procedure_p(proc), proc, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_NULLORCONS(pos,env) \
do { SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), env, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_HOOK(pos,a) \
do { SCM_ASSERT (SCM_NIMP (a) && SCM_HOOKP (a), a, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_RGXP(pos,a) \
do { SCM_ASSERT (SCM_NIMP (a) && SCM_RGXP (a), a, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_OPDIR(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_DIR(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_PORT(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_FPORT(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_OPFPORT(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_OPINPORT(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_OPENPORT(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP(port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_OPPORT(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_OPOUTPORT(pos,port) \
do { SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_FLUID(pos,fluid) \
do { SCM_ASSERT (SCM_NIMP (fluid) && SCM_FLUIDP (fluid), fluid, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_KEYWORD(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_KEYWORDP (v), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_STACK(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_STACKP (v), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_FRAME(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_FRAMEP (v), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_RSTATE(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_RSTATEP (v), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_ARRAY(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_BOOL_F != scm_array_p(v,SCM_UNDEFINED), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_VECTOR(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_VECTORP (v), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_STRUCT(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_STRUCTP (v), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_VTABLE(pos,v) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_NFALSEP(scm_struct_vtable_p(v)), v, pos, FUNC_NAME); } while (0)
#define SCM_VALIDATE_VECTOR_LEN(pos,v,len) \
do { SCM_ASSERT (SCM_NIMP (v) && SCM_VECTORP (v) && len == SCM_LENGTH(v), v, pos, FUNC_NAME); } while (0)
#endif

110
libguile/scmsigs.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -46,6 +50,8 @@
#include "async.h"
#include "eval.h"
#include "scm_validate.h"
#include "scmsigs.h"
#ifdef HAVE_UNISTD_H
@ -173,9 +179,10 @@ sys_deliver_signals (void)
}
/* user interface for installation of signal handlers. */
SCM_PROC(s_sigaction, "sigaction", 1, 2, 0, scm_sigaction);
SCM
scm_sigaction (SCM signum, SCM handler, SCM flags)
GUILE_PROC(scm_sigaction, "sigaction", 1, 2, 0,
(SCM signum, SCM handler, SCM flags),
"")
#define FUNC_NAME s_scm_sigaction
{
int csig;
#ifdef HAVE_SIGACTION
@ -190,8 +197,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
SCM *scheme_handlers = SCM_VELTS (*signal_handlers);
SCM old_handler;
SCM_ASSERT (SCM_INUMP (signum), signum, SCM_ARG1, s_sigaction);
csig = SCM_INUM (signum);
SCM_VALIDATE_INT_COPY(1,signum,csig);
#if defined(HAVE_SIGACTION)
#if defined(SA_RESTART) && defined(HAVE_RESTARTABLE_SYSCALLS)
/* don't allow SA_RESTART to be omitted if HAVE_RESTARTABLE_SYSCALLS
@ -203,7 +209,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
#endif
if (!SCM_UNBNDP (flags))
{
SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG3, s_sigaction);
SCM_VALIDATE_INT(3,flags);
action.sa_flags |= SCM_INUM (flags);
}
sigemptyset (&action.sa_mask);
@ -214,10 +220,8 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
query_only = 1;
else if (scm_integer_p (handler) == SCM_BOOL_T)
{
if (scm_num2long (handler, (char *) SCM_ARG2, s_sigaction)
== (long) SIG_DFL
|| scm_num2long (handler, (char *) SCM_ARG2, s_sigaction)
== (long) SIG_IGN)
if (SCM_NUM2LONG (2,handler) == (long) SIG_DFL
|| SCM_NUM2LONG (2,handler) == (long) SIG_IGN)
{
#ifdef HAVE_SIGACTION
action.sa_handler = (SIGRETTYPE (*) (int)) SCM_INUM (handler);
@ -227,7 +231,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
scheme_handlers[csig] = SCM_BOOL_F;
}
else
scm_out_of_range (s_sigaction, handler);
SCM_OUT_OF_RANGE (2, handler);
}
else if (SCM_FALSEP (handler))
{
@ -254,7 +258,7 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
}
else
{
SCM_ASSERT (SCM_NIMP (handler), handler, SCM_ARG2, s_sigaction);
SCM_VALIDATE_NIMP(2,handler);
#ifdef HAVE_SIGACTION
action.sa_handler = take_signal;
if (orig_handlers[csig].sa_handler == SIG_ERR)
@ -270,12 +274,12 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
if (query_only)
{
if (sigaction (csig, 0, &old_action) == -1)
scm_syserror (s_sigaction);
SCM_SYSERROR;
}
else
{
if (sigaction (csig, &action , &old_action) == -1)
scm_syserror (s_sigaction);
SCM_SYSERROR;
if (save_handler)
orig_handlers[csig] = old_action;
}
@ -287,14 +291,14 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
if (query_only)
{
if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
scm_syserror (s_sigaction);
SCM_SYSERROR;
if (signal (csig, old_chandler) == SIG_ERR)
scm_syserror (s_sigaction);
SCM_SYSERROR;
}
else
{
if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
scm_syserror (s_sigaction);
SCM_SYSERROR;
if (save_handler)
orig_handlers[csig] = old_chandler;
}
@ -304,10 +308,12 @@ scm_sigaction (SCM signum, SCM handler, SCM flags)
return scm_cons (old_handler, SCM_MAKINUM (0));
#endif
}
#undef FUNC_NAME
SCM_PROC (s_restore_signals, "restore-signals", 0, 0, 0, scm_restore_signals);
SCM
scm_restore_signals (void)
GUILE_PROC (scm_restore_signals, "restore-signals", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_restore_signals
{
int i;
SCM *scheme_handlers = SCM_VELTS (*signal_handlers);
@ -318,7 +324,7 @@ scm_restore_signals (void)
if (orig_handlers[i].sa_handler != SIG_ERR)
{
if (sigaction (i, &orig_handlers[i], NULL) == -1)
scm_syserror (s_restore_signals);
SCM_SYSERROR;
orig_handlers[i].sa_handler = SIG_ERR;
scheme_handlers[i] = SCM_BOOL_F;
}
@ -326,7 +332,7 @@ scm_restore_signals (void)
if (orig_handlers[i] != SIG_ERR)
{
if (signal (i, orig_handlers[i]) == SIG_ERR)
scm_syserror (s_restore_signals);
SCM_SYSERROR;
orig_handlers[i] = SIG_ERR;
scheme_handlers[i] = SCM_BOOL_F;
}
@ -334,38 +340,39 @@ scm_restore_signals (void)
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_alarm, "alarm", 1, 0, 0, scm_alarm);
SCM
scm_alarm (i)
SCM i;
GUILE_PROC(scm_alarm, "alarm", 1, 0, 0,
(SCM i),
"")
#define FUNC_NAME s_scm_alarm
{
unsigned int j;
SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_alarm);
SCM_VALIDATE_INT(1,i);
j = alarm (SCM_INUM (i));
return SCM_MAKINUM (j);
}
#undef FUNC_NAME
#ifdef HAVE_PAUSE
SCM_PROC(s_pause, "pause", 0, 0, 0, scm_pause);
SCM
scm_pause ()
GUILE_PROC(scm_pause, "pause", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_pause
{
pause ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif
SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep);
SCM
scm_sleep (i)
SCM i;
GUILE_PROC(scm_sleep, "sleep", 1, 0, 0,
(SCM i),
"")
#define FUNC_NAME s_scm_sleep
{
unsigned long j;
SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_sleep);
SCM_VALIDATE_INT_MIN(1,i,0);
#ifdef USE_THREADS
j = scm_thread_sleep (SCM_INUM(i));
#else
@ -373,15 +380,15 @@ scm_sleep (i)
#endif
return scm_ulong2num (j);
}
#undef FUNC_NAME
#if defined(USE_THREADS) || defined(HAVE_USLEEP)
SCM_PROC(s_usleep, "usleep", 1, 0, 0, scm_usleep);
SCM
scm_usleep (i)
SCM i;
GUILE_PROC(scm_usleep, "usleep", 1, 0, 0,
(SCM i),
"")
#define FUNC_NAME s_scm_usleep
{
SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_usleep);
SCM_VALIDATE_INT_MIN(1,i,0);
#ifdef USE_THREADS
/* If we have threads, we use the thread system's sleep function. */
@ -401,21 +408,22 @@ scm_usleep (i)
#endif
#endif
}
#undef FUNC_NAME
#endif /* GUILE_ISELECT || HAVE_USLEEP */
SCM_PROC(s_raise, "raise", 1, 0, 0, scm_raise);
SCM
scm_raise(sig)
SCM sig;
GUILE_PROC(scm_raise, "raise", 1, 0, 0,
(SCM sig),
"")
#define FUNC_NAME s_scm_raise
{
SCM_ASSERT(SCM_INUMP(sig), sig, SCM_ARG1, s_raise);
SCM_VALIDATE_INT(1,sig);
SCM_DEFER_INTS;
if (kill (getpid (), (int) SCM_INUM (sig)) != 0)
scm_syserror (s_raise);
SCM_SYSERROR;
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

49
libguile/simpos.c
View file

@ -38,12 +38,18 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "scmsigs.h"
#include "scm_validate.h"
#include "simpos.h"
#ifdef HAVE_STRING_H
@ -57,11 +63,10 @@
extern int system();
SCM_PROC(s_system, "system", 0, 1, 0, scm_system);
SCM
scm_system(cmd)
SCM cmd;
GUILE_PROC(scm_system, "system", 0, 1, 0,
(SCM cmd),
"")
#define FUNC_NAME s_scm_system
{
int rv;
@ -72,9 +77,9 @@ scm_system(cmd)
#else
rv = 0;
#endif
return rv ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(rv);
}
SCM_ASSERT(SCM_NIMP(cmd) && SCM_ROSTRINGP(cmd), cmd, SCM_ARG1, s_system);
SCM_VALIDATE_ROSTRING(1,cmd);
#ifdef HAVE_SYSTEM
SCM_DEFER_INTS;
errno = 0;
@ -82,42 +87,44 @@ scm_system(cmd)
cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_ROLENGTH (cmd), 0);
rv = system(SCM_ROCHARS(cmd));
if (rv == -1 || (rv == 127 && errno != 0))
scm_syserror (s_system);
SCM_SYSERROR;
SCM_ALLOW_INTS;
return SCM_MAKINUM (rv);
#else
scm_sysmissing (s_system);
SCM_SYSMISSING;
#endif
}
#undef FUNC_NAME
extern char *getenv();
SCM_PROC (s_getenv, "getenv", 1, 0, 0, scm_getenv);
SCM
scm_getenv(nam)
SCM nam;
GUILE_PROC (scm_getenv, "getenv", 1, 0, 0,
(SCM nam),
"")
#define FUNC_NAME s_scm_getenv
{
char *val;
SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_getenv);
if (SCM_ROSTRINGP (nam))
nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0);
SCM_VALIDATE_ROSTRING(1,nam);
nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0);
val = getenv(SCM_CHARS(nam));
return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F;
}
#undef FUNC_NAME
/* simple exit, without unwinding the scheme stack or flushing ports. */
SCM_PROC (s_primitive_exit, "primitive-exit", 0, 1, 0, scm_primitive_exit);
SCM
scm_primitive_exit (SCM status)
GUILE_PROC (scm_primitive_exit, "primitive-exit", 0, 1, 0,
(SCM status),
"")
#define FUNC_NAME s_scm_primitive_exit
{
int cstatus = 0;
if (!SCM_UNBNDP (status))
{
SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1, s_primitive_exit);
SCM_VALIDATE_INT(1,status);
cstatus = SCM_INUM (status);
}
exit (cstatus);
}
#undef FUNC_NAME
void

6
libguile/smob.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -273,4 +277,6 @@ scm_smob_prehistory ()
scm_make_smob_type_mfpe ("bigneg", 0,
NULL, NULL, scm_bigprint, scm_bigequal);
scm_make_smob_type("allocated", 0);
}

34
libguile/snarf.h
View file

@ -1,4 +1,3 @@
/* classes: h_files */
/* Macros for snarfing initialization actions from C source. */
@ -46,11 +45,25 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#ifndef SCM_MAGIC_SNARFER
#define GUILE_PROC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST
#define GUILE_PROC1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
static const char s_ ## FNAME [] = PRIMNAME; \
SCM FNAME ARGLIST
#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
static const char RANAME[]=STR
#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
static const char RANAME[]=STR
#define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \
static const char RANAME[]=STR; \
static SCM GF = 0
@ -61,8 +74,16 @@
static SCM GF = 0
#else
#if defined(__cplusplus) || defined(GUILE_CPLUSPLUS_SNARF)
#define GUILE_PROC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
%%% scm_make_gsubr (s_ ## FNAME, REQ, OPT, VAR, (SCM (*)(...)) FNAME);
#define GUILE_PROC1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
%%% scm_make_subr (s_ ## FNAME, TYPE, FNAME);
#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)(...))CFN)
%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)(...)) CFN)
#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)(...)) CFN)
#define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \
%%% scm_make_gsubr_with_generic (RANAME, REQ, OPT, VAR, (SCM (*)(...))CFN, &GF)
#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
@ -70,8 +91,17 @@
#define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \
%%% scm_make_subr_with_generic(RANAME, TYPE, (SCM (*)(...))CFN, &GF)
#else
#define GUILE_PROC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
%%% scm_make_gsubr (s_ ## FNAME, REQ, OPT, VAR, (SCM (*)()) FNAME);
#define GUILE_PROC1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
%%% scm_make_subr (s_ ## FNAME, TYPE, FNAME);
#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)()) CFN)
#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*)()) CFN)
#define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \
%%% scm_make_gsubr_with_generic (RANAME, REQ, OPT, VAR, (SCM (*)()) CFN, &GF)
#define SCM_PROC1(RANAME, STR, TYPE, CFN) \

422
libguile/socket.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -47,6 +51,7 @@
#include "feature.h"
#include "fports.h"
#include "scm_validate.h"
#include "socket.h"
#ifdef HAVE_STRING_H
@ -66,125 +71,121 @@
SCM_PROC (s_htons, "htons", 1, 0, 0, scm_htons);
SCM
scm_htons (SCM in)
GUILE_PROC (scm_htons, "htons", 1, 0, 0,
(SCM in),
"")
#define FUNC_NAME s_scm_htons
{
unsigned short c_in;
SCM_ASSERT (SCM_INUMP (in), in, SCM_ARG1, s_htons);
c_in = SCM_INUM (in);
SCM_VALIDATE_INT_COPY(1,in,c_in);
if (c_in != SCM_INUM (in))
scm_out_of_range (s_htons, in);
SCM_OUT_OF_RANGE (1,in);
return SCM_MAKINUM (htons (c_in));
}
#undef FUNC_NAME
SCM_PROC (s_ntohs, "ntohs", 1, 0, 0, scm_ntohs);
SCM
scm_ntohs (SCM in)
GUILE_PROC (scm_ntohs, "ntohs", 1, 0, 0,
(SCM in),
"")
#define FUNC_NAME s_scm_ntohs
{
unsigned short c_in;
SCM_ASSERT (SCM_INUMP (in), in, SCM_ARG1, s_ntohs);
c_in = SCM_INUM (in);
SCM_VALIDATE_INT_COPY(1,in,c_in);
if (c_in != SCM_INUM (in))
scm_out_of_range (s_ntohs, in);
SCM_OUT_OF_RANGE (1,in);
return SCM_MAKINUM (ntohs (c_in));
}
#undef FUNC_NAME
SCM_PROC (s_htonl, "htonl", 1, 0, 0, scm_htonl);
SCM
scm_htonl (SCM in)
GUILE_PROC (scm_htonl, "htonl", 1, 0, 0,
(SCM in),
"")
#define FUNC_NAME s_scm_htonl
{
unsigned long c_in = scm_num2ulong (in, (char *) SCM_ARG1, s_htonl);
unsigned long c_in = SCM_NUM2ULONG (1,in);
return scm_ulong2num (htonl (c_in));
}
#undef FUNC_NAME
SCM_PROC (s_ntohl, "ntohl", 1, 0, 0, scm_ntohl);
SCM
scm_ntohl (SCM in)
GUILE_PROC (scm_ntohl, "ntohl", 1, 0, 0,
(SCM in),
"")
#define FUNC_NAME s_scm_ntohl
{
unsigned long c_in = scm_num2ulong (in, (char *) SCM_ARG1, s_ntohl);
unsigned long c_in = SCM_NUM2ULONG (1,in);
return scm_ulong2num (ntohl (c_in));
}
#undef FUNC_NAME
SCM_SYMBOL (sym_socket, "socket");
static SCM scm_sock_fd_to_port SCM_P ((int fd, const char *proc));
static SCM
scm_sock_fd_to_port (fd, proc)
int fd;
const char *proc;
scm_sock_fd_to_port (int fd, const char *proc)
{
SCM result;
if (fd == -1)
scm_syserror (proc);
result = scm_fdes_to_port (fd, "r+0", sym_socket);
return result;
}
SCM_PROC (s_socket, "socket", 3, 0, 0, scm_socket);
SCM
scm_socket (family, style, proto)
SCM family;
SCM style;
SCM proto;
#define SCM_SOCK_FD_TO_PORT(fd) (scm_sock_fd_to_port((fd),FUNC_NAME))
GUILE_PROC (scm_socket, "socket", 3, 0, 0,
(SCM family, SCM style, SCM proto),
"")
#define FUNC_NAME s_scm_socket
{
int fd;
SCM result;
SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socket);
SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socket);
SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socket);
SCM_VALIDATE_INT(1,family);
SCM_VALIDATE_INT(2,style);
SCM_VALIDATE_INT(3,proto);
fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto));
result = scm_sock_fd_to_port (fd, s_socket);
result = SCM_SOCK_FD_TO_PORT (fd);
return result;
}
#undef FUNC_NAME
#ifdef HAVE_SOCKETPAIR
SCM_PROC (s_socketpair, "socketpair", 3, 0, 0, scm_socketpair);
SCM
scm_socketpair (family, style, proto)
SCM family;
SCM style;
SCM proto;
GUILE_PROC (scm_socketpair, "socketpair", 3, 0, 0,
(SCM family, SCM style, SCM proto),
"")
#define FUNC_NAME s_scm_socketpair
{
int fam;
int fd[2];
SCM a;
SCM b;
SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socketpair);
SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socketpair);
SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socketpair);
SCM_VALIDATE_INT(1,family);
SCM_VALIDATE_INT(2,style);
SCM_VALIDATE_INT(3,proto);
fam = SCM_INUM (family);
if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1)
scm_syserror (s_socketpair);
SCM_SYSERROR;
a = scm_sock_fd_to_port (fd[0], s_socketpair);
b = scm_sock_fd_to_port (fd[1], s_socketpair);
a = SCM_SOCK_FD_TO_PORT(fd[0]);
b = SCM_SOCK_FD_TO_PORT(fd[1]);
return scm_cons (a, b);
}
#undef FUNC_NAME
#endif
SCM_PROC (s_getsockopt, "getsockopt", 3, 0, 0, scm_getsockopt);
SCM
scm_getsockopt (sock, level, optname)
SCM sock;
SCM level;
SCM optname;
GUILE_PROC (scm_getsockopt, "getsockopt", 3, 0, 0,
(SCM sock, SCM level, SCM optname),
"")
#define FUNC_NAME s_scm_getsockopt
{
int fd;
int optlen;
@ -203,16 +204,13 @@ scm_getsockopt (sock, level, optname)
#endif
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_getsockopt);
SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_getsockopt);
SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_getsockopt);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_INT_COPY(2,level,ilevel);
SCM_VALIDATE_INT_COPY(3,optname,ioptname);
fd = SCM_FPORT_FDES (sock);
ilevel = SCM_INUM (level);
ioptname = SCM_INUM (optname);
if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
scm_syserror (s_getsockopt);
SCM_SYSERROR;
#ifdef SO_LINGER
if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
@ -244,15 +242,12 @@ scm_getsockopt (sock, level, optname)
#endif
return SCM_MAKINUM (*(int *) optval);
}
#undef FUNC_NAME
SCM_PROC (s_setsockopt, "setsockopt", 4, 0, 0, scm_setsockopt);
SCM
scm_setsockopt (sock, level, optname, value)
SCM sock;
SCM level;
SCM optname;
SCM value;
GUILE_PROC (scm_setsockopt, "setsockopt", 4, 0, 0,
(SCM sock, SCM level, SCM optname, SCM value),
"")
#define FUNC_NAME s_scm_setsockopt
{
int fd;
int optlen;
@ -263,13 +258,10 @@ scm_setsockopt (sock, level, optname, value)
#endif
int ilevel, ioptname;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_setsockopt);
SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_setsockopt);
SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_setsockopt);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_INT_COPY(2,level,ilevel);
SCM_VALIDATE_INT_COPY(3,optname,ioptname);
fd = SCM_FPORT_FDES (sock);
ilevel = SCM_INUM (level);
ioptname = SCM_INUM (optname);
if (0);
#ifdef SO_LINGER
else if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
@ -279,7 +271,7 @@ scm_setsockopt (sock, level, optname, value)
SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
&& SCM_INUMP (SCM_CAR (value))
&& SCM_INUMP (SCM_CDR (value)),
value, SCM_ARG4, s_setsockopt);
value, SCM_ARG4, FUNC_NAME);
ling.l_onoff = SCM_INUM (SCM_CAR (value));
ling.l_linger = SCM_INUM (SCM_CDR (value));
optlen = (int) sizeof (struct linger);
@ -289,7 +281,7 @@ scm_setsockopt (sock, level, optname, value)
SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
&& SCM_INUMP (SCM_CAR (value))
&& SCM_INUMP (SCM_CDR (value)),
value, SCM_ARG4, s_setsockopt);
value, SCM_ARG4, FUNC_NAME);
ling = SCM_INUM (SCM_CAR (value));
optlen = (int) sizeof (scm_sizet);
(*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
@ -299,7 +291,7 @@ scm_setsockopt (sock, level, optname, value)
#ifdef SO_SNDBUF
else if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
{
SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
SCM_VALIDATE_INT(4,value);
optlen = (int) sizeof (scm_sizet);
(*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
}
@ -307,7 +299,7 @@ scm_setsockopt (sock, level, optname, value)
#ifdef SO_RCVBUF
else if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
{
SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
SCM_VALIDATE_INT(4,value);
optlen = (int) sizeof (scm_sizet);
(*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
}
@ -315,33 +307,32 @@ scm_setsockopt (sock, level, optname, value)
else
{
/* Most options just take an int. */
SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
SCM_VALIDATE_INT(4,value);
optlen = (int) sizeof (int);
(*(int *) optval) = (int) SCM_INUM (value);
}
if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1)
scm_syserror (s_setsockopt);
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_shutdown, "shutdown", 2, 0, 0, scm_shutdown);
SCM
scm_shutdown (sock, how)
SCM sock;
SCM how;
GUILE_PROC (scm_shutdown, "shutdown", 2, 0, 0,
(SCM sock, SCM how),
"")
#define FUNC_NAME s_scm_shutdown
{
int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_shutdown);
SCM_ASSERT (SCM_INUMP (how) && 0 <= SCM_INUM (how) && 2 >= SCM_INUM (how),
how, SCM_ARG2, s_shutdown);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_INT(2,how);
SCM_ASSERT_RANGE(2,how,0 <= SCM_INUM (how) && 2 >= SCM_INUM (how));
fd = SCM_FPORT_FDES (sock);
if (shutdown (fd, SCM_INUM (how)) == -1)
scm_syserror (s_shutdown);
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* convert fam/address/args into a sockaddr of the appropriate type.
args is modified by removing the arguments actually used.
@ -351,16 +342,8 @@ scm_shutdown (sock, how)
size returns the size of the structure allocated. */
static struct sockaddr * scm_fill_sockaddr SCM_P ((int fam, SCM address, SCM *args, int which_arg, const char *proc, scm_sizet *size));
static struct sockaddr *
scm_fill_sockaddr (fam, address, args, which_arg, proc, size)
int fam;
SCM address;
SCM *args;
int which_arg;
const char *proc;
scm_sizet *size;
scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc,scm_sizet *size)
{
switch (fam)
{
@ -407,39 +390,31 @@ scm_fill_sockaddr (fam, address, args, which_arg, proc, size)
}
}
SCM_PROC (s_connect, "connect", 3, 0, 1, scm_connect);
SCM
scm_connect (sock, fam, address, args)
SCM sock;
SCM fam;
SCM address;
SCM args;
GUILE_PROC (scm_connect, "connect", 3, 0, 1,
(SCM sock, SCM fam, SCM address, SCM args),
"")
#define FUNC_NAME s_scm_connect
{
int fd;
struct sockaddr *soka;
scm_sizet size;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_connect);
SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_connect);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_INT(2,fam);
fd = SCM_FPORT_FDES (sock);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_connect, &size);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size);
if (connect (fd, soka, size) == -1)
scm_syserror (s_connect);
SCM_SYSERROR;
scm_must_free ((char *) soka);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_bind, "bind", 3, 0, 1, scm_bind);
SCM
scm_bind (sock, fam, address, args)
SCM sock;
SCM fam;
SCM address;
SCM args;
GUILE_PROC (scm_bind, "bind", 3, 0, 1,
(SCM sock, SCM fam, SCM address, SCM args),
"")
#define FUNC_NAME s_scm_bind
{
int rv;
struct sockaddr *soka;
@ -447,42 +422,38 @@ scm_bind (sock, fam, address, args)
int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_bind);
SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_bind);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_bind, &size);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_INT(2,fam);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size);
fd = SCM_FPORT_FDES (sock);
rv = bind (fd, soka, size);
if (rv == -1)
scm_syserror (s_bind);
SCM_SYSERROR;
scm_must_free ((char *) soka);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_listen, "listen", 2, 0, 0, scm_listen);
SCM
scm_listen (sock, backlog)
SCM sock;
SCM backlog;
GUILE_PROC (scm_listen, "listen", 2, 0, 0,
(SCM sock, SCM backlog),
"")
#define FUNC_NAME s_scm_listen
{
int fd;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_listen);
SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_INT(2,backlog);
fd = SCM_FPORT_FDES (sock);
if (listen (fd, SCM_INUM (backlog)) == -1)
scm_syserror (s_listen);
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
/* Put the components of a sockaddr into a new SCM vector. */
static SCM scm_addr_vector SCM_P ((struct sockaddr *address, const char *proc));
static SCM
scm_addr_vector (address, proc)
struct sockaddr *address;
const char *proc;
scm_addr_vector (struct sockaddr *address,const char *proc)
{
short int fam = address->sa_family;
SCM result;
@ -519,10 +490,8 @@ scm_addr_vector (address, proc)
static char *scm_addr_buffer;
static int scm_addr_buffer_size;
static void scm_init_addr_buffer SCM_P ((void));
static void
scm_init_addr_buffer ()
scm_init_addr_buffer (void)
{
scm_addr_buffer_size =
#ifdef HAVE_UNIX_DOMAIN_SOCKETS
@ -536,11 +505,10 @@ scm_init_addr_buffer ()
scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer");
}
SCM_PROC (s_accept, "accept", 1, 0, 0, scm_accept);
SCM
scm_accept (sock)
SCM sock;
GUILE_PROC (scm_accept, "accept", 1, 0, 0,
(SCM sock),
"")
#define FUNC_NAME s_scm_accept
{
int fd;
int newfd;
@ -549,128 +517,112 @@ scm_accept (sock)
int tmp_size;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_accept);
SCM_VALIDATE_OPFPORT(1,sock);
fd = SCM_FPORT_FDES (sock);
tmp_size = scm_addr_buffer_size;
newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size);
newsock = scm_sock_fd_to_port (newfd, s_accept);
newsock = scm_sock_fd_to_port (newfd, FUNC_NAME);
if (tmp_size > 0)
address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_accept);
address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
else
address = SCM_BOOL_F;
return scm_cons (newsock, address);
}
#undef FUNC_NAME
SCM_PROC (s_getsockname, "getsockname", 1, 0, 0, scm_getsockname);
SCM
scm_getsockname (sock)
SCM sock;
GUILE_PROC (scm_getsockname, "getsockname", 1, 0, 0,
(SCM sock),
"")
#define FUNC_NAME s_scm_getsockname
{
int tmp_size;
int fd;
SCM result;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_getsockname);
SCM_VALIDATE_OPFPORT(1,sock);
fd = SCM_FPORT_FDES (sock);
tmp_size = scm_addr_buffer_size;
if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
scm_syserror (s_getsockname);
SCM_SYSERROR;
if (tmp_size > 0)
result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname);
result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
else
result = SCM_BOOL_F;
return result;
}
#undef FUNC_NAME
SCM_PROC (s_getpeername, "getpeername", 1, 0, 0, scm_getpeername);
SCM
scm_getpeername (sock)
SCM sock;
GUILE_PROC (scm_getpeername, "getpeername", 1, 0, 0,
(SCM sock),
"")
#define FUNC_NAME s_scm_getpeername
{
int tmp_size;
int fd;
SCM result;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername);
SCM_VALIDATE_OPFPORT(1,sock);
fd = SCM_FPORT_FDES (sock);
tmp_size = scm_addr_buffer_size;
if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
scm_syserror (s_getpeername);
SCM_SYSERROR;
if (tmp_size > 0)
result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getpeername);
result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
else
result = SCM_BOOL_F;
return result;
}
#undef FUNC_NAME
SCM_PROC (s_recv, "recv!", 2, 1, 0, scm_recv);
SCM
scm_recv (sock, buf, flags)
SCM sock;
SCM buf;
SCM flags;
GUILE_PROC (scm_recv, "recv!", 2, 1, 0,
(SCM sock, SCM buf, SCM flags),
"")
#define FUNC_NAME s_scm_recv
{
int rv;
int fd;
int flg;
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_recv);
SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_STRING(2,buf);
SCM_VALIDATE_INT_DEF_COPY(3,flags,0,flg);
fd = SCM_FPORT_FDES (sock);
if (SCM_UNBNDP (flags))
flg = 0;
else
flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recv);
SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg));
if (rv == -1)
scm_syserror (s_recv);
SCM_SYSERROR;
return SCM_MAKINUM (rv);
}
#undef FUNC_NAME
SCM_PROC (s_send, "send", 2, 1, 0, scm_send);
SCM
scm_send (sock, message, flags)
SCM sock;
SCM message;
SCM flags;
GUILE_PROC (scm_send, "send", 2, 1, 0,
(SCM sock, SCM message, SCM flags),
"")
#define FUNC_NAME s_scm_send
{
int rv;
int fd;
int flg;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_send);
SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_ROSTRING(2,message);
SCM_VALIDATE_INT_DEF_COPY(3,flags,0,flg);
fd = SCM_FPORT_FDES (sock);
if (SCM_UNBNDP (flags))
flg = 0;
else
flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_send);
SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg));
if (rv == -1)
scm_syserror (s_send);
SCM_SYSERROR;
return SCM_MAKINUM (rv);
}
#undef FUNC_NAME
SCM_PROC (s_recvfrom, "recvfrom!", 2, 3, 0, scm_recvfrom);
SCM
scm_recvfrom (sock, buf, flags, start, end)
SCM sock;
SCM buf;
SCM flags;
SCM start;
SCM end;
GUILE_PROC (scm_recvfrom, "recvfrom!", 2, 3, 0,
(SCM sock, SCM buf, SCM flags, SCM start, SCM end),
"")
#define FUNC_NAME s_scm_recvfrom
{
int rv;
int fd;
@ -680,32 +632,29 @@ scm_recvfrom (sock, buf, flags, start, end)
int tmp_size;
SCM address;
SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
s_recvfrom);
SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recvfrom);
SCM_VALIDATE_OPFPORT(1,sock);
SCM_VALIDATE_STRING(2,buf);
cend = SCM_LENGTH (buf);
if (SCM_UNBNDP (flags))
flg = 0;
else
{
flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recvfrom);
flg = SCM_NUM2ULONG (3,flags);
if (!SCM_UNBNDP (start))
{
offset = (int) scm_num2long (start,
(char *) SCM_ARG4, s_recvfrom);
offset = (int) SCM_NUM2LONG (4,start);
if (offset < 0 || offset >= cend)
scm_out_of_range (s_recvfrom, start);
SCM_OUT_OF_RANGE (4, start);
if (!SCM_UNBNDP (end))
{
int tend = (int) scm_num2long (end,
(char *) SCM_ARG5, s_recvfrom);
int tend = (int) SCM_NUM2LONG (5,end);
if (tend <= offset || tend > cend)
scm_out_of_range (s_recvfrom, end);
SCM_OUT_OF_RANGE (5, end);
cend = tend;
}
@ -720,24 +669,20 @@ scm_recvfrom (sock, buf, flags, start, end)
(struct sockaddr *) scm_addr_buffer,
&tmp_size));
if (rv == -1)
scm_syserror (s_recvfrom);
SCM_SYSERROR;
if (tmp_size > 0)
address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_recvfrom);
address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
else
address = SCM_BOOL_F;
return scm_cons (SCM_MAKINUM (rv), address);
}
#undef FUNC_NAME
SCM_PROC (s_sendto, "sendto", 4, 0, 1, scm_sendto);
SCM
scm_sendto (sock, message, fam, address, args_and_flags)
SCM sock;
SCM message;
SCM fam;
SCM address;
SCM args_and_flags;
GUILE_PROC (scm_sendto, "sendto", 4, 0, 1,
(SCM sock, SCM message, SCM fam, SCM address, SCM args_and_flags),
"")
#define FUNC_NAME s_scm_sendto
{
int rv;
int fd;
@ -747,20 +692,18 @@ scm_sendto (sock, message, fam, address, args_and_flags)
int save_err;
sock = SCM_COERCE_OUTPORT (sock);
SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto);
SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message,
SCM_ARG2, s_sendto);
SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto);
SCM_VALIDATE_FPORT(1,sock);
SCM_VALIDATE_ROSTRING(2,message);
SCM_VALIDATE_INT(3,fam);
fd = SCM_FPORT_FDES (sock);
soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
s_sendto, &size);
FUNC_NAME, &size);
if (SCM_NULLP (args_and_flags))
flg = 0;
else
{
SCM_ASSERT (SCM_NIMP (args_and_flags) && SCM_CONSP (args_and_flags),
args_and_flags, SCM_ARG5, s_sendto);
flg = scm_num2ulong (SCM_CAR (args_and_flags), (char *) SCM_ARG5, s_sendto);
SCM_VALIDATE_NIMCONS(5,args_and_flags);
flg = SCM_NUM2ULONG (5,SCM_CAR (args_and_flags));
}
SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message),
flg, soka, size));
@ -768,9 +711,10 @@ scm_sendto (sock, message, fam, address, args_and_flags)
scm_must_free ((char *) soka);
errno = save_err;
if (rv == -1)
scm_syserror (s_sendto);
SCM_SYSERROR;
return SCM_MAKINUM (rv);
}
#undef FUNC_NAME

208
libguile/sort.c
View file

@ -38,6 +38,10 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* Written in December 1998 by Roland Orre <orre@nada.kth.se>
* This implements the same sort interface as slib/sort.scm
* for lists and vectors where slib defines:
@ -82,6 +86,7 @@ char *alloca ();
#include "alist.h"
#include "feature.h"
#include "scm_validate.h"
#include "sort.h"
/* The routine quicksort was extracted from the GNU C Library qsort.c
@ -404,20 +409,22 @@ scm_cmp_function (SCM p)
}
} /* scm_cmp_function */
SCM_PROC (s_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, scm_restricted_vector_sort_x);
/* Question: Is there any need to make this a more general array sort?
It is probably enough to manage the vector type. */
/* endpos equal as for substring, i.e. endpos is not included. */
/* More natural wih length? */
SCM
scm_restricted_vector_sort_x (SCM vec, SCM less, SCM startpos, SCM endpos)
GUILE_PROC (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
"")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
size_t vlen, spos, len, size = sizeof (SCM);
SCM *vp;
SCM_ASSERT (SCM_NIMP (vec), vec, SCM_ARG1, s_restricted_vector_sort_x);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_restricted_vector_sort_x);
SCM_VALIDATE_NIMP(1,vec);
SCM_VALIDATE_NIMP(2,less);
switch (SCM_TYP7 (vec))
{
case scm_tc7_vector: /* the only type we manage is vector */
@ -429,33 +436,30 @@ scm_restricted_vector_sort_x (SCM vec, SCM less, SCM startpos, SCM endpos)
case scm_tc7_dvect: /* double */
#endif
default:
scm_wta (vec, (char *) SCM_ARG1, s_restricted_vector_sort_x);
SCM_WTA (1,vec);
}
vp = SCM_VELTS (vec); /* vector pointer */
vlen = SCM_LENGTH (vec);
SCM_ASSERT (SCM_INUMP(startpos),
startpos, SCM_ARG3, s_restricted_vector_sort_x);
spos = SCM_INUM (startpos);
SCM_ASSERT ((spos >= 0) && (spos <= vlen),
startpos, SCM_ARG3, s_restricted_vector_sort_x);
SCM_ASSERT ((SCM_INUMP (endpos)) && (SCM_INUM (endpos) <= vlen),
endpos, SCM_ARG4, s_restricted_vector_sort_x);
SCM_VALIDATE_INT_COPY(3,startpos,spos);
SCM_ASSERT_RANGE (3,startpos,(spos >= 0) && (spos <= vlen));
SCM_VALIDATE_INT_RANGE(4,endpos,0,vlen+1);
len = SCM_INUM (endpos) - spos;
quicksort (&vp[spos], len, size, scm_cmp_function (less), less);
return SCM_UNSPECIFIED;
/* return vec; */
} /* scm_restricted_vector_sort_x */
}
#undef FUNC_NAME
/* (sorted? sequence less?)
* is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
* such that for all 1 <= i <= m,
* (not (less? (list-ref list i) (list-ref list (- i 1)))). */
SCM_PROC (s_sorted_p, "sorted?", 2, 0, 0, scm_sorted_p);
SCM
scm_sorted_p (SCM items, SCM less)
GUILE_PROC (scm_sorted_p, "sorted?", 2, 0, 0,
(SCM items, SCM less),
"")
#define FUNC_NAME s_scm_sorted_p
{
long len, j; /* list/vector length, temp j */
SCM item, rest; /* rest of items loop variable */
@ -464,13 +468,14 @@ scm_sorted_p (SCM items, SCM less)
if (SCM_NULLP (items))
return SCM_BOOL_T;
SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_sorted_p);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sorted_p);
SCM_VALIDATE_NIMP(1,items);
SCM_VALIDATE_NIMP(2,less);
if (SCM_CONSP (items))
{
len = scm_ilength (items); /* also checks that it's a pure list */
SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sorted_p);
SCM_ASSERT_RANGE (1,items,len >= 0);
if (len <= 1)
return SCM_BOOL_T;
@ -519,26 +524,27 @@ scm_sorted_p (SCM items, SCM less)
case scm_tc7_dvect: /* double */
#endif
default:
scm_wta (items, (char *) SCM_ARG1, s_sorted_p);
SCM_WTA (1,items);
}
}
return SCM_BOOL_F;
} /* scm_sorted_p */
}
#undef FUNC_NAME
/* (merge a b less?)
takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
and returns a new list in which the elements of a and b have been stably
interleaved so that (sorted? (merge a b less?) less?).
Note: this does _not_ accept vectors. */
SCM_PROC (s_merge, "merge", 3, 0, 0, scm_merge);
SCM
scm_merge (SCM alist, SCM blist, SCM less)
GUILE_PROC (scm_merge, "merge", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"")
#define FUNC_NAME s_scm_merge
{
long alen, blen; /* list lengths */
SCM build, last;
cmp_fun_t cmp = scm_cmp_function (less);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_merge);
SCM_VALIDATE_NIMP(3,less);
if (SCM_NULLP (alist))
return blist;
@ -546,10 +552,8 @@ scm_merge (SCM alist, SCM blist, SCM less)
return alist;
else
{
alen = scm_ilength (alist); /* checks that it's a pure list */
blen = scm_ilength (blist); /* checks that it's a pure list */
SCM_ASSERT (alen > 0, alist, SCM_ARG1, s_merge);
SCM_ASSERT (blen > 0, blist, SCM_ARG2, s_merge);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN(1,alist,alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN(2,blist,blen);
if ((*cmp) (less, &SCM_CAR (blist), &SCM_CAR (alist)))
{
build = scm_cons (SCM_CAR (blist), SCM_EOL);
@ -585,7 +589,9 @@ scm_merge (SCM alist, SCM blist, SCM less)
SCM_SETCDR (last, blist);
}
return build;
} /* scm_merge */
}
#undef FUNC_NAME
static SCM
scm_merge_list_x (SCM alist, SCM blist,
@ -637,30 +643,29 @@ scm_merge_list_x (SCM alist, SCM blist,
return build;
} /* scm_merge_list_x */
SCM_PROC (s_merge_x, "merge!", 3, 0, 0, scm_merge_x);
SCM
scm_merge_x (SCM alist, SCM blist, SCM less)
GUILE_PROC (scm_merge_x, "merge!", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"")
#define FUNC_NAME s_scm_merge_x
{
long alen, blen; /* list lengths */
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_merge_x);
SCM_VALIDATE_NIMP(3,less);
if (SCM_NULLP (alist))
return blist;
else if (SCM_NULLP (blist))
return alist;
else
{
alen = scm_ilength (alist); /* checks that it's a pure list */
blen = scm_ilength (blist); /* checks that it's a pure list */
SCM_ASSERT (alen >= 0, alist, SCM_ARG1, s_merge);
SCM_ASSERT (blen >= 0, blist, SCM_ARG2, s_merge);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN(1,alist,alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN(2,blist,blen);
return scm_merge_list_x (alist, blist,
alen, blen,
scm_cmp_function (less),
less);
}
} /* scm_merge_x */
}
#undef FUNC_NAME
/* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
The algorithm is stable. We also tried to use the algorithm used by
@ -709,22 +714,21 @@ scm_merge_list_step (SCM * seq,
} /* scm_merge_list_step */
SCM_PROC (s_sort_x, "sort!", 2, 0, 0, scm_sort_x);
/* scm_sort_x manages lists and vectors, not stable sort */
SCM
scm_sort_x (SCM items, SCM less)
GUILE_PROC (scm_sort_x, "sort!", 2, 0, 0,
(SCM items, SCM less),
"")
#define FUNC_NAME s_scm_sort_x
{
long len; /* list/vector length */
if (SCM_NULLP(items))
return SCM_EOL;
SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_sort_x);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort_x);
SCM_VALIDATE_NIMP(1,items);
SCM_VALIDATE_NIMP(2,less);
if (SCM_CONSP (items))
{
len = scm_ilength (items);
SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_x);
SCM_VALIDATE_LIST_COPYLEN(1,items,len);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
else if (SCM_VECTORP (items))
@ -737,25 +741,26 @@ scm_sort_x (SCM items, SCM less)
return items;
}
else
return scm_wta (items, (char *) SCM_ARG1, s_sort_x);
} /* scm_sort_x */
SCM_PROC (s_sort, "sort", 2, 0, 0, scm_sort);
RETURN_SCM_WTA (1,items);
}
#undef FUNC_NAME /* scm_sort_x */
/* scm_sort manages lists and vectors, not stable sort */
SCM
scm_sort (SCM items, SCM less)
GUILE_PROC (scm_sort, "sort", 2, 0, 0,
(SCM items, SCM less),
"")
#define FUNC_NAME s_scm_sort
{
SCM sortvec; /* the vector we actually sort */
long len; /* list/vector length */
if (SCM_NULLP(items))
return SCM_EOL;
SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_sort);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort);
SCM_VALIDATE_NIMP(1,items);
SCM_VALIDATE_NIMP(2,less);
if (SCM_CONSP (items))
{
len = scm_ilength (items);
SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort);
SCM_VALIDATE_LIST_COPYLEN(1,items,len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
@ -774,8 +779,9 @@ scm_sort (SCM items, SCM less)
}
#endif
else
return scm_wta (items, (char *) SCM_ARG1, s_sort_x);
} /* scm_sort */
RETURN_SCM_WTA (1,items);
}
#undef FUNC_NAME /* scm_sort */
static void
scm_merge_vector_x (void *const vecbase,
@ -830,22 +836,22 @@ scm_merge_vector_step (void *const vp,
} /* scm_merge_vector_step */
SCM_PROC (s_stable_sort_x, "stable-sort!", 2, 0, 0, scm_stable_sort_x);
/* stable-sort! manages lists and vectors */
SCM
scm_stable_sort_x (SCM items, SCM less)
GUILE_PROC (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
(SCM items, SCM less),
"")
#define FUNC_NAME s_scm_stable_sort_x
{
long len; /* list/vector length */
if (SCM_NULLP (items))
return SCM_EOL;
SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_stable_sort_x);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_stable_sort_x);
SCM_VALIDATE_NIMP(1,items);
SCM_VALIDATE_NIMP(2,less);
if (SCM_CONSP (items))
{
len = scm_ilength (items);
SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_x);
SCM_VALIDATE_LIST_COPYLEN(1,items,len);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
else if (SCM_VECTORP (items))
@ -864,24 +870,25 @@ scm_stable_sort_x (SCM items, SCM less)
return items;
}
else
return scm_wta (items, (char *) SCM_ARG1, s_stable_sort_x);
} /* scm_stable_sort_x */
SCM_PROC (s_stable_sort, "stable-sort", 2, 0, 0, scm_stable_sort);
RETURN_SCM_WTA (1,items);
}
#undef FUNC_NAME /* scm_stable_sort_x */
/* stable_sort manages lists and vectors */
SCM
scm_stable_sort (SCM items, SCM less)
GUILE_PROC (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less),
"")
#define FUNC_NAME s_scm_stable_sort
{
long len; /* list/vector length */
if (SCM_NULLP (items))
return SCM_EOL;
SCM_ASSERT (SCM_NIMP (items), items, SCM_ARG1, s_stable_sort);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_stable_sort);
SCM_VALIDATE_NIMP(1,items);
SCM_VALIDATE_NIMP(2,less);
if (SCM_CONSP (items))
{
len = scm_ilength (items);
SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort);
SCM_VALIDATE_LIST_COPYLEN(1,items,len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
@ -907,31 +914,36 @@ scm_stable_sort (SCM items, SCM less)
}
#endif
else
return scm_wta (items, (char *) SCM_ARG1, s_stable_sort);
} /* scm_stable_sort */
RETURN_SCM_WTA (1,items);
}
#undef FUNC_NAME /* scm_stable_sort */
SCM_PROC (s_sort_list_x, "sort-list!", 2, 0, 0, scm_sort_list_x);
SCM /* stable */
scm_sort_list_x (SCM items, SCM less)
/* stable */
GUILE_PROC (scm_sort_list_x, "sort-list!", 2, 0, 0,
(SCM items, SCM less),
"")
#define FUNC_NAME s_scm_sort_list_x
{
long len = scm_ilength (items);
SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_list_x);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort_list_x);
long len;
SCM_VALIDATE_LIST_COPYLEN(1,items,len);
SCM_VALIDATE_NIMP(2,less);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
} /* scm_sort_list_x */
}
#undef FUNC_NAME /* scm_sort_list_x */
SCM_PROC (s_sort_list, "sort-list", 2, 0, 0, scm_sort_list);
SCM /* stable */
scm_sort_list (SCM items, SCM less)
/* stable */
GUILE_PROC (scm_sort_list, "sort-list", 2, 0, 0,
(SCM items, SCM less),
"")
#define FUNC_NAME s_scm_sort_list
{
long len = scm_ilength (items);
SCM_ASSERT (len >= 0, items, SCM_ARG1, s_sort_list);
SCM_ASSERT (SCM_NIMP (less), less, SCM_ARG2, s_sort_list);
long len;
SCM_VALIDATE_LIST_COPYLEN(1,items,len);
SCM_VALIDATE_NIMP(2,less);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
} /* scm_sort_list_x */
}
#undef FUNC_NAME /* scm_sort_list_x */
void
scm_init_sort ()

98
libguile/srcprop.c
View file

@ -41,6 +41,10 @@
*
* The author can be reached at djurfeldt@nada.kth.se
* Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -53,6 +57,7 @@
#include "hash.h"
#include "weaks.h"
#include "scm_validate.h"
#include "srcprop.h"
/* {Source Properties}
@ -81,11 +86,8 @@ static scm_srcprops_chunk *srcprops_chunklist = 0;
static scm_srcprops *srcprops_freelist = 0;
static SCM marksrcprops SCM_P ((SCM obj));
static SCM
marksrcprops (obj)
SCM obj;
marksrcprops (SCM obj)
{
scm_gc_mark (SRCPROPFNAME (obj));
scm_gc_mark (SRCPROPCOPY (obj));
@ -93,11 +95,8 @@ marksrcprops (obj)
}
static scm_sizet freesrcprops SCM_P ((SCM obj));
static scm_sizet
freesrcprops (obj)
SCM obj;
freesrcprops (SCM obj)
{
*((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist;
srcprops_freelist = (scm_srcprops *) SCM_CDR (obj);
@ -105,13 +104,8 @@ freesrcprops (obj)
}
static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
static int
prinsrcprops (obj, port, pstate)
SCM obj;
SCM port;
scm_print_state *pstate;
prinsrcprops (SCM obj,SCM port,scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<srcprops ", port);
@ -124,12 +118,7 @@ prinsrcprops (obj, port, pstate)
SCM
scm_make_srcprops (line, col, filename, copy, plist)
int line;
int col;
SCM filename;
SCM copy;
SCM plist;
scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist)
{
register scm_srcprops *ptr;
SCM_DEFER_INTS;
@ -161,8 +150,7 @@ scm_make_srcprops (line, col, filename, copy, plist)
SCM
scm_srcprops_to_plist (obj)
SCM obj;
scm_srcprops_to_plist (SCM obj)
{
SCM plist = SRCPROPPLIST (obj);
if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
@ -175,62 +163,59 @@ scm_srcprops_to_plist (obj)
return plist;
}
SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties);
SCM
scm_source_properties (obj)
SCM obj;
GUILE_PROC (scm_source_properties, "source-properties", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_source_properties
{
SCM p;
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties);
SCM_VALIDATE_NIMP(1,obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
#ifndef SCM_RECKLESS
else if (SCM_NCONSP (obj))
scm_wrong_type_arg (s_source_properties, 1, obj);
SCM_WRONG_TYPE_ARG (1, obj);
#endif
p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL);
if (p != (SCM) NULL && SRCPROPSP (p))
return scm_srcprops_to_plist (p);
return SCM_EOL;
}
#undef FUNC_NAME
/* Perhaps this procedure should look through an alist
and try to make a srcprops-object...? */
SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x);
SCM
scm_set_source_properties_x (obj, plist)
SCM obj;
SCM plist;
GUILE_PROC (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
(SCM obj, SCM plist),
"")
#define FUNC_NAME s_scm_set_source_properties_x
{
SCM handle;
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x);
SCM_VALIDATE_NIMP(1,obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
#ifndef SCM_RECKLESS
else if (SCM_NCONSP (obj))
scm_wrong_type_arg (s_set_source_properties_x, 1, obj);
SCM_WRONG_TYPE_ARG(1, obj);
#endif
handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
SCM_SETCDR (handle, plist);
return plist;
}
#undef FUNC_NAME
SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property);
SCM
scm_source_property (obj, key)
SCM obj;
SCM key;
GUILE_PROC (scm_source_property, "source-property", 2, 0, 0,
(SCM obj, SCM key),
"")
#define FUNC_NAME s_scm_source_property
{
SCM p;
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property);
SCM_VALIDATE_NIMP(1,obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
#ifndef SCM_RECKLESS
else if (SCM_NECONSP (obj))
scm_wrong_type_arg (s_source_property, 1, obj);
SCM_WRONG_TYPE_ARG (1, obj);
#endif
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (SCM_IMP (p) || !SRCPROPSP (p))
@ -249,23 +234,21 @@ scm_source_property (obj, key)
}
return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
}
#undef FUNC_NAME
SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x);
SCM
scm_set_source_property_x (obj, key, datum)
SCM obj;
SCM key;
SCM datum;
GUILE_PROC (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
(SCM obj, SCM key, SCM datum),
"")
#define FUNC_NAME s_scm_set_source_property_x
{
scm_whash_handle h;
SCM p;
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x);
SCM_VALIDATE_NIMP(1,obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
#ifndef SCM_RECKLESS
else if (SCM_NCONSP (obj))
scm_wrong_type_arg (s_set_source_property_x, 1, obj);
SCM_WRONG_TYPE_ARG (1, obj);
#endif
h = scm_whash_get_handle (scm_source_whash, obj);
if (SCM_WHASHFOUNDP (h))
@ -298,8 +281,7 @@ scm_set_source_property_x (obj, key, datum)
}
else if (scm_sym_line == key)
{
SCM_ASSERT (SCM_INUMP (datum),
datum, SCM_ARG3, s_set_source_property_x);
SCM_VALIDATE_INT(3,datum);
if (SCM_NIMP (p) && SRCPROPSP (p))
SETSRCPROPLINE (p, SCM_INUM (datum));
else
@ -309,8 +291,7 @@ scm_set_source_property_x (obj, key, datum)
}
else if (scm_sym_column == key)
{
SCM_ASSERT (SCM_INUMP (datum),
datum, SCM_ARG3, s_set_source_property_x);
SCM_VALIDATE_INT(3,datum);
if (SCM_NIMP (p) && SRCPROPSP (p))
SETSRCPROPCOL (p, SCM_INUM (datum));
else
@ -336,6 +317,7 @@ scm_set_source_property_x (obj, key, datum)
SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void

286
libguile/stacks.c
View file

@ -42,6 +42,10 @@
*
* The author can be reached at djurfeldt@nada.kth.se
* Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -54,6 +58,7 @@
#include "procprop.h"
#include "modules.h"
#include "scm_validate.h"
#include "stacks.h"
@ -146,13 +151,8 @@
* DFRAME. OFFSET is used for relocation of pointers when the stack
* is read from a continuation.
*/
static int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, SCM *id, int *maxp));
static int
stack_depth (dframe, offset, id, maxp)
scm_debug_frame *dframe;
long offset;
SCM *id;
int *maxp;
stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp)
{
int n, size;
int max_depth = SCM_BACKTRACE_MAXDEPTH;
@ -185,12 +185,8 @@ stack_depth (dframe, offset, id, maxp)
/* Read debug info from DFRAME into IFRAME.
*/
static void read_frame SCM_P ((scm_debug_frame *dframe, long offset, scm_info_frame *iframe));
static void
read_frame (dframe, offset, iframe)
scm_debug_frame *dframe;
long offset;
scm_info_frame *iframe;
read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe)
{
SCM flags = SCM_INUM0;
int size;
@ -259,13 +255,8 @@ get_applybody ()
* DFRAME.
*/
static int read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes));
static int
read_frames (dframe, offset, n, iframes)
scm_debug_frame *dframe;
long offset;
int n;
scm_info_frame *iframes;
read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes)
{
int size;
scm_info_frame *iframe = iframes;
@ -338,8 +329,6 @@ read_frames (dframe, offset, n, iframes)
return iframe - iframes; /* Number of frames actually read */
}
static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key));
/* Narrow STACK by cutting away stackframes (mutatingly).
*
* Inner frames (most recent) are cut by advancing the frames pointer.
@ -362,12 +351,7 @@ static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer,
*/
static void
narrow_stack (stack, inner, inner_key, outer, outer_key)
SCM stack;
int inner;
SCM inner_key;
int outer;
SCM outer_key;
narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key)
{
scm_stack *s = SCM_STACK (stack);
int i;
@ -426,18 +410,19 @@ narrow_stack (stack, inner, inner_key, outer, outer_key)
SCM scm_stack_type;
SCM_PROC (s_stack_p, "stack?", 1, 0, 0, scm_stack_p);
SCM
scm_stack_p (obj)
SCM obj;
GUILE_PROC (scm_stack_p, "stack?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_stack_p
{
return SCM_NIMP (obj) && SCM_STACKP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_NIMP (obj) && SCM_STACKP (obj));
}
#undef FUNC_NAME
SCM_PROC (s_make_stack, "make-stack", 0, 0, 1, scm_make_stack);
SCM
scm_make_stack (args)
SCM args;
GUILE_PROC (scm_make_stack, "make-stack", 0, 0, 1,
(SCM args),
"")
#define FUNC_NAME s_scm_make_stack
{
int n, maxp, size;
scm_debug_frame *dframe = scm_last_debug_frame;
@ -447,9 +432,7 @@ scm_make_stack (args)
SCM obj, inner_cut, outer_cut;
SCM_ASSERT (SCM_NIMP (args) && SCM_CONSP (args),
scm_makfrom0str (s_make_stack),
SCM_WNA,
NULL);
SCM_FUNC_NAME, SCM_WNA, NULL);
obj = SCM_CAR (args);
args = SCM_CDR (args);
@ -459,7 +442,7 @@ scm_make_stack (args)
(from initialization of dframe, above) if obj is #t */
if (obj != SCM_BOOL_T)
{
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_make_stack);
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME);
if (SCM_DEBUGOBJP (obj))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
else if (scm_tc7_contin == SCM_TYP7 (obj))
@ -473,7 +456,7 @@ scm_make_stack (args)
}
else
{
scm_wta (obj, (char *) SCM_ARG1, s_make_stack);
scm_wta (obj, (char *) SCM_ARG1, FUNC_NAME);
abort ();
}
}
@ -527,11 +510,12 @@ scm_make_stack (args)
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id);
SCM
scm_stack_id (stack)
SCM stack;
GUILE_PROC (scm_stack_id, "stack-id", 1, 0, 0,
(SCM stack),
"")
#define FUNC_NAME s_scm_stack_id
{
scm_debug_frame *dframe;
long offset = 0;
@ -539,7 +523,7 @@ scm_stack_id (stack)
dframe = scm_last_debug_frame;
else
{
SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack);
SCM_VALIDATE_NIMP(1,stack);
if (SCM_DEBUGOBJP (stack))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
else if (scm_tc7_contin == SCM_TYP7 (stack))
@ -554,7 +538,7 @@ scm_stack_id (stack)
else if (SCM_STACKP (stack))
return SCM_STACK (stack) -> id;
else
scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack);
SCM_WRONG_TYPE_ARG (1, stack);
}
while (dframe && !SCM_VOIDFRAMEP (*dframe))
dframe = RELOC_FRAME (dframe->prev, offset);
@ -562,61 +546,54 @@ scm_stack_id (stack)
return dframe->vect[0].id;
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref);
SCM
scm_stack_ref (stack, i)
SCM stack;
SCM i;
GUILE_PROC (scm_stack_ref, "stack-ref", 2, 0, 0,
(SCM stack, SCM i),
"")
#define FUNC_NAME s_scm_stack_ref
{
SCM_ASSERT (SCM_NIMP (stack)
&& SCM_STACKP (stack),
stack,
SCM_ARG1,
s_stack_ref);
SCM_ASSERT (SCM_INUMP (i), i, SCM_ARG2, s_stack_ref);
SCM_ASSERT (SCM_INUM (i) >= 0
&& SCM_INUM (i) < SCM_STACK_LENGTH (stack),
i,
SCM_OUTOFRANGE,
s_stack_ref);
SCM_VALIDATE_STACK(1,stack);
SCM_VALIDATE_INT(2,i);
SCM_ASSERT_RANGE (1,i,
SCM_INUM (i) >= 0 &&
SCM_INUM (i) < SCM_STACK_LENGTH (stack));
return scm_cons (stack, i);
}
#undef FUNC_NAME
SCM_PROC(s_stack_length, "stack-length", 1, 0, 0, scm_stack_length);
SCM
scm_stack_length (stack)
SCM stack;
GUILE_PROC(scm_stack_length, "stack-length", 1, 0, 0,
(SCM stack),
"")
#define FUNC_NAME s_scm_stack_length
{
SCM_ASSERT (SCM_NIMP (stack)
&& SCM_STACKP (stack),
stack,
SCM_ARG1,
s_stack_length);
SCM_VALIDATE_STACK(1,stack);
return SCM_MAKINUM (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME
/* Frames
*/
SCM_PROC (s_frame_p, "frame?", 1, 0, 0, scm_frame_p);
SCM
scm_frame_p (obj)
SCM obj;
GUILE_PROC (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_frame_p
{
return SCM_NIMP (obj) && SCM_FRAMEP (obj);
return SCM_BOOL(SCM_NIMP (obj) && SCM_FRAMEP (obj));
}
#undef FUNC_NAME
SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame);
SCM
scm_last_stack_frame (obj)
SCM obj;
GUILE_PROC(scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_last_stack_frame
{
scm_debug_frame *dframe;
long offset = 0;
SCM stack;
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
SCM_VALIDATE_NIMP(1,obj);
if (SCM_DEBUGOBJP (obj))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
else if (scm_tc7_contin == SCM_TYP7 (obj))
@ -630,7 +607,7 @@ scm_last_stack_frame (obj)
}
else
{
scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
SCM_WTA (1,obj);
abort ();
}
@ -646,138 +623,119 @@ scm_last_stack_frame (obj)
return scm_cons (stack, SCM_INUM0);;
}
#undef FUNC_NAME
SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number);
SCM
scm_frame_number (frame)
SCM frame;
GUILE_PROC(scm_frame_number, "frame-number", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_number
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_number);
SCM_VALIDATE_FRAME(1,frame);
return SCM_MAKINUM (SCM_FRAME_NUMBER (frame));
}
#undef FUNC_NAME
SCM_PROC(s_frame_source, "frame-source", 1, 0, 0, scm_frame_source);
SCM
scm_frame_source (frame)
SCM frame;
GUILE_PROC(scm_frame_source, "frame-source", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_source
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_source);
SCM_VALIDATE_FRAME(1,frame);
return SCM_FRAME_SOURCE (frame);
}
#undef FUNC_NAME
SCM_PROC(s_frame_procedure, "frame-procedure", 1, 0, 0, scm_frame_procedure);
SCM
scm_frame_procedure (frame)
SCM frame;
GUILE_PROC(scm_frame_procedure, "frame-procedure", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_procedure
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_procedure);
SCM_VALIDATE_FRAME(1,frame);
return (SCM_FRAME_PROC_P (frame)
? SCM_FRAME_PROC (frame)
: SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments);
SCM
scm_frame_arguments (frame)
SCM frame;
GUILE_PROC(scm_frame_arguments, "frame-arguments", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_arguments
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_arguments);
SCM_VALIDATE_FRAME(1,frame);
return SCM_FRAME_ARGS (frame);
}
#undef FUNC_NAME
SCM_PROC(s_frame_previous, "frame-previous", 1, 0, 0, scm_frame_previous);
SCM
scm_frame_previous (frame)
SCM frame;
GUILE_PROC(scm_frame_previous, "frame-previous", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_previous
{
int n;
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_previous);
SCM_VALIDATE_FRAME(1,frame);
n = SCM_INUM (SCM_CDR (frame)) + 1;
if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
return SCM_BOOL_F;
else
return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
}
#undef FUNC_NAME
SCM_PROC(s_frame_next, "frame-next", 1, 0, 0, scm_frame_next);
SCM
scm_frame_next (frame)
SCM frame;
GUILE_PROC(scm_frame_next, "frame-next", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_next
{
int n;
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_next);
SCM_VALIDATE_FRAME(1,frame);
n = SCM_INUM (SCM_CDR (frame)) - 1;
if (n < 0)
return SCM_BOOL_F;
else
return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
}
#undef FUNC_NAME
SCM_PROC(s_frame_real_p, "frame-real?", 1, 0, 0, scm_frame_real_p);
SCM
scm_frame_real_p (frame)
SCM frame;
GUILE_PROC(scm_frame_real_p, "frame-real?", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_real_p
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_real_p);
return SCM_FRAME_REAL_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_FRAME(1,frame);
return SCM_BOOL(SCM_FRAME_REAL_P (frame));
}
#undef FUNC_NAME
SCM_PROC(s_frame_procedure_p, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p);
SCM
scm_frame_procedure_p (frame)
SCM frame;
GUILE_PROC(scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_procedure_p
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_procedure_p);
return SCM_FRAME_PROC_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_FRAME(1,frame);
return SCM_BOOL(SCM_FRAME_PROC_P (frame));
}
#undef FUNC_NAME
SCM_PROC(s_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p);
SCM
scm_frame_evaluating_args_p (frame)
SCM frame;
GUILE_PROC(scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_evaluating_args_p
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_evaluating_args_p);
return SCM_FRAME_EVAL_ARGS_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_VALIDATE_FRAME(1,frame);
return SCM_BOOL(SCM_FRAME_EVAL_ARGS_P (frame));
}
#undef FUNC_NAME
SCM_PROC(s_frame_overflow_p, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p);
SCM
scm_frame_overflow_p (frame)
SCM frame;
GUILE_PROC(scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_overflow_p
{
SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
frame,
SCM_ARG1,
s_frame_overflow_p);
SCM_VALIDATE_FRAME(1,frame);
return SCM_FRAME_OVERFLOW_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME

169
libguile/stime.c
View file

@ -38,12 +38,17 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "feature.h"
#include "scm_validate.h"
#include "stime.h"
#ifdef HAVE_UNISTD_H
@ -123,9 +128,11 @@ extern int errno;
#ifdef HAVE_FTIME
struct timeb scm_your_base = {0};
SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
SCM
scm_get_internal_real_time()
GUILE_PROC(scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_get_internal_real_time
{
struct timeb time_buffer;
@ -138,22 +145,29 @@ scm_get_internal_real_time()
SCM_MAKINUM (time_buffer.time)));
return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
SCM_MAKINUM (1000));
};
}
#undef FUNC_NAME
#else
timet scm_your_base = 0;
SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
SCM
scm_get_internal_real_time()
GUILE_PROC(scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_get_internal_real_time
{
return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
}
#undef FUNC_NAME
#endif
SCM_PROC (s_times, "times", 0, 0, 0, scm_times);
SCM
scm_times (void)
GUILE_PROC (scm_times, "times", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_times
{
#ifdef HAVE_TIMES
struct tms t;
@ -162,7 +176,7 @@ scm_times (void)
SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED);
rv = times (&t);
if (rv == -1)
scm_syserror (s_times);
SCM_SYSERROR;
SCM_VELTS (result)[0] = scm_long2num (rv);
SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
@ -170,9 +184,10 @@ scm_times (void)
SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime);
return result;
#else
scm_sysmissing (s_times);
SCM_SYSMISSING;
#endif
}
#undef FUNC_NAME
#ifndef HAVE_TZSET
/* GNU-WIN32's cygwin.dll doesn't have this. */
@ -182,36 +197,41 @@ scm_times (void)
static long scm_my_base = 0;
SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time);
SCM
scm_get_internal_run_time()
GUILE_PROC(scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_get_internal_run_time
{
return scm_long2num(mytime()-scm_my_base);
}
#undef FUNC_NAME
SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time);
SCM
scm_current_time()
GUILE_PROC(scm_current_time, "current-time", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_current_time
{
timet timv;
SCM_DEFER_INTS;
if ((timv = time (0)) == -1)
scm_syserror (s_current_time);
SCM_SYSERROR;
SCM_ALLOW_INTS;
return scm_long2num((long) timv);
}
#undef FUNC_NAME
SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday);
SCM
scm_gettimeofday (void)
GUILE_PROC (scm_gettimeofday, "gettimeofday", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_gettimeofday
{
#ifdef HAVE_GETTIMEOFDAY
struct timeval time;
SCM_DEFER_INTS;
if (gettimeofday (&time, NULL) == -1)
scm_syserror (s_gettimeofday);
SCM_SYSERROR;
SCM_ALLOW_INTS;
return scm_cons (scm_long2num ((long) time.tv_sec),
scm_long2num ((long) time.tv_usec));
@ -227,12 +247,13 @@ scm_gettimeofday (void)
SCM_DEFER_INTS;
if ((timv = time (0)) == -1)
scm_syserror (s_gettimeofday);
SCM_SYSERROR;
SCM_ALLOW_INTS;
return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
# endif
#endif
}
#undef FUNC_NAME
static SCM
filltime (struct tm *bd_time, int zoff, char *zname)
@ -293,9 +314,10 @@ restorezone (SCM zone, char **oldenv, const char *subr)
}
SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime);
SCM
scm_localtime (SCM time, SCM zone)
GUILE_PROC (scm_localtime, "localtime", 1, 1, 0,
(SCM time, SCM zone),
"")
#define FUNC_NAME s_scm_localtime
{
timet itime;
struct tm *ltptr, lt, *utc;
@ -305,9 +327,9 @@ scm_localtime (SCM time, SCM zone)
char **oldenv;
int err;
itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime);
itime = SCM_NUM2LONG (1,time);
SCM_DEFER_INTS;
oldenv = setzone (zone, SCM_ARG2, s_localtime);
oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
ltptr = localtime (&itime);
err = errno;
if (ltptr)
@ -321,11 +343,10 @@ scm_localtime (SCM time, SCM zone)
# ifdef HAVE_TZNAME
ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
# else
scm_misc_error (s_localtime, "Not fully implemented on this platform",
SCM_EOL);
SCM_MISC_ERROR ("Not fully implemented on this platform",_EOL);
# endif
#endif
zname = scm_must_malloc (strlen (ptr) + 1, s_localtime);
zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
strcpy (zname, ptr);
}
/* the struct is copied in case localtime and gmtime share a buffer. */
@ -334,11 +355,11 @@ scm_localtime (SCM time, SCM zone)
utc = gmtime (&itime);
if (utc == NULL)
err = errno;
restorezone (zone, oldenv, s_localtime);
restorezone (zone, oldenv, FUNC_NAME);
/* delayed until zone has been restored. */
errno = err;
if (utc == NULL || ltptr == NULL)
scm_syserror (s_localtime);
SCM_SYSERROR;
/* calculate timezone offset in seconds west of UTC. */
zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
@ -357,24 +378,27 @@ scm_localtime (SCM time, SCM zone)
scm_must_free (zname);
return result;
}
#undef FUNC_NAME
SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime);
SCM
scm_gmtime (SCM time)
GUILE_PROC (scm_gmtime, "gmtime", 1, 0, 0,
(SCM time),
"")
#define FUNC_NAME s_scm_gmtime
{
timet itime;
struct tm *bd_time;
SCM result;
itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime);
itime = SCM_NUM2LONG (1,time);
SCM_DEFER_INTS;
bd_time = gmtime (&itime);
if (bd_time == NULL)
scm_syserror (s_gmtime);
SCM_SYSERROR;
result = filltime (bd_time, 0, "GMT");
SCM_ALLOW_INTS;
return result;
}
#undef FUNC_NAME
/* copy time components from a Scheme object to a struct tm. */
static void
@ -413,9 +437,10 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
#endif
}
SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime);
SCM
scm_mktime (SCM sbd_time, SCM zone)
GUILE_PROC (scm_mktime, "mktime", 1, 1, 0,
(SCM sbd_time, SCM zone),
"")
#define FUNC_NAME s_scm_mktime
{
timet itime;
struct tm lt, *utc;
@ -425,10 +450,10 @@ scm_mktime (SCM sbd_time, SCM zone)
char **oldenv;
int err;
bdtime2c (sbd_time, &lt, SCM_ARG1, s_mktime);
bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
SCM_DEFER_INTS;
oldenv = setzone (zone, SCM_ARG2, s_mktime);
oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
itime = mktime (&lt);
err = errno;
@ -447,7 +472,7 @@ scm_mktime (SCM sbd_time, SCM zone)
SCM_EOL);
# endif
#endif
zname = scm_must_malloc (strlen (ptr) + 1, s_mktime);
zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
strcpy (zname, ptr);
}
@ -456,11 +481,11 @@ scm_mktime (SCM sbd_time, SCM zone)
if (utc == NULL)
err = errno;
restorezone (zone, oldenv, s_mktime);
restorezone (zone, oldenv, FUNC_NAME);
/* delayed until zone has been restored. */
errno = err;
if (utc == NULL || itime == -1)
scm_syserror (s_mktime);
SCM_SYSERROR;
zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
+ utc->tm_sec - lt.tm_sec;
@ -479,21 +504,22 @@ scm_mktime (SCM sbd_time, SCM zone)
scm_must_free (zname);
return result;
}
#undef FUNC_NAME
SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
SCM
scm_tzset (void)
GUILE_PROC (scm_tzset, "tzset", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_tzset
{
tzset();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
SCM
scm_strftime (format, stime)
SCM format;
SCM stime;
GUILE_PROC (scm_strftime, "strftime", 2, 0, 0,
(SCM format, SCM stime),
"")
#define FUNC_NAME s_scm_strftime
{
struct tm t;
@ -503,41 +529,37 @@ scm_strftime (format, stime)
int len;
SCM result;
SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
s_strftime);
bdtime2c (stime, &t, SCM_ARG2, s_strftime);
SCM_VALIDATE_ROSTRING(1,format);
bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
SCM_COERCE_SUBSTR (format);
fmt = SCM_ROCHARS (format);
len = SCM_ROLENGTH (format);
tbuf = scm_must_malloc (size, s_strftime);
tbuf = SCM_MUST_MALLOC (size);
while ((len = strftime (tbuf, size, fmt, &t)) == size)
{
scm_must_free (tbuf);
size *= 2;
tbuf = scm_must_malloc (size, s_strftime);
tbuf = SCM_MUST_MALLOC (size);
}
result = scm_makfromstr (tbuf, len, 0);
scm_must_free (tbuf);
return result;
}
#undef FUNC_NAME
SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime);
SCM
scm_strptime (format, string)
SCM format;
SCM string;
GUILE_PROC (scm_strptime, "strptime", 2, 0, 0,
(SCM format, SCM string),
"")
#define FUNC_NAME s_scm_strptime
{
#ifdef HAVE_STRPTIME
struct tm t;
char *fmt, *str, *rest;
SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
s_strptime);
SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2,
s_strptime);
SCM_VALIDATE_ROSTRING(1,format);
SCM_VALIDATE_ROSTRING(2,string);
SCM_COERCE_SUBSTR (format);
SCM_COERCE_SUBSTR (string);
@ -559,15 +581,16 @@ scm_strptime (format, string)
t.tm_isdst = -1;
SCM_DEFER_INTS;
if ((rest = strptime (str, fmt, &t)) == NULL)
scm_syserror (s_strptime);
SCM_SYSERROR;
SCM_ALLOW_INTS;
return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str));
#else
scm_sysmissing (s_strptime);
SCM_SYSMISSING;
#endif
}
#undef FUNC_NAME
void
scm_init_stime()

214
libguile/strings.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -45,39 +49,41 @@
#include "chars.h"
#include "strings.h"
#include "scm_validate.h"
/* {Strings}
*/
SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p);
SCM
scm_string_p (x)
SCM x;
GUILE_PROC(scm_string_p, "string?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_string_p
{
if (SCM_IMP (x))
return SCM_BOOL_F;
return SCM_STRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_STRINGP (x));
}
#undef FUNC_NAME
SCM_PROC(s_read_only_string_p, "read-only-string?", 1, 0, 0, scm_read_only_string_p);
SCM
scm_read_only_string_p (x)
SCM x;
GUILE_PROC(scm_read_only_string_p, "read-only-string?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_read_only_string_p
{
if (SCM_IMP (x))
return SCM_BOOL_F;
return SCM_ROSTRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_ROSTRINGP (x));
}
#undef FUNC_NAME
SCM_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string);
SCM_PROC(s_string, "string", 0, 0, 1, scm_string);
SCM_REGISTER_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string);
SCM
scm_string (chrs)
SCM chrs;
GUILE_PROC(scm_string, "string", 0, 0, 1,
(SCM chrs),
"")
#define FUNC_NAME s_scm_string
{
SCM res;
register unsigned char *data;
@ -88,7 +94,7 @@ scm_string (chrs)
if (i < 0)
{
SCM_ALLOW_INTS;
SCM_ASSERT (0, chrs, SCM_ARG1, s_string);
SCM_ASSERT (0, chrs, SCM_ARG1, FUNC_NAME);
}
len = 0;
{
@ -102,7 +108,7 @@ scm_string (chrs)
else
{
SCM_ALLOW_INTS;
SCM_ASSERT (0, s, SCM_ARG1, s_string);
SCM_ASSERT (0, s, SCM_ARG1, FUNC_NAME);
}
}
res = scm_makstr (len, 0);
@ -127,12 +133,11 @@ scm_string (chrs)
SCM_ALLOW_INTS;
return res;
}
#undef FUNC_NAME
SCM
scm_makstr (len, slots)
long len;
int slots;
scm_makstr (long len, int slots)
{
SCM s;
SCM * mem;
@ -140,7 +145,7 @@ scm_makstr (len, slots)
--slots;
SCM_REDEFER_INTS;
mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1,
s_string);
"scm_makstr");
if (slots >= 0)
{
int x;
@ -159,9 +164,7 @@ scm_makstr (len, slots)
/* If argc < 0, a null terminated scm_array is assumed. */
SCM
scm_makfromstrs (argc, argv)
int argc;
char **argv;
scm_makfromstrs (int argc, char **argv)
{
int i = argc;
SCM lst = SCM_EOL;
@ -203,10 +206,7 @@ scm_take0str (char *s)
SCM
scm_makfromstr (src, len, slots)
const char *src;
scm_sizet len;
int slots;
scm_makfromstr (const char *src, scm_sizet len, int slots)
{
SCM s;
register char *dst;
@ -220,8 +220,7 @@ scm_makfromstr (src, len, slots)
SCM
scm_makfrom0str (src)
const char *src;
scm_makfrom0str (const char *src)
{
if (!src) return SCM_BOOL_F;
return scm_makfromstr (src, (scm_sizet) strlen (src), 0);
@ -229,8 +228,7 @@ scm_makfrom0str (src)
SCM
scm_makfrom0str_opt (src)
const char *src;
scm_makfrom0str_opt (const char *src)
{
return scm_makfrom0str (src);
}
@ -238,21 +236,18 @@ scm_makfrom0str_opt (src)
SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string);
SCM
scm_make_string (k, chr)
SCM k;
SCM chr;
GUILE_PROC(scm_make_string, "make-string", 1, 1, 0,
(SCM k, SCM chr),
"")
#define FUNC_NAME s_scm_make_string
{
SCM res;
register long i;
SCM_ASSERT (SCM_INUMP (k) && (k >= 0), k, SCM_ARG1, s_make_string);
i = SCM_INUM (k);
SCM_VALIDATE_INT_MIN_COPY(1,k,0,i);
res = scm_makstr (i, 0);
if (!SCM_UNBNDP (chr))
{
SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_make_string);
SCM_VALIDATE_CHAR(2,chr);
{
unsigned char *dst = SCM_UCHARS (res);
char c = SCM_ICHR (chr);
@ -262,96 +257,79 @@ scm_make_string (k, chr)
}
return res;
}
#undef FUNC_NAME
SCM_PROC(s_string_length, "string-length", 1, 0, 0, scm_string_length);
SCM
scm_string_length (str)
SCM str;
GUILE_PROC(scm_string_length, "string-length", 1, 0, 0,
(SCM str),
"")
#define FUNC_NAME s_scm_string_length
{
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_length);
SCM_VALIDATE_ROSTRING(1,str);
return SCM_MAKINUM (SCM_ROLENGTH (str));
}
#undef FUNC_NAME
SCM_PROC(s_string_ref, "string-ref", 1, 1, 0, scm_string_ref);
SCM
scm_string_ref (str, k)
SCM str;
SCM k;
GUILE_PROC(scm_string_ref, "string-ref", 1, 1, 0,
(SCM str, SCM k),
"")
#define FUNC_NAME s_scm_string_ref
{
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_ref);
if (k == SCM_UNDEFINED)
k = SCM_MAKINUM (0);
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_ref);
SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_ref);
SCM_VALIDATE_ROSTRING(1,str);
SCM_VALIDATE_INT_DEF(2,k,0);
SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, FUNC_NAME);
return SCM_MAKICHR (SCM_ROUCHARS (str)[SCM_INUM (k)]);
}
#undef FUNC_NAME
SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x);
SCM
scm_string_set_x (str, k, chr)
SCM str;
SCM k;
SCM chr;
GUILE_PROC(scm_string_set_x, "string-set!", 3, 0, 0,
(SCM str, SCM k, SCM chr),
"")
#define FUNC_NAME s_scm_string_set_x
{
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str),
str, SCM_ARG1, s_string_set_x);
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_set_x);
SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG3, s_string_set_x);
if (! SCM_RWSTRINGP (str))
scm_misc_error (s_string_set_x, "argument is a read-only string", str);
SCM_ASSERT ((SCM_INUM (k) >= 0
&& ((unsigned) SCM_INUM (k)) < SCM_LENGTH (str)),
k, SCM_OUTOFRANGE, s_string_set_x);
SCM_VALIDATE_RWSTRING(1,str);
SCM_VALIDATE_INT_RANGE(2,k,0,SCM_LENGTH(str));
SCM_VALIDATE_CHAR(3,chr);
SCM_UCHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring);
SCM
scm_substring (str, start, end)
SCM str;
SCM start;
SCM end;
GUILE_PROC(scm_substring, "substring", 2, 1, 0,
(SCM str, SCM start, SCM end),
"")
#define FUNC_NAME s_scm_substring
{
long l;
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str),
str, SCM_ARG1, s_substring);
SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring);
if (end == SCM_UNDEFINED)
end = SCM_MAKINUM (SCM_ROLENGTH (str));
SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring);
SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, s_substring);
SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, s_substring);
SCM_VALIDATE_ROSTRING(1,str);
SCM_VALIDATE_INT(2,start);
SCM_VALIDATE_INT_DEF(3,end,SCM_ROLENGTH(str));
SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, FUNC_NAME);
SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, FUNC_NAME);
l = SCM_INUM (end)-SCM_INUM (start);
SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, s_substring);
SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, FUNC_NAME);
return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0);
}
#undef FUNC_NAME
SCM_PROC(s_string_append, "string-append", 0, 0, 1, scm_string_append);
SCM
scm_string_append (args)
SCM args;
GUILE_PROC(scm_string_append, "string-append", 0, 0, 1,
(SCM args),
"")
#define FUNC_NAME s_scm_string_append
{
SCM res;
register long i = 0;
register SCM l, s;
register unsigned char *data;
for (l = args;SCM_NIMP (l);) {
SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, s_string_append);
SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, FUNC_NAME);
s = SCM_CAR (l);
SCM_ASSERT (SCM_NIMP (s) && SCM_ROSTRINGP (s),
s, SCM_ARGn, s_string_append);
SCM_VALIDATE_ROSTRING(SCM_ARGn,s);
i += SCM_ROLENGTH (s);
l = SCM_CDR (l);
}
SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, s_string_append);
SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, FUNC_NAME);
res = scm_makstr (i, 0);
data = SCM_UCHARS (res);
for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
@ -360,37 +338,25 @@ scm_string_append (args)
}
return res;
}
#undef FUNC_NAME
SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring);
SCM
scm_make_shared_substring (str, frm, to)
SCM str;
SCM frm;
SCM to;
GUILE_PROC(scm_make_shared_substring, "make-shared-substring", 1, 2, 0,
(SCM str, SCM frm, SCM to),
"")
#define FUNC_NAME s_scm_make_shared_substring
{
long f;
long t;
SCM answer;
SCM len_str;
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_make_shared_substring);
SCM_VALIDATE_ROSTRING(1,str);
SCM_VALIDATE_INT_DEF_COPY(2,frm,0,f);
SCM_VALIDATE_INT_DEF_COPY(3,to,0,t);
if (frm == SCM_UNDEFINED)
frm = SCM_MAKINUM (0);
else
SCM_ASSERT (SCM_INUMP (frm), frm, SCM_ARG2, s_make_shared_substring);
if (to == SCM_UNDEFINED)
to = SCM_MAKINUM (SCM_ROLENGTH (str));
else
SCM_ASSERT (SCM_INUMP (to), to, SCM_ARG3, s_make_shared_substring);
f = SCM_INUM (frm);
t = SCM_INUM (to);
SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, s_make_shared_substring);
SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, FUNC_NAME);
SCM_ASSERT ((f <= t) && (t <= SCM_ROLENGTH (str)), to, SCM_OUTOFRANGE,
s_make_shared_substring);
FUNC_NAME);
SCM_NEWCELL (answer);
SCM_NEWCELL (len_str);
@ -417,7 +383,7 @@ scm_make_shared_substring (str, frm, to)
SCM_ALLOW_INTS;
return answer;
}
#undef FUNC_NAME
void
scm_init_strings ()

230
libguile/strop.c
View file

@ -17,12 +17,17 @@ along with this software; see the file COPYING. If not, write to the
Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "chars.h"
#include "scm_validate.h"
#include "strop.h"
#include "read.h" /*For SCM_CASE_INSENSITIVE_P*/
@ -32,7 +37,6 @@ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
static int
scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start,
SCM sub_end, const char *why)
{
unsigned char * p;
int x;
@ -82,10 +86,10 @@ scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start,
return -1;
}
SCM_PROC(s_string_index, "string-index", 2, 2, 0, scm_string_index);
SCM
scm_string_index (SCM str, SCM chr, SCM frm, SCM to)
GUILE_PROC(scm_string_index, "string-index", 2, 2, 0,
(SCM str, SCM chr, SCM frm, SCM to),
"")
#define FUNC_NAME s_scm_string_index
{
int pos;
@ -93,16 +97,17 @@ scm_string_index (SCM str, SCM chr, SCM frm, SCM to)
frm = SCM_BOOL_F;
if (to == SCM_UNDEFINED)
to = SCM_BOOL_F;
pos = scm_i_index (&str, chr, 1, frm, to, s_string_index);
pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME);
return (pos < 0
? SCM_BOOL_F
: SCM_MAKINUM (pos));
}
#undef FUNC_NAME
SCM_PROC(s_string_rindex, "string-rindex", 2, 2, 0, scm_string_rindex);
SCM
scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to)
GUILE_PROC(scm_string_rindex, "string-rindex", 2, 2, 0,
(SCM str, SCM chr, SCM frm, SCM to),
"")
#define FUNC_NAME s_scm_string_rindex
{
int pos;
@ -110,43 +115,36 @@ scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to)
frm = SCM_BOOL_F;
if (to == SCM_UNDEFINED)
to = SCM_BOOL_F;
pos = scm_i_index (&str, chr, -1, frm, to, s_string_rindex);
pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME);
return (pos < 0
? SCM_BOOL_F
: SCM_MAKINUM (pos));
}
#undef FUNC_NAME
SCM_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
SCM_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
SCM_PROC(s_substring_move_x, "substring-move!", 5, 0, 0, scm_substring_move_x);
SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
SCM
scm_substring_move_x (SCM str1, SCM start1, SCM end1,
SCM str2, SCM start2)
GUILE_PROC(scm_substring_move_x, "substring-move!", 5, 0, 0,
(SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
"")
#define FUNC_NAME s_scm_substring_move_x
{
long s1, s2, e, len;
SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1,
SCM_ARG1, s_substring_move_x);
SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_x);
SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_x);
SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2,
SCM_ARG4, s_substring_move_x);
SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_x);
s1 = SCM_INUM (start1), s2 = SCM_INUM (start2), e = SCM_INUM (end1);
SCM_VALIDATE_STRING(1,str1);
SCM_VALIDATE_INT_COPY(2,start1,s1);
SCM_VALIDATE_INT_COPY(3,end1,e);
SCM_VALIDATE_STRING(4,str2);
SCM_VALIDATE_INT_COPY(5,start2,s2);
len = e - s1;
SCM_ASSERT (len >= 0, end1, SCM_OUTOFRANGE, s_substring_move_x);
SCM_ASSERT (s1 <= SCM_LENGTH (str1) && s1 >= 0, start1,
SCM_OUTOFRANGE, s_substring_move_x);
SCM_ASSERT (s2 <= SCM_LENGTH (str2) && s2 >= 0, start2,
SCM_OUTOFRANGE, s_substring_move_x);
SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1,
SCM_OUTOFRANGE, s_substring_move_x);
SCM_ASSERT (len+s2 <= SCM_LENGTH (str2), start2,
SCM_OUTOFRANGE, s_substring_move_x);
SCM_ASSERT_RANGE (3,end1,len >= 0);
SCM_ASSERT_RANGE (2,start1,s1 <= SCM_LENGTH (str1) && s1 >= 0);
SCM_ASSERT_RANGE (5,start2,s2 <= SCM_LENGTH (str2) && s2 >= 0);
SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0);
SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2));
SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])),
(void *)(&(SCM_CHARS(str1)[s1])),
@ -154,94 +152,85 @@ scm_substring_move_x (SCM str1, SCM start1, SCM end1,
return scm_return_first(SCM_UNSPECIFIED, str1, str2);
}
#undef FUNC_NAME
SCM_PROC(s_substring_fill_x, "substring-fill!", 4, 0, 0, scm_substring_fill_x);
SCM
scm_substring_fill_x (SCM str, SCM start, SCM end, SCM fill)
GUILE_PROC(scm_substring_fill_x, "substring-fill!", 4, 0, 0,
(SCM str, SCM start, SCM end, SCM fill),
"")
#define FUNC_NAME s_scm_substring_fill_x
{
long i, e;
char c;
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x);
SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring_fill_x);
SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring_fill_x);
SCM_ASSERT (SCM_ICHRP (fill), fill, SCM_ARG4, s_substring_fill_x);
i = SCM_INUM (start), e = SCM_INUM (end);c = SCM_ICHR (fill);
SCM_ASSERT (i <= SCM_LENGTH (str) && i >= 0, start,
SCM_OUTOFRANGE, s_substring_fill_x);
SCM_ASSERT (e <= SCM_LENGTH (str) && e >= 0, end,
SCM_OUTOFRANGE, s_substring_fill_x);
SCM_VALIDATE_STRING(1,str);
SCM_VALIDATE_INT_COPY(2,start,i);
SCM_VALIDATE_INT_COPY(3,end,e);
SCM_VALIDATE_CHAR_COPY(4,fill,c);
SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0);
SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0);
while (i<e) SCM_CHARS (str)[i++] = c;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_string_null_p, "string-null?", 1, 0, 0, scm_string_null_p);
SCM
scm_string_null_p (str)
SCM str;
GUILE_PROC(scm_string_null_p, "string-null?", 1, 0, 0,
(SCM str),
"")
#define FUNC_NAME s_scm_string_null_p
{
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_null_p);
return (SCM_ROLENGTH (str)
? SCM_BOOL_F
: SCM_BOOL_T);
SCM_VALIDATE_ROSTRING(1,str);
return SCM_NEGATE_BOOL(SCM_ROLENGTH (str));
}
#undef FUNC_NAME
SCM_PROC(s_string_to_list, "string->list", 1, 0, 0, scm_string_to_list);
SCM
scm_string_to_list (str)
SCM str;
GUILE_PROC(scm_string_to_list, "string->list", 1, 0, 0,
(SCM str),
"")
#define FUNC_NAME s_scm_string_to_list
{
long i;
SCM res = SCM_EOL;
unsigned char *src;
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_to_list);
SCM_VALIDATE_ROSTRING(1,str);
src = SCM_ROUCHARS (str);
for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res);
return res;
}
#undef FUNC_NAME
SCM_PROC(s_string_copy, "string-copy", 1, 0, 0, scm_string_copy);
SCM
scm_string_copy (str)
SCM str;
GUILE_PROC(scm_string_copy, "string-copy", 1, 0, 0,
(SCM str),
"")
#define FUNC_NAME s_scm_string_copy
{
SCM_ASSERT (SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP (str)),
str, SCM_ARG1, s_string_copy);
SCM_VALIDATE_STRINGORSUBSTR(1,str);
return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0);
}
#undef FUNC_NAME
SCM_PROC(s_string_fill_x, "string-fill!", 2, 0, 0, scm_string_fill_x);
SCM
scm_string_fill_x (str, chr)
SCM str;
SCM chr;
GUILE_PROC(scm_string_fill_x, "string-fill!", 2, 0, 0,
(SCM str, SCM chr),
"")
#define FUNC_NAME s_scm_string_fill_x
{
register char *dst, c;
register long k;
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_fill_x);
SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_string_fill_x);
c = SCM_ICHR (chr);
dst = SCM_CHARS (str);
SCM_VALIDATE_STRING_COPY(1,str,dst);
SCM_VALIDATE_CHAR_COPY(2,chr,c);
for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x);
SCM
scm_string_upcase_x (v)
SCM v;
GUILE_PROC(scm_string_upcase_x, "string-upcase!", 1, 0, 0,
(SCM v),
"")
#define FUNC_NAME s_scm_string_upcase_x
{
register long k;
register unsigned char *cs;
@ -256,24 +245,25 @@ scm_string_upcase_x (v)
cs[k] = scm_upcase(cs[k]);
break;
default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x);
badarg1:SCM_WTA (1,v);
}
return v;
}
#undef FUNC_NAME
SCM_PROC(s_string_upcase, "string-upcase", 1, 0, 0, scm_string_upcase);
SCM
scm_string_upcase(SCM str)
GUILE_PROC(scm_string_upcase, "string-upcase", 1, 0, 0,
(SCM str),
"")
#define FUNC_NAME s_scm_string_upcase
{
return scm_string_upcase_x(scm_string_copy(str));
}
#undef FUNC_NAME
SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x);
SCM
scm_string_downcase_x (v)
SCM v;
GUILE_PROC(scm_string_downcase_x, "string-downcase!", 1, 0, 0,
(SCM v),
"")
#define FUNC_NAME s_scm_string_downcase_x
{
register long k;
register unsigned char *cs;
@ -287,28 +277,30 @@ scm_string_downcase_x (v)
cs[k] = scm_downcase(cs[k]);
break;
default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x);
badarg1:SCM_WTA (1,v);
}
return v;
}
#undef FUNC_NAME
SCM_PROC(s_string_downcase, "string-downcase", 1, 0, 0, scm_string_downcase);
SCM
scm_string_downcase(SCM str)
GUILE_PROC(scm_string_downcase, "string-downcase", 1, 0, 0,
(SCM str),
"")
#define FUNC_NAME s_scm_string_downcase
{
SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, SCM_ARG1, s_string_downcase);
SCM_VALIDATE_STRING(1,str);
return scm_string_downcase_x(scm_string_copy(str));
}
#undef FUNC_NAME
SCM_PROC(s_string_capitalize_x, "string-capitalize!", 1, 0, 0, scm_string_capitalize_x);
SCM
scm_string_capitalize_x (SCM s)
GUILE_PROC(scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
(SCM s),
"")
#define FUNC_NAME s_scm_string_capitalize_x
{
char *str;
int i, len, in_word=0;
SCM_ASSERT(SCM_NIMP(s) && SCM_STRINGP(s), s, SCM_ARG1, s_string_capitalize_x);
SCM_VALIDATE_STRING(1,s);
len = SCM_LENGTH(s);
str = SCM_CHARS(s);
for(i=0; i<len; i++) {
@ -324,29 +316,31 @@ scm_string_capitalize_x (SCM s)
}
return s;
}
#undef FUNC_NAME
SCM_PROC(s_string_capitalize, "string-capitalize", 1, 0, 0, scm_string_capitalize);
SCM
scm_string_capitalize(SCM s)
GUILE_PROC(scm_string_capitalize, "string-capitalize", 1, 0, 0,
(SCM s),
"")
#define FUNC_NAME s_scm_string_capitalize
{
SCM_ASSERT((SCM_NIMP(s)) && (SCM_STRINGP(s)), s, SCM_ARG1, s_string_capitalize);
SCM_VALIDATE_STRING(1,s);
return scm_string_capitalize_x(scm_string_copy(s));
}
#undef FUNC_NAME
SCM_PROC(s_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, scm_string_ci_to_symbol);
SCM
scm_string_ci_to_symbol(SCM str)
GUILE_PROC(scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
(SCM str),
"")
#define FUNC_NAME s_scm_string_ci_to_symbol
{
return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
? scm_string_downcase(str)
: str);
}
#undef FUNC_NAME
void
scm_init_strop ()
{
#include "strop.x"
}

51
libguile/strports.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "_scm.h"
@ -247,11 +251,7 @@ st_truncate (SCM port, off_t length)
}
SCM
scm_mkstrport (pos, str, modes, caller)
SCM pos;
SCM str;
long modes;
const char * caller;
scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
{
SCM z;
scm_port *pt;
@ -295,22 +295,22 @@ SCM scm_strport_to_string (SCM port)
return scm_makfromstr (pt->read_buf, pt->read_buf_size, 0);
}
SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string);
SCM
scm_call_with_output_string (proc)
SCM proc;
GUILE_PROC(scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
(SCM proc),
"")
#define FUNC_NAME s_scm_call_with_output_string
{
SCM p;
p = scm_mkstrport (SCM_INUM0,
scm_make_string (SCM_INUM0, SCM_UNDEFINED),
SCM_OPN | SCM_WRTNG,
s_call_with_output_string);
FUNC_NAME);
scm_apply (proc, p, scm_listofnull);
return scm_strport_to_string (p);
}
#undef FUNC_NAME
@ -319,8 +319,7 @@ scm_call_with_output_string (proc)
SCM
scm_strprint_obj (obj)
SCM obj;
scm_strprint_obj (SCM obj)
{
SCM str;
SCM port;
@ -336,24 +335,22 @@ scm_strprint_obj (obj)
SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string);
SCM
scm_call_with_input_string (str, proc)
SCM str;
SCM proc;
GUILE_PROC(scm_call_with_input_string, "call-with-input-string", 2, 0, 0,
(SCM str, SCM proc),
"")
#define FUNC_NAME s_scm_call_with_input_string
{
SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string);
SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME);
return scm_apply (proc, p, scm_listofnull);
}
#undef FUNC_NAME
/* Given a null-terminated string EXPR containing a Scheme expression
read it, and return it as an SCM value. */
SCM
scm_read_0str (expr)
char *expr;
scm_read_0str (char *expr)
{
SCM port = scm_mkstrport (SCM_INUM0,
scm_makfrom0str (expr),
@ -377,11 +374,10 @@ scm_eval_0str (const char *expr)
}
SCM_PROC (s_eval_string, "eval-string", 1, 0, 0, scm_eval_string);
SCM
scm_eval_string (string)
SCM string;
GUILE_PROC (scm_eval_string, "eval-string", 1, 0, 0,
(SCM string),
"")
#define FUNC_NAME s_scm_eval_string
{
SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG,
"scm_eval_0str");
@ -399,6 +395,7 @@ scm_eval_string (string)
return ans;
}
#undef FUNC_NAME
void scm_make_stptob (void); /* Called from ports.c */

220
libguile/struct.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -49,6 +53,7 @@
#include "weaks.h"
#include "hashtab.h"
#include "scm_validate.h"
#include "struct.h"
#ifdef HAVE_STRING_H
@ -61,24 +66,21 @@ static SCM required_vtable_fields = SCM_BOOL_F;
SCM scm_struct_table;
SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
SCM
scm_make_struct_layout (fields)
SCM fields;
GUILE_PROC (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
(SCM fields),
"")
#define FUNC_NAME s_scm_make_struct_layout
{
SCM new_sym;
SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
fields, SCM_ARG1, s_struct_make_layout);
{
SCM_VALIDATE_ROSTRING(1,fields);
{ /* scope */
char * field_desc;
int len;
int x;
len = SCM_ROLENGTH (fields);
field_desc = SCM_ROCHARS (fields);
SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME);
for (x = 0; x < len; x += 2)
{
@ -93,14 +95,14 @@ scm_make_struct_layout (fields)
case 's':
break;
default:
SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", FUNC_NAME);
}
switch (field_desc[x + 1])
{
case 'w':
SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
"self fields not writable", s_struct_make_layout);
"self fields not writable", FUNC_NAME);
case 'r':
case 'o':
@ -110,18 +112,18 @@ scm_make_struct_layout (fields)
case 'O':
SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
"self fields not allowed in tail array",
s_struct_make_layout);
FUNC_NAME);
SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
"tail array field must be last field in layout",
s_struct_make_layout);
FUNC_NAME);
break;
default:
SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", FUNC_NAME);
}
#if 0
if (field_desc[x] == 'd')
{
SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", FUNC_NAME);
x += 2;
goto recheck_ref;
}
@ -131,16 +133,14 @@ scm_make_struct_layout (fields)
}
return scm_return_first (new_sym, fields);
}
#undef FUNC_NAME
void
scm_struct_init (handle, tail_elts, inits)
SCM handle;
int tail_elts;
SCM inits;
scm_struct_init (SCM handle, int tail_elts, SCM inits)
{
SCM layout;
SCM * data;
@ -231,22 +231,19 @@ scm_struct_init (handle, tail_elts, inits)
}
SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
SCM
scm_struct_p (x)
SCM x;
GUILE_PROC (scm_struct_p, "struct?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_struct_p
{
return ((SCM_NIMP (x) && SCM_STRUCTP (x))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (x) && SCM_STRUCTP (x));
}
#undef FUNC_NAME
SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
SCM
scm_struct_vtable_p (x)
SCM x;
GUILE_PROC (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_struct_vtable_p
{
SCM layout;
SCM * mem;
@ -274,10 +271,9 @@ scm_struct_vtable_p (x)
if (SCM_IMP (mem[0]))
return SCM_BOOL_F;
return (SCM_SYMBOLP (mem[0])
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_SYMBOLP (mem[0]));
}
#undef FUNC_NAME
/* All struct data must be allocated at an address whose bottom three
@ -362,13 +358,10 @@ scm_struct_free_entity (SCM *vtable, SCM *data)
return n;
}
SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
SCM
scm_make_struct (vtable, tail_array_size, init)
SCM vtable;
SCM tail_array_size;
SCM init;
GUILE_PROC (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
"")
#define FUNC_NAME s_scm_make_struct
{
SCM layout;
int basic_size;
@ -376,10 +369,8 @@ scm_make_struct (vtable, tail_array_size, init)
SCM * data;
SCM handle;
SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
vtable, SCM_ARG1, s_make_struct);
SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
s_make_struct);
SCM_VALIDATE_VTABLE(1,vtable);
SCM_VALIDATE_INT(2,tail_array_size);
layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout];
basic_size = SCM_LENGTH (layout) / 2;
@ -404,16 +395,14 @@ scm_make_struct (vtable, tail_array_size, init)
SCM_ALLOW_INTS;
return handle;
}
#undef FUNC_NAME
SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
SCM
scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM extra_fields;
SCM tail_array_size;
SCM init;
GUILE_PROC (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
(SCM extra_fields, SCM tail_array_size, SCM init),
"")
#define FUNC_NAME s_scm_make_vtable_vtable
{
SCM fields;
SCM layout;
@ -422,10 +411,8 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM * data;
SCM handle;
SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
extra_fields, SCM_ARG1, s_make_vtable_vtable);
SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
s_make_vtable_vtable);
SCM_VALIDATE_ROSTRING(1,extra_fields);
SCM_VALIDATE_INT(2,tail_array_size);
fields = scm_string_append (scm_listify (required_vtable_fields,
extra_fields,
@ -445,16 +432,15 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM_ALLOW_INTS;
return handle;
}
#undef FUNC_NAME
SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
SCM
scm_struct_ref (handle, pos)
SCM handle;
SCM pos;
GUILE_PROC (scm_struct_ref, "struct-ref", 2, 0, 0,
(SCM handle, SCM pos),
"")
#define FUNC_NAME s_scm_struct_ref
{
SCM answer = SCM_UNDEFINED;
SCM * data;
@ -465,9 +451,8 @@ scm_struct_ref (handle, pos)
unsigned char field_type = 0;
SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
SCM_ARG1, s_struct_ref);
SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
SCM_VALIDATE_STRUCT(1,handle);
SCM_VALIDATE_INT(2,pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
@ -476,7 +461,7 @@ scm_struct_ref (handle, pos)
fields_desc = (unsigned char *) SCM_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME);
if (p * 2 < SCM_LENGTH (layout))
{
@ -488,14 +473,14 @@ scm_struct_ref (handle, pos)
if ((ref == 'R') || (ref == 'W'))
field_type = 'u';
else
SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
}
}
else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
field_type = fields_desc[SCM_LENGTH (layout) - 2];
else
{
SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
abort ();
}
@ -522,21 +507,19 @@ scm_struct_ref (handle, pos)
default:
SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME);
break;
}
return answer;
}
#undef FUNC_NAME
SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
SCM
scm_struct_set_x (handle, pos, val)
SCM handle;
SCM pos;
SCM val;
GUILE_PROC (scm_struct_set_x, "struct-set!", 3, 0, 0,
(SCM handle, SCM pos, SCM val),
"")
#define FUNC_NAME s_scm_struct_set_x
{
SCM * data;
SCM layout;
@ -544,12 +527,9 @@ scm_struct_set_x (handle, pos, val)
int n_fields;
unsigned char * fields_desc;
unsigned char field_type = 0;
SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
SCM_ARG1, s_struct_ref);
SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
SCM_VALIDATE_STRUCT(1,handle);
SCM_VALIDATE_INT(2,pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
@ -558,7 +538,7 @@ scm_struct_set_x (handle, pos, val)
fields_desc = (unsigned char *)SCM_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME);
if (p * 2 < SCM_LENGTH (layout))
{
@ -566,25 +546,25 @@ scm_struct_set_x (handle, pos, val)
field_type = fields_desc[p * 2];
set_x = fields_desc [p * 2 + 1];
if (set_x != 'w')
SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
}
else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
field_type = fields_desc[SCM_LENGTH (layout) - 2];
else
{
SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
abort ();
}
switch (field_type)
{
case 'u':
data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
data[p] = SCM_NUM2ULONG (3,val);
break;
#if 0
case 'i':
data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
data[p] = SCM_NUM2LONG (3,val);
break;
case 'd':
@ -597,40 +577,39 @@ scm_struct_set_x (handle, pos, val)
break;
case 's':
SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", FUNC_NAME);
break;
default:
SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME);
break;
}
return val;
}
#undef FUNC_NAME
SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
SCM
scm_struct_vtable (handle)
SCM handle;
GUILE_PROC (scm_struct_vtable, "struct-vtable", 1, 0, 0,
(SCM handle),
"")
#define FUNC_NAME s_scm_struct_vtable
{
SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
SCM_ARG1, s_struct_vtable);
SCM_VALIDATE_STRUCT(1,handle);
return SCM_STRUCT_VTABLE (handle);
}
#undef FUNC_NAME
SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
SCM
scm_struct_vtable_tag (handle)
SCM handle;
GUILE_PROC (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
(SCM handle),
"")
#define FUNC_NAME s_scm_struct_vtable_tag
{
SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (handle)),
handle, SCM_ARG1, s_struct_vtable_tag);
SCM_VALIDATE_VTABLE(1,handle);
return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3);
}
#undef FUNC_NAME
/* {Associating names and classes with vtables}
*
@ -661,39 +640,34 @@ scm_struct_create_handle (SCM obj)
return handle;
}
SCM_PROC (s_struct_vtable_name, "struct-vtable-name", 1, 0, 0, scm_struct_vtable_name);
SCM
scm_struct_vtable_name (SCM vtable)
GUILE_PROC (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
"")
#define FUNC_NAME s_scm_struct_vtable_name
{
SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (vtable)),
vtable, SCM_ARG1, s_struct_vtable_name);
SCM_VALIDATE_VTABLE(1,vtable);
return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
}
#undef FUNC_NAME
SCM_PROC (s_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, scm_set_struct_vtable_name_x);
SCM
scm_set_struct_vtable_name_x (SCM vtable, SCM name)
GUILE_PROC (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
(SCM vtable, SCM name),
"")
#define FUNC_NAME s_scm_set_struct_vtable_name_x
{
SCM_ASSERT (SCM_NIMP (vtable) && SCM_NFALSEP (scm_struct_vtable_p (vtable)),
vtable, SCM_ARG1, s_set_struct_vtable_name_x);
SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name),
name, SCM_ARG2, s_set_struct_vtable_name_x);
SCM_VALIDATE_VTABLE(1,vtable);
SCM_VALIDATE_SYMBOL(2,name);
SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
name);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void
scm_print_struct (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
{
if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);

308
libguile/symbols.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -48,6 +52,7 @@
#include "alist.h"
#include "weaks.h"
#include "scm_validate.h"
#include "symbols.h"
#ifdef HAVE_STRING_H
@ -69,10 +74,7 @@
unsigned long
scm_strhash (str, len, n)
unsigned char *str;
scm_sizet len;
unsigned long n;
scm_strhash (unsigned char *str,scm_sizet len,unsigned long n)
{
if (len > 5)
{
@ -100,10 +102,7 @@ int scm_symhash_dim = NUM_HASH_BUCKETS;
*/
SCM
scm_sym2vcell (sym, thunk, definep)
SCM sym;
SCM thunk;
SCM definep;
scm_sym2vcell (SCM sym,SCM thunk,SCM definep)
{
if (SCM_NIMP(thunk))
{
@ -165,9 +164,7 @@ scm_sym2vcell (sym, thunk, definep)
*/
SCM
scm_sym2ovcell_soft (sym, obarray)
SCM sym;
SCM obarray;
scm_sym2ovcell_soft (SCM sym, SCM obarray)
{
SCM lsym, z;
scm_sizet scm_hash;
@ -193,9 +190,7 @@ scm_sym2ovcell_soft (sym, obarray)
SCM
scm_sym2ovcell (sym, obarray)
SCM sym;
SCM obarray;
scm_sym2ovcell (SCM sym, SCM obarray)
{
SCM answer;
answer = scm_sym2ovcell_soft (sym, obarray);
@ -229,11 +224,7 @@ scm_sym2ovcell (sym, obarray)
SCM
scm_intern_obarray_soft (name, len, obarray, softness)
const char *name;
scm_sizet len;
SCM obarray;
int softness;
scm_intern_obarray_soft (const char *name,scm_sizet len,SCM obarray,int softness)
{
SCM lsym;
SCM z;
@ -329,27 +320,21 @@ scm_intern_obarray_soft (name, len, obarray, softness)
SCM
scm_intern_obarray (name, len, obarray)
const char *name;
scm_sizet len;
SCM obarray;
scm_intern_obarray (const char *name,scm_sizet len,SCM obarray)
{
return scm_intern_obarray_soft (name, len, obarray, 0);
}
SCM
scm_intern (name, len)
const char *name;
scm_sizet len;
scm_intern (const char *name,scm_sizet len)
{
return scm_intern_obarray (name, len, scm_symhash);
}
SCM
scm_intern0 (name)
const char * name;
scm_intern0 (const char * name)
{
return scm_intern (name, strlen (name));
}
@ -357,8 +342,7 @@ scm_intern0 (name)
/* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
SCM
scm_sysintern0_no_module_lookup (name)
const char *name;
scm_sysintern0_no_module_lookup (const char *name)
{
SCM easy_answer;
SCM_DEFER_INTS;
@ -394,9 +378,7 @@ int scm_can_use_top_level_lookup_closure_var;
closure to give NAME its value.
*/
SCM
scm_sysintern (name, val)
const char *name;
SCM val;
scm_sysintern (const char *name, SCM val)
{
SCM vcell = scm_sysintern0 (name);
SCM_SETCDR (vcell, val);
@ -404,8 +386,7 @@ scm_sysintern (name, val)
}
SCM
scm_sysintern0 (name)
const char *name;
scm_sysintern0 (const char *name)
{
SCM lookup_proc;
if (scm_can_use_top_level_lookup_closure_var &&
@ -424,8 +405,7 @@ scm_sysintern0 (name)
/* Lookup the value of the symbol named by the nul-terminated string
NAME in the current module. */
SCM
scm_symbol_value0 (name)
const char *name;
scm_symbol_value0 (const char *name)
{
/* This looks silly - we look up the symbol twice. But it is in
fact necessary given the current module system because the module
@ -439,63 +419,57 @@ scm_symbol_value0 (name)
return SCM_CDR (vcell);
}
SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
SCM
scm_symbol_p(x)
SCM x;
GUILE_PROC(scm_symbol_p, "symbol?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_symbol_p
{
if SCM_IMP(x) return SCM_BOOL_F;
return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_SYMBOLP(x));
}
#undef FUNC_NAME
SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string);
SCM
scm_symbol_to_string(s)
SCM s;
GUILE_PROC(scm_symbol_to_string, "symbol->string", 1, 0, 0,
(SCM s),
"")
#define FUNC_NAME s_scm_symbol_to_string
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string);
SCM_VALIDATE_SYMBOL(1,s);
return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
}
#undef FUNC_NAME
SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol);
SCM
scm_string_to_symbol(s)
SCM s;
GUILE_PROC(scm_string_to_symbol, "string->symbol", 1, 0, 0,
(SCM s),
"")
#define FUNC_NAME s_scm_string_to_symbol
{
SCM vcell;
SCM answer;
SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol);
SCM_VALIDATE_ROSTRING(1,s);
vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s));
answer = SCM_CAR (vcell);
return answer;
}
#undef FUNC_NAME
SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol);
SCM
scm_string_to_obarray_symbol(o, s, softp)
SCM o;
SCM s;
SCM softp;
GUILE_PROC(scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
(SCM o, SCM s, SCM softp),
"")
#define FUNC_NAME s_scm_string_to_obarray_symbol
{
SCM vcell;
SCM answer;
int softness;
SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2,
s_string_to_obarray_symbol);
SCM_VALIDATE_ROSTRING(2,s);
SCM_ASSERT((o == SCM_BOOL_F)
|| (o == SCM_BOOL_T)
|| (SCM_NIMP(o) && SCM_VECTORP(o)),
o,
SCM_ARG1,
s_string_to_obarray_symbol);
o, SCM_ARG1, FUNC_NAME);
softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
/* iron out some screwy calling conventions */
@ -513,19 +487,18 @@ scm_string_to_obarray_symbol(o, s, softp)
answer = SCM_CAR (vcell);
return answer;
}
#undef FUNC_NAME
SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol);
SCM
scm_intern_symbol(o, s)
SCM o;
SCM s;
GUILE_PROC(scm_intern_symbol, "intern-symbol", 2, 0, 0,
(SCM o, SCM s),
"")
#define FUNC_NAME s_scm_intern_symbol
{
scm_sizet hval;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol);
SCM_VALIDATE_SYMBOL(2,s);
if (o == SCM_BOOL_F)
o = scm_symhash;
SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol);
SCM_VALIDATE_VECTOR(1,o);
hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
/* If the symbol is already interned, simply return. */
SCM_REDEFER_INTS;
@ -549,19 +522,18 @@ scm_intern_symbol(o, s)
SCM_REALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol);
SCM
scm_unintern_symbol(o, s)
SCM o;
SCM s;
GUILE_PROC(scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
(SCM o, SCM s),
"")
#define FUNC_NAME s_scm_unintern_symbol
{
scm_sizet hval;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol);
SCM_VALIDATE_SYMBOL(2,s);
if (o == SCM_BOOL_F)
o = scm_symhash;
SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol);
SCM_VALIDATE_VECTOR(1,o);
hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
SCM_DEFER_INTS;
{
@ -588,36 +560,34 @@ scm_unintern_symbol(o, s)
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding);
SCM
scm_symbol_binding (o, s)
SCM o;
SCM s;
GUILE_PROC(scm_symbol_binding, "symbol-binding", 2, 0, 0,
(SCM o, SCM s),
"")
#define FUNC_NAME s_scm_symbol_binding
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding);
SCM_VALIDATE_SYMBOL(2,s);
if (o == SCM_BOOL_F)
o = scm_symhash;
SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding);
SCM_VALIDATE_VECTOR(1,o);
vcell = scm_sym2ovcell (s, o);
return SCM_CDR(vcell);
}
#undef FUNC_NAME
SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p);
SCM
scm_symbol_interned_p (o, s)
SCM o;
SCM s;
GUILE_PROC(scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
(SCM o, SCM s),
"")
#define FUNC_NAME s_scm_symbol_interned_p
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p);
SCM_VALIDATE_SYMBOL(2,s);
if (o == SCM_BOOL_F)
o = scm_symhash;
SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p);
SCM_VALIDATE_VECTOR(1,o);
vcell = scm_sym2ovcell_soft (s, o);
if (SCM_IMP(vcell) && (o == scm_symhash))
vcell = scm_sym2ovcell_soft (s, scm_weak_symhash);
@ -625,49 +595,46 @@ scm_symbol_interned_p (o, s)
? SCM_BOOL_T
: SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p);
SCM
scm_symbol_bound_p (o, s)
SCM o;
SCM s;
GUILE_PROC(scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
(SCM o, SCM s),
"")
#define FUNC_NAME s_scm_symbol_bound_p
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p);
SCM_VALIDATE_SYMBOL(2,s);
if (o == SCM_BOOL_F)
o = scm_symhash;
SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_bound_p);
SCM_VALIDATE_VECTOR(1,o);
vcell = scm_sym2ovcell_soft (s, o);
return (( SCM_NIMP(vcell)
&& (SCM_CDR(vcell) != SCM_UNDEFINED))
? SCM_BOOL_T
: SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x);
SCM
scm_symbol_set_x (o, s, v)
SCM o;
SCM s;
SCM v;
GUILE_PROC(scm_symbol_set_x, "symbol-set!", 3, 0, 0,
(SCM o, SCM s, SCM v),
"")
#define FUNC_NAME s_scm_symbol_set_x
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x);
SCM_VALIDATE_SYMBOL(2,s);
if (o == SCM_BOOL_F)
o = scm_symhash;
SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x);
SCM_VALIDATE_VECTOR(1,o);
vcell = scm_sym2ovcell (s, o);
SCM_SETCDR (vcell, v);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static void
msymbolize (s)
SCM s;
msymbolize (SCM s)
{
SCM string;
string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
@ -683,44 +650,42 @@ msymbolize (s)
}
SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref);
SCM
scm_symbol_fref (s)
SCM s;
GUILE_PROC(scm_symbol_fref, "symbol-fref", 1, 0, 0,
(SCM s),
"")
#define FUNC_NAME s_scm_symbol_fref
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref);
SCM_VALIDATE_SYMBOL(1,s);
SCM_DEFER_INTS;
if (SCM_TYP7(s) == scm_tc7_ssymbol)
msymbolize (s);
SCM_ALLOW_INTS;
return SCM_SYMBOL_FUNC (s);
}
#undef FUNC_NAME
SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref);
SCM
scm_symbol_pref (s)
SCM s;
GUILE_PROC(scm_symbol_pref, "symbol-pref", 1, 0, 0,
(SCM s),
"")
#define FUNC_NAME s_scm_symbol_pref
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref);
SCM_VALIDATE_SYMBOL(1,s);
SCM_DEFER_INTS;
if (SCM_TYP7(s) == scm_tc7_ssymbol)
msymbolize (s);
SCM_ALLOW_INTS;
return SCM_SYMBOL_PROPS (s);
}
#undef FUNC_NAME
SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x);
SCM
scm_symbol_fset_x (s, val)
SCM s;
SCM val;
GUILE_PROC(scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
(SCM s, SCM val),
"")
#define FUNC_NAME s_scm_symbol_fset_x
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x);
SCM_VALIDATE_SYMBOL(1,s);
SCM_DEFER_INTS;
if (SCM_TYP7(s) == scm_tc7_ssymbol)
msymbolize (s);
@ -728,16 +693,15 @@ scm_symbol_fset_x (s, val)
SCM_SYMBOL_FUNC (s) = val;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x);
SCM
scm_symbol_pset_x (s, val)
SCM s;
SCM val;
GUILE_PROC(scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
(SCM s, SCM val),
"")
#define FUNC_NAME s_scm_symbol_pset_x
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x);
SCM_VALIDATE_SYMBOL(1,s);
SCM_DEFER_INTS;
if (SCM_TYP7(s) == scm_tc7_ssymbol)
msymbolize (s);
@ -745,27 +709,24 @@ scm_symbol_pset_x (s, val)
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash);
SCM
scm_symbol_hash (s)
SCM s;
GUILE_PROC(scm_symbol_hash, "symbol-hash", 1, 0, 0,
(SCM s),
"")
#define FUNC_NAME s_scm_symbol_hash
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash);
SCM_VALIDATE_SYMBOL(1,s);
if (SCM_TYP7(s) == scm_tc7_ssymbol)
msymbolize (s);
return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
}
#undef FUNC_NAME
static void copy_and_prune_obarray SCM_P ((SCM from, SCM to));
static void
copy_and_prune_obarray (from, to)
SCM from;
SCM to;
copy_and_prune_obarray (SCM from, SCM to)
{
int i;
int length = SCM_LENGTH (from);
@ -789,46 +750,46 @@ copy_and_prune_obarray (from, to)
}
SCM_PROC(s_builtin_bindings, "builtin-bindings", 0, 0, 0, scm_builtin_bindings);
SCM
scm_builtin_bindings ()
GUILE_PROC(scm_builtin_bindings, "builtin-bindings", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_builtin_bindings
{
int length = SCM_LENGTH (scm_symhash);
SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL);
copy_and_prune_obarray (scm_symhash, obarray);
return obarray;
}
#undef FUNC_NAME
SCM_PROC(s_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, scm_builtin_weak_bindings);
SCM
scm_builtin_weak_bindings ()
GUILE_PROC(scm_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_builtin_weak_bindings
{
int length = SCM_LENGTH (scm_weak_symhash);
SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length));
copy_and_prune_obarray (scm_weak_symhash, obarray);
return obarray;
}
#undef FUNC_NAME
static int gensym_counter;
static SCM gensym_prefix;
/*fixme* Optimize */
SCM_PROC (s_gensym, "gensym", 0, 2, 0, scm_gensym);
SCM
scm_gensym (name, obarray)
SCM name;
SCM obarray;
/* :FIXME:OPTIMIZE */
GUILE_PROC (scm_gensym, "gensym", 0, 2, 0,
(SCM name, SCM obarray),
"")
#define FUNC_NAME s_scm_gensym
{
SCM new;
if (SCM_UNBNDP (name))
name = gensym_prefix;
else
SCM_ASSERT (SCM_NIMP (name) && SCM_ROSTRINGP (name),
name, SCM_ARG1, s_gensym);
SCM_VALIDATE_ROSTRING(1,name);
new = name;
if (SCM_UNBNDP (obarray))
{
@ -840,7 +801,7 @@ scm_gensym (name, obarray)
&& (SCM_VECTORP (obarray) || SCM_WVECTP (obarray)),
obarray,
SCM_ARG2,
s_gensym);
FUNC_NAME);
while (scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_T)
!= SCM_BOOL_F)
skip_test:
@ -851,6 +812,7 @@ scm_gensym (name, obarray)
SCM_EOL));
return scm_string_to_obarray_symbol (obarray, new, SCM_BOOL_F);
}
#undef FUNC_NAME
void
scm_init_symbols ()

14
libguile/tag.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
@ -85,11 +89,10 @@ SCM_CONST_LONG (scm_utag_flag_base, "utag_flag_base", 254);
SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255);
SCM_PROC (s_tag, "tag", 1, 0, 0, scm_tag);
SCM
scm_tag (x)
SCM x;
GUILE_PROC (scm_tag, "tag", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_tag
{
switch (SCM_ITAG3 (x))
{
@ -204,6 +207,7 @@ scm_tag (x)
}
return SCM_MAKINUM (-1);
}
#undef FUNC_NAME

10
libguile/tags.h
View file

@ -42,6 +42,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/** This file defines the format of SCM values and cons pairs.
@ -411,6 +415,12 @@ typedef long SCM;
#define scm_tc16_bigpos 0x027f
#define scm_tc16_bigneg 0x037f
/* Smob type 4: this is allocated, but not initialized cells;
this is required to prevent the gc from hosing your cells if
you have to allocate while creating the cell*/
#define scm_tc16_allocated 0x047f
/* {Immediate Values}

24
libguile/threads.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
/* This file does some pretty hairy #inclusion. It probably seemed
@ -79,17 +83,17 @@ long scm_tc16_condvar;
/* Scheme-visible thread functions. */
#ifdef USE_COOP_THREADS
SCM_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p);
SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p);
#endif
SCM_PROC(s_yield, "yield", 0, 0, 0, scm_yield);
SCM_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread);
SCM_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread);
SCM_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex);
SCM_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex);
SCM_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex);
SCM_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable);
SCM_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 0, 0, scm_wait_condition_variable);
SCM_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable);
SCM_REGISTER_PROC(s_yield, "yield", 0, 0, 0, scm_yield);
SCM_REGISTER_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread);
SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread);
SCM_REGISTER_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex);
SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex);
SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex);
SCM_REGISTER_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable);
SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 0, 0, scm_wait_condition_variable);
SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable);

64
libguile/throw.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -57,6 +61,7 @@
#include "stacks.h"
#include "fluids.h"
#include "scm_validate.h"
#include "throw.h"
@ -77,23 +82,16 @@ static int scm_tc16_jmpbuffer;
#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
static scm_sizet freejb SCM_P ((SCM jbsmob));
static scm_sizet
freejb (jbsmob)
SCM jbsmob;
freejb (SCM jbsmob)
{
scm_must_free ((char *) SCM_CDR (jbsmob));
return sizeof (scm_cell);
}
#endif
static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
printjb (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
printjb (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<jmpbuffer ", port);
scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
@ -103,9 +101,8 @@ printjb (exp, port, pstate)
}
static SCM make_jmpbuf SCM_P ((void));
static SCM
make_jmpbuf ()
make_jmpbuf (void)
{
SCM answer;
SCM_REDEFER_INTS;
@ -557,19 +554,15 @@ scm_handle_by_throw (handler_data, tag, args)
/* the Scheme-visible CATCH and LAZY-CATCH functions */
SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
SCM
scm_catch (tag, thunk, handler)
SCM tag;
SCM thunk;
SCM handler;
GUILE_PROC(scm_catch, "catch", 3, 0, 0,
(SCM tag, SCM thunk, SCM handler),
"")
#define FUNC_NAME s_scm_catch
{
struct scm_body_thunk_data c;
SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || tag == SCM_BOOL_T,
tag,
SCM_ARG1,
s_catch);
tag, SCM_ARG1, FUNC_NAME);
c.tag = tag;
c.body_proc = thunk;
@ -583,20 +576,19 @@ scm_catch (tag, thunk, handler)
scm_body_thunk, &c,
scm_handle_by_proc, &handler);
}
#undef FUNC_NAME
SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
SCM
scm_lazy_catch (tag, thunk, handler)
SCM tag;
SCM thunk;
SCM handler;
GUILE_PROC(scm_lazy_catch, "lazy-catch", 3, 0, 0,
(SCM tag, SCM thunk, SCM handler),
"")
#define FUNC_NAME s_scm_lazy_catch
{
struct scm_body_thunk_data c;
SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
|| (tag == SCM_BOOL_T),
tag, SCM_ARG1, s_lazy_catch);
tag, SCM_ARG1, FUNC_NAME);
c.tag = tag;
c.body_proc = thunk;
@ -611,28 +603,26 @@ scm_lazy_catch (tag, thunk, handler)
scm_body_thunk, &c,
scm_handle_by_proc, &handler);
}
#undef FUNC_NAME
/* throwing */
SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
SCM
scm_throw (key, args)
SCM key;
SCM args;
GUILE_PROC(scm_throw, "throw", 1, 0, 1,
(SCM key, SCM args),
"")
#define FUNC_NAME s_scm_throw
{
SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_throw);
SCM_VALIDATE_SYMBOL(1,key);
/* May return if handled by lazy catch. */
return scm_ithrow (key, args, 1);
}
#undef FUNC_NAME
SCM
scm_ithrow (key, args, noreturn)
SCM key;
SCM args;
int noreturn;
scm_ithrow (SCM key, SCM args, int noreturn)
{
SCM jmpbuf = SCM_UNDEFINED;
SCM wind_goal;

526
libguile/unif.c
View file

File diff suppressed because it is too large Load diff

116
libguile/variable.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -46,16 +50,12 @@
#include "genio.h"
#include "smob.h"
#include "scm_validate.h"
#include "variable.h"
static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
prin_var (exp, port, pstate)
SCM exp;
SCM port;
scm_print_state *pstate;
prin_var (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts ("#<variable ", port);
scm_intprint(exp, 16, port);
@ -75,21 +75,14 @@ prin_var (exp, port, pstate)
}
static SCM scm_markvar SCM_P ((SCM ptr));
static SCM
scm_markvar (ptr)
SCM ptr;
scm_markvar (SCM ptr)
{
return SCM_CDR (ptr);
}
static SCM var_equal SCM_P ((SCM var1, SCM var2));
static SCM
var_equal (var1, var2)
SCM var1;
SCM var2;
var_equal (SCM var1, SCM var2)
{
return scm_equal_p (SCM_CDR (var1), SCM_CDR (var2));
}
@ -100,21 +93,16 @@ int scm_tc16_variable;
static SCM anonymous_variable_sym;
static SCM make_vcell_variable SCM_P ((SCM vcell));
static SCM
make_vcell_variable (vcell)
SCM vcell;
make_vcell_variable (SCM vcell)
{
SCM_RETURN_NEWSMOB (scm_tc16_variable, vcell);
}
SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable);
SCM
scm_make_variable (init, name_hint)
SCM init;
SCM name_hint;
GUILE_PROC(scm_make_variable, "make-variable", 1, 1, 0,
(SCM init, SCM name_hint),
"")
#define FUNC_NAME s_scm_make_variable
{
SCM val_cell;
@ -128,13 +116,13 @@ scm_make_variable (init, name_hint)
SCM_ALLOW_INTS;
return make_vcell_variable (val_cell);
}
#undef FUNC_NAME
SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable);
SCM
scm_make_undefined_variable (name_hint)
SCM name_hint;
GUILE_PROC(scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0,
(SCM name_hint),
"")
#define FUNC_NAME s_scm_make_undefined_variable
{
SCM vcell;
@ -148,55 +136,52 @@ scm_make_undefined_variable (name_hint)
SCM_ALLOW_INTS;
return make_vcell_variable (vcell);
}
#undef FUNC_NAME
SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p);
SCM
scm_variable_p (obj)
SCM obj;
GUILE_PROC(scm_variable_p, "variable?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_variable_p
{
return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP(obj) && SCM_VARIABLEP (obj));
}
#undef FUNC_NAME
SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref);
SCM
scm_variable_ref (var)
SCM var;
GUILE_PROC(scm_variable_ref, "variable-ref", 1, 0, 0,
(SCM var),
"")
#define FUNC_NAME s_scm_variable_ref
{
SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref);
SCM_VALIDATE_VARIABLE(1,var);
return SCM_CDR (SCM_CDR (var));
}
#undef FUNC_NAME
SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x);
SCM
scm_variable_set_x (var, val)
SCM var;
SCM val;
GUILE_PROC(scm_variable_set_x, "variable-set!", 2, 0, 0,
(SCM var, SCM val),
"")
#define FUNC_NAME s_scm_variable_set_x
{
SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x);
SCM_VALIDATE_VARIABLE(1,var);
SCM_SETCDR (SCM_CDR (var), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable);
SCM
scm_builtin_variable (name)
SCM name;
GUILE_PROC(scm_builtin_variable, "builtin-variable", 1, 0, 0,
(SCM name),
"")
#define FUNC_NAME s_scm_builtin_variable
{
SCM vcell;
SCM var_slot;
SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_builtin_variable);
SCM_VALIDATE_SYMBOL(1,name);
vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T);
if (vcell == SCM_BOOL_F)
return SCM_BOOL_F;
@ -212,19 +197,18 @@ scm_builtin_variable (name)
return SCM_CDR (var_slot);
}
#undef FUNC_NAME
SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p);
SCM
scm_variable_bound_p (var)
SCM var;
GUILE_PROC(scm_variable_bound_p, "variable-bound?", 1, 0, 0,
(SCM var),
"")
#define FUNC_NAME s_scm_variable_bound_p
{
SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p);
return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))
? SCM_BOOL_F
: SCM_BOOL_T);
SCM_VALIDATE_VARIABLE(1,var);
return SCM_NEGATE_BOOL(SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var))));
}
#undef FUNC_NAME

158
libguile/vectors.c
View file

@ -38,12 +38,17 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "eq.h"
#include "scm_validate.h"
#include "vectors.h"
#include "unif.h"
@ -53,15 +58,13 @@
* C code can safely call it on arrays known to be used in a single
* threaded manner.
*
* SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
* SCM_REGISTER_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
*/
static char s_vector_set_length_x[] = "vector-set-length!";
SCM
scm_vector_set_length_x (vect, len)
SCM vect;
SCM len;
scm_vector_set_length_x (SCM vect, SCM len)
{
long l;
scm_sizet siz;
@ -119,15 +122,15 @@ scm_vector_set_length_x (vect, len)
return vect;
}
SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p);
SCM
scm_vector_p(x)
SCM x;
GUILE_PROC(scm_vector_p, "vector?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_vector_p
{
if (SCM_IMP(x)) return SCM_BOOL_F;
return SCM_VECTORP(x) ? SCM_BOOL_T : SCM_BOOL_F;
return SCM_BOOL(SCM_VECTORP(x));
}
#undef FUNC_NAME
SCM_GPROC(s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
@ -140,23 +143,24 @@ scm_vector_length(v)
return SCM_MAKINUM(SCM_LENGTH(v));
}
SCM_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
SCM_PROC(s_vector, "vector", 0, 0, 1, scm_vector);
SCM_REGISTER_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
SCM
scm_vector(l)
SCM l;
GUILE_PROC(scm_vector, "vector", 0, 0, 1,
(SCM l),
"")
#define FUNC_NAME s_scm_vector
{
SCM res;
register SCM *data;
long i = scm_ilength(l);
SCM_ASSERT(i >= 0, l, SCM_ARG1, s_vector);
int i;
SCM_VALIDATE_LIST_COPYLEN(1,l,i);
res = scm_make_vector (SCM_MAKINUM(i), SCM_UNSPECIFIED);
data = SCM_VELTS(res);
for(;i && SCM_NIMP(l);--i, l = SCM_CDR(l))
*data++ = SCM_CAR(l);
return res;
}
#undef FUNC_NAME
SCM_GPROC(s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);
@ -193,25 +197,23 @@ scm_vector_set_x(v, k, obj)
}
SCM_PROC (s_make_vector, "make-vector", 1, 1, 0, scm_make_vector);
SCM
scm_make_vector (k, fill)
SCM k;
SCM fill;
GUILE_PROC (scm_make_vector, "make-vector", 1, 1, 0,
(SCM k, SCM fill),
"")
#define FUNC_NAME s_scm_make_vector
{
SCM v;
register long i;
register long j;
register SCM *velts;
SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector);
SCM_VALIDATE_INT_MIN(1,k,0);
if (SCM_UNBNDP(fill))
fill = SCM_UNSPECIFIED;
i = SCM_INUM(k);
SCM_NEWCELL(v);
SCM_DEFER_INTS;
SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, FUNC_NAME));
SCM_SETLENGTH(v, i, scm_tc7_vector);
velts = SCM_VELTS(v);
j = 0;
@ -219,46 +221,44 @@ scm_make_vector (k, fill)
SCM_ALLOW_INTS;
return v;
}
#undef FUNC_NAME
SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list);
SCM
scm_vector_to_list(v)
SCM v;
GUILE_PROC(scm_vector_to_list, "vector->list", 1, 0, 0,
(SCM v),
"")
#define FUNC_NAME s_scm_vector_to_list
{
SCM res = SCM_EOL;
long i;
SCM *data;
SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_to_list);
SCM_VALIDATE_VECTOR(1,v);
data = SCM_VELTS(v);
for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res);
return res;
}
#undef FUNC_NAME
SCM_PROC (s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x);
SCM
scm_vector_fill_x (v, fill_x)
SCM v;
SCM fill_x;
GUILE_PROC (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
(SCM v, SCM fill_x),
"")
#define FUNC_NAME s_scm_vector_fill_x
{
register long i;
register SCM *data;
SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_fill_x);
SCM_VALIDATE_VECTOR(1,v);
data = SCM_VELTS(v);
for(i = SCM_LENGTH(v) - 1; i >= 0; i--)
data[i] = fill_x;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM
scm_vector_equal_p(x, y)
SCM x;
SCM y;
scm_vector_equal_p(SCM x, SCM y)
{
long i;
for(i = SCM_LENGTH(x)-1;i >= 0;i--)
@ -268,73 +268,53 @@ scm_vector_equal_p(x, y)
}
SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x);
SCM
scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
SCM vec1;
SCM start1;
SCM end1;
SCM vec2;
SCM start2;
GUILE_PROC (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
(SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
"")
#define FUNC_NAME s_scm_vector_move_left_x
{
long i;
long j;
long e;
SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_left_x);
SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_left_x);
SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_left_x);
SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_left_x);
SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_left_x);
i = SCM_INUM (start1);
j = SCM_INUM (start2);
e = SCM_INUM (end1);
SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_left_x);
SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_left_x);
SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_left_x);
SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_left_x);
SCM_VALIDATE_VECTOR(1,vec1);
SCM_VALIDATE_INT_COPY(2,start1,i);
SCM_VALIDATE_INT_COPY(3,end1,e);
SCM_VALIDATE_VECTOR(4,vec2);
SCM_VALIDATE_INT_COPY(5,start2,j);
SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, FUNC_NAME);
SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME);
SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME);
SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME);
while (i<e) SCM_VELTS (vec2)[j++] = SCM_VELTS (vec1)[i++];
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x);
SCM
scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
SCM vec1;
SCM start1;
SCM end1;
SCM vec2;
SCM start2;
GUILE_PROC (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
(SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
"")
#define FUNC_NAME s_scm_vector_move_right_x
{
long i;
long j;
long e;
SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1),
vec1, SCM_ARG1, s_vector_move_right_x);
SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_right_x);
SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_right_x);
SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2),
vec2, SCM_ARG4, s_vector_move_right_x);
SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_right_x);
i = SCM_INUM (start1);
j = SCM_INUM (start2);
e = SCM_INUM (end1);
SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0,
start1, SCM_OUTOFRANGE, s_vector_move_right_x);
SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0,
start2, SCM_OUTOFRANGE, s_vector_move_right_x);
SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0,
end1, SCM_OUTOFRANGE, s_vector_move_right_x);
SCM_VALIDATE_VECTOR(1,vec1);
SCM_VALIDATE_INT_COPY(2,start1,i);
SCM_VALIDATE_INT_COPY(3,end1,e);
SCM_VALIDATE_VECTOR(4,vec2);
SCM_VALIDATE_INT_COPY(5,start2,j);
SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, FUNC_NAME);
SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME);
SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME);
j = e - i + j;
SCM_ASSERT (j <= SCM_LENGTH (vec2),
start2, SCM_OUTOFRANGE, s_vector_move_right_x);
SCM_ASSERT (j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME);
while (i < e)
SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e];
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

31
libguile/version.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include "_scm.h"
@ -48,33 +52,36 @@
/* Return a Scheme string containing Guile's major version number. */
SCM_PROC(s_major_version, "major-version", 0, 0, 0, scm_major_version);
SCM
scm_major_version ()
GUILE_PROC(scm_major_version, "major-version", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_major_version
{
return scm_makfrom0str (GUILE_MAJOR_VERSION);
}
#undef FUNC_NAME
/* Return a Scheme string containing Guile's minor version number. */
SCM_PROC(s_minor_version, "minor-version", 0, 0, 0, scm_minor_version);
SCM
scm_minor_version ()
GUILE_PROC(scm_minor_version, "minor-version", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_minor_version
{
return scm_makfrom0str (GUILE_MINOR_VERSION);
}
#undef FUNC_NAME
/* Return a Scheme string containing Guile's complete version. */
SCM_PROC(s_version, "version", 0, 0, 0, scm_version);
SCM
scm_version ()
GUILE_PROC(scm_version, "version", 0, 0, 0,
(),
"")
#define FUNC_NAME s_scm_version
{
return scm_makfrom0str (GUILE_VERSION);
}
#undef FUNC_NAME

20
libguile/vports.c
View file

@ -38,6 +38,10 @@
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
@ -46,6 +50,7 @@
#include "chars.h"
#include "fports.h"
#include "scm_validate.h"
#include "vports.h"
#ifdef HAVE_STRING_H
@ -132,17 +137,15 @@ sf_close (SCM port)
SCM_PROC(s_make_soft_port, "make-soft-port", 2, 0, 0, scm_make_soft_port);
SCM
scm_make_soft_port (pv, modes)
SCM pv;
SCM modes;
GUILE_PROC(scm_make_soft_port, "make-soft-port", 2, 0, 0,
(SCM pv, SCM modes),
"")
#define FUNC_NAME s_scm_make_soft_port
{
scm_port *pt;
SCM z;
SCM_ASSERT (SCM_NIMP (pv) && SCM_VECTORP (pv) && 5 == SCM_LENGTH (pv), pv, SCM_ARG1, s_make_soft_port);
SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_make_soft_port);
SCM_VALIDATE_VECTOR_LEN(1,pv,5);
SCM_VALIDATE_ROSTRING(2,modes);
SCM_COERCE_SUBSTR (modes);
SCM_NEWCELL (z);
SCM_DEFER_INTS;
@ -158,6 +161,7 @@ scm_make_soft_port (pv, modes)
SCM_ALLOW_INTS;
return z;
}
#undef FUNC_NAME
void scm_make_sfptob (void); /* Called from ports.c */

121
libguile/weaks.c
View file

@ -38,10 +38,15 @@
* If you write modifications of your own for this library, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
#include <stdio.h>
#include "_scm.h"
#include "scm_validate.h"
#include "weaks.h"
@ -50,12 +55,10 @@
*/
SCM_PROC(s_make_weak_vector, "make-weak-vector", 1, 1, 0, scm_make_weak_vector);
SCM
scm_make_weak_vector (k, fill)
SCM k;
SCM fill;
GUILE_PROC(scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
(SCM k, SCM fill),
"")
#define FUNC_NAME s_scm_make_weak_vector
{
SCM v;
v = scm_make_vector (scm_sum (k, SCM_MAKINUM (2)), fill);
@ -67,21 +70,22 @@ scm_make_weak_vector (k, fill)
SCM_ALLOW_INTS;
return v;
}
#undef FUNC_NAME
SCM_PROC(s_weak_vector, "weak-vector", 0, 0, 1, scm_weak_vector);
SCM_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
SCM
scm_weak_vector (l)
SCM l;
GUILE_PROC(scm_weak_vector, "weak-vector", 0, 0, 1,
(SCM l),
"")
#define FUNC_NAME s_scm_weak_vector
{
SCM res;
register SCM *data;
long i;
i = scm_ilength (l);
SCM_ASSERT (i >= 0, l, SCM_ARG1, s_weak_vector);
SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
data = SCM_VELTS (res);
for (;
@ -90,18 +94,17 @@ scm_weak_vector (l)
*data++ = SCM_CAR (l);
return res;
}
#undef FUNC_NAME
SCM_PROC(s_weak_vector_p, "weak-vector?", 1, 0, 0, scm_weak_vector_p);
SCM
scm_weak_vector_p (x)
SCM x;
GUILE_PROC(scm_weak_vector_p, "weak-vector?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_weak_vector_p
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x));
}
#undef FUNC_NAME
@ -109,88 +112,82 @@ scm_weak_vector_p (x)
SCM_PROC(s_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, scm_make_weak_key_hash_table);
SCM
scm_make_weak_key_hash_table (k)
SCM k;
GUILE_PROC(scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0,
(SCM k),
"")
#define FUNC_NAME s_scm_make_weak_key_hash_table
{
SCM v;
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_key_hash_table);
SCM_VALIDATE_INT(1,k);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 1;
SCM_ALLOW_INTS;
return v;
}
#undef FUNC_NAME
SCM_PROC (s_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, scm_make_weak_value_hash_table);
SCM
scm_make_weak_value_hash_table (k)
SCM k;
GUILE_PROC (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0,
(SCM k),
"")
#define FUNC_NAME s_scm_make_weak_value_hash_table
{
SCM v;
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table);
SCM_VALIDATE_INT(1,k);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 2;
SCM_ALLOW_INTS;
return v;
}
#undef FUNC_NAME
SCM_PROC (s_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, scm_make_doubly_weak_hash_table);
SCM
scm_make_doubly_weak_hash_table (k)
SCM k;
GUILE_PROC (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
(SCM k),
"")
#define FUNC_NAME s_scm_make_doubly_weak_hash_table
{
SCM v;
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_doubly_weak_hash_table);
SCM_VALIDATE_INT(1,k);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 3;
SCM_ALLOW_INTS;
return v;
}
#undef FUNC_NAME
SCM_PROC(s_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, scm_weak_key_hash_table_p);
SCM
scm_weak_key_hash_table_p (x)
SCM x;
GUILE_PROC(scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_weak_key_hash_table_p
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x));
}
#undef FUNC_NAME
SCM_PROC (s_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, scm_weak_value_hash_table_p);
SCM
scm_weak_value_hash_table_p (x)
SCM x;
GUILE_PROC (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_weak_value_hash_table_p
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x));
}
#undef FUNC_NAME
SCM_PROC (s_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, scm_doubly_weak_hash_table_p);
SCM
scm_doubly_weak_hash_table_p (x)
SCM x;
GUILE_PROC (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
(SCM x),
"")
#define FUNC_NAME s_scm_doubly_weak_hash_table_p
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x))
? SCM_BOOL_T
: SCM_BOOL_F);
return SCM_BOOL(SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x));
}
#undef FUNC_NAME