scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

hacked libcig for the new FFI. most of this is untested

This commit is contained in:
marting 1999-09-14 19:46:27 +00:00
parent 77f21395fd
commit d050b89038
4 changed files with 95 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
cig/cig.scm
View File

@ -859,10 +859,11 @@
(map (lambda (c-name)
(format #f "~% S48_EXPORT_FUNCTION(~a);" c-name))
c-names))))
(format oport s48-init-boilerplate fname register-txt))
(format oport s48-init-boilerplate (file-name-nondirectory fname) register-txt))
(lp (append c-names (define-foreign-process-form form oport))))))))))))
; Frank: end
(define (cig-standalone-toplevel fname) ; ignore your args.
(process-define-foreign-file fname)
0)

96
cig/libcig.c
View File

@ -6,81 +6,93 @@
#include <stdlib.h> /* For malloc. */
#include "libcig.h"
scheme_value df_strlen_or_false(long nargs, scheme_value *args)
s48_value df_strlen_or_false(s48_value g1)
{
extern scheme_value strlen_or_false(const char * );
scheme_value ret1;
scheme_value r1;
extern s48_value strlen_or_false(const char * );
s48_value ret1;
s48_value r1;
cig_check_nargs(1, nargs, "strlen_or_false");
r1 = strlen_or_false((const char * )AlienVal(args[0]));
r1 = strlen_or_false((const char * )AlienVal(g1));
ret1 = r1;
return ret1;
}
}
scheme_value df_cstring_nullp(long nargs, scheme_value *args)
s48_value df_cstring_nullp(s48_value g1)
{
extern int cstring_nullp(const char * );
scheme_value ret1;
s48_value ret1;
int r1;
cig_check_nargs(1, nargs, "cstring_nullp");
r1 = cstring_nullp((const char * )AlienVal(args[0]));
r1 = cstring_nullp((const char * )AlienVal(g1));
ret1 = ENTER_BOOLEAN(r1);
return ret1;
}
}
scheme_value df_c2scheme_strcpy_free(long nargs, scheme_value *args)
s48_value df_c2scheme_strcpy_free(s48_value g1, s48_value g2)
{
extern int c2scheme_strcpy_free(scheme_value , char* );
scheme_value ret1;
extern int c2scheme_strcpy_free(s48_value , char* );
s48_value ret1;
int r1;
cig_check_nargs(2, nargs, "c2scheme_strcpy_free");
r1 = c2scheme_strcpy_free(args[1], (char* )AlienVal(args[0]));
r1 = c2scheme_strcpy_free(g1, (char* )AlienVal(g2));
ret1 = ENTER_BOOLEAN(r1);
return ret1;
}
}
scheme_value df_c2scheme_strcpy(long nargs, scheme_value *args)
s48_value df_c2scheme_strcpy(s48_value g1, s48_value g2)
{
extern int c2scheme_strcpy(scheme_value , char* );
scheme_value ret1;
extern int c2scheme_strcpy(s48_value , char* );
s48_value ret1;
int r1;
cig_check_nargs(2, nargs, "c2scheme_strcpy");
r1 = c2scheme_strcpy(args[1], (char* )AlienVal(args[0]));
r1 = c2scheme_strcpy(g1, (char* )AlienVal(g2));
ret1 = ENTER_BOOLEAN(r1);
return ret1;
}
}
scheme_value df_c_veclen(long nargs, scheme_value *args)
s48_value df_c_veclen(s48_value g1)
{
extern scheme_value c_veclen(long* );
scheme_value ret1;
scheme_value r1;
extern s48_value c_veclen(long* );
s48_value ret1;
s48_value r1;
cig_check_nargs(1, nargs, "c_veclen");
r1 = c_veclen((long* )AlienVal(args[0]));
r1 = c_veclen((long* )AlienVal(g1));
ret1 = r1;
return ret1;
}
}
scheme_value df_free(long nargs, scheme_value *args)
s48_value df_free(s48_value g1)
{
cig_check_nargs(1, nargs, "free");
free((void* )AlienVal(args[0]));
return SCHFALSE;
}
free((void* )AlienVal(g1));
return S48_FALSE;
}
scheme_value df_set_strvec_carriers(long nargs, scheme_value *args)
s48_value df_set_strvec_carriers(s48_value g1, s48_value g2)
{
extern void set_strvec_carriers(scheme_value , char** );
extern void set_strvec_carriers(s48_value , char** );
cig_check_nargs(2, nargs, "set_strvec_carriers");
set_strvec_carriers(args[1], (char** )AlienVal(args[0]));
return SCHFALSE;
}
set_strvec_carriers(g1, (char** )AlienVal(g2));
return S48_FALSE;
}
s48_value ciginit(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);
return S48_UNSPECIFIC;
}

