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) (map (lambda (c-name)
(format #f "~% S48_EXPORT_FUNCTION(~a);" c-name)) (format #f "~% S48_EXPORT_FUNCTION(~a);" c-name))
c-names)))) 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)))))))))))) (lp (append c-names (define-foreign-process-form form oport))))))))))))
; Frank: end ; Frank: end
(define (cig-standalone-toplevel fname) ; ignore your args. (define (cig-standalone-toplevel fname) ; ignore your args.
(process-define-foreign-file fname) (process-define-foreign-file fname)
0) 0)

82
cig/libcig.c
View File

@ -6,81 +6,93 @@
#include <stdlib.h> /* For malloc. */ #include <stdlib.h> /* For malloc. */
#include "libcig.h" #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 * ); extern s48_value strlen_or_false(const char * );
scheme_value ret1; s48_value ret1;
scheme_value r1; 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; ret1 = r1;
return ret1; 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 * ); extern int cstring_nullp(const char * );
scheme_value ret1; s48_value ret1;
int r1; 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); ret1 = ENTER_BOOLEAN(r1);
return ret1; 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* ); extern int c2scheme_strcpy_free(s48_value , char* );
scheme_value ret1; s48_value ret1;
int r1; 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); ret1 = ENTER_BOOLEAN(r1);
return ret1; 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* ); extern int c2scheme_strcpy(s48_value , char* );
scheme_value ret1; s48_value ret1;
int r1; 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); ret1 = ENTER_BOOLEAN(r1);
return ret1; 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* ); extern s48_value c_veclen(long* );
scheme_value ret1; s48_value ret1;
scheme_value r1; 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; ret1 = r1;
return ret1; 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])); free((void* )AlienVal(g1));
return SCHFALSE; 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])); set_strvec_carriers(g1, (char** )AlienVal(g2));
return SCHFALSE; 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 !! //JMG: untested !!
#define StrByte(x, i) ((i) + S48_ADDRESS_AFTER_HEADER((x), char)) #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); extern char *scheme2c_strcpy(s48_value sstr);

51
cig/libcig1.c
View File

@ -17,10 +17,10 @@
** If C string is NULL, do nothing and return #f. ** 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 ) { if( cstr ) {
strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) ); strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
return 1; return 1;
} }
else return 0; 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. */ /* 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 ) { if( cstr ) {
strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) ); strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
Free(cstr); Free(cstr);
return 1; return 1;
} }
else return 0; else return 0;
} }
char *scheme2c_strcpy(scheme_value sstr) char *scheme2c_strcpy(s48_value sstr)
{ {
char *result; char *result;
int slen; int slen;
extern int errno; extern int errno;
slen = STRING_LENGTH(sstr); slen = S48_STRING_LENGTH(sstr);
result = Malloc(char, slen+1); result = Malloc(char, slen+1);
if( result == NULL ) { if( result == NULL ) {
@ -65,12 +65,12 @@ char *scheme2c_strcpy(scheme_value sstr)
** The terminating null is not counted. Returns #f on NULL. ** 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; const long *vptr = vec;
if( !vptr ) return SCHFALSE; if( !vptr ) return S48_FALSE;
while( *vptr ) vptr++; while( *vptr ) vptr++;
return ENTER_FIXNUM(vptr - vec); return s48_enter_fixnum(vptr - vec);
} }
@ -113,26 +113,32 @@ char *copystring_or_die(const char *str ) /* Note: NULL -> NULL. */
int cstring_nullp( const char *s ) { return ! s; } int cstring_nullp( const char *s ) { return ! s; }
scheme_value strlen_or_false(const char *s) s48_value strlen_or_false(const char *s)
{ return s ? ENTER_FIXNUM(strlen(s)) : SCHFALSE; } { return s ? s48_enter_fixnum(strlen(s)) : S48_FALSE; }
/* svec is a Scheme vector of C string carriers. Scan over the C strings /* svec is a Scheme vector of C string carriers. Scan over the C strings
** in cvec, and initialise the corresponding string carriers in svec. ** 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; 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-- ) { for(; svec_len > 0; cv++, sv++, svec_len-- ) {
/* *sv is a (cons (make-alien <c-string>) <string-length>). */ /* *sv is a (cons (make-alien <c-string>) <string-length>). */
scheme_value carrier = *sv; s48_value carrier = *sv;
scheme_value alien = CAR(carrier); s48_value alien = S48_CAR(carrier);
CDR(carrier) = ENTER_FIXNUM(strlen(*cv)); int strl = strlen(*cv);
AlienVal(alien) = (long) *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;
} }
} }
@ -147,3 +153,12 @@ void cig_check_nargs(int arity, int nargs, const char *fn)
exit(-1); 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); */
/* } */