Key

Not instrumented

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-

2

;;;

3

;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL.

4

;;;

5

6

;;;

7

;;; Permission is hereby granted, free of charge, to any person

8

;;; obtaining a copy of this software and associated documentation

9

;;; files (the "Software"), to deal in the Software without

10

;;; restriction, including without limitation the rights to use, copy,

11

;;; modify, merge, publish, distribute, sublicense, and/or sell copies

12

;;; of the Software, and to permit persons to whom the Software is

13

;;; furnished to do so, subject to the following conditions:

14

;;;

15

;;; The above copyright notice and this permission notice shall be

16

;;; included in all copies or substantial portions of the Software.

17

;;;

18

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

19

;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

20

;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

21

;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT

22

;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,

23

;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,

24

;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER

25

;;; DEALINGS IN THE SOFTWARE.

26

;;;

27

28

;;;# Administrivia

29

30

(defpackage #:cffi-sys

31

(:use #:common-lisp #:sb-alien #:cffi-utils)

32

(:export

33

#:canonicalize-symbol-name-case

34

#:pointerp

35

#:pointer-eq

36

#:null-pointer

37

#:null-pointer-p

38

#:inc-pointer

39

#:make-pointer

40

#:pointer-address

41

#:%foreign-alloc

42

#:foreign-free

43

#:with-foreign-pointer

44

#:%foreign-funcall

45

#:%foreign-funcall-pointer

46

#:%foreign-type-alignment

47

#:%foreign-type-size

48

#:%load-foreign-library

49

#:%close-foreign-library

50

#:native-namestring

51

#:%mem-ref

52

#:%mem-set

53

#:make-shareable-byte-vector

54

#:with-pointer-to-vector-data

55

#:%foreign-symbol-pointer

56

#:%defcallback

57

#:%callback

58

#:list-encodings

59

#:default-encoding

60

#:%lisp-string-octet-length

61

#:%lisp-string-to-foreign

62

#:%lisp-string-into-foreign

63

#:%foreign-string-length

64

#:%foreign-string-to-lisp))

65

66

(in-package #:cffi-sys)

67

68

;;;# Features

69

70

(eval-when (:compile-toplevel :load-toplevel :execute)

71

(mapc (lambda (feature) (pushnew feature *features*))

72

'(;; OS/CPU features.

73

#+darwin cffi-features:darwin

74

#+(and unix (not win32)) cffi-features:unix

75

#+win32 cffi-features:windows

76

#+x86 cffi-features:x86

77

#+x86-64 cffi-features:x86-64

78

#+(and ppc (not ppc64)) cffi-features:ppc32

79

;; Misfeatures

80

cffi-features:flat-namespace

81

)))

82

83

;;; Symbol case.

84

85

(declaim (inline canonicalize-symbol-name-case))

86

(defun canonicalize-symbol-name-case (name)

87

(declare (string name))

88

(string-upcase name))

89

90

;;;# Basic Pointer Operations

91

92

(declaim (inline pointerp))

93

(defun pointerp (ptr)

94

"Return true if PTR is a foreign pointer."

95

(sb-sys:system-area-pointer-p ptr))

96

97

(declaim (inline pointer-eq))

98

(defun pointer-eq (ptr1 ptr2)

99

"Return true if PTR1 and PTR2 point to the same address."

100

(declare (type system-area-pointer ptr1 ptr2))

101

(sb-sys:sap= ptr1 ptr2))

102

103

(declaim (inline null-pointer))

104

(defun null-pointer ()

105

"Construct and return a null pointer."

106

(sb-sys:int-sap 0))

107

108

(declaim (inline null-pointer-p))

109

(defun null-pointer-p (ptr)

110

"Return true if PTR is a null pointer."

111

(declare (type system-area-pointer ptr))

112

(zerop (sb-sys:sap-int ptr)))

113

114

(declaim (inline inc-pointer))

115

(defun inc-pointer (ptr offset)

116

"Return a pointer pointing OFFSET bytes past PTR."

117

(declare (type system-area-pointer ptr)

118

(type integer offset))

119

(sb-sys:sap+ ptr offset))

120

121

(declaim (inline make-pointer))

122

(defun make-pointer (address)

123

"Return a pointer pointing to ADDRESS."

124

(declare (type (unsigned-byte 32) address))

125

(sb-sys:int-sap address))

126

127

(declaim (inline pointer-address))

128

(defun pointer-address (ptr)

129

"Return the address pointed to by PTR."

130

(declare (type system-area-pointer ptr))

131

(sb-sys:sap-int ptr))

132

133

;;;# Allocation

134

;;;

135

;;; Functions and macros for allocating foreign memory on the stack

136

;;; and on the heap. The main CFFI package defines macros that wrap

137

;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage

138

;;; when the memory has dynamic extent.

139

140

(declaim (inline %foreign-alloc))

141

(defun %foreign-alloc (size)

142

"Allocate SIZE bytes on the heap and return a pointer."

143

(declare (type (unsigned-byte 32) size))

144

(alien-sap (make-alien (unsigned 8) size)))

145

146

(declaim (inline foreign-free))

147

(defun foreign-free (ptr)

148

"Free a PTR allocated by FOREIGN-ALLOC."

149

(declare (type system-area-pointer ptr))

150

(free-alien (sap-alien ptr (* (unsigned 8)))))

151

152

(defmacro with-foreign-pointer ((var size &optional size-var) &body body)

153

"Bind VAR to SIZE bytes of foreign memory during BODY. The

154

pointer in VAR is invalid beyond the dynamic extent of BODY, and

155

may be stack-allocated if supported by the implementation. If

156

SIZE-VAR is supplied, it will be bound to SIZE during BODY."

157

(unless size-var

158

(setf size-var (gensym "SIZE")))

159

;; If the size is constant we can stack-allocate.

160

(if (constantp size)

161

(let ((alien-var (gensym "ALIEN")))

162

`(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))

163

(let ((,size-var ,(eval size))

164

(,var (alien-sap ,alien-var)))

165

(declare (ignorable ,size-var))

166

,@body)))

167

`(let* ((,size-var ,size)

168

(,var (%foreign-alloc ,size-var)))

169

(unwind-protect

170

(progn ,@body)

171

(foreign-free ,var)))))

172

173

;;;# Shareable Vectors

174

;;;

175

;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA

176

;;; should be defined to perform a copy-in/copy-out if the Lisp

177

;;; implementation can't do this.

178

179

(declaim (inline make-shareable-byte-vector))

180

(defun make-shareable-byte-vector (size)

181

"Create a Lisp vector of SIZE bytes can passed to

182

WITH-POINTER-TO-VECTOR-DATA."

183

; (declare (type sb-int:index size))

184

(make-array size :element-type '(unsigned-byte 8)))

185

186

(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)

187

"Bind PTR-VAR to a foreign pointer to the data in VECTOR."

188

(let ((vector-var (gensym "VECTOR")))

189

`(let ((,vector-var ,vector))

190

(declare (type (sb-kernel:simple-unboxed-array (*)) ,vector-var))

191

(sb-sys:with-pinned-objects (,vector-var)

192

(let ((,ptr-var (sb-sys:vector-sap ,vector-var)))

193

,@body)))))

194

195

;;;# Dereferencing

196

197

;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler

198

;;; macros that optimize the case where the type keyword is constant

199

;;; at compile-time.

200

(defmacro define-mem-accessors (&body pairs)

201

`(progn

202

(defun %mem-ref (ptr type &optional (offset 0))

203

(ecase type

204

,@(loop for (keyword fn) in pairs

205

collect `(,keyword (,fn ptr offset)))))

206

(defun %mem-set (value ptr type &optional (offset 0))

207

(ecase type

208

,@(loop for (keyword fn) in pairs

209

collect `(,keyword (setf (,fn ptr offset) value)))))

210

(define-compiler-macro %mem-ref

211

(&whole form ptr type &optional (offset 0))

212

(if (constantp type)

213

(ecase (eval type)

214

,@(loop for (keyword fn) in pairs

215

collect `(,keyword `(,',fn ,ptr ,offset))))

216

form))

217

(define-compiler-macro %mem-set

218

(&whole form value ptr type &optional (offset 0))

219

(if (constantp type)

220

(once-only (value)

221

(ecase (eval type)

222

,@(loop for (keyword fn) in pairs

223

collect `(,keyword `(setf (,',fn ,ptr ,offset)

224

,value)))))

225

form))))

226

227

(define-mem-accessors

228

(:char sb-sys:signed-sap-ref-8)

229

(:unsigned-char sb-sys:sap-ref-8)

230

(:short sb-sys:signed-sap-ref-16)

231

(:unsigned-short sb-sys:sap-ref-16)

232

(:int sb-sys:signed-sap-ref-32)

233

(:unsigned-int sb-sys:sap-ref-32)

234

(:long sb-sys:signed-sap-ref-word)

235

(:unsigned-long sb-sys:sap-ref-word)

236

(:long-long sb-sys:signed-sap-ref-64)

237

(:unsigned-long-long sb-sys:sap-ref-64)

238

(:float sb-sys:sap-ref-single)

239

(:double sb-sys:sap-ref-double)

240

(:pointer sb-sys:sap-ref-sap))

241

242

;;;# Calling Foreign Functions

243

244

(defun convert-foreign-type (type-keyword)

245

"Convert a CFFI type keyword to an SB-ALIEN type."

246

(ecase type-keyword

247

(:char 'char)

248

(:unsigned-char 'unsigned-char)

249

(:short 'short)

250

(:unsigned-short 'unsigned-short)

251

(:int 'int)

252

(:unsigned-int 'unsigned-int)

253

(:long 'long)

254

(:unsigned-long 'unsigned-long)

255

(:long-long 'long-long)

256

(:unsigned-long-long 'unsigned-long-long)

257

(:float 'single-float)

258

(:double 'double-float)

259

(:pointer 'system-area-pointer)

260

(:void 'void)))

261

262

(defun %foreign-type-size (type-keyword)

263

"Return the size in bytes of a foreign type."

264

(/ (sb-alien-internals:alien-type-bits

265

(sb-alien-internals:parse-alien-type

266

(convert-foreign-type type-keyword) nil)) 8))

267

268

(defun %foreign-type-alignment (type-keyword)

269

"Return the alignment in bytes of a foreign type."

270

#+(and darwin ppc (not ppc64))

271

(case type-keyword

272

((:double :long-long :unsigned-long-long)

273

(return-from %foreign-type-alignment 8)))

274

;; No override necessary for other types...

275

(/ (sb-alien-internals:alien-type-alignment

276

(sb-alien-internals:parse-alien-type

277

(convert-foreign-type type-keyword) nil)) 8))

278

279

(defun foreign-funcall-type-and-args (args)

280

"Return an SB-ALIEN function type for ARGS."

281

(let ((return-type 'void))

282

(loop for (type arg) on args by #'cddr

283

if arg collect (convert-foreign-type type) into types

284

and collect arg into fargs

285

else do (setf return-type (convert-foreign-type type))

286

finally (return (values types fargs return-type)))))

287

288

(defmacro %%foreign-funcall (name types fargs rettype)

289

"Internal guts of %FOREIGN-FUNCALL."

290

`(alien-funcall

291

(extern-alien ,name (function ,rettype ,@types))

292

,@fargs))

293

294

(defmacro %foreign-funcall (name args &key library calling-convention)

295

"Perform a foreign function call, document it more later."

296

(declare (ignore library calling-convention))

297

(multiple-value-bind (types fargs rettype)

298

(foreign-funcall-type-and-args args)

299

`(%%foreign-funcall ,name ,types ,fargs ,rettype)))

300

301

(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)

302

"Funcall a pointer to a foreign function."

303

(declare (ignore calling-convention))

304

(multiple-value-bind (types fargs rettype)

305

(foreign-funcall-type-and-args args)

306

(with-unique-names (function)

307

`(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))

308

(alien-funcall ,function ,@fargs)))))

309

310

;;;# Callbacks

311

312

;;; The *CALLBACKS* hash table contains a direct mapping of CFFI

313

;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA.

314

;;; SBCL will maintain the addresses of the callbacks across saved

315

;;; images, so it is safe to store the pointers directly.

316

(defvar *callbacks* (make-hash-table))

317

318

(defmacro %defcallback (name rettype arg-names arg-types body

319

&key calling-convention)

320

(declare (ignore calling-convention))

321

`(setf (gethash ',name *callbacks*)

322

(alien-sap

323

(sb-alien::alien-lambda ,(convert-foreign-type rettype)

324

,(mapcar (lambda (sym type)

325

(list sym (convert-foreign-type type)))

326

arg-names arg-types)

327

,body))))

328

329

(defun %callback (name)

330

(or (gethash name *callbacks*)

331

(error "Undefined callback: ~S" name)))

332

333

;;;# Loading and Closing Foreign Libraries

334

335

(declaim (inline %load-foreign-library))

336

(defun %load-foreign-library (name path)

337

"Load a foreign library."

338

(declare (ignore name))

339

(load-shared-object path))

340

341

(defun %close-foreign-library (handle)

342

"Closes a foreign library."

343

(sb-alien::dlclose-or-lose

344

(find (sb-ext:native-namestring handle) sb-alien::*shared-objects*

345

:key #'sb-alien::shared-object-file

346

:test #'string=)))

347

348

(defun native-namestring (pathname)

349

(sb-ext:native-namestring pathname))

350

351

;;;# Foreign Globals

352

353

(defun %foreign-symbol-pointer (name library)

354

"Returns a pointer to a foreign symbol NAME."

355

(declare (ignore library))

356

(let-when (address (sb-sys:find-foreign-symbol-address name))

357

(sb-sys:int-sap address)))

358

359

;;;# Encoding-Aware String Interface

360

361

;;; Maps encodings to their terminator lengths.

362

(defparameter *encodings* (make-hash-table :test 'eq))

363

364

;;; Return the number of octets in a null terminator for a SBCL

365

;;; external-format. I'm not sure if this is a very good way to do

366

;;; this but it does seem to get the right results for me. Note that

367

;;; we do need to count the null bytes because a converted UTF-16

368

;;; string may contain a byte-order mark.

369

(defun charset-terminator-length (ef)

370

(max 1 (count-if #'zerop

371

(ignore-errors

372

(sb-ext:string-to-octets (string (code-char 0))

373

:external-format ef)))))

374

375

(defun cffi-to-sbcl-enc (enc)

376

(case enc

377

(:shift-jis :shift_jis)

378

(:mac-cyrillic :x-mac-cyrillic)

379

(t enc)))

380

381

(defun sbcl-to-cffi-enc (enc)

382

(case enc

383

(:shift_jis :shift-jis)

384

(:x-mac-cyrillic :mac-cyrillic)

385

(:latin-1 :iso-8859-1)

386

(:latin-9 :iso-8859-9)

387

(t enc)))

388

389

;;; Fill the *ENCODINGS* hash-table.

390

(mapcar (lambda (ef)

391

;; As of 2007-02-24, SBCL only supports EBCDIC for streams.

392

(unless (eq ef :ebcdic-us)

393

(setf (gethash (sbcl-to-cffi-enc ef) *encodings*)

394

(charset-terminator-length ef))))

395

(mapcar #'caar sb-impl::*external-formats*))

396

397

;;; Bind EXTERNAL-FORMAT and LENGTH to the values from *ENCODINGS* for

398

;;; ENCODING, signalling an error if the encoding is not supported.

399

(defmacro with-encoding ((external-format length) encoding &body body)

400

(once-only (encoding)

401

`(let ((,external-format (cffi-to-sbcl-enc ,encoding))

402

(,length (or (gethash ,encoding *encodings*)

403

(error "Unsupported encoding: ~S" ,encoding))))

404

,@body)))

405

406

;;; Return a list of CFFI encodings supported by this implementation.

407

(defun list-encodings ()

408

(loop for key being the hash-keys of *encodings* collect key))

409

410

;;; Convenience type for working with octet arrays.

411

(deftype ub8 () '(unsigned-byte 8))

412

413

(defun default-encoding ()

414

(sbcl-to-cffi-enc sb-alien::*default-c-string-external-format*))

415

416

;;; Expands into a loop that calculates the length of the foreign

417

;;; string at SAP plus OFFSET, using ACCESSOR and looking for a null

418

;;; terminator of LENGTH bytes.

419

(defmacro sap-string-length (sap offset accessor length)

420

(once-only (sap offset length)

421

`(do ((i 0 (+ i ,length)))

422

((zerop (,accessor ,sap (+ ,offset i))) i)

423

(declare (fixnum i)))))

424

425

;;; Return the length in octets of the null terminated foreign string

426

;;; at POINTER plus OFFSET octets, assumed to be encoded in ENCODING,

427

;;; a CFFI encoding. This should be smart enough to look for 8-bit vs

428

;;; 16-bit null terminators, as appropriate for the encoding.

429

(defun %foreign-string-length (pointer encoding &key (offset 0))

430

(with-encoding (ef length) encoding

431

(declare (ignore ef))

432

(ecase length

433

(1 (sap-string-length pointer offset sb-sys:sap-ref-8 1))

434

(2 (sap-string-length pointer offset sb-sys:sap-ref-16 2))

435

(4 (sap-string-length pointer offset sb-sys:sap-ref-32 4)))))

436

437

;;; Convert COUNT octets starting OFFSET bytes from POINTER into a

438

;;; freshly allocated Lisp string and return it. If COUNT is not

439

;;; supplied, the string is assumed to be null-terminated.

440

(defun %foreign-string-to-lisp (pointer encoding &key (offset 0) count)

441

(when (null count)

442

(setf count (%foreign-string-length pointer encoding :offset offset)))

443

(let* ((octets (make-array count :element-type 'ub8)))

444

(sb-kernel:copy-ub8-from-system-area pointer offset octets 0 count)

445

(with-encoding (ef length) encoding

446

(declare (ignore length))

447

(sb-ext:octets-to-string octets :external-format ef))))

448

449

;;; Return the length of STRING from START to END, converted to

450

;;; ENCODING, in octets, not including the null terminator.

451

(defun %lisp-string-octet-length (string encoding &key (start 0) end)

452

(with-encoding (ef length) encoding

453

(declare (ignore length))

454

(length

455

(sb-ext:string-to-octets string :external-format ef :start start

456

:end end :null-terminate nil))))

457

458

;;; Shorthand syntax for calling SB-EXT:STRING-TO-OCTETS.

459

(defmacro string-to-octets (string start end ef &optional (nullp t))

460

`(sb-ext:string-to-octets ,string :start ,start :end ,end

461

:external-format ,ef :null-terminate ,nullp))

462

463

;;; Convert characters from START to END (character indices) in STRING

464

;;; to a foreign string, encoding in ENCODING, a CFFI encoding.

465

;;; Returns a freshly allocated foreign string that must be freed with

466

;;; %FOREIGN-FREE.

467

(defun %lisp-string-to-foreign (string encoding &key (start 0) end)

468

(with-encoding (ef terminator-len) encoding

469

(declare (ignore terminator-len))

470

(let* ((octets (string-to-octets string start end ef))

471

(count (length octets))

472

(buf (%foreign-alloc count)))

473

(sb-kernel:copy-ub8-to-system-area octets 0 buf 0 count)

474

buf)))

475

476

;;; Convert characters from START to END in STRING to a foreign

477

;;; string, encoded in ENCODING, a CFFI encoding. The maximum

478

;;; number of octets written to BUF will be:

479

;;;

480

;;; (- BUFSIZE OFFSET NULL-TERMINATOR-LENGTH)

481

;;;

482

;;; This ensures the resulting string will always be null-terminated.

483

;;;

484

;;; FIXME: This might result in an invalid Unicode string if the

485

;;; buffer isn't large enough. Is this a problem? [2006-01-07 JJB]

486

(defun %lisp-string-into-foreign (string encoding buffer bufsize

487

&key (start 0) end (offset 0))

488

(with-encoding (ef t-len) encoding

489

(let* ((octets (string-to-octets string start end ef nil))

490

(vector-length (length octets))

491

(count (min (- bufsize offset t-len) vector-length)))

492

(unless (minusp count)

493

(sb-kernel:copy-ub8-to-system-area octets 0 buffer offset count)

494

(dotimes (i t-len)

495

(setf (sb-sys:sap-ref-8 buffer (+ count i)) 0)))))

496

buffer)

Kind	Covered	All	%
expression	168	253	66.4
branch	13	16	81.3

Coverage report: /home/luis/src/cffi/src/cffi-sbcl.lisp