6
cig/libcig.h
View File

@ -8,9 +8,11 @@
//JMG: untested !!
#define StrByte(x, i) ((i) + S48_ADDRESS_AFTER_HEADER((x), char))
// JMG: #define cig_string_body(x) (S48_ADDRESS_AFTER_HEADER((x), char))
#define cig_string_body(x) (S48_ADDRESS_AFTER_HEADER((x), char))
#define AlienVal(x) (STOB_REF((x),0))
#define AlienVal(x) (S48_STOB_REF((x),0))
#define ENTER_BOOLEAN(x) (x ? S48_TRUE : S48_FALSE)
extern char *scheme2c_strcpy(s48_value sstr);

55
cig/libcig1.c
View File

@ -17,10 +17,10 @@
** If C string is NULL, do nothing and return #f.
*/
int c2scheme_strcpy(scheme_value sstr, const char *cstr)
int c2scheme_strcpy(s48_value sstr, const char *cstr)
{
if( cstr ) {
strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) );
strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
return 1;
}
else return 0;
@ -28,23 +28,23 @@ int c2scheme_strcpy(scheme_value sstr, const char *cstr)
/* Same as above, but free the C string when we are done. */
int c2scheme_strcpy_free(scheme_value sstr, const char *cstr)
int c2scheme_strcpy_free(s48_value sstr, const char *cstr)
{
if( cstr ) {
strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) );
strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
Free(cstr);
return 1;
}
else return 0;
}
char *scheme2c_strcpy(scheme_value sstr)
char *scheme2c_strcpy(s48_value sstr)
{
char *result;
int slen;
extern int errno;
slen = STRING_LENGTH(sstr);
slen = S48_STRING_LENGTH(sstr);
result = Malloc(char, slen+1);
if( result == NULL ) {
@ -65,12 +65,12 @@ char *scheme2c_strcpy(scheme_value sstr)
** The terminating null is not counted. Returns #f on NULL.
*/
scheme_value c_veclen(const long *vec)
s48_value c_veclen(const long *vec)
{
const long *vptr = vec;
if( !vptr ) return SCHFALSE;
if( !vptr ) return S48_FALSE;
while( *vptr ) vptr++;
return ENTER_FIXNUM(vptr - vec);
return s48_enter_fixnum(vptr - vec);
}
@ -113,28 +113,34 @@ char *copystring_or_die(const char *str ) /* Note: NULL -> NULL. */
int cstring_nullp( const char *s ) { return ! s; }
scheme_value strlen_or_false(const char *s)
{ return s ? ENTER_FIXNUM(strlen(s)) : SCHFALSE; }
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(scheme_value svec, char const * const * cvec)
void set_strvec_carriers(s48_value svec, char const * const * cvec)
{
int svec_len = VECTOR_LENGTH(svec);
int svec_len = S48_VECTOR_LENGTH(svec);
char const * const * cv = cvec;
scheme_value *sv = &VECTOR_REF(svec,0);
s48_value s = S48_VECTOR_REF(svec,0);
s48_value *sv = &s;
for(; svec_len > 0; cv++, sv++, svec_len-- ) {
/* *sv is a (cons (make-alien <c-string>) <string-length>). */
scheme_value carrier = *sv;
scheme_value alien = CAR(carrier);
CDR(carrier) = ENTER_FIXNUM(strlen(*cv));
AlienVal(alien) = (long) *cv;
}
}
s48_value carrier = *sv;
s48_value alien = S48_CAR(carrier);
int strl = strlen(*cv);
s48_value cdrinspe = s48_enter_fixnum(strl);
S48_UNSAFE_SET_CDR(carrier, cdrinspe);
S48_UNSAFE_SET_CAR(carrier, (long) *cv);
//AlienVal(alien) = (long) *cv;
}
}
/* Helper function for arg checking. Why bother, actually? */
void cig_check_nargs(int arity, int nargs, const char *fn)
@ -147,3 +153,12 @@ void cig_check_nargs(int arity, int nargs, const char *fn)
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); */
/* } */