conservatory
/
ffigen
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Unpack 960213.tar.gz

This commit is contained in:
Lassi Kortela 2023-05-19 11:13:22 +03:00
parent 1a496ecc36
commit b2d44413ea
9 changed files with 172 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
BUGS.FFI Normal file
View File

@ -0,0 +1,3 @@
Known bugs
- the use of delete-file in chez.w is not portable.

11
CHGLOG.FFI Normal file
View File

@ -0,0 +1,11 @@
Changes to FFIGEN over time.
960213 / lth
- Fixed error in chez.w:basic-type-name where the entry for unsigned-short
was a list and not a pair, causing a crash.
- Fixed error in chez.w:dump-struct/union-def to avoid generating code
for structures and unions with no fields (declarations, effectively).
- Fixed portability problems in process.sch: reverse! changed to reverse.
- Implemented function pointer casts in chez.w:c-cast-expression.
- Changed 'ffigen' driver program to use /usr/include by default, and
also to define -D_NO_LONGLONG by default.

16
chez-stdlib.c Normal file
View File

@ -0,0 +1,16 @@
#include "chez-stdlib.h"
int _ref_int( unsigned _p, int _k ) { return ((int*)_p)[_k]; }
void _set_int( unsigned _p, int _k, int _v ) { ((int*)_p)[_k] = _v; }
unsigned _ref_uint( unsigned _p, int _k ) { return ((unsigned*)_p)[_k]; }
void _set_uint( unsigned _p, int _k, unsigned _v ) { ((unsigned*)_p)[_k] = _v; }
char _ref_char( unsigned _p, int _k ) { return ((char*)_p)p[_k]; }
void _set_char( unsigned _p, int _k, char _v ) { ((char*)_p)[_k] = _v; }
double _ref_double( unsigned _p, int _k ) { return ((double*)_p)[_k]; }
void _set_double( unsigned _p, int _k, double _v ) { ((double*)_p)[_k] = _v; }
float _ref_float( unsigned _p, int _k ) { return ((float*)_p)[_k]; }
void _set_float( unsigned _p, int _k, float _v ) { ((float*)_p)[_k] = _v; }

10
chez-stdlib.h Normal file
View File

@ -0,0 +1,10 @@
int _ref_int( unsigned _p, int _k );
void _set_int( unsigned _p, int _k, int _v );
unsigned _ref_uint( unsigned _p, int _k );
void _set_uint( unsigned _p, int _k, unsigned _v );
char _ref_char( unsigned _p, int _k );
void _set_char( unsigned _p, int _k, char _v );
double _ref_double( unsigned _p, int _k );
void _set_double( unsigned _p, int _k, double _v );
float _ref_float( unsigned _p, int _k );
void _set_float( unsigned _p, int _k, float _v );

49
chez-stdlib.sch Normal file
View File

@ -0,0 +1,49 @@
(define _ref_int
(foreign-function "_ref_int" (unsigned-32 integer-32) integer-32))
(define _set_int
(foreign-function "_set_int" (unsigned-32 integer-32 integer-32) void))
(define _ref_uint
(foreign-function "_ref_uint" (unsigned-32 integer-32) integer-32))
(define _set_uint
(foreign-function "_set_uint" (unsigned-32 integer-32 unsigned-32) void))
(define _ref_char
(foreign-function "_ref_char" (unsigned-32 integer-32) char))
(define _set_char
(foreign-function "_set_char" (unsigned-32 integer-32 char) void))
(define _ref_double
(foreign-function "_ref_double" (unsigned-32 integer-32) double-float))
(define _set_double
(foreign-function "_set_double" (unsigned-32 integer-32 double-float) void))
(define _ref_float
(foreign-function "_ref_float" (unsigned-32 integer-32) single-float))
(define _set_float
(foreign-function "_set_float" (unsigned-32 integer-32 single-float) void))
(define _memcpy
(let ((memcpy-*-*
(foreign-function "memcpy" (unsigned-32 unsigned-32 unsigned-32) void))
(memcpy-string-string
(foreign-function "memcpy" (string string unsigned-32) void))
(memcpy-string-*
(foreign-function "memcpy" (string unsigned-32 unsigned-32) void))
(memcpy-*-string
(foreign-function "memcpy" (unsigned-32 string unsigned-32) void)))
(lambda (a b count)
(cond ((string? a)
(cond ((string? b) (memcpy-string-string a b count))
((integer? b) (memcpy-string-* a b count))
(else ???)))
((integer? a)
(cond ((string? b) (memcpy-*-string a b count))
((integer? b) (memcpy-*-* a b count))
(else ???)))
(else ???)))))

46
chez.sch
View File

