Added and removed some WITH-STANDARD-IO-SYNTAX.
[com-informatimago:com-informatimago.git] / clisp / uffi.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               uffi.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             clisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;NOWEB:              T
8 ;;;;DESCRIPTION
9 ;;;;
10 ;;;;    This API is obsolete. See: CFFI.
11 ;;;;
12 ;;;;    This is a UFFI layer over the clisp native FFI.
13 ;;;;
14 ;;;;
15 ;;;;    Programs running on CLISP may set CUSTOM:*FOREING-ENCODING*
16 ;;;;    and this will be honored in the conversion of strings between
17 ;;;;    Lisp and C by the underlying FFI.
18 ;;;;
19 ;;;;
20 ;;;;AUTHORS
21 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
22 ;;;;    <KMR> Kevin M. Rosenberg
23 ;;;;MODIFICATIONS
24 ;;;;    2004-07-29 <PJB> Implemented LOAD-FOREIGN-LIBRARY, FIND-FOREIGN-LIBRARY.
25 ;;;;    2003-06-03 <PJB> Created.
26 ;;;;                     Some code taken from Kevin M. Rosenberg's UFFI 1.2.15.
27 ;;;;BUGS
28 ;;;;    Not tested yet.
29 ;;;;
30 ;;;;    FIND-FOREIGN-LIBRARY can't do its work portably for the ill definition
31 ;;;;    of COMMON-LISP:DIRECTORY.  Only a unix implementation is provided.
32 ;;;;
33 ;;;;LEGAL
34 ;;;;    LGPL
35 ;;;;
36 ;;;;    Copyright Pascal J. Bourguignon 2003 - 2004
37 ;;;;
38 ;;;;    This library is free software; you can redistribute it and/or
39 ;;;;    modify it under the terms of the GNU Lesser General Public
40 ;;;;    License as published by the Free Software Foundation; either
41 ;;;;    version 2 of the License, or (at your option) any later
42 ;;;;    version.
43 ;;;;
44 ;;;;    This library is distributed in the hope that it will be
45 ;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
46 ;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
47 ;;;;    PURPOSE.  See the GNU Lesser General Public License for more
48 ;;;;    details.
49 ;;;;
50 ;;;;    You should have received a copy of the GNU Lesser General
51 ;;;;    Public License along with this library; if not, write to the
52 ;;;;    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
53 ;;;;    Boston, MA 02111-1307 USA
54 ;;;;****************************************************************************
55
56 (in-package "COMMON-LISP-USER")
57 (DEFPACKAGE "COM.INFORMATIMAGO.CLISP.UFFI"
58   (:NICKNAMES "UFFI")
59   (:DOCUMENTATION "
60 This package implements over clisp native FFI the UFFI API as defined in
61 'UFFI Reference Guide' by Kevin M. Rosenberg, Heart Hospital of New Mexico.
62
63 The version of the UFFI implemented here is uffi-1.2.15.
64
65 URL:    http://uffi.b9.com/manual/book1.html
66 URL:    http://uffi.b9.com/
67
68 LEGAL:  Copyright Pascal J. Bourguignon 2003 - 2004
69
70         This package is free software; you can redistribute it and/or
71         modify it under the terms of the GNU Lesser General Public
72         License as published by the Free Software Foundation; either
73         version 2 of the License, or (at your option) any later
74         version.
75
76         This library is distributed in the hope that it will be
77         useful, but WITHOUT ANY WARRANTY; without even the implied
78         warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
79         PURPOSE.  See the GNU Lesser General Public License for more
80         details.
81
82         You should have received a copy of the GNU Lesser General
83         Public License along with this library; if not, write to the
84         Free Software Foundation, Inc., 59 Temple Place, Suite 330,
85         Boston, MA 02111-1307 USA
86 ")
87   (:USE "COMMON-LISP") ;; actually: FROM COMMON-LISP IMPORT ALL;
88   ;; really: USE FFI,CUSTOM,EXT;
89   (:EXPORT
90
91    ;; immediate types
92    "DEF-TYPE"
93    "DEF-CONSTANT" ;; Don't use it!
94    "DEF-FOREIGN-TYPE"
95    "NULL-CHAR-P"
96
97    ;; aggregate types
98    "DEF-ENUM"
99    "DEF-STRUCT"
100    "GET-SLOT-VALUE"
101    "GET-SLOT-POINTER"
102    "DEF-ARRAY-POINTER"
103    "DEREF-ARRAY"
104    "DEF-UNION"
105
106    ;; objects
107    "ALLOCATE-FOREIGN-OBJECT"
108    "FREE-FOREIGN-OBJECT"
109    "WITH-FOREIGN-OBJECT"
110    "WITH-FOREIGN-OBJECTS"
111    "SIZE-OF-FOREIGN-TYPE"
112    "POINTER-ADDRESS"
113    "DEREF-POINTER"
114    "ENSURE-CHAR-CHARACTER"
115    "ENSURE-CHAR-INTEGER"
116    "NULL-POINTER-P"
117    "MAKE-NULL-POINTER"
118    "+NULL-CSTRING-POINTER"+
119    "CHAR-ARRAY-TO-POINTER"
120
121    ;; string functions
122    "CONVERT-FROM-CSTRING"
123    "CONVERT-TO-CSTRING"
124    "FREE-CSTRING"
125    "WITH-CSTRING"
126    "WITH-CSTRINGS"
127    "CONVERT-FROM-FOREIGN-STRING"
128    "CONVERT-TO-FOREIGN-STRING"
129    "ALLOCATE-FOREIGN-STRING"
130    "WITH-FOREIGN-STRING"
131
132    ;; function call
133    "DEF-FUNCTION"
134
135    ;; Libraries
136    "FIND-FOREIGN-LIBRARY"
137    "LOAD-FOREIGN-LIBRARY"
138    "DEFAULT-FOREIGN-LIBRARY-TYPE"
139
140    ;; OS
141    "RUN-SHELL-COMMAND" ;; This is not used anywhere by UFFI: what's the use?
142    ;; Don't use it: if you need such a function, use a POSIX or an OS API,
143    ;; not a UFFI.
144
145    )) ;;COM.INFORMATIMAGO.CLISP.UFFI
146 (IN-PACKAGE "COM.INFORMATIMAGO.CLISP.UFFI")
147
148 (provide :uffi) ;; Some client code use REQUIRE! Can you imagine that?
149
150
151
152 ;; In general functions defined with UFFI (DEF-FUNCTION) do not convert
153 ;; between Lisp objects and C objects. This is to be done by the client
154 ;; code.
155
156
157 ;; FFI provides for specification of the external language, with :C (K&C),
158 ;; :STDC (ANSI C) or :STDC-STDCALL (ANSI C with stdcall).
159 ;; UFFI does not.
160
161
162 ;; UFFI does not allow the definition of a C variable (extern).
163 ;; FFI does, with def-c-var.
164 ;; However, we could play C tricks to get a UFFI pointer to a C variable.
165 ;; (Is there any other such variable than errno?)
166
167
168
169 ;; In FFI, c-type  as defined with def-c-type are symbols  used as key in
170 ;; an internal hash table where c-type objects are stored.
171
172
173 ;; (uffi:def-type the-struct-type-def the-struct-type)
174 ;; (let ((a-foreign-struct (allocate-foreign-object 'the-struct-type)))
175 ;;   (declare 'the-struct-type-def a-foreign-struct)
176 ;;   (get-slot-value a-foreign-struct 'the-struct-type 'field-name))
177
178
179 ;; There's no UFFI type to specify function types.
180
181 ;; UFFI:DEF-FUNCTION corresponds to FFI:DEF-CALL-OUT
182 ;; There's none corresponding to FFI:DEF-CALL-IN
183
184
185 ;; UFFI has only :IN arguments.
186 ;; FFI has also :INOUT and :OUT arguments.
187 ;; We'll use :ALLOCATION :NONE and :IN arguments, and manage our own buffers.
188
189 ;; FFI:
190 ;; Passing FFI:C-STRUCT, FFI:C-UNION, FFI:C-ARRAY, FFI:C-ARRAY-MAX values
191 ;; as arguments (not via pointers) is only possible to the extent the C
192 ;; compiler supports it. Most C compilers do it right, but some C
193 ;; compilers (such as gcc on hppa) have problems with this.
194
195
196 ;; UFFI: The values must be converted between Lisp types and C types by the
197 ;;       client code.
198 ;; FFI: The values are converted automatically between Lisp and C, depending
199 ;;      on the FFI-C-TYPE-TO-CL-TYPE table and specifications of C types.
200 ;;
201 ;; Therefore: UFFI :CSTRING are implemented as CL:STRING
202 ;;            UFFI :CENUM   are implemented as CL:INTEGER
203 ;;            UFFI :CSTRUCT are implemented as CL:DEFSTRUCT
204 ;;            UFFI :CARRAY  are implemented as CL:ARRAY ?
205
206
207
208
209
210
211 ;; (* TYPE)
212 ;; (ENUM   (FIELD VALUE)...)
213 ;; (STRUCT (FIELD TYPE)...)
214 ;; (UNION  (FIELD TYPE)...)
215 ;; (* (ARRAY TYPE))
216 ;; :struct-pointer
217 ;; :pointer-self
218
219
220 ;; ;; immediate types
221 ;;    "DEF-TYPE"             --> LISP DEFTYPE  WITH CONVERSION TO :CL
222 ;;
223 ;;    "DEF-FOREIGN-TYPE"     --> C    typedef type name;
224 ;;                           --> DEF-C-TYPE
225 ;;
226 ;;    "NULL-CHAR-P"
227 ;;
228 ;;    ;; aggregate types
229 ;;    "DEF-ENUM"             --> C    typedef enum {...} name;
230 ;;                           --> DEF-C-ENUM DEFTYPE
231 ;;                             
232 ;;    "DEF-STRUCT"           --> C    typedef struct name {...} name;
233 ;;                           --> DEF-C-STRUCT
234 ;;
235 ;;    "GET-SLOT-VALUE"
236 ;;    "GET-SLOT-POINTER"
237 ;;    "DEF-ARRAY-POINTER"    --> C    typedef type* name;
238 ;;                           --> DEF-C-TYPE
239 ;;
240 ;;    "DEREF-ARRAY"
241 ;;
242 ;;    "DEF-UNION"            --> C    typedef union {...} name;
243 ;;                           --> DEF-C-TYPE
244 ;;
245 ;;
246 ;;    ;; objects
247 ;;    "ALLOCATE-FOREIGN-OBJECT"
248 ;;    "FREE-FOREIGN-OBJECT"
249 ;;    "WITH-FOREIGN-OBJECT"   --> FFI:WITH-FOREIGN-OBJECT
250 ;;    "WITH-FOREIGN-OBJECTS"
251 ;;    "SIZE-OF-FOREIGN-TYPE"
252 ;;    "POINTER-ADDRESS"
253 ;;    "DEREF-POINTER"
254 ;;    "ENSURE-CHAR-CHARACTER"
255 ;;    "ENSURE-CHAR-INTEGER"
256 ;;    "NULL-POINTER-P"
257 ;;    "MAKE-NULL-POINTER"
258 ;;    "+NULL-CSTRING-POINTER"+
259 ;;    "CHAR-ARRAY-TO-POINTER"
260 ;;
261 ;;    ;; string functions
262 ;;    "CONVERT-FROM-CSTRING"
263 ;;    "CONVERT-TO-CSTRING"
264 ;;    "FREE-CSTRING"
265 ;;    "WITH-CSTRING"
266 ;;    "WITH-CSTRINGS"
267 ;;    "CONVERT-FROM-FOREIGN-STRING"
268 ;;    "CONVERT-TO-FOREIGN-STRING"          --> (FFI:C-ARRAY-MAX FFI:UCHAR SIZE)
269 ;;    "ALLOCATE-FOREIGN-STRING"            --> (FFI:C-ARRAY-MAX FFI:UCHAR SIZE)
270 ;;                                      OR --> (FFI:C-ARRAY-MAX FFI:CHAR  SIZE)
271 ;;    "WITH-FOREIGN-STRING"                --> FFI:WITH-FOREIGN-OBJECT
272
273
274
275
276
277 ;; Because of (:struct name) and (:struct-pointer name) we must keep
278 ;; a separate list of structure names (even if def-struct creates both
279 ;; a typedef and a struct).
280 ;;
281 ;; Because of :pointer-self, when we convert a struct, we must keep the
282 ;; current structure name at hand.
283 ;;
284 ;; We should check that a structure does not contain a (:struct self)
285 ;; if not encapsulated into a (* ).
286
287
288
289
290
291
292 ;;;  FFI-C-TYPE-TO-CL-TYPE
293 ;;;     (BOOLEAN             . BOOLEAN)
294 ;;;     (CHARACTER           . CHARACTER)
295 ;;;     (FFI:SHORT           . INTEGER)
296 ;;;     (FFI:USHORT          . INTEGER)
297 ;;;     (FFI:INT             . INTEGER)
298 ;;;     (FFI:UINT            . INTEGER)
299 ;;;     (FFI:LONG            . INTEGER)
300 ;;;     (FFI:ULONG           . INTEGER)
301 ;;;     (SINGLE-FLOAT        . SINGLE-FLOAT)
302 ;;;     (DOUBLE-FLOAT        . DOUBLE-FLOAT)
303
304
305 (defstruct (type-conv (:type list) (:conc-name nil))
306   uffi-type ffi-type cl-type)
307
308
309 (DEFCONSTANT +TYPE-CONVERSION-LIST+
310   '( ;; :UFFI                :FFI                    :CL
311     (:CHAR                  FFI:CHARACTER           CHARACTER)
312     (:UNSIGNED-CHAR         FFI:CHARACTER           CHARACTER)
313     (:BYTE                  FFI:SINT8               (SIGNED-BYTE    8))
314     (:UNSIGNED-BYTE         FFI:UINT8               (UNSIGNED-BYTE  9))
315     (:SHORT                 FFI:SINT16              (SIGNED-BYTE   16))
316     (:UNSIGNED-SHORT        FFI:UINT16              (UNSIGNED-BYTE 16))
317     (:INT                   FFI:SINT32              (SIGNED-BYTE   32))
318     (:UNSIGNED-INT          FFI:UINT32              (UNSIGNED-BYTE 32))
319     (:LONG                  FFI:SINT32              (SIGNED-BYTE   32))
320     (:UNSIGNED-LONG         FFI:UINT32              (UNSIGNED-BYTE 32))
321     (:FLOAT                 SINGLE-FLOAT            SINGLE-FLOAT)
322     (:DOUBLE                DOUBLE-FLOAT            DOUBLE-FLOAT)
323     (:CSTRING               FFI:C-POINTER           STRING)
324     (:POINTER-VOID          FFI:C-POINTER           T)
325     (:VOID                  NIL                     NIL)
326 ;;;
327 ;;; (:ENUM                  FFI:INT                 INTEGER)
328 ;;; ((:STRUCT name)         FFI:C-STRUCT            STRUCTURE)
329 ;;; ((:STRUCT-POINTER name) (FFI:C-PTR-NULL FFI:C-STRUCT)   STRUCTURE)
330 ;;; ;;   FOR LISP TYPE: WE BUILD A DEFSTRUCT
331 ;;; (:UNION                 FFI:C-UNION             UNION)
332 ;;; ;;   FOR LISP TYPE: FFI CONSIDER IT TO BE OF THE TYPE OF THE FIRST FIELD.
333 ;;; ((:ARRAY TYPE)          (FFI:C-ARRAY-PTR TYPE)  (ARRAY :ELEMENT-TYPE TYPE))
334 ;;;
335     )
336   "A LIST OF: (UFFI-TYPE  FFI-TYPE  CL-TYPE)"
337   ) ;;+TYPE-CONVERSION-LIST+
338
339
340 (defvar +TYPE-CONVERSION-HASH+ 
341   (let ((table (MAKE-HASH-TABLE :SIZE 23)))
342     (DOLIST (RECORD +TYPE-CONVERSION-LIST+)
343       (SETF (GETHASH (UFFI-TYPE RECORD) table) RECORD))
344     table)
345   "A hash uffi-type --> (uffi-type  ffi-type  cl-type)."
346   ) ;;+TYPE-CONVERSION-HASH+
347
348
349 (PROCLAIM '(INLINE GET-TYPE-CONVERSION-RECORD))
350 (DEFUN GET-TYPE-CONVERSION-RECORD (UFFI-TYPE)
351   "
352 PRIVATE
353 RETURN:             THE RECORD FROM +TYPE-CONVERSION-HASH+ CORRESPONDING
354                     TO UFFI-TYPE, OR NIL IF NONE EXISTS.
355 "
356   (GETHASH UFFI-TYPE +TYPE-CONVERSION-HASH+)
357   ) ;;GET-TYPE-CONVERSION-RECORD
358
359
360 (DEFVAR *FOREIGN-TYPES-HASH* (MAKE-HASH-TABLE :SIZE 23)
361   "A HASH TABLE OF THE NAMED FOREIGN TYPES: NAME --> UFFI-TYPE."
362   ) ;;*FOREIGN-TYPES-HASH*
363
364
365 (DEFVAR *FOREIGN-STRUCTS-HASH* (MAKE-HASH-TABLE :SIZE 23)
366   "A HASH TABLE OF THE NAMED FOREIGN STRUCTS: NAME --> UFFI-STRUCT-TYPE."
367   ) ;;*FOREIGN-STRUCTS-HASH*
368
369
370
371 ;;; PRIMITIVE-UFFI-TYPE
372 ;;; :POINTER-SELF
373 ;;; (:STRUCT-POINTER STRUCT-NAME)
374 ;;; (:STRUCT STRUCT-NAME)
375 ;;; (:STRUCT STRUCT-NAME (FNAME FTYPE)...)
376 ;;; 'TYPE
377 ;;;
378 ;;; (:UNION UNION-NAME (FNAME FTYPE)...)
379 ;;; (:ARRAY-PTR TYPE)
380 ;;; (:ARRAY     TYPE SIZE)
381
382
383 (DEFUN CLEAN-UFFI-TYPE (UFFI-TYPE &OPTIONAL CURRENT-STRUCT)
384   "
385 PRIVATE
386 DO:                 REPLACE :POINTER-SELF BY (* (:STRUCT CURRENT-STRUCT),)
387                             (:STRUCT-POINTER NAME) BY (* (:STRUCT NAME)),
388                     AND CHECK THAT A STRUCTURE EXISTS FOR (:STRUCT NAME).
389                     REPLACE (* :UNSIGNED-CHAR) and (* :CHAR) BY :CSTRING,
390                     SINCE IT SEEMS UFFI CLIENT CODE ERRONEOUSLY 
391                     USE (* :UNSIGNED-CHAR) INSTEAD OF :CSTRING...
392 RETURN:             A CLEANED UFFI-TYPE.
393 TODO:               CHECK OF (STRUCT X (FIELD (STRUCT X))).
394 "
395   (IF (ATOM UFFI-TYPE)
396       (IF (EQ UFFI-TYPE :POINTER-SELF)
397           (IF CURRENT-STRUCT
398               `(* (:STRUCT ,CURRENT-STRUCT))
399               (ERROR "FOUND :POINTER-SELF OUT OF A STRUCTURE."))
400           UFFI-TYPE)
401       (CASE (FIRST UFFI-TYPE)
402         (:STRUCT-POINTER
403          (UNLESS (= 2 (LENGTH UFFI-TYPE))
404            (ERROR "INVALID UFFI TYPE: ~S." UFFI-TYPE))
405          `(* ,(CLEAN-UFFI-TYPE (SECOND UFFI-TYPE))))
406         (:STRUCT
407             (COND
408               ((= 2 (LENGTH UFFI-TYPE))
409                (UNLESS (GETHASH (SECOND UFFI-TYPE) *FOREIGN-STRUCTS-HASH*)
410                  (ERROR "UNKNOWN STRUCT TYPE: ~S." UFFI-TYPE))
411                UFFI-TYPE)
412               ((< 2 (LENGTH UFFI-TYPE))
413                (LET ((STRUCT-NAME (SECOND UFFI-TYPE)))
414                  (UNLESS (SYMBOLP STRUCT-NAME)
415                    (ERROR "EXPECTED A SYMBOL AS STRUCT NAME INSTEAD OF ~S."
416                           STRUCT-NAME))
417                  `(:STRUCT ,STRUCT-NAME
418                     ,@(MAPCAR (LAMBDA (FIELD)
419                                 (LET ((NAME (FIRST FIELD))
420                                       (TYPE (SECOND FIELD)))
421                                   (UNLESS (= 2 (LENGTH FIELD))
422                                     (ERROR "INVALID STRUCT FIELD ~S." FIELD))
423                                   (LIST NAME (CLEAN-UFFI-TYPE TYPE STRUCT-NAME))))
424                               (CDDR UFFI-TYPE)))))
425               (T
426                (ERROR "INVALID STRUCT TYPE: ~S." UFFI-TYPE))))
427         (COMMON-LISP:QUOTE
428          (CLEAN-UFFI-TYPE (SECOND UFFI-TYPE) CURRENT-STRUCT))
429         (:UNION
430          (UNLESS (< 2 (LENGTH UFFI-TYPE))
431            (ERROR "MISSING FIELDS IN UNION TYPE ~S." UFFI-TYPE))
432          `(:UNION ,(SECOND UFFI-TYPE)
433                   ,@(MAPCAR (LAMBDA (FIELD)
434                               (LET ((NAME (FIRST FIELD))
435                                     (TYPE (SECOND FIELD)))
436                                 (UNLESS (= 2 (LENGTH FIELD))
437                                   (ERROR "INVALID UNION FIELD ~S." FIELD))
438                                 (LIST NAME
439                                       (CLEAN-UFFI-TYPE TYPE CURRENT-STRUCT))))
440                             (CDDR UFFI-TYPE))))
441         (:ARRAY-PTR
442          (UNLESS (= 2 (LENGTH UFFI-TYPE))
443            (ERROR "INVALID ARRAY-PTR TYPE: ~S." UFFI-TYPE))
444          `(:ARRAY-PTR ,(CLEAN-UFFI-TYPE (SECOND UFFI-TYPE) CURRENT-STRUCT)))
445         (:ARRAY
446          (UNLESS (= 3 (LENGTH UFFI-TYPE))
447            (ERROR "INVALID ARRAY TYPE: ~S." UFFI-TYPE))
448          (LET ((SIZE (THIRD UFFI-TYPE)))
449            (UNLESS (AND (INTEGERP SIZE) (< 0 SIZE))
450              (ERROR "INVALID ARRAY SIZE: ~S." SIZE))
451            `(:ARRAY ,(CLEAN-UFFI-TYPE (SECOND UFFI-TYPE) CURRENT-STRUCT)
452                     ,SIZE)))
453         (*
454          (unless (= 2 (length uffi-type))
455            (error "INVALID POINTER TYPE: ~S." uffi-type))
456          `(* ,(CLEAN-UFFI-TYPE (SECOND UFFI-TYPE))))
457         ;;(if (member (second uffi-type) '(:unsigned-char :char))
458         ;;'FFI:C-POINTER
459         (OTHERWISE
460          (ERROR "INVALID TYPE: ~S." UFFI-TYPE))))
461   ) ;;CLEAN-UFFI-TYPE
462
463       
464 (DEFUN CONVERT-FROM-UFFI-TYPE (UFFI-TYPE CONTEXT)
465   "
466 PRIVATE
467 DO:                 Converts from a uffi type to an implementation
468                     specific type.
469 UFFI-TYPE:          A UFFI TYPE.
470 CONTEXT:            :FFI OR :CL
471 RETURN:             A FFI TYPE (C-TYPE), OR A COMMON-LISP TYPE,
472                     DEPENDING ON THE CONTEXT.
473 "
474   (UNLESS (OR (EQ CONTEXT :FFI) (EQ CONTEXT :CL))
475     (ERROR "UNEXPECTED CONTEXT ~S, SHOULD BE EITHER :FFI OR :CL." CONTEXT))
476   (IF (ATOM UFFI-TYPE)
477       (LET ((RECORD (GET-TYPE-CONVERSION-RECORD UFFI-TYPE)))
478         (IF RECORD
479             ;; primitive types
480             (IF (EQ CONTEXT :FFI)
481                 (FFI-TYPE RECORD)
482                 (CL-TYPE  RECORD))
483             ;; named types
484             (LET ((TYPE (GETHASH UFFI-TYPE *FOREIGN-TYPES-HASH*)))
485               (IF TYPE
486                   (CONVERT-FROM-UFFI-TYPE TYPE CONTEXT)
487                   (ERROR "UNKNOWN UFFI TYPE ~S." UFFI-TYPE)))))
488       (LET ((SUB-TYPE (FIRST UFFI-TYPE)))
489         (CASE SUB-TYPE
490           (:STRUCT
491               (LET ((NAME (SECOND UFFI-TYPE))
492                     (FIELDS
493                      (MAPCAR
494                       (LAMBDA (FIELD)
495                         (LET ((NAME (FIRST FIELD))
496                               (TYPE (SECOND FIELD)))
497                           (LIST NAME (CONVERT-FROM-UFFI-TYPE TYPE CONTEXT))))
498                       (CDDR UFFI-TYPE))))
499                 ;; TODO: SEE GENERATION OF  (:STRUCT NAME)
500                 ;;       VS. GENERATION OF: (:STRUCT NAME (FIELD TYPE)...)
501                 (IF (NULL FIELDS)
502                     (LET ((TYPE (GETHASH NAME *FOREIGN-STRUCTS-HASH*)))
503                       (IF TYPE
504                           (IF (EQ CONTEXT :FFI)
505                               `(FFI:C-STRUCT ,NAME)
506                               NAME) ;; (CONVERT-FROM-UFFI-TYPE TYPE CONTEXT)
507                           (ERROR "UNKNOWN UFFI STRUCTURE ~S." NAME)))
508                     (IF (EQ CONTEXT :FFI)
509                         `(FFI:C-STRUCT ,NAME ,@FIELDS)
510                         `(DEFSTRUCT ,NAME ,@FIELDS)))))
511           (:UNION
512            (IF (EQ CONTEXT :FFI)
513                `(:C-UNION ,@(MAPCAR
514                              (LAMBDA (FIELD)
515                                (LET ((NAME (FIRST FIELD))
516                                      (TYPE (SECOND FIELD)))
517                                  (LIST NAME
518                                        (CONVERT-FROM-UFFI-TYPE TYPE CONTEXT))))
519                              (CDDR UFFI-TYPE)))
520                `(CONVERT-FROM-UFFI-TYPE (SECOND (SECOND UFFI-TYPE)) CONTEXT)))
521           (:ARRAY-PTR
522            (LET ((ELEMENT-TYPE
523                   (CONVERT-FROM-UFFI-TYPE  (SECOND UFFI-TYPE) CONTEXT)))
524              (IF (EQ CONTEXT :FFI)
525                  `(FFI:C-ARRAY-PTR ,ELEMENT-TYPE)
526                  `(ARRAY ,ELEMENT-TYPE *))))
527           (:ARRAY
528            (LET ((ELEMENT-TYPE
529                   (CONVERT-FROM-UFFI-TYPE (SECOND UFFI-TYPE) CONTEXT))
530                  (ARRAY-SIZE   (CDDR  UFFI-TYPE)))
531              (IF (EQ CONTEXT :FFI)
532                  `(FFI:C-ARRAY ,ELEMENT-TYPE ,ARRAY-SIZE)
533                  `(ARRAY ,ELEMENT-TYPE (,ARRAY-SIZE)))))
534           (*
535            (if (eq context :ffi)
536                `(ffi:c-ptr ,(convert-from-uffi-type (second uffi-type) :ffi))
537                ;;'FFI:C-POINTER
538                (error "I don't know what a ~S is in Lisp.")))
539           (OTHERWISE
540            (ERROR "INVALID TYPE ~S." UFFI-TYPE)))))
541   ) ;;CONVERT-FROM-UFFI-TYPE
542
543
544
545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
546 ;; I. Declarations ;;
547 ;;;;;;;;;;;;;;;;;;;;;
548
549
550 (DEFMACRO DEF-TYPE (NAME TYPE)
551   "
552 DO:                 Defines a Common Lisp type based on a UFFI type.
553 NAME:               A symbol naming the type
554 TYPE:               A form that is evaluated that specifies the UFFI type.
555 IMPLEMENTATION:     For now, we generate `(DEFTYPE ,NAME T).
556 URL:                http://uffi.b9.com/manual/def-type.html
557 URL:                http://www.lisp.org/HyperSpec/Body/mac_deftype.html
558 "
559   (setf type (clean-uffi-type type))
560   `(DEFTYPE ,NAME T ,(CONVERT-FROM-UFFI-TYPE TYPE :CL))) ;;DEF-TYPE
561
562
563
564 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
565 ;; II. Primitive Types ;;
566 ;;;;;;;;;;;;;;;;;;;;;;;;;
567
568
569 (DEFMACRO DEF-CONSTANT (NAME VALUE &KEY (EXPORT NIL))
570   "
571 DO:                 This is a thin wrapper around defconstant.
572                     It evaluates at compile-time and optionally
573                     exports the symbol from the package.
574 NAME:               A symbol that will be bound to the value.
575 VALUE:              An evaluated form that is bound the the name.
576 EXPORT:             EXPORT <=> The name is exported from the current package.
577                     The default is NIL
578 NOTE:               I would not advise using this macro, since it does not
579                     allow to attach a documentation string!
580 URL:                http://uffi.b9.com/manual/def-constant.html
581 URL:                http://www.lisp.org/HyperSpec/Body/mac_defconstant.html
582 URL:                http://www.lisp.org/HyperSpec/Body/fun_export.html
583 "
584   `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
585      (DEFCONSTANT ,NAME ,VALUE)
586      ,(WHEN EXPORT (LIST 'EXPORT `(QUOTE ,NAME)))
587      ',NAME)
588   ) ;;DEF-CONSTANT
589
590
591
592 (DEFMACRO DEF-FOREIGN-TYPE (NAME TYPE)
593   "
594 DO:                 Defines a new foreign type.
595 NAME:               A symbol naming the new foreign type.
596 VALUE:              A form that is not evaluated that defines
597                     the new foreign type.
598 URL:                http://uffi.b9.com/manual/def-foreign-type.html
599 URL:                http://clisp.sourceforge.net/impnotes.html#def-c-type
600 "
601   (LET* ((NAME NAME)
602          (UFFI-TYPE (CLEAN-UFFI-TYPE type NAME))
603          (FFI-TYPE  (CONVERT-FROM-UFFI-TYPE UFFI-TYPE :FFI)) )
604     `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
605        (SETF (GETHASH ',NAME *FOREIGN-TYPES-HASH*) ',UFFI-TYPE)
606        (FFI:DEF-C-TYPE ,NAME ,FFI-TYPE)))) ;;DEF-FOREIGN-TYPE
607
608
609
610 (DEFMACRO NULL-CHAR-P (VAL)
611   "
612 DO:                 Tests if a character or integer is NULL.
613                     This abstracts the difference in implementations where
614                     some return a character and some return an integer
615                     when dereferencing a C character pointer.
616 CHAR:               A character or integer.
617 RETURN:             A boolean flag indicating if char is a NULL value.
618 URL:                http://uffi.b9.com/manual/null-char-p.html
619 "
620   `(LET ((VAL ,VAL)) (IF (CHARACTERP VAL) (ZEROP (CHAR-CODE VAL)) (ZEROP VAL)))
621   ) ;;NULL-CHAR-P
622
623
624
625 (DEFUN MAKE-CONSTANT-NAME (ENUM-NAME SEPARATOR-STRING CONSTANT-ID)
626   "
627 PRIVATE
628 DO:                 Builds an enum constant name.
629 "
630   (INTERN (with-standard-io-syntax
631             (FORMAT NIL "~A~A~A" ENUM-NAME SEPARATOR-STRING CONSTANT-ID))))
632
633
634
635 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
636 ;; III. Aggregate Types ;;
637 ;;;;;;;;;;;;;;;;;;;;;;;;;;
638
639
640 (DEFMACRO DEF-ENUM (NAME CONSTANTS &KEY (SEPARATOR-STRING "#"))
641   "
642 DO:                 Declares a C enumeration.
643                     It generates constants with integer values for the
644                     elements of the enumeration. The symbols for the these
645                     constant values are created by the concatenation of
646                     the enumeration name, separator-string, and field
647                     symbol. Also creates a foreign type with the name name
648                     of type :int.
649 NAME:               A symbol that names the enumeration.
650 CONSTANTS:          A list of enum constants definitions.
651                     Each definition can be a symbol or a list of two
652                     elements. Symbols get assigned a value of the current
653                     counter which starts at 0 and increments by 1 for each
654                     subsequent symbol. It the constants definition is a list,
655                     the first position is the symbol and the second
656                     position is the value to assign the the symbol. The
657                     current counter gets set to 1+ this value.
658 SEPARATOR-STRING:   A string that governs the creation of constants.
659                     The default is \"#\".
660 IMPLEMENTATION:     We generate both a DEF-C-TYPE for the NAME
661                     and a DEF-C-ENUM for the constants.
662 URL:                http://uffi.b9.com/manual/def-enum.html
663 URL:                http://clisp.sourceforge.net/impnotes.html#def-c-enum
664 URL:                http://clisp.sourceforge.net/impnotes.html#def-c-type
665 "
666   (LET ((C-CONSTANTS
667          (MAPCAR
668           (LAMBDA (CONSTANT)
669             (COND
670               ((SYMBOLP CONSTANT)
671                (LIST (MAKE-CONSTANT-NAME NAME SEPARATOR-STRING CONSTANT))  )
672               ((AND (CONSP CONSTANT)
673                     (= 2 (LENGTH CONSTANT)) (INTEGERP (CADR CONSTANT)))
674                (LIST (MAKE-CONSTANT-NAME NAME SEPARATOR-STRING (CAR CONSTANT))
675                      (CADR CONSTANT)))
676               (T
677                (ERROR "INVALID ENUM CONSTANT SYNTAX: ~S." CONSTANT))))
678           CONSTANTS)))
679     `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
680        (SETF (GETHASH ,NAME *FOREIGN-TYPES-HASH*) :INT)
681        (FFI:DEF-C-TYPE  ,NAME  ,(CONVERT-FROM-UFFI-TYPE :INT :FFI))
682        (FFI:DEF-C-ENUM  ,NAME  ,@C-CONSTANTS)))
683   ) ;;DEF-ENUM
684
685
686 (DEFMACRO DEF-STRUCT (NAME &REST FIELDS)
687   "
688 DO:                 Declares a structure.
689                     A special type is available as a slot in the field. It is
690                     a pointer that points to an instance of the parent
691                     structure. It's type is :pointer-self.
692 NAME:               A symbol that names the structure.
693 FIELDS:             A variable number of field definitions.
694                     Each definition is a list consisting of a symbol naming
695                     the field followed by its foreign type.  
696 IMPLEMENTATION:     Generates a DEF-C-STRUCT which defines both a foreign
697                     C type and a Common-Lisp STRUCTURE-CLASS.
698 URL:                http://uffi.b9.com/manual/def-struct.html
699 URL:                http://clisp.sourceforge.net/impnotes.html#def-c-struct
700 "
701   (LET* ((NAME NAME)
702          (UFFI-TYPE (CLEAN-UFFI-TYPE `(:STRUCT ,NAME ,@FIELDS) NAME))
703          (FFI-TYPE  (CONVERT-FROM-UFFI-TYPE UFFI-TYPE :FFI)) )
704     `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
705        (SETF (GETHASH ',NAME *FOREIGN-TYPES-HASH*)
706              (SETF (GETHASH ',NAME *FOREIGN-STRUCTS-HASH*) ',UFFI-TYPE))
707        (FFI:DEF-C-STRUCT ,@(CDR FFI-TYPE))))
708   ) ;;DEF-STRUCT
709
710 ;; ,(CONVERT-FROM-UFFI-TYPE TYPE :CL)
711 ;; (COM.INFORMATIMAGO.CLISP.UFFI::CLEAN-UFFI-TYPE '(* :unsigned-char) 'struct-name)
712 ;; (setf name 'ldap-error fields '((e_code :int) (e_reason (* :unsigned-char))))
713
714
715 (DEFMACRO GET-SLOT-VALUE (OBJ TYPE FIELD)
716   "
717 DO:                 Accesses a slot value from a structure.
718 OBJ:                A pointer to foreign structure.
719 TYPE:               A name of the foreign structure type.
720 FIELD:              A name of the desired field in foreign structure.
721 RETURN:             The value of the field in the structure.
722 SEE ALSO:           GET-SLOT-POINTER
723 URL:                http://uffi.b9.com/manual/get-slot-value.html
724 URL:                http://clisp.sourceforge.net/impnotes.html#slot
725 "
726   (when (and (listp type) (eq 'quote (car type)))
727     (setf type (second type)))
728   ;; TODO: CHECK CONVERT TYPE.
729   `(FFI:SLOT (FFI:DEREF (FFI:CAST (ffi:foreign-value ,OBJ) (* ,TYPE)))
730              ,FIELD)) ;;GET-SLOT-VALUE
731
732
733
734 (DEFMACRO GET-SLOT-POINTER (OBJ TYPE FIELD)
735   "
736 DO:                 Accesses a slot value from a structure.
737 OBJ:                A pointer to foreign structure.
738 TYPE:               A name of the foreign structure type.
739 FIELD:              A name of the desired field in foreign structure.
740 RETURN:             The value of the field in the structure: A POINTER.
741 NOTE:               This is similar to GET-SLOT-VALUE.
742                     It is used when the value of a slot is a pointer type.
743 SEE ALSO:           GET-SLOT-VALUE
744 URL:                http://uffi.b9.com/manual/get-slot-pointer.html
745 URL:                http://clisp.sourceforge.net/impnotes.html#slot
746 "
747   ;; NO DIFFERENCE TO ACCESS POINTER FIELD THAN TO ACCESS VALUE FIELDS.
748   `(GET-SLOT-VALUE ,OBJ ,TYPE ,FIELD)
749   ) ;;GET-SLOT-POINTER
750
751
752
753 (DEFMACRO DEF-ARRAY-POINTER (NAME TYPE)
754   "
755 DO:                 Defines a type that is a pointer to an array of type.
756 NAME:               A name of the new foreign type.
757 TYPE:               The foreign type of the array elements.
758 URL:                http://uffi.b9.com/manual/def-array-pointer.html
759 URL:                http://clisp.sourceforge.net/impnotes.html#c-array-ptr
760 URL:                http://clisp.sourceforge.net/impnotes.html#def-c-type
761 "
762   (LET* ((NAME NAME)
763          (UFFI-TYPE (CLEAN-UFFI-TYPE `(:ARRAY-PTR ,TYPE)))
764          (FFI-TYPE  (CONVERT-FROM-UFFI-TYPE UFFI-TYPE :FFI)) )
765     `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
766        (SETF (GETHASH ,NAME *FOREIGN-TYPES-HASH*) ,UFFI-TYPE)
767        (FFI:DEF-C-TYPE ,NAME ,FFI-TYPE)))
768   ) ;;DEF-ARRAY-POINTER
769
770
771
772 (DEFMACRO DEF-UNION (NAME &REST FIELDS)
773   "
774 NAME:               A name of the new union type.
775 FIELDS:             A list of fields of the union.
776 DO:                 Defines a foreign union type.
777 URL:                http://uffi.b9.com/manual/def-union.html
778 URL:                http://clisp.sourceforge.net/impnotes.html#c-union
779 URL:                http://clisp.sourceforge.net/impnotes.html#def-c-type
780 "
781   (LET* ((NAME NAME)
782          (UFFI-TYPE (CLEAN-UFFI-TYPE `(:UNION ,NAME ,@FIELDS)))
783          (FFI-TYPE  (CONVERT-FROM-UFFI-TYPE UFFI-TYPE :FFI)) )
784     `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
785        (SETF (GETHASH ,NAME *FOREIGN-TYPES-HASH*) ,UFFI-TYPE)
786        (FFI:DEF-C-TYPE ,NAME ,FFI-TYPE)))
787   ) ;;DEF-UNION
788
789
790
791 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
792 ;; IV. Objects ;;
793 ;;;;;;;;;;;;;;;;;
794
795
796 (FFI:DEF-CALL-OUT MALLOC
797     (:NAME "malloc")
798   (:ARGUMENTS (SIZE FFI:UINT32 :IN))
799   (:RETURN-TYPE FFI:C-POINTER)
800   (:LANGUAGE :STDC)
801   (:library "/lib/libc.so.6"))
802
803
804 (FFI:DEF-CALL-OUT FREE
805     (:NAME "free")
806   (:ARGUMENTS (PTR FFI:C-POINTER :IN))
807   (:RETURN-TYPE NIL)
808   (:LANGUAGE :STDC)
809   (:library "/lib/libc.so.6"))
810
811
812 (DEFMACRO ALLOCATE-FOREIGN-OBJECT (TYPE &OPTIONAL (SIZE 1))
813   "
814 DO:                 Allocates an instance of a foreign object.
815 TYPE:               The type of foreign object to allocate.
816                     This parameter is evaluated.
817 SIZE:               An optional size parameter that is evaluated.
818                     If specified, allocates and returns an array
819                     of type that is size members long.
820                     This parameter is evaluated.
821 RETURN:             A pointer to the foreign object.
822 URL:                http://uffi.b9.com/manual/allocate-foreign-object.html
823 URL:                
824 IMPLEMENTATION:     
825 "
826   ;; TODO: CHECK IF TYPE IS CONTANT AND THE.N CHECK AND CONVERT
827   ;;       IT AT COMPILE TIME.
828   `(ffi:allocate-shallow (convert-from-uffi-type
829                           (clean-uffi-type ,type) :ffi)
830                          :count ,size)) ;;ALLOCATE-FOREIGN-OBJECT
831
832
833 (DEFMACRO FREE-FOREIGN-OBJECT (PTR)
834   "
835 DO:                 Frees the memory used by the allocation of a foreign
836                     object.
837 PTR:                A pointer to the allocated foreign object to free.
838 URL:                http://uffi.b9.com/manual/free-foreign-object.html
839 URL:
840 IMPLEMENTATION:     
841 "
842   `(ffi:foreign-free ,ptr)
843   ) ;;FREE-FOREIGN-OBJECT
844
845
846 (DEFMACRO WITH-FOREIGN-OBJECT ((VAR TYPE) &BODY BODY)
847   "
848 DO:                 This function wraps the allocation, binding,
849                     and destruction of a foreign object. On CMUCL and
850                     Lispworks platforms the object is stack allocated
851                     for efficiency. Benchmarks show that AllegroCL
852                     performs much better with static allocation.
853 VAR:                The variable name to bind.
854 TYPE:               The type of foreign object to allocate.
855                     This parameter is evaluated.
856 RETURN:             The result of evaluating the body.
857 URL:                http://uffi.b9.com/manual/with-foreign-object.html
858 URL:
859 "
860   `(LET ((,VAR (ALLOCATE-FOREIGN-OBJECT ,TYPE)))
861      (UNWIND-PROTECT
862           (PROGN ,@BODY)
863        (FREE-FOREIGN-OBJECT ,VAR)))
864   ) ;;WITH-FOREIGN-OBJECT
865
866
867 (DEFMACRO SIZE-OF-FOREIGN-TYPE (TYPE)
868   "
869 FTYPE:              A foreign type specifier. This parameter is evaluated.
870 RETURN:             The number of data bytes used by a foreign object type.
871                     This does not include any Lisp storage overhead.
872 URL:                http://uffi.b9.com/manual/size-of-foreign-type.html
873 URL:                http://clisp.sourceforge.net/impnotes.html#sizeof
874 "
875   `(FFI:SIZEOF (CONVERT-FROM-UFFI-TYPE (CLEAN-UFFI-TYPE ,TYPE) :FFI))
876   ) ;;SIZE-OF-FOREIGN-TYPE
877
878
879 (DEFMACRO POINTER-ADDRESS (PTR)
880   "
881 PTR:                A pointer to a foreign object.
882 RETURN:             An integer representing the pointer's address.
883 URL:                http://uffi.b9.com/manual/pointer-address.html
884 URL:                http://clisp.sourceforge.net/impnotes.html#c-var-addr
885 "
886   `(LET ((PTR ,PTR))
887      (DECLARE (TYPE 'FFI:FOREIGN-ADDRESS PTR))
888      (FFI::FOREIGN-ADDRESS-UNSIGNED PTR))
889   ) ;;POINTER-ADDRESS
890
891
892 (DEFMACRO DEREF-POINTER (PTR TYPE)
893   "
894 PTR:                A pointer to a foreign object.
895 TYPE:               A foreign type of the object being pointed to.
896 RETURN:             The value of the object where the pointer points.
897 URL:                http://uffi.b9.com/manual/deref-pointer.html
898 URL:                http://clisp.sourceforge.net/impnotes.html#deref
899 NOTE:               This is an accessor and can be used with SETF .
900 "
901   `(FFI:DEREF (FFI:CAST (ffi:foreign-value ,PTR)
902                         (CONVERT-FROM-UFFI-TYPE
903                          (CLEAN-UFFI-TYPE (LIST '* ,TYPE)) :FFI)
904                         ))
905   ) ;;DEREF-POINTER
906
907
908 (DEFMACRO ENSURE-CHAR-CHARACTER (OBJECT)
909   "
910 DO:                 Ensures that an object obtained by dereferencing
911                     a :CHAR pointer is a character.
912 OBJECT:             Either a character or a integer specifying
913                     a character code.
914 RETURN:             A character.
915 URL:                http://uffi.b9.com/manual/ensure-char-character.html
916 URL:
917 "
918   `(LET ((OBJECT ,OBJECT))
919      (IF (CHARACTERP OBJECT) OBJECT (CODE-CHAR OBJECT)))
920   ) ;;ENSURE-CHAR-CHARACTER
921
922
923 (DEFMACRO ENSURE-CHAR-INTEGER (OBJECT)
924   "
925 DO:                 Ensures that an object obtained by dereferencing
926                     a :CHAR pointer is an integer.
927 OBJECT:             Either a character or a integer specifying
928                     a character code.
929 RETURN:             An integer.
930 URL:                http://uffi.b9.com/manual/ensure-char-integer.html
931 URL:
932 "
933   `(LET ((OBJECT ,OBJECT))
934      (IF (CHARACTERP OBJECT) (CHAR-CODE OBJECT) OBJECT))
935   ) ;;ENSURE-CHAR-INTEGER
936
937
938 (DEFMACRO MAKE-NULL-POINTER (TYPE)
939   "
940 DO:                 Creates a NULL pointer of a specified type.
941 TYPE:               A type of object to which the pointer refers.
942 RETURN:             The NULL pointer of type TYPE.
943 URL:                http://uffi.b9.com/manual/make-null-pointer.html
944 URL:
945 "
946   (declare (ignore type))
947   (FFI::UNSIGNED-FOREIGN-ADDRESS 0)
948   ;;  `(FFI:CAST (ffi:foreign-value (FFI::UNSIGNED-FOREIGN-ADDRESS 0))
949   ;;              (CONVERT-FROM-UFFI-TYPE
950   ;;               (CLEAN-UFFI-TYPE (LIST '* ,TYPE)) :FFI))
951   ) ;;MAKE-NULL-POINTER
952
953
954
955 (DEFMACRO NULL-POINTER-P (PTR)
956   "
957 DO:                 Tests if a pointer is has a NULL value.
958 PTR:                A foreign object pointer.
959 RETURN:             Whether ptr is NULL.
960 URL:                http://uffi.b9.com/manual/null-pointer-p.html
961 URL:                http://clisp.sourceforge.net/impnotes.html#fa-null
962 "
963   `(FFI:FOREIGN-ADDRESS-NULL ,PTR)
964   ) ;;NULL-POINTER-P
965
966
967 (DEFCONSTANT +NULL-CSTRING-POINTER+
968   (FFI::UNSIGNED-FOREIGN-ADDRESS 0)
969   ;;(FFI:CAST (ffi:foreign-value (FFI::UNSIGNED-FOREIGN-ADDRESS 0))
970   ;;          (CONVERT-FROM-UFFI-TYPE (CLEAN-UFFI-TYPE :CSTRING) :FFI))
971   "A NULL cstring pointer.
972 This can be used for testing if a cstring returned by a function is NULL.
973 URL:                http://uffi.b9.com/manual/null-cstring-pointer.html
974 "
975   ) ;;+NULL-CSTRING-POINTER+
976
977
978 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
979 ;; V. Strings ;;
980 ;;;;;;;;;;;;;;;;
981
982
983 (DEFMACRO CONVERT-FROM-CSTRING (CSTRING)
984   "
985 CSTRING:            A cstring.
986 RETURN:             A Lisp string.
987 DO:                 Converts a Lisp string to a cstring.
988                     This is most often used when processing the
989                     results of a foreign function that returns a
990                     cstring.
991 URL:                http://uffi.b9.com/manual/convert-from-cstring.html
992 "
993   `,CSTRING
994   ) ;;CONVERT-FROM-CSTRING
995
996
997
998 (DEFMACRO CONVERT-TO-CSTRING (STRING)
999   "
1000 STRING:             A Lisp string.
1001 RETURN:             A cstring.
1002 DO:                 Converts a Lisp string to a cstring.
1003                     The cstring should be freed with free-cstring.
1004 URL:                http://uffi.b9.com/manual/convert-to-cstring.html
1005 "
1006   `,STRING
1007   ) ;;CONVERT-TO-CSTRING
1008
1009
1010 (DEFMACRO FREE-CSTRING (CSTRING)
1011   "
1012 CSTRING:            A cstring.
1013 DO:                 Frees any memory possibly allocated by convert-to-cstring.
1014                     On some implementions, a cstring is just the Lisp
1015                     string itself.
1016 "
1017   (declare (ignore cstring))
1018   ;; NOP
1019   ) ;;FREE-CSTRING
1020
1021
1022 (DEFMACRO WITH-CSTRING ((CSTRING STRING) &BODY BODY)
1023   "
1024 CSTRING:            A symbol naming the cstring to be created.
1025 STRING:             A Lisp string that will be translated to a cstring.
1026 BODY:               The body of where the CSTRING will be bound.
1027 DO:                 Binds a symbol to a cstring created from conversion
1028                     of a string. Automatically frees the cstring.
1029 URL:                http://uffi.b9.com/manual/with-cstring.html
1030 "
1031   ;; `(let ((,cstring (convert-to-cstring ,string)))
1032   ;;    (unwind-protect
1033   ;;        (progn ,@body)
1034   ;;      (free-cstring ,cstring)))
1035   `(LET ((,CSTRING ,STRING))
1036      ,@BODY)
1037   ) ;;WITH-CSTRING
1038
1039
1040 (defun foreign-string-length (foreign-string)
1041   (do ((len 0 (1+ len)))
1042       ((= 0 (ffi:element (ffi:foreign-value foreign-string) len))
1043        len))) ;;foreign-string-length
1044
1045
1046 (DEFUN CONVERT-FROM-FOREIGN-STRING (FOREIGN-STRING
1047                                     &KEY LENGTH (NULL-TERMINATED-P T))
1048   "
1049 DO:                 Builds a Lisp string from a foreign string.
1050                     Can translate ASCII and binary strings.
1051 FOREIGN-STRING:     A foreign string.
1052 LENGTH:             The length of the foreign string to convert.
1053                     The default is the length of the string until
1054                     a NULL character is reached.
1055 NULL-TERMINATED-P:  A boolean flag with a default value of T.
1056                     When true, the string is converted until the first
1057                     NULL character is reached.
1058 RETURN:             A Lisp string.
1059 URL:        http://uffi.b9.com/manual/convert-from-foreign-string.html
1060 URL:        http://clisp.sourceforge.net/impnotes.html#encoding
1061 "
1062   (let ((byte-vector (make-array (list (if (or null-terminated-p (null length))
1063                                            (foreign-string-length foreign-string)
1064                                            length))
1065                                  :element-type '(unsigned-byte 8)))
1066         (foreign-type `(ffi:c-array ffi:uchar ,(list length))))
1067     (declare (ignore foreign-type))     ; TODO!
1068     (dotimes (i (length byte-vector))
1069       (setf (aref byte-vector i)
1070             (ffi:element (ffi:foreign-value foreign-string) i)))
1071     (EXT:CONVERT-STRING-FROM-BYTES byte-vector CUSTOM:*FOREIGN-ENCODING*)  
1072     )) ;;CONVERT-FROM-FOREIGN-STRING
1073
1074
1075 (DEFUN CONVERT-TO-FOREIGN-STRING (STRING)
1076   "
1077 STRING:             A Lisp string.
1078 RETURN:             A foreign string.
1079 DO:                 Converts a Lisp string to a foreign string.
1080                     Memory should be freed with free-foreign-object.
1081 URL:        http://uffi.b9.com/manual/convert-to-foreign-string.html
1082 "
1083   (let* ((byte-vector
1084           (EXT:CONVERT-STRING-TO-BYTES string CUSTOM:*FOREIGN-ENCODING*))
1085          (result (ALLOCATE-FOREIGN-STRING (1+ (length byte-vector))))
1086          (foreign-type `(ffi:c-array 
1087                          ffi:uchar ,(list (1+ (length byte-vector))))))
1088     (declare (ignore foreign-type))     ; TODO!
1089     (dotimes (i (length byte-vector))
1090       (setf (ffi:element (ffi:foreign-value result) i)
1091             (aref byte-vector i)))
1092     (setf (ffi:element  (ffi:foreign-value result) (length byte-vector)) 0)
1093     result)) ;;CONVERT-TO-FOREIGN-STRING
1094
1095
1096 (DEFUN ALLOCATE-FOREIGN-STRING (SIZE &KEY (UNSIGNED T))
1097   "
1098 SIZE:               The size of the space to be allocated in bytes.
1099 UNSIGNED:           A boolean flag with a default value of T.
1100                     When true, marks the pointer as an :UNSIGNED-CHAR.
1101 RETURN:             A foreign string which has undefined contents.
1102 DO:                 Allocates space for a foreign string.
1103                     Memory should be freed with free-foreign-object.
1104 URL:            http://uffi.b9.com/manual/allocate-foreign-string.html
1105 "
1106   (ALLOCATE-FOREIGN-OBJECT (if unsigned ':unsigned-char ':char) size)
1107   ) ;;ALLOCATE-FOREIGN-STRING
1108
1109
1110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1111 ;; VI. Functions & Libraries ;;
1112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1113
1114
1115 (DEFPARAMETER *MODULES-TO-LIBRARY-MAP* (MAKE-HASH-TABLE :TEST (FUNCTION EQUAL))
1116   "Maps module names to library paths.")
1117
1118
1119 (DEFMACRO DEF-FUNCTION (NAME ARGS &KEY MODULE RETURNING)
1120   "
1121 DO:                 Declares a foreign function.
1122 NAME:               A string or list specifying the function name.
1123                     If it is a string, that names the foreign
1124                     function. A Lisp name is created by translating
1125                     #\_ to #\- and by converting to upper-case in
1126                     case-insensitive Lisp implementations. If it is a
1127                     list, the first item is a string specifying the
1128                     foreign function name and the second it is a
1129                     symbol stating the Lisp name.
1130 ARGS:               A list of argument declarations.  If NIL, indicates
1131                     that the function does not take any arguments.
1132 MODULE:             A string specifying which module (or library)
1133                     that the foreign function resides. (Required by Lispworks)
1134 RETURNING:          A declaration specifying the result type of
1135                     the foreign function. :VOID indicates that this function
1136                     does not return any value.
1137 URL:                http://uffi.b9.com/manual/def-function.html
1138 NOTE:               All Common-Lisp implementations are 'case-insensitive'.
1139                     http://www.lisp.org/HyperSpec/Body/sec_2-1-1-2.html
1140 "
1141   (let (l-name c-name)
1142     (if (stringp name)
1143         (setq c-name name
1144               l-name (intern (string-upcase
1145                               (substitute (character "-") (character "_") name))))
1146         (setq c-name (first name)
1147               l-name (second name)))
1148     `(FFI:DEF-CALL-OUT
1149          ,l-name
1150          (:name ,c-name)
1151        ,@(when args
1152                `((:arguments
1153                   ,@(mapcar (lambda (arg)
1154                               `(,(first arg)
1155                                  ,(CONVERT-FROM-UFFI-TYPE 
1156                                    (clean-uffi-type (second arg)) :FFI)
1157                                  :in))
1158                             args))))
1159        ,@(when returning
1160                `((:return-type ,(CONVERT-FROM-UFFI-TYPE
1161                                  (clean-uffi-type returning) :FFI))))
1162        ,@(when module
1163                (let ((library (gethash module *MODULES-TO-LIBRARY-MAP*)))
1164                  `((:library  ,(or library module)))))
1165        (:LANGUAGE :STDC)))) ;;DEF-FUNCTION
1166
1167
1168 (DEFUN LOAD-FOREIGN-LIBRARY (FILENAME &KEY MODULE SUPPORTING-LIBRARIES)
1169   "
1170 DO:                 Loads a foreign library. Applies a module name
1171                     to functions within the library. Ensures that
1172                     a library is only loaded once during a session.
1173 FILENAME:           A string or pathname specifying the library location
1174                     in the filesystem. At least one implementation
1175                     (Lispworks) can not accept a logical pathname.
1176 MODULE:             A string designating the name of the module to
1177                     apply to functions in this library.
1178                     (Required for Lispworks)
1179 SUPPORTING-LIBRARIES:
1180                     A list of strings naming the libraries required to
1181                     link the foreign library. (Required by CMUCL)
1182 RETURN:             A boolean flag, T if the library was able to be
1183                     loaded successfully or if the library has been
1184                     previously loaded, otherwise NIL.
1185 URL:                http://uffi.b9.com/manual/load-foreign-library.html
1186 IMPLEMENTATION:     Loading the library is defered to the first function call.
1187                     Here we just register the mapping between the MODULE and
1188                     the FILENAME.
1189 TODO:               Should we explicitely load the SUPPORTING-LIBRARIES too?
1190 "
1191   (declare (ignore SUPPORTING-LIBRARIES))
1192   (when module
1193     (setf (gethash module *MODULES-TO-LIBRARY-MAP*) (namestring filename)))
1194   t) ;;LOAD-FOREIGN-LIBRARY
1195
1196
1197 (DEFUN SPLIT-STRING (STRING &OPTIONAL (SEPARATORS " "))
1198   "
1199 NOTE:   current implementation only accepts as separators
1200         a string containing literal characters.
1201 "
1202   (UNLESS (SIMPLE-STRING-P STRING)     (SETQ STRING     (COPY-SEQ STRING)))
1203   (UNLESS (SIMPLE-STRING-P SEPARATORS) (SETQ SEPARATORS (COPY-SEQ SEPARATORS)))
1204   (LET ((CHUNKS  '())
1205         (POSITION 0)
1206         (NEXTPOS  0)
1207         (STRLEN   (LENGTH STRING)) )
1208     (DECLARE (TYPE SIMPLE-STRING STRING SEPARATORS))
1209     (LOOP WHILE (< POSITION STRLEN)
1210        DO
1211        (LOOP WHILE (AND (< NEXTPOS STRLEN)
1212                         (NOT (POSITION (CHAR STRING NEXTPOS) SEPARATORS)))
1213           DO (SETQ NEXTPOS (1+ NEXTPOS))
1214           ) ;;loop
1215        (PUSH (SUBSEQ STRING POSITION NEXTPOS) CHUNKS)
1216        (SETQ POSITION (1+ NEXTPOS))
1217        (SETQ NEXTPOS  POSITION)
1218        ) ;;loop
1219     (NREVERSE CHUNKS)
1220     )) ;;SPLIT-STRING
1221
1222
1223 (DEFUN FIND-FOREIGN-LIBRARY (NAMES DIRECTORIES &KEY DRIVE-LETTERS TYPES VERBOSE)
1224   "
1225 NAMES:              A string or list of strings containing the base name
1226                     of the library file.
1227 DIRECTORIES:        A string or list of strings containing the directory
1228                     the library file.
1229 DRIVE-LETTERS:      A string or list of strings containing the drive letters
1230                     for the library file.
1231 TYPES:              A string or list of strings containing the file type
1232                     of the library file. Default is NIL. If NIL, will use
1233                     a default type based on the currently running
1234                     implementation.
1235 VERBOSE:            This is an extension from the UFFI specification.
1236                     Prints a line on *trace-output* for each path considered.
1237 RETURN:             The path of the first found file, or NIL if the
1238                     library file was not found.
1239 DO:                 Finds a foreign library by searching through a number
1240                     of possible locations.
1241 URL:                http://uffi.b9.com/manual/find-foreign-library.html
1242 IMPLEMENTATION:     You'd better leave it up to the system to find the library!
1243                     This implementation can't locate libc because on linux,
1244                     there's no link named libc.so and this API doesn't allow
1245                     for a version number (anyway, library versions such as in
1246                     libc.so.6.0.1 have nothing to do with COMMON-LISP version 
1247                     that are actually file versions and mere integers).
1248                     Some people believe the can pass with impunity strings
1249                     containing dots as types. But that's not so.
1250 "
1251   (flet ((ensure-list (item) (if (listp item) item (list item))))
1252     (setf names         (ensure-list names))
1253     (setf directories   (ensure-list directories))
1254     (setf drive-letters (ensure-list drive-letters))
1255     (setf types         (ensure-list types))
1256     (setf names (mapcan (lambda (name)
1257                           (if (or (<= (length name) 3)
1258                                   (string/= "lib" name :end2 3))
1259                               (list name (concatenate 'string "lib" name))
1260                               (list name))) names))
1261     (setf types (or (delete-if (lambda (item) 
1262                                  (not (every (function alphanumericp) item)))
1263                                types) '("so")))
1264     (setf drive-letters (or drive-letters '(nil)))
1265     (when verbose
1266       (format *trace-output* "Directories   = ~S~%" directories)
1267       (format *trace-output* "Types         = ~S~%" types)
1268       (format *trace-output* "Names         = ~S~%" names)
1269       (format *trace-output* "Drive-letters = ~S~%" drive-letters))
1270     (dolist (dir directories)
1271       (dolist (type types)
1272         (dolist (name names)
1273           (dolist (device drive-letters)
1274             (let ((path (make-pathname
1275                          :device device
1276                          :directory ((lambda (items)
1277                                        (if (char= (character "/") (char dir 0))
1278                                            (cons :absolute (cdr items))
1279                                            (cons :relative items)))
1280                                      (split-string dir "/"))
1281                          :name name
1282                          :type type)))
1283               (when verbose
1284                 (format *trace-output* "; Considering ~S~%" path))
1285               (when (probe-file path)
1286                 (return-from find-foreign-library path))))))
1287       nil))) ;;FIND-FOREIGN-LIBRARY
1288
1289
1290 ;;;; THE END ;;;;