From b2d44413eadede0ed10022260ecff561a3aa0b0b Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Fri, 19 May 2023 11:13:22 +0300 Subject: [PATCH] Unpack 960213.tar.gz --- BUGS.FFI | 3 +++ CHGLOG.FFI | 11 ++++++++++ chez-stdlib.c | 16 +++++++++++++++ chez-stdlib.h | 10 +++++++++ chez-stdlib.sch | 49 ++++++++++++++++++++++++++++++++++++++++++++ chez.sch | 46 ++++++++++++++++++++++++++++++++--------- chez.w | 54 ++++++++++++++++++++++++++++++++++++++----------- ffigen | 5 +++-- process.sch | 4 ++-- 9 files changed, 172 insertions(+), 26 deletions(-) create mode 100644 BUGS.FFI create mode 100644 CHGLOG.FFI create mode 100644 chez-stdlib.c create mode 100644 chez-stdlib.h create mode 100644 chez-stdlib.sch diff --git a/BUGS.FFI b/BUGS.FFI new file mode 100644 index 0000000..8ff08eb --- /dev/null +++ b/BUGS.FFI @@ -0,0 +1,3 @@ +Known bugs + +- the use of delete-file in chez.w is not portable. diff --git a/CHGLOG.FFI b/CHGLOG.FFI new file mode 100644 index 0000000..ba73a64 --- /dev/null +++ b/CHGLOG.FFI @@ -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. diff --git a/chez-stdlib.c b/chez-stdlib.c new file mode 100644 index 0000000..019ebe6 --- /dev/null +++ b/chez-stdlib.c @@ -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; } diff --git a/chez-stdlib.h b/chez-stdlib.h new file mode 100644 index 0000000..448c46e --- /dev/null +++ b/chez-stdlib.h @@ -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 ); diff --git a/chez-stdlib.sch b/chez-stdlib.sch new file mode 100644 index 0000000..4ab7e9d --- /dev/null +++ b/chez-stdlib.sch @@ -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 ???))))) diff --git a/chez.sch b/chez.sch index a39005e..8b5c859 100644 --- a/chez.sch +++ b/chez.sch @@ -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)) diff --git a/chez.w b/chez.w index b1eb534..aa35554 100644 --- a/chez.w +++ b/chez.w @@ -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. diff --git a/ffigen b/ffigen index e6c40d7..fd1b505 100755 --- a/ffigen +++ b/ffigen @@ -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 diff --git a/process.sch b/process.sch index ef66260..71acac9 100644 --- a/process.sch +++ b/process.sch @@ -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))))