@ -82,14 +82,15 @@
((string-prefix=? oldname free) (string-append "_free_" typedef-name))
(else (error "compute-newname: can't handle: " oldname))))))
(define (dump-struct/union-def structure qualifier name)
(let* ((funcname (if (string=? qualifier "")
name
(string-append qualifier "_" name)))
(cast (if (string=? qualifier "")
name
(string-append qualifier " " name))))
(generate-constructor-and-destructor structure funcname cast)
(generate-accessors-and-mutators structure funcname cast "")))
(if (not (null? (fields structure)))
(let* ((funcname (if (string=? qualifier "")
name
(string-append qualifier "_" name)))
(cast (if (string=? qualifier "")
name
(string-append qualifier " " name))))
(generate-constructor-and-destructor structure funcname cast)
(generate-accessors-and-mutators structure funcname cast ""))))
(define (generate-constructor-and-destructor structure funcname cast)
(function-pair constructor-template
(vector funcname cast)
@ -263,7 +264,7 @@
(signed-char . "signed char")
(unsigned-char . "unsigned char")
(short . "short")
(unsigned-short "unsigned short")
(unsigned-short . "unsigned short")
(int . "int")
(enum . "int")
(unsigned . "unsigned")
@ -279,10 +280,25 @@
(begin (warn "Unknown type " type)
"***invalid***"))))
(define (c-cast-expression type)
(define (function-cast stars ftype)
(string-append (c-cast-expression (rett ftype))
"(" stars ")("
(apply string-append
(insert
","
(map c-cast-expression (arglist ftype))))
")"))
(cond ((primitive-type? type)
(basic-type-name type))
((pointer-type? type)
(string-append (c-cast-expression (cadr type)) "*"))
(let loop ((t (cadr type)) (stars "*"))
(cond ((eq? 'function (record-tag t))
(function-cast stars t))
((eq? 'pointer (record-tag t))
(loop (cadr t) (string-append "*" stars)))
(else
(string-append (c-cast-expression (cadr type)) "*")))))
((eq? (record-tag type) 'enum-ref)
(basic-type-name '(int ())))
((memq (record-tag type) '(struct-ref union-ref))
@ -301,6 +317,16 @@
(else
(warn "c-cast-expression: Too complicated: " type)
"unknown")))
(define (insert x l)
(define (loop l)
(if (null? (cdr l))
l
(cons (car l) (cons x (loop (cdr l))))))
(if (or (null? l)
(null? (cdr l)))
l
(loop l)))
(define (string-prefix=? s prefix)
(let ((limit (string-length prefix)))
(and (<= limit (string-length s))

54
chez.w
View File

@ -3,7 +3,7 @@
% This is a nuweb document.
% nuweb is available by anon. ftp from cs.rice.edu in /public/preston.
%
% Author: Lars Thomas Hansen (lth@cs.uoregon.edu)
% Author: Lars Thomas Hansen (lth@@cs.uoregon.edu)
%
% Copyright (C) 1996 The University of Oregon. All rights reserved.
%
@ -435,16 +435,21 @@ for the structure.
@d dump structs and unions
@{(define (dump-struct/union-def structure qualifier name)
(let* ((funcname (if (string=? qualifier "")
name
(string-append qualifier "_" name)))
(cast (if (string=? qualifier "")
name
(string-append qualifier " " name))))
(generate-constructor-and-destructor structure funcname cast)
(generate-accessors-and-mutators structure funcname cast "")))
(if (not (null? (fields structure)))
(let* ((funcname (if (string=? qualifier "")
name
(string-append qualifier "_" name)))
(cast (if (string=? qualifier "")
name
(string-append qualifier " " name))))
(generate-constructor-and-destructor structure funcname cast)
(generate-accessors-and-mutators structure funcname cast ""))))
@| dump-struct/union-def @}
Constructors, destructors, accessors and mutators are generated only if
the field list for the structure is non-empty, as an empty field lists
implies that the structure has merely been declared.
\subsubsection{Constructors and destructors}
The procedure \verb|generate-constructor-and-destructor| generates
@ -925,7 +930,7 @@ issue; here are our encodings:
(signed-char . "signed char")
(unsigned-char . "unsigned char")
(short . "short")
(unsigned-short "unsigned short")
(unsigned-short . "unsigned short")
(int . "int")
(enum . "int")
(unsigned . "unsigned")
@ -954,10 +959,25 @@ refers to the structure, and that name should be used instead.
@d utility functions
@{(define (c-cast-expression type)
(define (function-cast stars ftype)
(string-append (c-cast-expression (rett ftype))
"(" stars ")("
(apply string-append
(insert
","
(map c-cast-expression (arglist ftype))))
")"))
(cond ((primitive-type? type)
(basic-type-name type))
((pointer-type? type)
(string-append (c-cast-expression (cadr type)) "*"))
(let loop ((t (cadr type)) (stars "*"))
(cond ((eq? 'function (record-tag t))
(function-cast stars t))
((eq? 'pointer (record-tag t))
(loop (cadr t) (string-append "*" stars)))
(else
(string-append (c-cast-expression (cadr type)) "*")))))
((eq? (record-tag type) 'enum-ref)
(basic-type-name '(int ())))
((memq (record-tag type) '(struct-ref union-ref))
@ -976,7 +996,17 @@ refers to the structure, and that name should be used instead.
(else
(warn "c-cast-expression: Too complicated: " type)
"unknown")))
@| c-cast-expression @}
(define (insert x l)
(define (loop l)
(if (null? (cdr l))
l
(cons (car l) (cons x (loop (cdr l))))))
(if (or (null? l)
(null? (cdr l)))
l
(loop l)))
@| c-cast-expression insert @}
\verb|String-prefix=?| takes a string and a prefix and tests whether the
prefix matches the string.

5
ffigen
View File

@ -11,9 +11,10 @@ LCCHOME=/home/users/lth/net/lcc
ARCH=sparc/solaris
TMP=/tmp/ffitmp.$$
DEFINES="-D__STDC__"
INCLUDES="-I$LCCHOME/include/$ARCH -I/usr/include -I."
DEFINES="-D__STDC__ -D_NO_LONGLONG"
output=""
INCLUDES="-I/usr/include -I."
#INCLUDES="-I$LCCHOME/include/$ARCH -I/usr/include -I."
VERBOSE=1
if [ $# -lt 1 ]; then

4
process.sch
View File

@ -290,12 +290,12 @@
(define (instantiate template args)
(define (get-arg n)
(reverse! (string->list (vector-ref args n))))
(reverse (string->list (vector-ref args n))))
(let ((limit (string-length template)))
(let loop ((i 0) (r '()))
(cond ((= i limit)
(list->string (reverse! r)))
(list->string (reverse r)))
((char=? (string-ref template i) #\@)
(let ((k (- (char->integer (string-ref template (+ i 1)))
(char->integer #\0))))