File: libcig.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (133 lines) | stat: -rw-r--r-- 4,243 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
;;; (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.

(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