Wed Aug 11 19:54:15 BRT 2010 Gustavo Henrique Milare * Support for argument directions. New patches: [Support for argument directions. Gustavo Henrique Milare **20100811225415 Ignore-this: 9558d12e50e838bf6e66f505ab42895a ] { hunk ./src/cffi-abcl.lisp 170 `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect - (progn ,@body) + (locally ,@body) (foreign-free ,var)))) ;;;# Shareable Vectors hunk ./src/cffi-allegro.lisp 147 `(let* ((,size-var ,size) (,var (ff:allocate-fobject :char :c ,size-var))) (unwind-protect - (progn ,@body) + (locally ,@body) (ff:free-fobject ,var)))) ;;;# Shareable Vectors hunk ./src/cffi-clisp.lisp 235 ;; copy-in (loop for i below ,size-var do (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i)) - (unwind-protect (progn ,@body) + (unwind-protect (locally ,@body) ;; copy-out (loop for i below ,size-var do (setf (aref ,vector-var i) hunk ./src/cffi-cmucl.lisp 131 `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect - (progn ,@body) + (locally ,@body) (foreign-free ,var))))) ;;;# Allocation hunk ./src/cffi-corman.lisp 138 `(let* ((,size-var ,size) (,var (malloc ,size-var))) (unwind-protect - (progn ,@body) + (locally ,@body) (free ,var)))) ;;;# Shareable Vectors hunk ./src/cffi-ecl.lisp 93 `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect - (progn ,@body) + (locally ,@body) (foreign-free ,var)))) ;;;# Misc. Pointer Operations hunk ./src/cffi-gcl.lisp 107 `(let* ((,size-var ,size) (,var (foreign-alloc ,size-var))) (unwind-protect - (progn ,@body) + (locally ,@body) (foreign-free ,var)))) ;;;# Misc. Pointer Operations hunk ./src/cffi-sbcl.lisp 158 `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect - (progn ,@body) + (locally ,@body) (foreign-free ,var))))) ;;;# Shareable Vectors hunk ./src/functions.lisp 7 ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2007, Luis Oliveira +;;; Copyright (C) 2010, Gustavo Henrique Milare ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation hunk ./src/functions.lisp 44 ;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of ;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function. +;;; We define a wrapper pointer for arguments of directions +;;; :OUT, :COPY and :IN-OUT in DEFCFUN. + +(define-foreign-type wrapper-pointer () + ((base-type :accessor base-type :initarg :base-type) + (directions :accessor directions :initarg :directions)) + (:actual-type :pointer)) + +;;; Auxiliary virtual type parsers for argument directions. +;;; +;;; If desired, FOREIGN-FUNCALL can also support argument directions +;;; by exporting the symbols OUT, COPY and IN-OUT +;;; (or changing them to keywords and changing DIRECTION-TO-TYPE +;;; accordingly). +;;; Without any changes, it should work when used like this: +;;; +;;; (cffi:foreign-funcall (cffi::in-out :int) 3 (cffi::out :int) nil :void) +;;; +;;; OUT arguments would be required, which is inconsistent. +;;; It might also be error-prone and of little practical use. + +;; (define-parse-method in (base-type) +;; (parse-type base-type)) + +(define-parse-method out (base-type) + (make-instance 'wrapper-pointer + :base-type base-type + :directions '(:output))) + +(define-parse-method copy (base-type) + (make-instance 'wrapper-pointer + :base-type base-type + :directions '(:input))) + +(define-parse-method in-out (base-type) + (make-instance 'wrapper-pointer + :base-type base-type + :directions '(:input :output))) + +(defun direction-to-type (base-type &optional (direction :in)) + (ecase direction + (:in base-type) + (:out `(out ,base-type)) + (:in-out `(in-out ,base-type)) + (:copy `(copy ,base-type)))) + +(defmethod expand-to-foreign-dyn (value var-pointer body (type wrapper-pointer)) + (with-unique-names (var-value) + (let ((base-type (base-type type))) + `(with-foreign-object (,var-pointer ,base-type) + ,@(if (member :input (directions type)) + (list (expand-to-foreign-dyn + value var-value + `((%mem-set ,var-value ,var-pointer + ,(canonicalize-foreign-type base-type)) + ,@body) + (parse-type base-type))) + body))))) + (defun translate-objects (syms args types rettype call-form) "Helper function for FOREIGN-FUNCALL and DEFCFUN." hunk ./src/functions.lisp 105 - (if (null args) - (expand-from-foreign call-form (parse-type rettype)) - (expand-to-foreign-dyn - (car args) (car syms) - (list (translate-objects (cdr syms) (cdr args) - (cdr types) rettype call-form)) - (parse-type (car types))))) + (labels ((%translate-objects (syms args types rettype call-form values) + (if (null args) + (let ((form (expand-from-foreign + call-form (parse-type rettype))) + (values (reverse values))) + (if (eq :void (canonicalize-foreign-type rettype)) + `(progn ,form (values ,@values)) + `(values ,form ,@values))) + (let ((parsed-type (parse-type (car types)))) + (expand-to-foreign-dyn + (car args) (car syms) + (list (%translate-objects + (cdr syms) (cdr args) + (cdr types) rettype call-form + (if (and (typep parsed-type 'wrapper-pointer) + (member :output (directions parsed-type))) + (cons `(mem-ref ,(car syms) + ,(base-type parsed-type)) + values) + values))) + (parse-type (car types))))))) + (%translate-objects syms args types rettype call-form nil))) (defun parse-args-and-types (args) "Returns 4 values. Types, canonicalized types, args and return type." hunk ./src/functions.lisp 244 ;;; The DEFCFUN macro provides a declarative interface for defining ;;; Lisp functions that call foreign functions. +(defun parse-defcfun-args (args) + (loop for arg in args + for (name type direction) = arg + if (eq :out direction) + collect (list nil type direction) into all-args + else collect arg into all-args + and collect name into in-args + finally (return (values in-args all-args)))) + ;; If cffi-sys doesn't provide a defcfun-helper-forms, ;; we define one that uses %foreign-funcall. (eval-when (:compile-toplevel :load-toplevel :execute) hunk ./src/functions.lisp 267 (defun %defcfun (lisp-name foreign-name return-type args options docstring) (let ((arg-names (mapcar #'car args)) - (arg-types (mapcar #'cadr args)) + (arg-types (mapcar #'(lambda (arg) + (apply #'direction-to-type (cdr arg))) + args)) (syms (make-gensym-list (length args)))) (multiple-value-bind (prelude caller) (defcfun-helper-forms hunk ./src/functions.lisp 277 syms (mapcar #'canonicalize-foreign-type arg-types) options) `(progn ,prelude - (defun ,lisp-name ,arg-names + (defun ,lisp-name ,(parse-defcfun-args args) ,@(ensure-list docstring) ,(translate-objects syms arg-names arg-types return-type caller)))))) hunk ./src/functions.lisp 284 (defun %defcfun-varargs (lisp-name foreign-name return-type args options doc) (with-unique-names (varargs) - (let ((arg-names (mapcar #'car args))) - `(defmacro ,lisp-name (,@arg-names &rest ,varargs) + (multiple-value-bind (in-args all-args) + (parse-defcfun-args args) + `(defmacro ,lisp-name (,@in-args &rest ,varargs) ,@(ensure-list doc) `(foreign-funcall-varargs ,'(,foreign-name ,@options) hunk ./src/functions.lisp 290 - ,,`(list ,@(loop for (name type) in args - collect `',type collect name)) + ,,`(list ,@(loop for (name . type-and-dir) in all-args + collect `',(apply #'direction-to-type type-and-dir) + collect name)) ,@,varargs ,',return-type))))) hunk ./tests/defcfun.lisp 6 ;;; defcfun.lisp --- Tests function definition and calling. ;;; ;;; Copyright (C) 2005-2007, Luis Oliveira +;;; Copyright (C) 2010, Gustavo Henrique Milare ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation hunk ./tests/defcfun.lisp 410 (loop repeat 100 do (stdcall-fun 1 2 3) finally (return (stdcall-fun 1 2 3))) 6)) + +(defcfun "sum_out" :void + (dest :int :out) + (a :int :in) + (b :int :in)) + +(deftest defcfun.directions.sum-out + (sum-out 4 7) + 11) + +(defcfun (sum-out-vararg "sum_out") :void + (dest :int :out) + &rest) + +(deftest defcfun.directions.sum-out-vararg + (sum-out-vararg :int 4 :int 7) + 11) + +(defcfun "sum_and_sub_out" :void + (sum :int :out) + (sub :int :out) + (a :int :in) + (b :int :in)) + +(deftest defcfun.directions.sum-and-sub-out + (sum-and-sub-out 4 7) + 11 -3) + +(defcfun (sum-and-sub-out-vararg "sum_and_sub_out") :void + (sum :int :out) + (sub :int :out) + &rest) + +(deftest defcfun.directions.sum-and-sub-out + (sum-and-sub-out-vararg :int 4 :int 7) + 11 -3) + +(defcfun "read_next_char_out" :int + (dest :char :out) + (string ::string) + (start :int)) + +(deftest defcfun.directions.read-next-char-out + (read-next-char-out " a bc " 0) + 2 #.(char-code #\a)) + +(deftest defcfun.directions.read-next-char-out-2 + (read-next-char-out " a bc " 3) + 4 #.(char-code #\b)) + +(defcfun "sum_in_out" :void + (dest :int :in-out) + (a :int :in) + (b :int :in)) + +(deftest defcfun.directions.sum-in-out + (sum-in-out 2 4 7) + 13) + +(defcfun (sum-in-out-vararg "sum_in_out") :void + (dest :int :in-out) + &rest) + +(deftest defcfun.directions.sum-in-out-vararg + (sum-in-out-vararg 2 :int 4 :int 7) + 13) + +(defcfun "sum_and_sub_in_out" :void + (sum :int :in-out) + (sub :int :in-out) + (a :int :in) + (b :int :in)) + +(deftest defcfun.directions.sum-and-sub-in-out + (sum-and-sub-in-out 2 3 4 7) + 13 0) + +(defcfun (sum-and-sub-in-out-vararg "sum_and_sub_in_out") :void + (sum :int :in-out) + (sub :int :in-out) + &rest) + +(deftest defcfun.directions.sum-and-sub-in-out + (sum-and-sub-in-out-vararg 2 3 :int 4 :int 7) + 13 0) + +(defcfun "hash_copy" :void + (value :int :in-out) + (hash1 :int :copy) + (hash2 :int :copy)) + +(deftest defcfun.directions.hash-copy + (hash-copy 97 5 3) + 488) hunk ./tests/libtest.c 6 * libtest.c --- auxiliary C lib for testing purposes * * Copyright (C) 2005-2007, Luis Oliveira + * Copyright (C) 2010, Gustavo Henrique Milare * * Permission is hereby granted, free of charge, to any person * obtaining a copy of this software and associated documentation hunk ./tests/libtest.c 879 /* vim: ts=4 et */ + +/* + * DEFCFUN.DIRECTIONS.SUM-OUT + */ + +DLLEXPORT +void sum_out(int *dest, int a, int b) +{ + *dest = a + b; +} + +/* + * DEFCFUN.DIRECTIONS.SUM-AND-SUB-OUT + */ + +DLLEXPORT +void sum_and_sub_out(int *sum, int *sub, int a, int b) +{ + *sum = a + b; + *sub = a - b; +} + +/* + * DEFCFUN.DIRECTIONS.READ-NEXT-CHAR-OUT + * DEFCFUN.DIRECTIONS.READ-NEXT-CHAR-OUT-2 + */ + +DLLEXPORT +int read_next_char_out(char *dest, char *string, int start) +{ + int i; + + for (i=start; string[i]==' '; i++); + + *dest = string[i]; + + return i; +} + +/* + * DEFCFUN.DIRECTIONS.SUM-IN-OUT + */ + +DLLEXPORT +void sum_in_out(int *dest, int a, int b) +{ + *dest = *dest + a + b; +} + +/* + * DEFCFUN.DIRECTIONS.SUM-AND-SUB-IN-OUT + */ + +DLLEXPORT +void sum_and_sub_in_out(int *sum, int *sub, int a, int b) +{ + *sum = *sum + a + b; + *sub = *sub + a - b; +} + +/* + * DEFCFUN.DIRECTIONS.HASH-CHAR-COPY + */ + +DLLEXPORT +void hash_copy(int *value, int *hash1, int *hash2) +{ + *value = (*value) * (*hash1) + (*hash2); +} hunk ./uffi-compat/uffi-compat.lisp 114 (:cstring :pointer) (:pointer-void :pointer) (:pointer-self :pointer) - (:char '(uffi-char :char)) - (:unsigned-char '(uffi-char :unsigned-char)) + ;; Uffi's documentation says dereferencing :char and :unsigned-char + ;; returns characters while it actually returns integers + (:char :char) + (:unsigned-char :unsigned-char) (:byte :char) (:unsigned-byte :unsigned-char) (t hunk ./uffi-compat/uffi-compat.lisp 408 "Define a foreign function." (declare (ignore module)) `(cffi:defcfun ,name ,(convert-uffi-type returning) - ,@(loop for (name type) in args - collect `(,name ,(convert-uffi-type type))))) + ,@(loop for (name type . rest) in args + collect `(,name ,(convert-uffi-type type) ,@rest)))) ;;; Taken from UFFI's src/libraries.lisp } Context: [cffi-ecl: always push no-long-long Luis Oliveira **20100428225604 Ignore-this: 784c1c4b1567455e551ceeee0381cee8 LONG-LONG is not supported by ECL's interpreter yet. ] [cffi-tests: don't use FOREIGN-FREE for malloc()ed memory Luis Oliveira **20100428225337 Ignore-this: 5c02fbd1880a2f69a7bb59f8bb22f66b Patch courtesy of Juan Jose Garcia-Ripoll. ] [New pointer-related tests Luis Oliveira **20100428224243 Ignore-this: 6a2f040e2212317b46441a48851d48ac Testing error situations for some pointer operations. ] [cffi-ecl: simplify shareable vector implementation Luis Oliveira **20100425231232 Ignore-this: 75b0d4bba44f7313d3a629184ee93d42 Patch courtesy of Juan Jose Garcia-Ripoll. ] [cffi-ecl: inline %mem-set and %mem-ref Luis Oliveira **20100425230219 Ignore-this: 121b7b707e867051fc5ef8b45a306234 Patch courtesy of Juan Jose Garcia-Ripoll. ] [cffi-ecl: use C-INLINE when producing compiled code Luis Oliveira **20100425225004 Ignore-this: 30c083fea4568be7c20f4f819d5a8ffa Using the ECL extension EXT:WITH-BACKEND, CFFI can produce code that works differently when using the interpreter than when using the lisp2C compiler. This leads to more efficient code. This change is backwards compatible. Patch courtesy of Juan Jose Garcia-Ripoll. ] [cffi-ecl: reexport NULL-POINTER-P from SI Luis Oliveira **20100425223914 Ignore-this: 7dd39ad27e6827545c1b16fc071fa4b5 Patch courtesy of Juan Jose Garcia-Ripoll. ] [cffi-ecl: use ECL's :long-long feature Luis Oliveira **20100425223748 Ignore-this: a58e16e0ef93b05576d05852f47fda6f Patch courtesy of Juan Jose Garcia-Ripoll. ] [Allegro: fix WITH-FOREIGN-POINTER Luis Oliveira **20100425122443 Ignore-this: 275a83ec9e6b161c046644ef2e4b79a5 - Fixes previous patch. - New test: WITH-FOREIGN-POINTER.CONSTANT-SIZE. ] [Allow the use of constants in WITH-FOREIGN-OBJECT for Allegro. Jianshi Huang **20100421091956 Ignore-this: 612e375c10cae6e070b94baddf231e0d ] [Remove unused C macro SIGNED_ from common.h Stelian Ionescu **20100219173353 Ignore-this: 127d3fac79151d22b23ce435cab3558 ] [cffi-manual: navigation improvements. Luis Oliveira **20100106232110 Ignore-this: 5944e0d6072d1357b41a42d2658708d4 - Add WITH-FOREIGN-OBJECTS and WITH-FOREIGN-STRINGS to the dictionary menus. (This unfortunately seems to require specifying the @node declarations in full.) - Make the table of contents more manageable by turning @unnumberedsecs into @headings. - Fix docstring in DEFSTRUCT example. ] [cffi-lispworks: add IGNORE declaration to CREATE-FOREIGN-FUNCALLABLE Luis Oliveira **20100101174635 Ignore-this: a6fbc492c01a1b45339b0fde226f6cb7 ] [cffi-lispworks: make null-pointer-p check its argument's type Luis Oliveira **20100101174529 Ignore-this: 5aa0ba3afae82dd729f849c03582ac6c ] [Documentation: add note about RT, update description of no-long-long. Luis Oliveira **20100101173443 Ignore-this: 97430803980a0492290dafbd29cb062f ] [Preliminary support for ABCL. Luis Oliveira **20100101172600 Ignore-this: 1b9e5eb2ba0718bff2756f1897ad08b3 ] [Update email address. Stelian Ionescu **20091211164938 Ignore-this: c8aab03fe8a070fc83fb39ab3fa3ad42 ] [Remove spurious PRINT call. Stelian Ionescu **20091211164909 Ignore-this: ea138b4aff965ed7547956a93c98bfac ] [cffi-manual: the :STRING type does not support ub8 arrays anymore Luis Oliveira **20091124232002 Ignore-this: 509d08ce9acceacbe694a678552746bc ] [libtest: support 64-bit on OSX Leopard Luis Oliveira **20091124231741 Ignore-this: d7997fa0aca44a1f0351bdde32ea91f8 ] [cffi-tests: show Lispworks the full path to libm.dylib Luis Oliveira **20091124231442 Ignore-this: ccf9bfdc692e726f7760b1dd0ecfb985 ] [cffi-lispworks: turns out Lispworks does support llong on 32-bit platforms Luis Oliveira **20091124231321 Ignore-this: 8e131fb8e20f9d1448dd740d336ec1b4 ] [Deprecate groveler clause FLAG in favour of CC-FLAGS. Stelian Ionescu **20090823121108 Ignore-this: e1537717a9e7356b208d5cd14b34ba50 ] [cffi-allegro: define long long types on 64-bit platforms Luis Oliveira **20090821210052 Patch courtesy of John Fremlin. ] [cffi-tests: fix pointer-to-integer casts in libtest.c Luis Oliveira **20090821205447] [cffi-tests: don't use stdcall #ifndef WIN32 Luis Oliveira **20090821205144] [Also canonicalize search paths in library specs. Stelian Ionescu **20090809005356 Ignore-this: 86a039c7ebbc757c9934fe99368ae0bb ] [Update manual. Stelian Ionescu **20090808222834 Ignore-this: 15e832e5220a6ca70722730d81edf283 DEFCFUN & co. now take only :CONVENTION. ] [Whitespace. Stelian Ionescu **20090808221547 Ignore-this: 18d99969b97b190176e88d9eb24a94ce ] [Declare DEFCALLBACK, DEFCFUN and DEFINE-FOREIGN-LIBRARY's keyword args :CCONV and :CALLING-CONVENTION obsolete, use :CONVENTION instead. Stelian Ionescu **20090808221055 Ignore-this: 9e90dfde20f4a4dfd764c5250d8b2ea6 ] [Fix docstring of LIST-FOREIGN-LIBRARIES. Stelian Ionescu **20090807164116 Ignore-this: 5c65a2d7608718e9bc0560e780855bf1 ] [Fix reloading a library in LOAD-FOREIGN-LIBRARY. Stelian Ionescu **20090807162733 Ignore-this: 267edf226a87d24d0441bf85515cc437 ] [Use type :wrapper for wrapper libraries generated by the groveler. Stelian Ionescu **20090804204132 Ignore-this: d61f9a69cfb323905d8abbb40bf84be9 ] [Use type :test for the test libraries. Stelian Ionescu **20090720154312 Ignore-this: 6dad3c93d47cd22e27c73c6ba7f2e8d1 ] [Add the ability to specify a foreign library's type and search path. Stelian Ionescu **20090720154028 Ignore-this: 7de87b54da57c74f9a7c994d6255df84 Also export: - FOREIGN-LIBRARY - FOREIGN-LIBRARY-PATHNAME - FOREIGN-LIBRARY-TYPE - FOREIGN-LIBRARY-LOADED-P - LIST-FOREIGN-LIBRARIES ] [Cosmetic changes (cconv -> calling-convention). Stelian Ionescu **20090720153925 Ignore-this: 38bc21d362c69fbf2dc10d268615b4fb ] [Groveler fixes for ECL. Stelian Ionescu **20090804193738 Ignore-this: b834b25942f10bf4a42fdc3e9d0a2a0e ] [ECL: support more vector types in CFFI-SYS:WITH-POINTER-TO-VECTOR-DATA Luis Oliveira **20090725231330 Patch courtesy of Andy Hefner. ] [cffi-openmcl: prepend _ to external names on #+darwin, not just #+darwinppc Luis Oliveira **20090710180832] [grovel: don't use cffi-features. Luis Oliveira **20090702201557] [clisp: small fix to %FOREIGN-ALLOC Luis Oliveira **20090701185918 - Deal with (%foreign-alloc 0) gracefully by turning it into a one byte allocation. This is similar to what glibc's malloc() does, IIUC. - Regression test: FOREIGN-ALLOC.6. Reported by Tobias Rautenkranz. ] [Don't trim #\VT. Stelian Ionescu **20090625164315 Ignore-this: d8d498764120b505ef429533a31e7ad4 ] [Groveler: trim-whitespace not strip-whitespace. Stelian Ionescu **20090622215252 Ignore-this: 4cf64b68c733985620a54547172f0acc ] [Groveler: fix typo. Stelian Ionescu **20090622213353 Ignore-this: 6611cf5e23cf79f39487005c3cd54cea ] [Groveler: small refactoring, create *EXE-EXTENSION* Stelian Ionescu **20090622212626 Ignore-this: e05a49eac29b50b75d739d7a8a4d5376 ] [Groveler: move boilerplate C code to common.h Stelian Ionescu **20090622211857 Ignore-this: eb1d4dfe79eda50736030b8a58245fa ] [Groveller: fix usage of *CC-FLAGS*. Stelian Ionescu **20090622205142 Ignore-this: 8ec1dee6e977bb621978a140d00d4df6 ] [Include with the groveler boilerplate code. Stelian Ionescu **20090622201324 Ignore-this: a61b2c378174118bda30f34881fd0d16 ] [Move the DEFPACKAGE and INVOKE out of grovel.lisp Stelian Ionescu **20090622200317 Ignore-this: 684f7b807e38f1562c83987999f5f2f6 ] [Style change. Stelian Ionescu **20090622194557 Ignore-this: d5fec823114054a26e5d3f868a51e61d ] [Groveler: use WITH-STANDARD-IO-SYNTAX when processing grovel files. Stelian Ionescu **20090622190429 Ignore-this: b2de6817830cfa76780382f6f58b04ee ] [Groveler: implement %INVOKE for ABCL. Stelian Ionescu **20090622190326 Ignore-this: 1131c355c7fbef55c972c5444bed2bf7 ] [TAG 0.10.5 Luis Oliveira **20090616162007 Ignore-this: f21c050e8ca02edcf2e2bac58555deb9 ] Patch bundle hash: a1fe1dcf3cc06c673d145e9e5609fdff1f2823f4