scsh-0.6/cig/libcig.scm

140 lines
4.2 KiB
Scheme
Raw Normal View History

1999-09-14 09:36:47 -04:00
;;; (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.
2002-01-09 11:33:20 -05:00
(foreign-init-name "cig")
1999-09-14 09:36:47 -04:00
(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