"I'm not proud of it"
(Olin Shivers) R.I.P cig 1994 - 2003
This commit is contained in:
parent
f2c4ddb44d
commit
29ed0edb27
84
Makefile.in
84
Makefile.in
|
@ -42,7 +42,7 @@ htmldir = $(libdir)/scsh/doc/scsh-manual/html
|
||||||
# LDFLAGS = -N
|
# LDFLAGS = -N
|
||||||
|
|
||||||
.c.o:
|
.c.o:
|
||||||
$(CC) -g -c $(DEFS) -I$(srcdir)/c -I$(srcdir)/cig $(CPPFLAGS) $(CFLAGS) -o $@ $<
|
$(CC) -g -c $(DEFS) -I$(srcdir)/c $(CPPFLAGS) $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
# BUILD_RUNNABLE has to be Scheme 48 0.53. This is used for builds directly
|
# BUILD_RUNNABLE has to be Scheme 48 0.53. This is used for builds directly
|
||||||
# out of the CVS repository.
|
# out of the CVS repository.
|
||||||
|
@ -103,9 +103,6 @@ START_LINKER = echo ',batch' && echo ',bench on'
|
||||||
IMAGE = scheme48.image
|
IMAGE = scheme48.image
|
||||||
INITIAL = build/initial.image
|
INITIAL = build/initial.image
|
||||||
VM = scshvm
|
VM = scshvm
|
||||||
LIBCIG = cig/lib$(VM).a
|
|
||||||
CIG = cig/cig
|
|
||||||
CIGOBJS = cig/libcig.o cig/libcig1.o
|
|
||||||
|
|
||||||
#scsh-lib
|
#scsh-lib
|
||||||
LIBSCSHVM = scsh/lib$(VM).a
|
LIBSCSHVM = scsh/lib$(VM).a
|
||||||
|
@ -138,7 +135,7 @@ SCSH_INITIALIZERS = s48_init_syslog s48_init_posix_regexp \
|
||||||
s48_init_userinfo s48_init_sighandlers \
|
s48_init_userinfo s48_init_sighandlers \
|
||||||
s48_init_syscalls s48_init_network s48_init_flock \
|
s48_init_syscalls s48_init_network s48_init_flock \
|
||||||
s48_init_dirstuff s48_init_time s48_init_tty \
|
s48_init_dirstuff s48_init_time s48_init_tty \
|
||||||
s48_init_cig s48_init_libscsh s48_init_md5
|
s48_init_libscsh s48_init_md5
|
||||||
|
|
||||||
UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
|
UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
|
||||||
|
|
||||||
|
@ -147,7 +144,7 @@ SRFI_OBJS = c/srfi/srfi-27.o
|
||||||
SRFI_INITIALIZERS = s48_init_srfi_27
|
SRFI_INITIALIZERS = s48_init_srfi_27
|
||||||
|
|
||||||
S48OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o c/external.o
|
S48OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o c/external.o
|
||||||
OBJS = scsh/process_args.o c/init.o $(S48OBJS) $(CIGOBJS) $(SCSHOBJS) \
|
OBJS = scsh/process_args.o c/init.o $(S48OBJS) $(SCSHOBJS) \
|
||||||
$(SCSHVMHACKS) $(SRFI_OBJS)
|
$(SCSHVMHACKS) $(SRFI_OBJS)
|
||||||
|
|
||||||
FAKEHS = c/fake/dlfcn.h c/fake/sigact.h c/fake/strerror.h \
|
FAKEHS = c/fake/dlfcn.h c/fake/sigact.h c/fake/strerror.h \
|
||||||
|
@ -162,7 +159,7 @@ CONFIG_FILES = scheme/interfaces.scm scheme/low-packages.scm \
|
||||||
|
|
||||||
# The following is the first rule and therefore the "make" command's
|
# The following is the first rule and therefore the "make" command's
|
||||||
# default target.
|
# default target.
|
||||||
enough: $(VM) $(IMAGE) go $(LIBCIG) scsh $(LIBSCSH) $(LIBSCSHVM)
|
enough: $(VM) $(IMAGE) go scsh $(LIBSCSH) $(LIBSCSHVM)
|
||||||
|
|
||||||
# --------------------
|
# --------------------
|
||||||
# External code to include in the VM
|
# External code to include in the VM
|
||||||
|
@ -173,7 +170,6 @@ EXTERNAL_FLAGS = $(SOCKET_FLAGS)
|
||||||
EXTERNAL_INITIALIZERS = $(ADDITIONAL_INITIALIZER) $(SOCKET_INITIALIZERS) \
|
EXTERNAL_INITIALIZERS = $(ADDITIONAL_INITIALIZER) $(SOCKET_INITIALIZERS) \
|
||||||
$(LOOKUP_INITIALIZERS) \
|
$(LOOKUP_INITIALIZERS) \
|
||||||
$(SCSH_INITIALIZERS) $(SRFI_INITIALIZERS) \
|
$(SCSH_INITIALIZERS) $(SRFI_INITIALIZERS) \
|
||||||
s48_init_cig
|
|
||||||
|
|
||||||
|
|
||||||
# Rules for any external code.
|
# Rules for any external code.
|
||||||
|
@ -214,11 +210,6 @@ ADDITIONAL_INITIALIZER = s48_init_additional_inits
|
||||||
infestation. | mail scsh-notifications@zurich.ai.mit.edu
|
infestation. | mail scsh-notifications@zurich.ai.mit.edu
|
||||||
|
|
||||||
|
|
||||||
# This says how to process .scm files with cig to make .c stubs.
|
|
||||||
#.SUFFIXES: .scm
|
|
||||||
#.scm.c:
|
|
||||||
# $(srcdir)/$(VM) -o $(srcdir)/$(VM) -i $(CIG) < $< > $*.c
|
|
||||||
|
|
||||||
# These .h files mediate between the code exported from foo1.c
|
# These .h files mediate between the code exported from foo1.c
|
||||||
# and imported into foo.scm's stub foo.c.
|
# and imported into foo.scm's stub foo.c.
|
||||||
|
|
||||||
|
@ -252,13 +243,6 @@ $(VM): c/main.o $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#JMG: again cig and scsh-lib
|
|
||||||
$(LIBCIG): c/main.o $(OBJS)
|
|
||||||
# $(CC) -r -o $@ main.o $(OBJS)
|
|
||||||
$(RM) $@
|
|
||||||
$(AR) $@ c/main.o $(OBJS)
|
|
||||||
$(RANLIB) $@
|
|
||||||
|
|
||||||
$(LIBSCSHVM): c/smain.o $(OBJS)
|
$(LIBSCSHVM): c/smain.o $(OBJS)
|
||||||
$(RM) $@
|
$(RM) $@
|
||||||
$(AR) $@ c/smain.o $(OBJS)
|
$(AR) $@ c/smain.o $(OBJS)
|
||||||
|
@ -338,12 +322,6 @@ inst-inc:
|
||||||
$(INSTALL_DATA) $(srcdir)/c/scheme48.h $(incdir)
|
$(INSTALL_DATA) $(srcdir)/c/scheme48.h $(incdir)
|
||||||
$(INSTALL_DATA) $(srcdir)/c/write-barrier.h $(incdir)
|
$(INSTALL_DATA) $(srcdir)/c/write-barrier.h $(incdir)
|
||||||
|
|
||||||
install-cig: cig
|
|
||||||
$(INSTALL_PROGRAM) $(srcdir)/$(CIG) $(LIB)/cig
|
|
||||||
$(INSTALL_PROGRAM) $(srcdir)/$(CIG).image $(LIB)/cig
|
|
||||||
$(INSTALL_DATA) $(srcdir)/$(LIBCIG) $(LIB)/cig
|
|
||||||
$(INSTALL_DATA) $(srcdir)/cig/libcig.h $(LIB)/cig
|
|
||||||
|
|
||||||
inst-misc:
|
inst-misc:
|
||||||
for stub in env big opt misc link srfi; do \
|
for stub in env big opt misc link srfi; do \
|
||||||
for f in scheme/$$stub/*.scm; do \
|
for f in scheme/$$stub/*.scm; do \
|
||||||
|
@ -417,7 +395,7 @@ dirs:
|
||||||
done && \
|
done && \
|
||||||
for dir in \
|
for dir in \
|
||||||
rts env big opt misc link srfi scsh doc/scsh-manual \
|
rts env big opt misc link srfi scsh doc/scsh-manual \
|
||||||
doc/s48-manual/html doc/scsh-paper/html cig; do \
|
doc/s48-manual/html doc/scsh-paper/html ; do \
|
||||||
{ mkdir -p $(LIB)/$$dir && [ -w $(LIB)/$$dir ]; } || { \
|
{ mkdir -p $(LIB)/$$dir && [ -w $(LIB)/$$dir ]; } || { \
|
||||||
echo "$(LIB)/$$dir not a writable directory" >&2; \
|
echo "$(LIB)/$$dir not a writable directory" >&2; \
|
||||||
exit 1; \
|
exit 1; \
|
||||||
|
@ -427,7 +405,7 @@ dirs:
|
||||||
configure: configure.in
|
configure: configure.in
|
||||||
autoheader && autoconf
|
autoheader && autoconf
|
||||||
|
|
||||||
clean: clean-cig clean-scsh
|
clean: clean-scsh
|
||||||
-rm -f $(VM) *.o c/*/*.o c/*.o \
|
-rm -f $(VM) *.o c/*/*.o c/*.o \
|
||||||
$(IMAGE) \
|
$(IMAGE) \
|
||||||
build/*.tmp $(MANPAGE) build/linker.image \
|
build/*.tmp $(MANPAGE) build/linker.image \
|
||||||
|
@ -435,9 +413,6 @@ clean: clean-cig clean-scsh
|
||||||
scheme/vm/scheme48vm.c scheme/vm/scheme48heap.c \
|
scheme/vm/scheme48vm.c scheme/vm/scheme48heap.c \
|
||||||
go $(distname)
|
go $(distname)
|
||||||
|
|
||||||
clean-cig:
|
|
||||||
-rm -f cig/*.o $(CIG) $(CIG).image $(LIBCIG)
|
|
||||||
|
|
||||||
distclean: clean
|
distclean: clean
|
||||||
rm -f Makefile config.log config.status c/sysdep.h config.cache \
|
rm -f Makefile config.log config.status c/sysdep.h config.cache \
|
||||||
scsh/machine \
|
scsh/machine \
|
||||||
|
@ -497,7 +472,6 @@ DISTFILES = README COPYING INSTALL RELEASE configure config.sub config.guess \
|
||||||
scsh/*.scm scsh/*/*.scm \
|
scsh/*.scm scsh/*/*.scm \
|
||||||
scsh/*.[ch] scsh/*/*.[ch] \
|
scsh/*.[ch] scsh/*/*.[ch] \
|
||||||
scsh/*.scm.in scsh/*/Makefile.inc \
|
scsh/*.scm.in scsh/*/Makefile.inc \
|
||||||
cig/*.scm cig/*.[ch] \
|
|
||||||
doc/scsh.man \
|
doc/scsh.man \
|
||||||
doc/scsh-manual/*.tex doc/scsh-manual/*.sty \
|
doc/scsh-manual/*.tex doc/scsh-manual/*.sty \
|
||||||
doc/scsh-manual/man.ps doc/scsh-manual/man.pdf \
|
doc/scsh-manual/man.ps doc/scsh-manual/man.pdf \
|
||||||
|
@ -537,7 +511,8 @@ dist: build/initial.image
|
||||||
else \
|
else \
|
||||||
echo "Can't write $$distfile" >&2; \
|
echo "Can't write $$distfile" >&2; \
|
||||||
exit 1; \
|
exit 1; \
|
||||||
fi
|
fi && \
|
||||||
|
echo "Hope you already called ./autogen..."
|
||||||
|
|
||||||
# Increment the minor version number
|
# Increment the minor version number
|
||||||
inc:
|
inc:
|
||||||
|
@ -730,40 +705,6 @@ i-know-what-i-am-doing:
|
||||||
) | $(BUILD_RUNNABLE) -h 5000000 && \
|
) | $(BUILD_RUNNABLE) -h 5000000 && \
|
||||||
mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c
|
mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c
|
||||||
|
|
||||||
cig: $(CIG) $(CIG).image $(LIBCIG)
|
|
||||||
|
|
||||||
|
|
||||||
$(CIG): $(VM) $(IMAGE) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm
|
|
||||||
(echo ",batch"; \
|
|
||||||
echo ",translate =scheme48/ $(srcdir)/scheme/"; \
|
|
||||||
echo ",config ,load $(srcdir)/cig/cig.scm"; \
|
|
||||||
echo ",config ,load $(srcdir)/cig/libcig.scm"; \
|
|
||||||
echo ",load-package cig-standalone"; \
|
|
||||||
echo ",in cig-standalone"; \
|
|
||||||
echo ",translate =scheme48/ $(LIB)/"; \
|
|
||||||
echo ",build cig-standalone-toplevel /tmp/cig") \
|
|
||||||
| ./$(VM) -i ./$(IMAGE)
|
|
||||||
$(srcdir)/cig/image2script $(LIB)/$(VM) </tmp/cig > $(CIG)
|
|
||||||
-chmod +x $(CIG)
|
|
||||||
mv /tmp/cig $(srcdir)/cig/cig_bootstrap
|
|
||||||
$(RM) /tmp/cig
|
|
||||||
|
|
||||||
$(CIG).image: $(IMAGE) $(VM) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm
|
|
||||||
(echo ",batch"; \
|
|
||||||
echo ",translate =scheme48/ $(srcdir)/scheme/"; \
|
|
||||||
echo ",config ,load $(srcdir)/cig/cig.scm"; \
|
|
||||||
echo ",config ,load $(srcdir)/cig/libcig.scm"; \
|
|
||||||
echo ",load-package cig-aux"; \
|
|
||||||
echo ",open define-foreign-syntax"; \
|
|
||||||
echo ",translate =scheme48/ $(LIB)/"; \
|
|
||||||
echo ",dump /tmp/cig \"(CIG Preloaded -bri)\"") \
|
|
||||||
| ./$(VM) -o ./$(VM) -i ./$(IMAGE)
|
|
||||||
$(srcdir)/cig/image2script $(LIB)/$(VM) \
|
|
||||||
-o $(LIB)/$(VM) \
|
|
||||||
</tmp/cig > $(CIG).image
|
|
||||||
-chmod +x $(CIG).image
|
|
||||||
$(RM) /tmp/cig
|
|
||||||
|
|
||||||
#-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
#-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
# SCSH Specifics
|
# SCSH Specifics
|
||||||
#-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
#-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
|
@ -858,21 +799,12 @@ SCHEME =scsh/awk.scm \
|
||||||
# scsh/dbm.scm db.scm ndbm.scm
|
# scsh/dbm.scm db.scm ndbm.scm
|
||||||
# jcontrol
|
# jcontrol
|
||||||
|
|
||||||
# Bogus, but it makes the scm->c->o two-ply dependency work.
|
|
||||||
# Explicitly giving the .o/.c dependency also makes it go.
|
|
||||||
############################################################
|
|
||||||
cig/libcig.c: cig/libcig.scm
|
|
||||||
|
|
||||||
scsh/scsh: scsh/scsh-tramp.c
|
scsh/scsh: scsh/scsh-tramp.c
|
||||||
$(CC) -o $@ $(CPPFLAGS) $(CFLAGS) \
|
$(CC) -o $@ $(CPPFLAGS) $(CFLAGS) \
|
||||||
-DVM=\"$(LIB)/$(VM)\" \
|
-DVM=\"$(LIB)/$(VM)\" \
|
||||||
-DIMAGE=\"$(LIB)/scsh.image\" \
|
-DIMAGE=\"$(LIB)/scsh.image\" \
|
||||||
scsh/scsh-tramp.c
|
scsh/scsh-tramp.c
|
||||||
|
|
||||||
bs: build/build-scsh-image
|
|
||||||
sh $(srcdir)/build/build-scsh-image "$(srcdir)" "$(LIB)" "$(IMAGE)" \
|
|
||||||
"$(VM)" cig/cig.image
|
|
||||||
|
|
||||||
loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
|
loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
|
||||||
$(srcdir)/scsh/machine/packages.scm \
|
$(srcdir)/scsh/machine/packages.scm \
|
||||||
$(srcdir)/scsh/rx/packages.scm \
|
$(srcdir)/scsh/rx/packages.scm \
|
||||||
|
|
|
@ -1,3 +0,0 @@
|
||||||
cig
|
|
||||||
cig.image
|
|
||||||
|
|
1171
cig/cig.scm
1171
cig/cig.scm
File diff suppressed because it is too large
Load Diff
|
@ -1,48 +0,0 @@
|
||||||
#!/bin/sh -
|
|
||||||
|
|
||||||
binary=$1
|
|
||||||
shift
|
|
||||||
|
|
||||||
if [ `echo $binary | wc -c` -gt 28 ] ; then
|
|
||||||
echo "#!/bin/sh -"
|
|
||||||
echo exec $binary $* -i '"$0"' '"$@"'
|
|
||||||
|
|
||||||
elif [ $# -gt 0 ] ; then
|
|
||||||
echo '#!'$binary \\
|
|
||||||
echo $* -i
|
|
||||||
|
|
||||||
else echo '#!'$binary -i
|
|
||||||
fi
|
|
||||||
|
|
||||||
exec cat
|
|
||||||
|
|
||||||
|
|
||||||
# This program reads an S48 image from stdin and turns it into
|
|
||||||
# an executable by prepending a #! prefix. The vm and its
|
|
||||||
# args are passed to this program on the command line.
|
|
||||||
#
|
|
||||||
# If the vm binary is 27 chars or less, then we can directly
|
|
||||||
# execute the vm with one of these scripts:
|
|
||||||
# No args:
|
|
||||||
# image2script /usr/local/bin/svm <image
|
|
||||||
# outputs this script:
|
|
||||||
# #!/usr/local/bin/svm -i
|
|
||||||
# ...image bits follow...
|
|
||||||
#
|
|
||||||
# Args:
|
|
||||||
# image2script /usr/bin/svm -h 4000000 -o /usr/bin/svm <image
|
|
||||||
# outputs this script:
|
|
||||||
# #!/usr/bin/svm \
|
|
||||||
# -h 4000000 -o /usr/bin/svm -i
|
|
||||||
# ...image bits follow...
|
|
||||||
#
|
|
||||||
# The exec system call won't handle the #! line if it contains more than
|
|
||||||
# 32 chars, so if the vm binary is over 28 chars, we have to use a /bin/sh
|
|
||||||
# trampoline.
|
|
||||||
# image2script /user1/lecturer/shivers/vc/scsh/s48/lib/svm -h 4000000 < ...
|
|
||||||
# outputs this script:
|
|
||||||
# #!/bin/sh -
|
|
||||||
# exec /user1/lecturer/shivers/vc/scsh/s48/lib/svm -h 4000000 -i $0 $*
|
|
||||||
# ...image bits follow...
|
|
||||||
#
|
|
||||||
# -Olin
|
|
117
cig/libcig.c
117
cig/libcig.c
|
@ -1,117 +0,0 @@
|
||||||
/* This is an Scheme48/C interface file,
|
|
||||||
** automatically generated by a hacked version of cig 3.0.
|
|
||||||
step 4
|
|
||||||
*/
|
|
||||||
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h> /* For malloc. */
|
|
||||||
#include "libcig.h"
|
|
||||||
|
|
||||||
s48_value df_strlen_or_false(s48_value g1)
|
|
||||||
{
|
|
||||||
extern s48_value strlen_or_false(const char * );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
s48_value r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = strlen_or_false((const char * )AlienVal(g1));
|
|
||||||
ret1 = r1;
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_cstring_nullp(s48_value g1)
|
|
||||||
{
|
|
||||||
extern int cstring_nullp(const char * );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = cstring_nullp((const char * )AlienVal(g1));
|
|
||||||
ret1 = ENTER_BOOLEAN(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_c2scheme_strcpy_free(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern int c2scheme_strcpy_free(s48_value , char* );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = c2scheme_strcpy_free(g1, (char* )AlienVal(g2));
|
|
||||||
ret1 = ENTER_BOOLEAN(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_c2scheme_strcpy(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern int c2scheme_strcpy(s48_value , char* );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = c2scheme_strcpy(g1, (char* )AlienVal(g2));
|
|
||||||
ret1 = ENTER_BOOLEAN(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_c_veclen(s48_value g1)
|
|
||||||
{
|
|
||||||
extern s48_value c_veclen(long* );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
s48_value r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = c_veclen((long* )AlienVal(g1));
|
|
||||||
ret1 = r1;
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_free(s48_value g1)
|
|
||||||
{
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
free((void* )AlienVal(g1));
|
|
||||||
return S48_FALSE;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_set_strvec_carriers(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern void set_strvec_carriers(s48_value , char** );
|
|
||||||
|
|
||||||
|
|
||||||
set_strvec_carriers(g1, (char** )AlienVal(g2));
|
|
||||||
return S48_FALSE;
|
|
||||||
}
|
|
||||||
|
|
||||||
void s48_init_cig(void)
|
|
||||||
{
|
|
||||||
S48_EXPORT_FUNCTION(df_strlen_or_false);
|
|
||||||
S48_EXPORT_FUNCTION(df_cstring_nullp);
|
|
||||||
S48_EXPORT_FUNCTION(df_c2scheme_strcpy_free);
|
|
||||||
S48_EXPORT_FUNCTION(df_c2scheme_strcpy);
|
|
||||||
S48_EXPORT_FUNCTION(df_c_veclen);
|
|
||||||
S48_EXPORT_FUNCTION(df_free);
|
|
||||||
S48_EXPORT_FUNCTION(df_set_strvec_carriers);
|
|
||||||
}
|
|
32
cig/libcig.h
32
cig/libcig.h
|
@ -1,32 +0,0 @@
|
||||||
#include "scheme48.h"
|
|
||||||
|
|
||||||
/* StobData is used by fdports.c. It should be changed over to STOB_REF
|
|
||||||
** by removing the extra indirection. */
|
|
||||||
#define StobData(x) (S48_ADDRESS_AFTER_HEADER(x, s48_value))
|
|
||||||
|
|
||||||
#define IsChar(x) ((((long) x) & 0xff) == S48_CHAR)
|
|
||||||
/* JMG: untested !! */
|
|
||||||
|
|
||||||
#define StrByte(x, i) ((i) + S48_ADDRESS_AFTER_HEADER((x), char))
|
|
||||||
#define cig_string_body(x) (S48_ADDRESS_AFTER_HEADER((x), char))
|
|
||||||
|
|
||||||
#define AlienVal(x) (S48_STOB_REF((x),0))
|
|
||||||
/* JMG: no () around this, because it's a do..while(0) */
|
|
||||||
#define SetAlienVal(x, v) S48_STOB_SET((x), 0, (v))
|
|
||||||
|
|
||||||
/* JMG: some hacks to leave to old sources untouched */
|
|
||||||
#define ENTER_BOOLEAN(x) (x ? S48_TRUE : S48_FALSE)
|
|
||||||
#define EXTRACT_BOOLEAN(x) ((x==S48_TRUE) ? 1 : 0)
|
|
||||||
/* #define ENTER_FIXNUM(x) (s48_enter_fixnum(x)) */
|
|
||||||
/* #define SCHFALSE S48_FALSE */
|
|
||||||
|
|
||||||
extern char *scheme2c_strcpy(s48_value sstr);
|
|
||||||
|
|
||||||
extern s48_value strlen_or_false(const char *s);
|
|
||||||
|
|
||||||
extern char *copystring_or_die(const char *);
|
|
||||||
extern char *copystring(char *, const char *);
|
|
||||||
|
|
||||||
extern s48_value strlen_or_false(const char *);
|
|
||||||
|
|
||||||
extern void cig_check_nargs(int arity, int nargs, const char *fn);
|
|
139
cig/libcig.scm
139
cig/libcig.scm
|
@ -1,139 +0,0 @@
|
||||||
;;; (DEFINE-FOREIGN ...) forms are expanded by Cig into Scheme stubs.
|
|
||||||
;;; These stubs reference some support procedures to rep-convert the
|
|
||||||
;;; standard reps (e.g., string). This structure provides these support
|
|
||||||
;;; procedures.
|
|
||||||
;;;
|
|
||||||
;;; We export three kinds of things:
|
|
||||||
;;; - Type predicates that aren't in the R4RS env (e.g., FIXNUM?).
|
|
||||||
;;; - Carrier makers for making boxes to return things in.
|
|
||||||
;;; - Scheme-side rep-converters for return values.
|
|
||||||
|
|
||||||
(define-structure cig-aux
|
|
||||||
(export cstring-null?
|
|
||||||
C->scheme-string
|
|
||||||
C->scheme-string-w/len
|
|
||||||
C->scheme-string-w/len-no-free
|
|
||||||
C-string-vec->Scheme&free
|
|
||||||
C-string-vec->Scheme ; Bogus, because clients not reentrant.
|
|
||||||
string-carrier->string
|
|
||||||
string-carrier->string-no-free
|
|
||||||
fixnum?
|
|
||||||
make-string-carrier
|
|
||||||
make-alien
|
|
||||||
alien?
|
|
||||||
)
|
|
||||||
(open scheme code-vectors define-foreign-syntax)
|
|
||||||
|
|
||||||
(begin
|
|
||||||
(define min-fixnum (- (expt 2 29)))
|
|
||||||
(define max-fixnum (- (expt 2 29) 1))
|
|
||||||
(define (fixnum? x) (and (integer? x) (<= min-fixnum x max-fixnum)))
|
|
||||||
|
|
||||||
;; Internal utility.
|
|
||||||
(define (mapv! f v)
|
|
||||||
(let ((len (vector-length v)))
|
|
||||||
(do ((i 0 (+ i 1)))
|
|
||||||
((= i len) v)
|
|
||||||
(vector-set! v i (f (vector-ref v i))))))
|
|
||||||
|
|
||||||
;; Make a carrier for returning strings.
|
|
||||||
;; It holds a raw C string and a fixnum giving the length of the string.
|
|
||||||
(define (make-string-carrier) (cons (make-alien) 0))
|
|
||||||
|
|
||||||
(define (make-alien) (make-code-vector 4 0))
|
|
||||||
(define (alien? x) (and (code-vector? x) (= 4 (code-vector-length x)))) ; BOGUS
|
|
||||||
|
|
||||||
|
|
||||||
;;; C/Scheme string and vector conversion
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
;;; Generally speaking, in the following routines,
|
|
||||||
;;; a NULL C string param causes a function to return #f.
|
|
||||||
(foreign-init-name "cig")
|
|
||||||
|
|
||||||
(define-foreign %cstring-length-or-false
|
|
||||||
(strlen_or_false ((C "const char * ~a") cstr))
|
|
||||||
desc)
|
|
||||||
|
|
||||||
(define-foreign cstring-null?
|
|
||||||
(cstring_nullp ((C "const char * ~a") cstr))
|
|
||||||
bool)
|
|
||||||
|
|
||||||
(define-foreign %copy-c-string&free
|
|
||||||
(c2scheme_strcpy_free (string-desc sstr) ((C char*) cstr))
|
|
||||||
bool)
|
|
||||||
|
|
||||||
(define-foreign %copy-c-string
|
|
||||||
(c2scheme_strcpy (string-desc sstr) ((C char*) cstr))
|
|
||||||
bool)
|
|
||||||
|
|
||||||
(define (C->scheme-string cstr)
|
|
||||||
(cond ((%cstring-length-or-false cstr)
|
|
||||||
=> (lambda (strlen)
|
|
||||||
(let ((str (make-string strlen)))
|
|
||||||
(%copy-c-string&free str cstr)
|
|
||||||
str)))
|
|
||||||
(else #f)))
|
|
||||||
|
|
||||||
(define (C->scheme-string-w/len cstr len)
|
|
||||||
(and (integer? len)
|
|
||||||
(let ((str (make-string len)))
|
|
||||||
(%copy-c-string&free str cstr)
|
|
||||||
str)))
|
|
||||||
|
|
||||||
(define (C->scheme-string-w/len-no-free cstr len)
|
|
||||||
(and (integer? len)
|
|
||||||
(let ((str (make-string len)))
|
|
||||||
(%copy-c-string str cstr)
|
|
||||||
str)))
|
|
||||||
|
|
||||||
(define (string-carrier->string carrier)
|
|
||||||
(C->scheme-string-w/len (car carrier) (cdr carrier)))
|
|
||||||
|
|
||||||
(define (string-carrier->string-no-free carrier)
|
|
||||||
(C->scheme-string-w/len-no-free (car carrier) (cdr carrier)))
|
|
||||||
|
|
||||||
;;; Return the length of a null-terminated C word vector.
|
|
||||||
;;; Does not count the null word as part of the length.
|
|
||||||
;;; If vector is NULL, returns #f.
|
|
||||||
|
|
||||||
(define-foreign %c-veclen-or-false
|
|
||||||
(c_veclen ((C long*) c-vec))
|
|
||||||
desc) ; integer or #f if arg is NULL.
|
|
||||||
|
|
||||||
;;; CVEC is a C vector of char* strings, length VECLEN.
|
|
||||||
;;; This procedure converts a C vector of strings into a Scheme vector of
|
|
||||||
;;; strings. The C vector and its strings are all assumed to come from
|
|
||||||
;;; the malloc heap; they are returned to the heap when the rep-conversion
|
|
||||||
;;; is done.
|
|
||||||
;;;
|
|
||||||
;;; Hack: if VECLEN is #f, CVEC is assumed to be NULL terminated, and
|
|
||||||
;;; its length is calculated thusly.
|
|
||||||
|
|
||||||
(define (C-string-vec->Scheme&free cvec veclen)
|
|
||||||
(let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
|
|
||||||
(mapv! (lambda (ignore) (make-string-carrier)) vec)
|
|
||||||
(%set-string-vector-carriers! vec cvec)
|
|
||||||
(C-free cvec)
|
|
||||||
(mapv! string-carrier->string vec)))
|
|
||||||
|
|
||||||
(define (C-string-vec->Scheme cvec veclen) ; No free.
|
|
||||||
(let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
|
|
||||||
(mapv! (lambda (ignore) (make-string-carrier)) vec)
|
|
||||||
(%set-string-vector-carriers! vec cvec)
|
|
||||||
(mapv! string-carrier->string-no-free vec)))
|
|
||||||
|
|
||||||
|
|
||||||
(define-foreign C-free (free ((C void*) ptr)) no-declare ; for SunOS 4.x
|
|
||||||
ignore)
|
|
||||||
|
|
||||||
(define-foreign %set-string-vector-carriers!
|
|
||||||
(set_strvec_carriers (vector-desc svec) ((C char**) cvec))
|
|
||||||
ignore)
|
|
||||||
|
|
||||||
)) ; egakcap
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
163
cig/libcig1.c
163
cig/libcig1.c
|
@ -1,163 +0,0 @@
|
||||||
/* Generic routines for Scheme48/C interfacing -- mostly for converting
|
|
||||||
** strings and null-terminated vectors back and forth.
|
|
||||||
** Copyright (c) 1993 by Olin Shivers.
|
|
||||||
*/
|
|
||||||
|
|
||||||
#include "libcig.h"
|
|
||||||
#include <string.h>
|
|
||||||
#include <stddef.h>
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
#include <errno.h>
|
|
||||||
|
|
||||||
#define Malloc(type,n) ((type *) malloc(sizeof(type)*(n)))
|
|
||||||
#define Free(p) (free((char *)(p)))
|
|
||||||
|
|
||||||
/* (c2scheme_strcpy dest_scheme_string source_C_string)
|
|
||||||
** Copies C string's chars into Scheme string. Return #t.
|
|
||||||
** If C string is NULL, do nothing and return #f.
|
|
||||||
*/
|
|
||||||
|
|
||||||
int c2scheme_strcpy(s48_value sstr, const char *cstr)
|
|
||||||
{
|
|
||||||
if( cstr ) {
|
|
||||||
strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
else return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/* Same as above, but free the C string when we are done. */
|
|
||||||
int c2scheme_strcpy_free(s48_value sstr, const char *cstr)
|
|
||||||
{
|
|
||||||
if( cstr ) {
|
|
||||||
strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
|
|
||||||
Free(cstr);
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
else return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
char *scheme2c_strcpy(s48_value sstr)
|
|
||||||
{
|
|
||||||
char *result;
|
|
||||||
int slen;
|
|
||||||
|
|
||||||
slen = S48_STRING_LENGTH(sstr);
|
|
||||||
result = Malloc(char, slen+1);
|
|
||||||
|
|
||||||
if( result == NULL ) {
|
|
||||||
fprintf(stderr,
|
|
||||||
"Fatal error: C stub tried to copy Scheme string,\n"
|
|
||||||
"but malloc failed on arg 0x%x, errno %d.\n",
|
|
||||||
sstr, errno);
|
|
||||||
exit(-1);
|
|
||||||
}
|
|
||||||
|
|
||||||
memcpy(result, cig_string_body(sstr), slen);
|
|
||||||
result[slen] = '\000';
|
|
||||||
return result;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/* One arg, a zero-terminated C word vec. Returns length.
|
|
||||||
** The terminating null is not counted. Returns #f on NULL.
|
|
||||||
*/
|
|
||||||
|
|
||||||
s48_value c_veclen(const long *vec)
|
|
||||||
{
|
|
||||||
const long *vptr = vec;
|
|
||||||
if( !vptr ) return S48_FALSE;
|
|
||||||
while( *vptr ) vptr++;
|
|
||||||
return s48_enter_fixnum(vptr - vec);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/* Copy string from into string to. If to is NULL, malloc a fresh string
|
|
||||||
** (if the malloc loses, return NULL).
|
|
||||||
** If from is NULL, then
|
|
||||||
** - if to is NULL, do nothing and return NULL.
|
|
||||||
** - Otherwise, deposit a single nul byte.
|
|
||||||
** Under normal conditions, this routine returns the destination string.
|
|
||||||
**
|
|
||||||
** The little boundary cases of this procedure are a study in obfuscation
|
|
||||||
** because C doesn't have a reasonable string data type. Give me a break.
|
|
||||||
*/
|
|
||||||
char *copystring(char *to, const char *from)
|
|
||||||
{
|
|
||||||
if( from ) {
|
|
||||||
int slen = strlen(from)+1;
|
|
||||||
if( !to && !(to = Malloc(char, slen)) ) return NULL;
|
|
||||||
else return memcpy(to, from, slen);
|
|
||||||
}
|
|
||||||
|
|
||||||
else
|
|
||||||
return to ? *to = '\000', to : NULL;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* As in copystring, but if malloc loses, print out an error msg and croak. */
|
|
||||||
char *copystring_or_die(const char *str ) /* Note: NULL -> NULL. */
|
|
||||||
{
|
|
||||||
if( str ) {
|
|
||||||
int len = strlen(str)+1;
|
|
||||||
char *new_str = Malloc(char, len);
|
|
||||||
if( ! new_str ) {
|
|
||||||
fprintf(stderr, "copystring: Malloc failed.\n");
|
|
||||||
exit(-1);
|
|
||||||
}
|
|
||||||
return memcpy(new_str, str, len);
|
|
||||||
}
|
|
||||||
else return NULL;
|
|
||||||
}
|
|
||||||
|
|
||||||
int cstring_nullp( const char *s ) { return ! s; }
|
|
||||||
|
|
||||||
s48_value strlen_or_false(const char *s)
|
|
||||||
{ return s ? s48_enter_fixnum(strlen(s)) : S48_FALSE; }
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
/* svec is a Scheme vector of C string carriers. Scan over the C strings
|
|
||||||
** in cvec, and initialise the corresponding string carriers in svec.
|
|
||||||
*/
|
|
||||||
void set_strvec_carriers(s48_value svec, char const * const * cvec)
|
|
||||||
{
|
|
||||||
int svec_len = S48_VECTOR_LENGTH(svec);
|
|
||||||
char const * const * cv = cvec;
|
|
||||||
int i = 0;
|
|
||||||
|
|
||||||
/* JMG: now using normal array access, instead of pointer++ on a s48_value */
|
|
||||||
for(; svec_len > 0; i++, cv++, svec_len-- ) {
|
|
||||||
s48_value carrier, alien;
|
|
||||||
int strl;
|
|
||||||
|
|
||||||
/* *sv is a (cons (make-alien <c-string>) <string-length>). */
|
|
||||||
carrier = S48_VECTOR_REF(svec,i);
|
|
||||||
alien = S48_CAR(carrier);
|
|
||||||
strl = strlen(*cv);
|
|
||||||
S48_SET_CDR(carrier, s48_enter_fixnum(strl));
|
|
||||||
SetAlienVal(alien, (long) *cv);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Helper function for arg checking. Why bother, actually? */
|
|
||||||
void cig_check_nargs(int arity, int nargs, const char *fn)
|
|
||||||
{
|
|
||||||
if( arity != nargs ) {
|
|
||||||
fprintf(stderr,
|
|
||||||
"Cig fatal error (%s) -- C stub expected %d arg%s, "
|
|
||||||
"but got %d.\n",
|
|
||||||
fn, arity, (arity == 1) ? "" : "s", nargs);
|
|
||||||
exit(-1);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
/* void ciginit(){ */
|
|
||||||
/* S48_EXPORT_FUNCTION (df_strlen_or_false); */
|
|
||||||
/* S48_EXPORT_FUNCTION (df_c_veclen); */
|
|
||||||
/* S48_EXPORT_FUNCTION (df_set_strvec_carriers); */
|
|
||||||
/* S48_EXPORT_FUNCTION (df_c2scheme_strcpy_free); */
|
|
||||||
/* S48_EXPORT_FUNCTION (df_cstring_nullp); */
|
|
||||||
/* S48_EXPORT_FUNCTION (df_free); */
|
|
||||||
/* S48_EXPORT_FUNCTION (df_c2scheme_strcpy); */
|
|
||||||
/* } */
|
|
|
@ -14,3 +14,39 @@ s48_value char_pp_2_string_list(char **vec){
|
||||||
S48_GC_UNPROTECT();
|
S48_GC_UNPROTECT();
|
||||||
return list;
|
return list;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
char *scheme2c_strcpy(s48_value sstr)
|
||||||
|
{
|
||||||
|
char *result;
|
||||||
|
int slen;
|
||||||
|
|
||||||
|
slen = S48_STRING_LENGTH(sstr);
|
||||||
|
result = Malloc(char, slen+1);
|
||||||
|
|
||||||
|
if( result == NULL ) {
|
||||||
|
fprintf(stderr,
|
||||||
|
"Fatal error: C stub tried to copy Scheme string,\n"
|
||||||
|
"but malloc failed on arg 0x%x, errno %d.\n",
|
||||||
|
sstr, errno);
|
||||||
|
exit(-1);
|
||||||
|
}
|
||||||
|
|
||||||
|
memcpy(result, s48_extract_string(sstr), slen);
|
||||||
|
result[slen] = '\000';
|
||||||
|
return result;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value strlen_or_false(const char *s)
|
||||||
|
{ return s ? s48_enter_fixnum(strlen(s)) : S48_FALSE; }
|
||||||
|
|
||||||
|
/* Helper function for arg checking. Why bother, actually? */
|
||||||
|
void cig_check_nargs(int arity, int nargs, const char *fn)
|
||||||
|
{
|
||||||
|
if( arity != nargs ) {
|
||||||
|
fprintf(stderr,
|
||||||
|
"Cig fatal error (%s) -- C stub expected %d arg%s, "
|
||||||
|
"but got %d.\n",
|
||||||
|
fn, arity, (arity == 1) ? "" : "s", nargs);
|
||||||
|
exit(-1);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
|
@ -1,4 +1,10 @@
|
||||||
#include "libcig.h"
|
#include <string.h>
|
||||||
|
#include <stddef.h>
|
||||||
|
#include <stdio.h>
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <errno.h>
|
||||||
|
|
||||||
|
#include "scheme48.h"
|
||||||
#define Alloc(type) ((type *) malloc(sizeof(type)))
|
#define Alloc(type) ((type *) malloc(sizeof(type)))
|
||||||
#define Malloc(type,n) ((type *) malloc(sizeof(type)*(n)))
|
#define Malloc(type,n) ((type *) malloc(sizeof(type)*(n)))
|
||||||
#define Free(p) (free((char *)(p)))
|
#define Free(p) (free((char *)(p)))
|
||||||
|
@ -8,3 +14,8 @@
|
||||||
#define streq(a,b) (!strcmp((a),(b)))
|
#define streq(a,b) (!strcmp((a),(b)))
|
||||||
|
|
||||||
s48_value char_pp_2_string_list(char **);
|
s48_value char_pp_2_string_list(char **);
|
||||||
|
char *scheme2c_strcpy(s48_value sstr);
|
||||||
|
|
||||||
|
/* The rest is needed by dbm.c and ndbm.c only */
|
||||||
|
s48_value strlen_or_false(const char *s);
|
||||||
|
void cig_check_nargs(int arity, int nargs, const char *fn);
|
||||||
|
|
Loading…
Reference in New Issue