"I'm not proud of it"
(Olin Shivers)
R.I.P
cig
1994 - 2003
This commit is contained in:
mainzelm
parent
f2c4ddb44d
commit
29ed0edb27
84
Makefile.in
84
Makefile.in
|
|
@ -42,7 +42,7 @@ htmldir = $(libdir)/scsh/doc/scsh-manual/html
|
|||
# LDFLAGS = -N
|
||||
|
||||
.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
|
||||
# out of the CVS repository.
|
||||
|
|
@ -103,9 +103,6 @@ START_LINKER = echo ',batch' && echo ',bench on'
|
|||
IMAGE = scheme48.image
|
||||
INITIAL = build/initial.image
|
||||
VM = scshvm
|
||||
LIBCIG = cig/lib$(VM).a
|
||||
CIG = cig/cig
|
||||
CIGOBJS = cig/libcig.o cig/libcig1.o
|
||||
|
||||
#scsh-lib
|
||||
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_syscalls s48_init_network s48_init_flock \
|
||||
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
|
||||
|
||||
|
|
@ -147,7 +144,7 @@ SRFI_OBJS = c/srfi/srfi-27.o
|
|||
SRFI_INITIALIZERS = s48_init_srfi_27
|
||||
|
||||
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)
|
||||
|
||||
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
|
||||
# default target.
|
||||
enough: $(VM) $(IMAGE) go $(LIBCIG) scsh $(LIBSCSH) $(LIBSCSHVM)
|
||||
enough: $(VM) $(IMAGE) go scsh $(LIBSCSH) $(LIBSCSHVM)
|
||||
|
||||
# --------------------
|
||||
# External code to include in the VM
|
||||
|
|
@ -173,7 +170,6 @@ EXTERNAL_FLAGS = $(SOCKET_FLAGS)
|
|||
EXTERNAL_INITIALIZERS = $(ADDITIONAL_INITIALIZER) $(SOCKET_INITIALIZERS) \
|
||||
$(LOOKUP_INITIALIZERS) \
|
||||
$(SCSH_INITIALIZERS) $(SRFI_INITIALIZERS) \
|
||||
s48_init_cig
|
||||
|
||||
|
||||
# Rules for any external code.
|
||||
|
|
@ -214,11 +210,6 @@ ADDITIONAL_INITIALIZER = s48_init_additional_inits
|
|||
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
|
||||
# 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)
|
||||
$(RM) $@
|
||||
$(AR) $@ c/smain.o $(OBJS)
|
||||
|
|
@ -338,12 +322,6 @@ inst-inc:
|
|||
$(INSTALL_DATA) $(srcdir)/c/scheme48.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:
|
||||
for stub in env big opt misc link srfi; do \
|
||||
for f in scheme/$$stub/*.scm; do \
|
||||
|
|
@ -417,7 +395,7 @@ dirs:
|
|||
done && \
|
||||
for dir in \
|
||||
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 ]; } || { \
|
||||
echo "$(LIB)/$$dir not a writable directory" >&2; \
|
||||
exit 1; \
|
||||
|
|
@ -427,7 +405,7 @@ dirs:
|
|||
configure: configure.in
|
||||
autoheader && autoconf
|
||||
|
||||
clean: clean-cig clean-scsh
|
||||
clean: clean-scsh
|
||||
-rm -f $(VM) *.o c/*/*.o c/*.o \
|
||||
$(IMAGE) \
|
||||
build/*.tmp $(MANPAGE) build/linker.image \
|
||||
|
|
@ -435,9 +413,6 @@ clean: clean-cig clean-scsh
|
|||
scheme/vm/scheme48vm.c scheme/vm/scheme48heap.c \
|
||||
go $(distname)
|
||||
|
||||
clean-cig:
|
||||
-rm -f cig/*.o $(CIG) $(CIG).image $(LIBCIG)
|
||||
|
||||
distclean: clean
|
||||
rm -f Makefile config.log config.status c/sysdep.h config.cache \
|
||||
scsh/machine \
|
||||
|
|
@ -497,7 +472,6 @@ DISTFILES = README COPYING INSTALL RELEASE configure config.sub config.guess \
|
|||
scsh/*.scm scsh/*/*.scm \
|
||||
scsh/*.[ch] scsh/*/*.[ch] \
|
||||
scsh/*.scm.in scsh/*/Makefile.inc \
|
||||
cig/*.scm cig/*.[ch] \
|
||||
doc/scsh.man \
|
||||
doc/scsh-manual/*.tex doc/scsh-manual/*.sty \
|
||||
doc/scsh-manual/man.ps doc/scsh-manual/man.pdf \
|
||||
|
|
@ -537,7 +511,8 @@ dist: build/initial.image
|
|||
else \
|
||||
echo "Can't write $$distfile" >&2; \
|
||||
exit 1; \
|
||||
fi
|
||||
fi && \
|
||||
echo "Hope you already called ./autogen..."
|
||||
|
||||
# Increment the minor version number
|
||||
inc:
|
||||
|
|
@ -730,40 +705,6 @@ i-know-what-i-am-doing:
|
|||
) | $(BUILD_RUNNABLE) -h 5000000 && \
|
||||
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
|
||||
#-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
|
|
@ -858,21 +799,12 @@ SCHEME =scsh/awk.scm \
|
|||
# scsh/dbm.scm db.scm ndbm.scm
|
||||
# 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
|
||||
$(CC) -o $@ $(CPPFLAGS) $(CFLAGS) \
|
||||
-DVM=\"$(LIB)/$(VM)\" \
|
||||
-DIMAGE=\"$(LIB)/scsh.image\" \
|
||||
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 \
|
||||
$(srcdir)/scsh/machine/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();
|
||||
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 Malloc(type,n) ((type *) malloc(sizeof(type)*(n)))
|
||||
#define Free(p) (free((char *)(p)))
|
||||
|
|
@ -8,3 +14,8 @@
|
|||
#define streq(a,b) (!strcmp((a),(b)))
|
||||
|
||||
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