cffi_0.19.0/0000755000175000017500000000000013124312147011302 5ustar luisluiscffi_0.19.0/scripts/0000755000175000017500000000000013103031266012766 5ustar luisluiscffi_0.19.0/scripts/release.lisp0000755000175000017500000002301013103031266015276 0ustar luisluis#!/usr/bin/env clisp ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- (defpackage :release-script (:use #:cl #:regexp)) (in-package :release-script) ;;;; Configuration ------------------------------------------------------------ (defparameter *project-name* "cffi") (defparameter *asdf-file* (format nil "~A.asd" *project-name*)) (defparameter *host* "common-lisp.net") (defparameter *release-dir* (format nil "/project/~A/public_html/releases" *project-name*)) (defparameter *version-file* "VERSION") (defparameter *version-file-dir* (format nil "/project/~A/public_html" *project-name*)) ;;;; -------------------------------------------------------------------------- ;;;; Utilities (defun ensure-list (x) (if (listp x) x (list x))) (defmacro string-case (expression &body clauses) `(let ((it ,expression)) ; yes, anaphoric, deal with it. (cond ,@(loop for clause in clauses collect `((or ,@(loop for alternative in (ensure-list (first clause)) collect (or (eq t alternative) `(string= it ,alternative)))) ,@(rest clause)))))) (defparameter *development-mode* nil) (defun die (format-control &rest format-args) (format *error-output* "~?" format-control format-args) (if *development-mode* (cerror "continue" "die") (ext:quit 1))) (defun numeric-split (string) (if (digit-char-p (char string 0)) (multiple-value-bind (number next-position) (parse-integer string :junk-allowed t) (cons number (when (< next-position (length string)) (numeric-split (subseq string next-position))))) (let ((next-digit-position (position-if #'digit-char-p string))) (if next-digit-position (cons (subseq string 0 next-digit-position) (numeric-split (subseq string next-digit-position))) (list string))))) (defun natural-string-< (s1 s2) (labels ((aux< (l1 l2) (cond ((null l1) (not (null l2))) ((null l2) nil) (t (destructuring-bind (x . xs) l1 (destructuring-bind (y . ys) l2 (cond ((and (numberp x) (stringp y)) t) ((and (numberp y) (stringp x)) nil) ((and (numberp x) (numberp y)) (or (< x y) (and (= x y) (aux< xs ys)))) (t (or (string-lessp x y) (and (string-equal x y) (aux< xs ys))))))))))) (aux< (numeric-split s1) (numeric-split s2)))) ;;;; Running commands (defparameter *dry-run* nil) (defun cmd? (format-control &rest format-args) (let ((cmd (format nil "~?" format-control format-args))) (with-open-stream (s1 (ext:run-shell-command cmd :output :stream)) (loop for line = (read-line s1 nil nil) while line collect line)))) ;; XXX: quote arguments. (defun cmd (format-control &rest format-args) (when *development-mode* (format *debug-io* "CMD: ~?~%" format-control format-args)) (let ((ret (ext:run-shell-command (format nil "~?" format-control format-args)))) (or (null ret) (zerop ret)))) (defun cmd! (format-control &rest format-args) (or (apply #'cmd format-control format-args) (die "cmd '~?' failed." format-control format-args))) (defun maybe-cmd! (format-control &rest format-args) (if *dry-run* (format t "SUPPRESSING: ~?~%" format-control format-args) (apply #'cmd! format-control format-args))) ;;;; (defun find-current-version () (subseq (reduce (lambda (x y) (if (natural-string-< x y) y x)) (or (cmd? "git tag -l v\\*") (die "no version tags found. Please specify initial version."))) 1)) (defun parse-version (string) (mapcar (lambda (x) (parse-integer x :junk-allowed t)) (loop repeat 3 ; XXX: parameterize for el in (regexp-split "\\." (find-current-version)) collect el))) (defun check-for-unrecorded-changes (&optional force) (unless (cmd "git diff --exit-code") (write-line "Unrecorded changes.") (if force (write-line "Continuing anyway.") (die "Aborting.~@ Use -f or --force if you want to make a release anyway.")))) (defun new-version-number-candidates (current-version) (labels ((alternatives (before after) (when after (cons (append before (list (1+ (first after))) (mapcar (constantly 0) (rest after))) (alternatives (append before (list (first after))) (rest after)))))) (loop for alt in (alternatives nil (parse-version current-version)) collect (format nil "~{~d~^.~}" alt)))) (defun ask-user-for-version (current-version next-versions) (format *query-io* "Current version is ~A. Which will be the next one?~%" current-version) (loop for i from 1 and version in next-versions do (format *query-io* "~T~A) ~A~%" i version)) (format *query-io* "? ") (finish-output *query-io*) (nth (1- (parse-integer (read-line) :junk-allowed t)) next-versions)) (defun git-tag-tree (version) (write-line "Tagging the tree...") (maybe-cmd! "git tag \"v~A\"" version)) (defun add-version-to-system-file (version path-in path-out) (let ((defsystem-line (format nil "(defsystem :~A" *project-name*))) (with-open-file (in path-in :direction :input) (with-open-file (out path-out :direction :output) (loop for line = (read-line in nil nil) while line do (write-line line out) when (string= defsystem-line line) do (format out " :version ~s~%" version)))))) (defun create-dist (version distname) (write-line "Creating distribution...") (cmd! "mkdir \"~a\"" distname) (cmd! "git archive master | tar xC \"~A\"" distname) (format t "Updating ~A with new version: ~A~%" *asdf-file* version) (let* ((asdf-file-path (format nil "~A/~A" distname *asdf-file*)) (tmp-asdf-file-path (format nil "~a.tmp" asdf-file-path))) (add-version-to-system-file version asdf-file-path tmp-asdf-file-path) (cmd! "mv \"~a\" \"~a\"" tmp-asdf-file-path asdf-file-path))) (defun tar-and-sign (distname tarball) (write-line "Creating and signing tarball...") (cmd! "tar czf \"~a\" \"~a\"" tarball distname) (cmd! "gpg -b -a \"~a\"" tarball)) (defparameter *remote-directory* (format nil "~A:~A" *host* *release-dir*)) (defun upload-tarball (tarball signature remote-directory) (write-line "Copying tarball to web server...") (maybe-cmd! "scp \"~A\" \"~A\" \"~A\"" tarball signature remote-directory) (format t "Uploaded ~A and ~A.~%" tarball signature)) (defun update-remote-links (tarball signature host release-dir project-name) (format t "Updating ~A_latest links...~%" project-name) (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz\"" host tarball release-dir project-name) (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz.asc\"" host signature release-dir project-name)) (defun upload-version-file (version version-file host version-file-dir) (format t "Uploading ~A...~%" version-file) (with-open-file (out version-file :direction :output) (write-string version out)) (maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-dir) (maybe-cmd! "rm \"~A\"" version-file)) (defun maybe-clean-things-up (tarball signature) (when (y-or-n-p "Clean local tarball and signature?") (cmd! "rm \"~A\" \"~A\"" tarball signature))) (defun run (force version) (check-for-unrecorded-changes force) ;; figure out what version we'll be preparing. (unless version (let* ((current-version (find-current-version)) (next-versions (new-version-number-candidates current-version))) (setf version (or (ask-user-for-version current-version next-versions) (die "invalid selection."))))) (git-tag-tree version) (let* ((distname (format nil "~A_~A" *project-name* version)) (tarball (format nil "~A.tar.gz" distname)) (signature (format nil "~A.asc" tarball))) ;; package things up. (create-dist version distname) (tar-and-sign distname tarball) ;; upload. (upload-tarball tarball signature *remote-directory*) (update-remote-links tarball signature *host* *release-dir* *project-name*) (when *version-file* (upload-version-file version *version-file* *host* *version-file-dir*)) ;; clean up. (maybe-clean-things-up tarball signature) ;; documentation. (write-line "Building and uploading documentation...") (maybe-cmd! "make -C doc upload-docs") ;; push tags and any outstanding changes. (write-line "Pushing tags and changes...") (maybe-cmd! "git push --tags origin master"))) ;;;; Do it to it (let ((force nil) (version nil) (args ext:*args*)) (loop while args do (string-case (pop args) (("-h" "--help") (write-line "No help, sorry. Read the source.") (ext:quit 0)) (("-f" "--force") (setf force t)) (("-v" "--version") (setf version (pop args))) (("-n" "--dry-run") (setf *dry-run* t)) (t (die "Unrecognized argument '~a'" it)))) (run force version)) cffi_0.19.0/toolchain/0000755000175000017500000000000013103031266013257 5ustar luisluiscffi_0.19.0/toolchain/c-toolchain.lisp0000644000175000017500000003665613103031266016370 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; c-toolchain.lisp --- Generic support compiling and linking C code. ;;; ;;; Copyright (C) 2005-2006, Dan Knap ;;; Copyright (C) 2005-2006, Emily Backes ;;; Copyright (C) 2007, Stelian Ionescu ;;; Copyright (C) 2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi-toolchain) ;;; Utils (defun parse-command-flags (flags) (let ((separators '(#\Space #\Tab #\Newline #\Return))) (remove-if 'emptyp (split-string flags :separator separators)))) (defun parse-command-flags-list (strings) (loop for flags in strings append (parse-command-flags flags))) (defun program-argument (x) (etypecase x (string x) (pathname (native-namestring x)))) (defun invoke (command &rest args) (when (pathnamep command) (setf command (native-namestring command)) #+os-unix (unless (absolute-pathname-p command) (setf command (strcat "./" command)))) (let ((cmd (cons command (mapcar 'program-argument args)))) (safe-format! *debug-io* "; ~A~%" (escape-command cmd)) (run-program cmd :output :interactive :error-output :interactive))) ;;; C support (defparameter *cc* nil "C compiler") (defparameter *cc-flags* nil "flags for the C compiler") (defparameter *ld* nil "object linker") ;; NB: can actually be the same as *cc* (defparameter *ld-exe-flags* nil "flags for linking executables via *ld*") (defparameter *ld-dll-flags* nil "flags for linking shared library via *ld*") (defparameter *linkkit-start* nil "flags for the implementation linkkit, start") (defparameter *linkkit-end* nil "flags for the implementation linkkit, end") (defun link-all-library (lib) ;; Flags to provide to cc to link a whole library into an executable (when lib (if (featurep :darwin) ;; actually, LLVM ld vs GNU ld `("-Wl,-force_load" ,lib) `("-Wl,--whole-archive" ,lib "-Wl,--no-whole-archive")))) (defun normalize-flags (directory flags) (loop for val in (parse-command-flags flags) collect (cond ((find (first-char val) "-+/") val) ((probe-file* (subpathname directory val))) (t val)))) (defun implementation-file (file &optional type) (subpathname (lisp-implementation-directory) file :type (bundle-pathname-type type))) ;; TODO: on CCL, extract data from ;; (pathname (strcat "ccl:lisp-kernel/" (ccl::kernel-build-directory) "/Makefile")) ? #+clisp (progn (defparameter *clisp-toolchain-parameters* '(("CC" *cc*) ("CFLAGS" *cc-flags* t) ("CLFLAGS" *cc-exe-flags* t) ("LIBS" *linkkit-start* t) ("X_LIBS" *linkkit-end* t))) (defun clisp-toolchain-parameters (&optional linkset) (nest (let* ((linkset (ensure-pathname (or linkset "base") :defaults (lisp-implementation-directory) :ensure-absolute t :ensure-directory t :want-existing t)) (makevars (subpathname linkset "makevars")))) (with-input-file (params makevars :if-does-not-exist nil)) (when params) (loop for l = (read-line params nil nil) while l finally (appendf *linkkit-start* (normalize-flags linkset "modules.o")) do) (if-let (p (position #\= l))) (let ((var (subseq l 0 p)) ;; strip the start and end quote characters (val (subseq l (+ p 2) (- (length l) 1))))) (if-let (param (cdr (assoc var *clisp-toolchain-parameters* :test 'equal)))) (destructuring-bind (sym &optional normalizep) param (setf (symbol-value sym) (if normalizep (normalize-flags linkset val) val)))) (setf *ld* *cc* *ld-exe-flags* `(,@*cc-flags* #-darwin "-Wl,--export-dynamic") *ld-dll-flags* (list* #+darwin "-dynamiclib" ;; -bundle ? #-darwin "-shared" *cc-flags*)))) ;; TODO: for CMUCL, see whatever uses its linker.sh, ;; and teach it to accept additional objects / libraries ;; as it links a runtime plus a core into an executable #+ecl (defun ecl-toolchain-parameters () (setf *cc* c:*cc* *cc-flags* `(,@(parse-command-flags c::*cc-flags*) ,@(parse-command-flags c:*user-cc-flags*)) ;; For the below, we just use c::build-FOO *ld* *cc* *ld-exe-flags* *cc-flags* *ld-dll-flags* *cc-flags* *linkkit-start* nil *linkkit-end* nil)) #+mkcl (defun mkcl-toolchain-parameters () (setf *cc* compiler::*cc* *cc-flags* (parse-command-flags compiler::*cc-flags*) ;; For the below, we just use compiler::build-FOO *ld* *cc* *ld-exe-flags* *cc-flags* *ld-dll-flags* *cc-flags* *linkkit-start* nil *linkkit-end* nil)) #+sbcl (progn (defparameter *sbcl-toolchain-parameters* '(("CC" *cc*) ("CFLAGS" *cc-flags* t) ("LINKFLAGS" *ld-exe-flags* t) ("USE_LIBSBCL" *linkkit-start* t) ("LIBS" *linkkit-end* t))) (defun sbcl-toolchain-parameters () (nest (let* ((sbcl-home (lisp-implementation-directory)) (sbcl.mk (subpathname sbcl-home "sbcl.mk")))) (with-input-file (params sbcl.mk :if-does-not-exist nil)) (when params) (loop for l = (read-line params nil nil) while l finally (appendf *linkkit-end* '("-lm")) do) (if-let (p (position #\= l))) (let ((var (subseq l 0 p)) (val (subseq l (1+ p))))) (if-let (param (cdr (assoc var *sbcl-toolchain-parameters* :test 'equal)))) (destructuring-bind (sym &optional normalizep) param (setf (symbol-value sym) (if normalizep (normalize-flags sbcl-home val) val)))) (unless (featurep :sb-linkable-runtime) (setf *linkkit-start* nil *linkkit-end* nil)) (setf *ld* *cc* ;; ! *ld-dll-flags* (list* #+darwin "-dynamiclib" #-darwin "-shared" *cc-flags*)))) (defun default-toolchain-parameters () ;; The values below are legacy guesses from previous versions of CFFI. ;; It would be nice to clean them up, remove unneeded guesses, ;; annotate every guess with some comment explaining the context. ;; TODO: have proper implementation-provided linkkit parameters ;; for all implementations as above, and delete the below altogether. (let ((arch-flags ;; Former *cpu-word-size-flags* #+arm '("-marm") #+arm64 '() #-(or arm arm64) (ecase (cffi:foreign-type-size :pointer) (4 '("-m32")) (8 '("-m64"))))) (setf *cc* (or (getenvp "CC") #+(or cygwin (not windows)) "cc" "gcc") *cc-flags* (or (getenv "CFLAGS") (append arch-flags ;; For MacPorts #+darwin (list "-I" "/opt/local/include/") ;; ECL internal flags #+ecl (parse-command-flags c::*cc-flags*) ;; FreeBSD non-base header files #+freebsd (list "-I" "/usr/local/include/"))) *ld* *cc* *ld-exe-flags* `(,@arch-flags #-darwin "-Wl,--export-dynamic") *ld-dll-flags* (list* #+darwin "-dynamiclib" ;; -bundle ? #-darwin "-shared" *cc-flags*) *linkkit-start* nil *linkkit-end* nil))) (defun ensure-toolchain-parameters () #+clisp (unless *cc* (clisp-toolchain-parameters)) #+ecl (unless *cc* (ecl-toolchain-parameters)) #+mkcl (unless *cc* (mkcl-toolchain-parameters)) #+sbcl (unless *cc* (sbcl-toolchain-parameters)) (unless *cc* (default-toolchain-parameters))) ;; Actually initialize toolchain parameters (ignore-errors (ensure-toolchain-parameters)) (defun call-with-temporary-output (output-file fun) (let ((output-file (ensure-pathname output-file :want-file t :ensure-absolute t :truenamize t))) (with-temporary-file (:pathname tmp :direction :output :prefix (strcat (native-namestring (pathname-directory-pathname output-file)) (pathname-name output-file) "-tmp") :suffix "" :type (pathname-type output-file)) (funcall fun tmp) (rename-file-overwriting-target tmp output-file)))) (defmacro with-temporary-output ((output-file-var &optional (output-file-val output-file-var)) &body body) "Create an output file atomically, by executing the BODY while OUTPUT-FILE-VAR is bound to a temporary file name, then atomically renaming that temporary file to OUTPUT-FILE-VAL." `(call-with-temporary-output ,output-file-val (lambda (,output-file-var) ,@body))) (defun invoke-builder (builder output-file &rest args) "Invoke the C Compiler with given OUTPUT-FILE and arguments ARGS" (with-temporary-output (output-file) (apply 'invoke `(,@builder ,output-file ,@args)))) (defun cc-compile (output-file inputs) (apply 'invoke-builder (list *cc* "-o") output-file "-c" (append *cc-flags* #-windows '("-fPIC") inputs))) (defun link-executable (output-file inputs) (apply 'invoke-builder (list *ld* "-o") output-file (append *ld-exe-flags* inputs))) (defun link-lisp-executable (output-file inputs) #+ecl (let ((c::*ld-flags* (format nil "-Wl,--export-dynamic ~@[ ~A~]" c::*ld-flags*))) (c::build-program output-file :lisp-files inputs)) #+mkcl (compiler::build-program output-file :lisp-object-files (mapcar 'program-argument inputs) :on-missing-lisp-object-initializer nil) #-(or ecl mkcl) (link-executable output-file `(,@*linkkit-start* ,@inputs ,@*linkkit-end*))) (defun link-static-library (output-file inputs) #+ecl (c::build-static-library output-file :lisp-files inputs) #+mkcl (compiler::build-static-library output-file :lisp-object-files (mapcar 'program-argument inputs) :on-missing-lisp-object-initializer nil) #-(or ecl mkcl) (with-temporary-output (output-file) (delete-file-if-exists output-file) #+(or bsd linux windows) (apply 'invoke `(;; TODO: make it portable to BSD. ;; ar D is also on FreeBSD, but not on OpenBSD or Darwin, dunno about NetBSD; ;; ar T seems to only be on Linux (means something different on Darwin). Sigh. ;; A MRI script might be more portable... not, only supported by GNU binutils. ;; I couldn't get libtool to work, and it's not ubiquitous anyway. ;; ,@`("libtool" "--mode=link" ,*cc* ,@*cc-flags* "-static" "-o" ,output-file) ;; "Solution": never link .a's into further .a's, only link .o's into .a's, ;; which implied changes that are now the case in ASDF 3.2.0. #+bsd ,@`("ar" "rcs" ,output-file) ;; NB: includes darwin #+linux ,@`("ar" "rcsDT" ,output-file) #+windows ,@`("lib" "-nologo" ,(strcat "-out:" (native-namestring output-file))) ,@inputs)) #-(or bsd linux windows) (error "Not implemented on your system"))) (defun link-shared-library (output-file inputs) ;; remove the library so we won't possibly be overwriting ;; the code of any existing process (delete-file-if-exists output-file) #+ecl (c::build-shared-library output-file :lisp-files inputs) #+mkcl (compiler::build-shared-library output-file :lisp-object-files (mapcar 'program-argument inputs) :on-missing-lisp-object-initializer nil) #-(or ecl mkcl) ;; Don't use a temporary file, because linking is sensitive to the output file name :-/ (or put it in a temporary directory?) (apply 'invoke *ld* "-o" output-file (append *ld-dll-flags* inputs))) ;;; Computing file names (defun make-c-file-name (output-defaults &optional suffix) (make-pathname :type "c" :name (strcat (pathname-name output-defaults) suffix) :defaults output-defaults)) (defun make-o-file-name (output-defaults &optional suffix) (make-pathname :type (bundle-pathname-type :object) :name (format nil "~A~@[~A~]" (pathname-name output-defaults) suffix) :defaults output-defaults)) (defun make-so-file-name (defaults) (make-pathname :type (bundle-pathname-type :shared-library) :defaults defaults)) (defun make-exe-file-name (defaults) (make-pathname :type (bundle-pathname-type :program) :defaults defaults)) ;;; Implement link-op on image-based platforms. #-(or clasp ecl mkcl) (defmethod perform ((o link-op) (c system)) (let* ((inputs (input-files o c)) (output (first (output-files o c))) (kind (bundle-type o))) (when output ;; some operations skip any output when there is no input (ecase kind (:program (link-executable output inputs)) ((:lib :static-library) (link-static-library output inputs)) ((:dll :shared-library) (link-shared-library output inputs)))))) (defclass c-file (source-file) ((cflags :initarg :cflags :initform :default) (type :initform "c"))) (defmethod output-files ((o compile-op) (c c-file)) (let* ((i (first (input-files o c))) (base (format nil "~(~{~a~^__~}~)" (mapcar (lambda (x) (substitute-if #\_ (complement #'alphanumericp) x)) (component-find-path c)))) (path (make-pathname :defaults i :name base))) (list (make-o-file-name path) (make-so-file-name path)))) (defmethod perform ((o compile-op) (c c-file)) (let ((i (first (input-files o c)))) (destructuring-bind (.o .so) (output-files o c) (cc-compile .o (list i)) (link-shared-library .so (list .o))))) (defmethod perform ((o load-op) (c c-file)) (let ((o (second (input-files o c)))) (cffi:load-foreign-library (file-namestring o) :search-path (list (pathname-directory-pathname o))))) (setf (find-class 'asdf::c-file) (find-class 'c-file)) (defclass o-file (source-file) ((cflags :initarg :cflags :initform :default) (type :initform (bundle-pathname-type :object))) (:documentation "class for pre-compile object components")) (defmethod output-files ((op compile-op) (c o-file)) (let* ((o (first (input-files op c))) (so (apply-output-translations (make-so-file-name o)))) (values (list o so) t))) (defmethod perform ((o load-op) (c o-file)) (let ((so (second (input-files o c)))) (cffi:load-foreign-library (file-namestring so) :search-path (list (pathname-directory-pathname so))))) (setf (find-class 'asdf::o-file) (find-class 'o-file)) cffi_0.19.0/toolchain/bundle.lisp0000644000175000017500000006630613103031266015434 0ustar luisluis;;;; ------------------------------------------------------------------------- ;;;; ASDF-Bundle (uiop/package:define-package :asdf/bundle (:recycle :asdf/bundle :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) (:export #:bundle-op #:bundle-type #:program-system #:bundle-system #:bundle-pathname-type #:direct-dependency-files #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:basic-compile-bundle-op #:prepare-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op #:lib-op #:monolithic-lib-op #:dll-op #:monolithic-dll-op #:deliver-asd-op #:monolithic-deliver-asd-op #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system #:user-system-p #:user-system #:trivial-system-p #:prologue-code #:epilogue-code #:static-library)) (in-package :asdf/bundle) (with-upgradability () (defclass bundle-op (basic-compile-op) ;; NB: use of instance-allocated slots for operations is DEPRECATED ;; and only supported in a temporary fashion for backward compatibility. ;; Supported replacement: Define slots on program-system instead. ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class)) (:documentation "base class for operations that bundle outputs from multiple components")) (defclass monolithic-op (operation) () (:documentation "A MONOLITHIC operation operates on a system *and all of its dependencies*. So, for example, a monolithic concatenate operation will concatenate together a system's components and all of its dependencies, but a simple concatenate operation will concatenate only the components of the system itself.")) (defclass monolithic-bundle-op (bundle-op monolithic-op) ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation. ;; DEPRECATED. Supported replacement: Define slots on program-system instead. ((prologue-code :initform nil :accessor prologue-code) (epilogue-code :initform nil :accessor epilogue-code)) (:documentation "operations that are both monolithic-op and bundle-op")) (defclass program-system (system) ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) (no-uiop :initform nil :initarg :no-uiop :reader no-uiop) (prefix-lisp-object-files :initarg :prefix-lisp-object-files :initform nil :accessor prefix-lisp-object-files) (postfix-lisp-object-files :initarg :postfix-lisp-object-files :initform nil :accessor postfix-lisp-object-files) (extra-object-files :initarg :extra-object-files :initform nil :accessor extra-object-files) (extra-build-args :initarg :extra-build-args :initform nil :accessor extra-build-args))) (defmethod prologue-code ((x system)) nil) (defmethod epilogue-code ((x system)) nil) (defmethod no-uiop ((x system)) nil) (defmethod prefix-lisp-object-files ((x system)) nil) (defmethod postfix-lisp-object-files ((x system)) nil) (defmethod extra-object-files ((x system)) nil) (defmethod extra-build-args ((x system)) nil) (defclass link-op (bundle-op) () (:documentation "Abstract operation for linking files together")) (defclass gather-operation (bundle-op) ((gather-operation :initform nil :allocation :class :reader gather-operation) (gather-type :initform :no-output-file :allocation :class :reader gather-type)) (:documentation "Abstract operation for gathering many input files from a system")) (defun operation-monolithic-p (op) (typep op 'monolithic-op)) ;; Dependencies of a gather-op are the actions of the dependent operation ;; for all the (sorted) required components for loading the system. ;; Monolithic operations typically use lib-op as the dependent operation, ;; and all system-level dependencies as required components. ;; Non-monolithic operations typically use compile-op as the dependent operation, ;; and all transitive sub-components as required components (excluding other systems). (defmethod component-depends-on ((o gather-operation) (s system)) (let* ((mono (operation-monolithic-p o)) (go (make-operation (or (gather-operation o) 'compile-op))) (bundle-p (typep go 'bundle-op)) ;; In a non-mono operation, don't recurse to other systems. ;; In a mono operation gathering bundles, don't recurse inside systems. (component-type (if mono (if bundle-p 'system t) '(not system))) ;; In the end, only keep system bundles or non-system bundles, depending. (keep-component (if bundle-p 'system '(not system))) (deps ;; Required-components only looks at the dependencies of an action, excluding the action ;; itself, so it may be safely used by an action recursing on its dependencies (which ;; may or may not be an overdesigned API, since in practice we never use it that way). ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks ;; cleaner, we will miss the load-op on the requested system itself, which doesn't ;; matter for a regular system, but matters, a lot, for a package-inferred-system. ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works ;; for our needs of gathering all the files we want to include in a bundle. ;; Note that we use basic-compile-op rather than compile-op so it will still work on ;; systems when *load-system-operation* is load-bundle-op. (required-components s :other-systems mono :component-type component-type :keep-component keep-component :goal-operation 'load-op :keep-operation 'basic-compile-op))) `((,go ,@deps) ,@(call-next-method)))) ;; Create a single fasl for the entire library (defclass basic-compile-bundle-op (bundle-op) ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object :allocation :class) (bundle-type :initform :fasl :allocation :class)) (:documentation "Base class for compiling into a bundle")) ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op (defclass prepare-bundle-op (sideway-operation) ((sideway-operation :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op :allocation :class)) (:documentation "Operation class for loading the bundles of a system's dependencies")) (defclass lib-op (link-op gather-operation non-propagating-operation) ((gather-type :initform :object :allocation :class) (bundle-type :initform :lib :allocation :class)) (:documentation "Compile the system and produce a linkable static library (.a/.lib) for all the linkable object files associated with the system. Compare with DLL-OP. On most implementations, these object files only include extensions to the runtime written in C or another language with a compiler producing linkable object files. On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files themselves. In any case, this operation will produce what you need to further build a static runtime for your system, or a dynamic library to load in an existing runtime.")) ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so; ;; on other implementations, we combine (usually concatenate) the .fasl files into one. (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation #+(or clasp ecl mkcl) link-op) ((selfward-operation :initform '(prepare-bundle-op) :allocation :class)) (:documentation "This operator is an alternative to COMPILE-OP. Build a system and all of its dependencies, but build only a single (\"monolithic\") FASL, instead of one per source file, which may be more resource efficient. That monolithic FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) (defclass load-bundle-op (basic-load-op selfward-operation) ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)) (:documentation "This operator is an alternative to LOAD-OP. Build a system and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with respect to LOAD-OP is that it builds only a single FASL, which may be faster and more resource efficient.")) ;; NB: since the monolithic-op's can't be sideway-operation's, ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, ;; we'd have to have the monolithic-op not inherit from the main op, ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. (defclass dll-op (link-op gather-operation non-propagating-operation) ((gather-type :initform :object :allocation :class) (bundle-type :initform :dll :allocation :class)) (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) for all the linkable object files associated with the system. Compare with LIB-OP.")) (defclass deliver-asd-op (basic-compile-op selfward-operation) ((selfward-operation ;; TODO: implement link-op on all implementations, and make that ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class)) (:documentation "produce an asd file for delivering the system as a single fasl")) (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op) ((selfward-operation ;; TODO: implement link-op on all implementations, and make that ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op) :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) :allocation :class)) (:documentation "produce fasl and asd files for combined system and dependencies.")) (defclass monolithic-compile-bundle-op (basic-compile-bundle-op monolithic-bundle-op #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation) () (:documentation "Create a single fasl for the system and its dependencies.")) (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op) ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) (:documentation "Load a single fasl for the system and its dependencies.")) (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) ((gather-type :initform :object :allocation :class)) (:documentation "Compile the system and produce a linkable static library (.a/.lib) for all the linkable object files associated with the system or its dependencies. See LIB-OP.")) (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) ((gather-type :initform :object :allocation :class)) (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) for all the linkable object files associated with the system or its dependencies. See LIB-OP")) (defclass image-op (monolithic-bundle-op selfward-operation #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation) ((bundle-type :initform :image :allocation :class) (gather-operation :initform 'lib-op :allocation :class) #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class) (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) (defclass program-op (image-op) ((bundle-type :initform :program :allocation :class)) (:documentation "create an executable file from the system and its dependencies")) ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type. (defun bundle-pathname-type (bundle-type) (etypecase bundle-type ((or null string) ;; pass through nil or string literal bundle-type) ((eql :no-output-file) ;; marker for a bundle-type that has NO output file (error "No output file, therefore no pathname type")) ((eql :fasl) ;; the type of a fasl #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles ((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image") ;; NB: on CLASP and ECL these implementations, we better agree with ;; (compile-file-type :type bundle-type)) ((eql :object) ;; the type of a linkable object file (os-cond ((os-unix-p) "o") ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj")))) ((member :lib :static-library) ;; the type of a linkable library (os-cond ((os-unix-p) "a") ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) ((member :dll :shared-library) ;; the type of a shared library (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) ((eql :program) ;; the type of an executable program (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) ;; Compute the output-files for a given bundle action (defun bundle-output-files (o c) (let ((bundle-type (bundle-type o))) (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. (and (null (input-files o c)) (not (member bundle-type '(:image :program))))) (let ((name (or (component-build-pathname c) (let ((suffix (unless (typep o 'program-op) ;; "." is no good separator for Logical Pathnames, so we use "--" (if (operation-monolithic-p o) "--all-systems" ;; These use a different type .fasb or .a instead of .fasl #-(or clasp ecl mkcl) "--system")))) (format nil "~A~@[~A~]" (component-name c) suffix)))) (type (bundle-pathname-type bundle-type))) (values (list (subpathname (component-pathname c) name :type type)) (eq (class-of o) (coerce-class (component-build-operation c) :package :asdf/interface :super 'operation :error nil))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) #-(or clasp ecl mkcl) (progn (defmethod perform ((o image-op) (c system)) (dump-image (output-file o c) :executable (typep o 'program-op))) (defmethod perform :before ((o program-op) (c system)) (setf *image-entry-point* (ensure-function (component-entry-point c))))) (defclass compiled-file (file-component) ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")) (:documentation "Class for a file that is already compiled, e.g. as part of the implementation, of an outer build system that calls into ASDF, or of opaque libraries shipped along the source code.")) (defclass precompiled-system (system) ((build-pathname :initarg :fasl)) (:documentation "Class For a system that is delivered as a precompiled fasl")) (defclass prebuilt-system (system) ((build-pathname :initarg :static-library :initarg :lib :accessor prebuilt-system-static-library)) (:documentation "Class for a system delivered with a linkable static library (.a/.lib)"))) ;;; ;;; BUNDLE-OP ;;; ;;; This operation takes all components from one or more systems and ;;; creates a single output file, which may be ;;; a FASL, a statically linked library, a shared library, etc. ;;; The different targets are defined by specialization. ;;; (when-upgrading (:version "3.2.0") ;; Cancel any previously defined method (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys) (declare (ignore initargs)))) (with-upgradability () (defgeneric trivial-system-p (component)) (defun user-system-p (s) (and (typep s 'system) (not (builtin-system-p s)) (not (trivial-system-p s))))) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype user-system () '(and system (satisfies user-system-p)))) ;;; ;;; First we handle monolithic bundles. ;;; These are standalone systems which contain everything, ;;; including other ASDF systems required by the current one. ;;; A PROGRAM is always monolithic. ;;; ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL ;;; (with-upgradability () (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) ;; This function selects output files from direct dependencies; ;; your component-depends-on method must gather the correct dependencies in the correct order. (while-collecting (collect) (map-direct-dependencies t o c #'(lambda (sub-o sub-c) (loop :for f :in (funcall key sub-o sub-c) :when (funcall test f) :do (collect f)))))) (defun pathname-type-equal-function (type) #'(lambda (p) (equalp (pathname-type p) type))) (defmethod input-files ((o gather-operation) (c system)) (unless (eq (bundle-type o) :no-output-file) (direct-dependency-files o c :key 'output-files :test (pathname-type-equal-function (bundle-pathname-type (gather-type o)))))) ;; Find the operation that produces a given bundle-type (defun select-bundle-operation (type &optional monolithic) (ecase type ((:dll :shared-library) (if monolithic 'monolithic-dll-op 'dll-op)) ((:lib :static-library) (if monolithic 'monolithic-lib-op 'lib-op)) ((:fasl) (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op)) ((:image) 'image-op) ((:program) 'program-op)))) ;;; ;;; LOAD-BUNDLE-OP ;;; ;;; This is like ASDF's LOAD-OP, but using bundle fasl files. ;;; (with-upgradability () (defmethod component-depends-on ((o load-bundle-op) (c system)) `((,o ,@(component-sideway-dependencies c)) (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) ,@(call-next-method))) (defmethod input-files ((o load-bundle-op) (c system)) (when (user-system-p c) (output-files (find-operation o 'compile-bundle-op) c))) (defmethod perform ((o load-bundle-op) (c system)) (when (input-files o c) (perform-lisp-load-fasl o c))) (defmethod mark-operation-done :after ((o load-bundle-op) (c system)) (mark-operation-done (find-operation o 'load-op) c))) ;;; ;;; PRECOMPILED FILES ;;; ;;; This component can be used to distribute ASDF systems in precompiled form. ;;; Only useful when the dependencies have also been precompiled. ;;; (with-upgradability () (defmethod trivial-system-p ((s system)) (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) (defmethod input-files ((o operation) (c compiled-file)) (list (component-pathname c))) (defmethod perform ((o load-op) (c compiled-file)) (perform-lisp-load-fasl o c)) (defmethod perform ((o load-source-op) (c compiled-file)) (perform (find-operation o 'load-op) c)) (defmethod perform ((o operation) (c compiled-file)) nil)) ;;; ;;; Pre-built systems ;;; (with-upgradability () (defmethod trivial-system-p ((s prebuilt-system)) t) (defmethod perform ((o link-op) (c prebuilt-system)) nil) (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system)) nil) (defmethod perform ((o lib-op) (c prebuilt-system)) nil) (defmethod perform ((o dll-op) (c prebuilt-system)) nil) (defmethod component-depends-on ((o gather-operation) (c prebuilt-system)) nil) (defmethod output-files ((o lib-op) (c prebuilt-system)) (values (list (prebuilt-system-static-library c)) t))) ;;; ;;; PREBUILT SYSTEM CREATOR ;;; (with-upgradability () (defmethod output-files ((o deliver-asd-op) (s system)) (list (make-pathname :name (component-name s) :type "asd" :defaults (component-pathname s)))) (defmethod perform ((o deliver-asd-op) (s system)) (let* ((inputs (input-files o s)) (fasl (first inputs)) (library (second inputs)) (asd (first (output-files o s))) (name (if (and fasl asd) (pathname-name asd) (return-from perform))) (version (component-version s)) (dependencies (if (operation-monolithic-p o) ;; We want only dependencies, and we use basic-load-op rather than load-op so that ;; this will keep working on systems when *load-system-operation* is load-bundle-op (remove-if-not 'builtin-system-p (required-components s :component-type 'system :keep-operation 'basic-load-op)) (while-collecting (x) ;; resolve the sideway-dependencies of s (map-direct-dependencies t 'load-op s #'(lambda (o c) (when (and (typep o 'load-op) (typep c 'system)) (x c))))))) (depends-on (mapcar 'coerce-name dependencies))) (when (pathname-equal asd (system-source-file s)) (cerror "overwrite the asd file" "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~ which is probably not what you want; you probably need to tweak your output translations." (cons o s) asd)) (with-open-file (s asd :direction :output :if-exists :supersede :if-does-not-exist :create) (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" (operation-monolithic-p o) name) (format s ";;; Built for ~A ~A on a ~A/~A ~A~%" (lisp-implementation-type) (lisp-implementation-version) (software-type) (machine-type) (software-version)) (let ((*package* (find-package :asdf-user))) (pprint `(defsystem ,name :class prebuilt-system :version ,version :depends-on ,depends-on :components ((:compiled-file ,(pathname-name fasl))) ,@(when library `(:lib ,(file-namestring library)))) s) (terpri s))))) #-(or clasp ecl mkcl) (defmethod perform ((o basic-compile-bundle-op) (c system)) (let* ((input-files (input-files o c)) (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) (output-files (output-files o c)) (output-file (first output-files))) (assert (eq (not input-files) (not output-files))) (when input-files (when non-fasl-files (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S" (implementation-type) non-fasl-files)) (when (or (prologue-code c) (epilogue-code c)) (error "prologue-code and epilogue-code are not supported on ~A" (implementation-type))) (with-staging-pathname (output-file) (combine-fasls fasl-files output-file))))) (defmethod input-files ((o load-op) (s precompiled-system)) (bundle-output-files (find-operation o 'compile-bundle-op) s)) (defmethod perform ((o load-op) (s precompiled-system)) (perform-lisp-load-fasl o s)) (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system)) #+xcl (declare (ignorable o)) `((load-op ,s) ,@(call-next-method)))) #| ;; Example use: (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) (asdf:load-system :precompiled-asdf-utils) |# #+(or clasp ecl mkcl) (with-upgradability () #+ecl ;; doesn't work on clasp or mkcl (yet?). (unless (use-ecl-byte-compiler-p) (setf *load-system-operation* 'load-bundle-op)) (defun system-module-pathname (module) (let ((name (coerce-name module))) (some 'file-exists-p (list #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object) #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib) #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object) #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:") #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;"))))) (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name))) "Creates a prebuilt-system if PATHNAME isn't NIL." (when pathname (make-instance 'prebuilt-system :name (coerce-name name) :static-library (resolve-symlinks* pathname)))) (defmethod component-depends-on :around ((o image-op) (c system)) (destructuring-bind ((lib-op . deps)) (call-next-method) (labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)) (ensure-linkable-system (x) (unless (has-it-p x) (or (if-let (s (find-system x)) (and (system-source-directory x) (list s))) (if-let (p (system-module-pathname x)) (list (make-prebuilt-system x p))))))) `((,lib-op ,@(unless (no-uiop c) (append (ensure-linkable-system "cmp") (or (ensure-linkable-system "uiop") (ensure-linkable-system "asdf")))) ,@deps))))) (defmethod perform ((o link-op) (c system)) (let* ((object-files (input-files o c)) (output (output-files o c)) (bundle (first output)) (programp (typep o 'program-op)) (kind (bundle-type o))) (when output (apply 'create-image bundle (append (when programp (prefix-lisp-object-files c)) object-files (when programp (postfix-lisp-object-files c))) :kind kind :prologue-code (when programp (prologue-code c)) :epilogue-code (when programp (epilogue-code c)) :build-args (when programp (extra-build-args c)) :extra-object-files (when programp (extra-object-files c)) :no-uiop (no-uiop c) (when programp `(:entry-point ,(component-entry-point c)))))))) cffi_0.19.0/toolchain/static-link.lisp0000644000175000017500000001135513103031266016377 0ustar luisluis;; FIXME: arrange packages so that this can be moved in ASDF some time later? (in-package #:cffi-toolchain) (defun static-ops-enabled-p () (ensure-toolchain-parameters) (and (or *linkkit-start* *linkkit-end*) t)) (defclass static-runtime-op (monolithic-bundle-op link-op selfward-operation) ((selfward-operation :initform 'monolithic-lib-op :allocation :class)) (:documentation "Create a Lisp runtime linkable library for the system and its dependencies.")) (defmethod output-files ((o static-runtime-op) (s system)) #-(or ecl mkcl) (list (subpathname (component-pathname s) (strcat (coerce-name s) "-runtime") :type (bundle-pathname-type :program)))) (defmethod perform ((o static-runtime-op) (s system)) (link-lisp-executable (output-file o s) (link-all-library (first (input-files o s))))) (defclass static-image-op (image-op) (#-(or ecl mkcl) (selfward-operation :initform '(load-op static-runtime-op) :allocation :class) #+(or ecl mkcl) (gather-operation :initform 'compile-op :allocation :class) #+(or ecl mkcl) (gather-type :initform :object :allocation :class)) (:documentation "Create a statically linked standalone image for the system.")) (defclass static-program-op (program-op static-image-op) (#-(or ecl mkcl) (selfward-operation :initform '(load-op static-runtime-op) :allocation :class) #+(or ecl mkcl) (gather-operation :initform 'compile-op :allocation :class) #+(or ecl mkcl) (gather-type :initform :object :allocation :class)) (:documentation "Create a statically linked standalone executable for the system.")) ;; Problem? Its output may conflict with the program-op output :-/ #-(or ecl mkcl) (defmethod perform ((o static-image-op) (s system)) #-(or clisp sbcl) (error "Not implemented yet") #+(or clisp sbcl) (let* ((name (coerce-name s)) (runtime (output-file 'static-runtime-op s)) (image #+clisp (implementation-file "base/lispinit.mem") #+sbcl (subpathname (lisp-implementation-directory) "sbcl.core")) (output (output-file o s)) (child-op (if (typep o 'program-op) 'program-op 'image-op))) (with-temporary-output (tmp output) (apply 'invoke runtime #+clisp "-M" #+sbcl "--core" image `(#+clisp ,@'("--silent" "-ansi" "-norc" "-x") #+sbcl ,@'("--noinform" "--non-interactive" "--no-sysinit" "--no-userinit" "--eval") ,(with-safe-io-syntax (:package :asdf) (let ((*print-pretty* nil) (*print-case* :downcase)) (format ;; This clever staging allows to put things in a single form, ;; as required for CLISP not to print output for the first form, ;; yet allow subsequent forms to rely on packages defined by former forms. nil "'(~@{#.~S~^ ~})" '(require "asdf") '(in-package :asdf) `(progn ,@(if-let (ql-home (find-symbol* :*quicklisp-home* :ql-setup nil)) `((load ,(subpathname (symbol-value ql-home) "setup.lisp")))) (setf asdf:*central-registry* ',asdf:*central-registry*) (initialize-source-registry ',asdf::*source-registry-parameter*) (initialize-output-translations ',asdf::*output-translations-parameter*) (load-system "cffi-grovel") ;; We force the operation to take place (defmethod operation-done-p ((operation ,child-op) (system (eql (find-system ,name)))) nil) ;; Some implementations (notably SBCL) die as part of dumping an image, ;; so redirect output-files to desired destination, for this processs might ;; never otherwise get a chance to move the file to destination. (defmethod output-files ((operation ,child-op) (system (eql (find-system ,name)))) (values (list ,tmp) t)) (operate ',child-op ,name) (quit)))))))))) #+(or ecl mkcl) (defmethod perform ((o static-image-op) (s system)) (let (#+ecl (c::*ld-flags* (format nil "-Wl,--export-dynamic ~@[ ~A~]" c::*ld-flags*))) (call-next-method))) ;; Allow for :static-FOO-op in ASDF definitions. (setf (find-class 'asdf::static-runtime-op) (find-class 'static-runtime-op) (find-class 'asdf::static-image-op) (find-class 'static-image-op) (find-class 'asdf::static-program-op) (find-class 'static-program-op)) cffi_0.19.0/toolchain/package.lisp0000644000175000017500000000361413103031266015547 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; package.lisp --- Toolchain DEFPACKAGE. ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (uiop:define-package #:cffi-toolchain (:mix #:asdf #:uiop #:common-lisp) (:import-from #:asdf/bundle #:link-op #:bundle-pathname-type #:bundle-type #:gather-operation #:gather-type) (:export ;; Variables #:*cc* #:*cc-flags* #:*ld* #:*ld-exe-flags* #:*ld-dll-flags* #:*linkkit-start* #:*linkkit-end* ;; Functions from c-toolchain #:make-c-file-name #:make-o-file-name #:make-so-file-name #:make-exe-file-name #:parse-command-flags #:parse-command-flags-list #:invoke #:invoke-build #:cc-compile #:link-static-library #:link-shared-library #:link-executable #:link-lisp-executable ;; ASDF classes #:c-file #:o-file #:static-runtime-op #:static-image-op #:static-program-op )) cffi_0.19.0/uffi-compat/0000755000175000017500000000000013103031266013511 5ustar luisluiscffi_0.19.0/uffi-compat/uffi-compat.lisp0000644000175000017500000005417013103031266016623 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; uffi-compat.lisp --- UFFI compatibility layer for CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg. (defpackage #:cffi-uffi-compat (:nicknames #:uffi) ;; is this a good idea? (:use #:cl) (:export ;; immediate types #:def-constant #:def-foreign-type #:def-type #:null-char-p ;; aggregate types #:def-enum #:def-struct #:get-slot-value #:get-slot-pointer #:def-array-pointer #:deref-array #:def-union ;; objects #:allocate-foreign-object #:free-foreign-object #:with-foreign-object #:with-foreign-objects #:size-of-foreign-type #:pointer-address #:deref-pointer #:ensure-char-character #:ensure-char-integer #:ensure-char-storable #:null-pointer-p #:make-null-pointer #:make-pointer #:+null-cstring-pointer+ #:char-array-to-pointer #:with-cast-pointer #:def-foreign-var #:convert-from-foreign-usb8 #:def-pointer-var ;; string functions #:convert-from-cstring #:convert-to-cstring #:free-cstring #:with-cstring #:with-cstrings #:convert-from-foreign-string #:convert-to-foreign-string #:allocate-foreign-string #:with-foreign-string #:with-foreign-strings #:foreign-string-length ; not implemented #:string-to-octets #:octets-to-string #:foreign-encoded-octet-count ;; function call #:def-function ;; libraries #:find-foreign-library #:load-foreign-library #:default-foreign-library-type #:foreign-library-types ;; os #:getenv #:run-shell-command )) (in-package #:cffi-uffi-compat) #+clisp (eval-when (:compile-toplevel :load-toplevel :execute) (when (equal (machine-type) "POWER MACINTOSH") (pushnew :ppc *features*))) (defun convert-uffi-type (uffi-type) "Convert a UFFI primitive type to a CFFI type." ;; Many CFFI types are the same as UFFI. This list handles the ;; exceptions only. (case uffi-type (:cstring :pointer) (:pointer-void :pointer) (:pointer-self :pointer) ;; Although UFFI's documentation claims dereferencing :CHAR and ;; :UNSIGNED-CHAR returns characters, it actually returns ;; integers. (:char :char) (:unsigned-char :unsigned-char) (:byte :char) (:unsigned-byte :unsigned-char) (t (if (listp uffi-type) (case (car uffi-type) ;; this is imho gross but it is what uffi does (quote (convert-uffi-type (second uffi-type))) (* :pointer) (:array `(uffi-array ,(convert-uffi-type (second uffi-type)) ,(third uffi-type))) (:union (second uffi-type)) (:struct (convert-uffi-type (second uffi-type))) (:struct-pointer :pointer)) uffi-type)))) (cffi:define-foreign-type uffi-array-type () ;; ELEMENT-TYPE should be /unparsed/, suitable for passing to mem-aref. ((element-type :initform (error "An element-type is required.") :accessor element-type :initarg :element-type) (nelems :initform (error "nelems is required.") :accessor nelems :initarg :nelems)) (:actual-type :pointer) (:documentation "UFFI's :array type.")) (cffi:define-parse-method uffi-array (element-type count) (make-instance 'uffi-array-type :element-type element-type :nelems (or count 1))) (defmethod cffi:foreign-type-size ((type uffi-array-type)) (* (cffi:foreign-type-size (element-type type)) (nelems type))) (defmethod cffi::aggregatep ((type uffi-array-type)) t) ;; UFFI's :(unsigned-)char #+#:ignore (cffi:define-foreign-type uffi-char () ()) #+#:ignore (cffi:define-parse-method uffi-char (base-type) (make-instance 'uffi-char :actual-type base-type)) #+#:ignore (defmethod cffi:translate-to-foreign ((value character) (type uffi-char)) (char-code value)) #+#:ignore (defmethod cffi:translate-from-foreign (obj (type uffi-char)) (code-char obj)) (defmacro def-type (name type) "Define a Common Lisp type NAME for UFFI type TYPE." (declare (ignore type)) `(deftype ,name () t)) (defmacro def-foreign-type (name type) "Define a new foreign type." `(cffi:defctype ,name ,(convert-uffi-type type))) (defmacro def-constant (name value &key export) "Define a constant and conditionally export it." `(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant ,name ,value) ,@(when export `((export ',name))) ',name)) (defmacro null-char-p (val) "Return true if character is null." `(zerop (char-code ,val))) (defmacro def-enum (enum-name args &key (separator-string "#")) "Creates a constants for a C type enum list, symbols are created in the created in the current package. The symbol is the concatenation of the enum-name name, separator-string, and field-name" (let ((counter 0) (cmds nil) (constants nil)) (declare (fixnum counter)) (dolist (arg args) (let ((name (if (listp arg) (car arg) arg)) (value (if (listp arg) (prog1 (setq counter (cadr arg)) (incf counter)) (prog1 counter (incf counter))))) (setq name (intern (concatenate 'string (symbol-name enum-name) separator-string (symbol-name name)))) (push `(def-constant ,name ,value) constants))) (setf cmds (append '(progn) `((cffi:defctype ,enum-name :int)) (nreverse constants))) cmds)) (defmacro def-struct (name &body fields) "Define a C structure." `(cffi:defcstruct ,name ,@(loop for (name uffi-type) in fields for cffi-type = (convert-uffi-type uffi-type) collect (list name cffi-type)))) ;; TODO: figure out why the compiler macro is kicking in before ;; the setf expander. (defun %foreign-slot-value (obj type field) (cffi:foreign-slot-value obj `(:struct ,type) field)) (defun (setf %foreign-slot-value) (value obj type field) (setf (cffi:foreign-slot-value obj `(:struct ,type) field) value)) (defmacro get-slot-value (obj type field) "Access a slot value from a structure." `(%foreign-slot-value ,obj ,type ,field)) ;; UFFI uses a different function when accessing a slot whose ;; type is a pointer. We don't need that in CFFI so we use ;; foreign-slot-value too. (defmacro get-slot-pointer (obj type field) "Access a pointer slot value from a structure." `(cffi:foreign-slot-value ,obj ,type ,field)) (defmacro def-array-pointer (name type) "Define a foreign array type." `(cffi:defctype ,name (uffi-array ,(convert-uffi-type type) 1))) (defmacro deref-array (array type position) "Dereference an array." `(cffi:mem-aref ,array ,(if (constantp type) `',(element-type (cffi::parse-type (convert-uffi-type (eval type)))) `(element-type (cffi::parse-type (convert-uffi-type ,type)))) ,position)) ;; UFFI's documentation on DEF-UNION is a bit scarce, I'm not sure ;; if DEFCUNION and DEF-UNION are strictly compatible. (defmacro def-union (name &body fields) "Define a foreign union type." `(cffi:defcunion ,name ,@(loop for (name uffi-type) in fields for cffi-type = (convert-uffi-type uffi-type) collect (list name cffi-type)))) (defmacro allocate-foreign-object (type &optional (size 1)) "Allocate one or more instance of a foreign type." `(cffi:foreign-alloc ,(if (constantp type) `',(convert-uffi-type (eval type)) `(convert-uffi-type ,type)) :count ,size)) (defmacro free-foreign-object (ptr) "Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT." `(cffi:foreign-free ,ptr)) (defmacro with-foreign-object ((var type) &body body) "Wrap the allocation of a foreign object around BODY." `(cffi:with-foreign-object (,var (convert-uffi-type ,type)) ,@body)) ;; Taken from UFFI's src/objects.lisp (defmacro with-foreign-objects (bindings &rest body) (if bindings `(with-foreign-object ,(car bindings) (with-foreign-objects ,(cdr bindings) ,@body)) `(progn ,@body))) (defmacro size-of-foreign-type (type) "Return the size in bytes of a foreign type." `(cffi:foreign-type-size (convert-uffi-type ,type))) (defmacro pointer-address (ptr) "Return the address of a pointer." `(cffi:pointer-address ,ptr)) (defmacro deref-pointer (ptr type) "Dereference a pointer." `(cffi:mem-ref ,ptr (convert-uffi-type ,type))) (defsetf deref-pointer (ptr type) (value) `(setf (cffi:mem-ref ,ptr (convert-uffi-type ,type)) ,value)) (defmacro ensure-char-character (obj &environment env) "Convert OBJ to a character if it is an integer." (if (constantp obj env) (if (characterp obj) obj (code-char obj)) (let ((obj-var (gensym))) `(let ((,obj-var ,obj)) (if (characterp ,obj-var) ,obj-var (code-char ,obj-var)))))) (defmacro ensure-char-integer (obj &environment env) "Convert OBJ to an integer if it is a character." (if (constantp obj env) (let ((the-obj (eval obj))) (if (characterp the-obj) (char-code the-obj) the-obj)) (let ((obj-var (gensym))) `(let ((,obj-var ,obj)) (if (characterp ,obj-var) (char-code ,obj-var) ,obj-var))))) (defmacro ensure-char-storable (obj) "Ensure OBJ is storable as a character." `(ensure-char-integer ,obj)) (defmacro make-null-pointer (type) "Create a NULL pointer." (declare (ignore type)) `(cffi:null-pointer)) (defmacro make-pointer (address type) "Create a pointer to ADDRESS." (declare (ignore type)) `(cffi:make-pointer ,address)) (defmacro null-pointer-p (ptr) "Return true if PTR is a null pointer." `(cffi:null-pointer-p ,ptr)) (defparameter +null-cstring-pointer+ (cffi:null-pointer) "A constant NULL string pointer.") (defmacro char-array-to-pointer (obj) obj) (defmacro with-cast-pointer ((var ptr type) &body body) "Cast a pointer, does nothing in CFFI." (declare (ignore type)) `(let ((,var ,ptr)) ,@body)) (defmacro def-foreign-var (name type module) "Define a symbol macro to access a foreign variable." (declare (ignore module)) (flet ((lisp-name (name) (intern (cffi-sys:canonicalize-symbol-name-case (substitute #\- #\_ name))))) `(cffi:defcvar ,(if (listp name) name (list name (lisp-name name))) ,(convert-uffi-type type)))) (defmacro def-pointer-var (name value &optional doc) #-openmcl `(defvar ,name ,value ,@(if doc (list doc))) #+openmcl `(ccl::defloadvar ,name ,value ,doc)) (defmacro convert-from-cstring (s) "Convert a cstring to a Lisp string." (let ((ret (gensym))) `(let ((,ret (cffi:foreign-string-to-lisp ,s))) (if (equal ,ret "") nil ,ret)))) (defmacro convert-to-cstring (obj) "Convert a Lisp string to a cstring." (let ((str (gensym))) `(let ((,str ,obj)) (if (null ,str) (cffi:null-pointer) (cffi:foreign-string-alloc ,str))))) (defmacro free-cstring (ptr) "Free a cstring." `(cffi:foreign-string-free ,ptr)) (defmacro with-cstring ((foreign-string lisp-string) &body body) "Binds a newly creating string." (let ((str (gensym)) (body-proc (gensym))) `(flet ((,body-proc (,foreign-string) ,@body)) (let ((,str ,lisp-string)) (if (null ,str) (,body-proc (cffi:null-pointer)) (cffi:with-foreign-string (,foreign-string ,str) (,body-proc ,foreign-string))))))) ;; Taken from UFFI's src/strings.lisp (defmacro with-cstrings (bindings &rest body) (if bindings `(with-cstring ,(car bindings) (with-cstrings ,(cdr bindings) ,@body)) `(progn ,@body))) (defmacro def-function (name args &key module (returning :void)) "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))))) ;;; Taken from UFFI's src/libraries.lisp (defvar *loaded-libraries* nil "List of foreign libraries loaded. Used to prevent reloading a library") (defun default-foreign-library-type () "Returns string naming default library type for platform" #+(or win32 cygwin mswindows) "dll" #+(or macos macosx darwin ccl-5.0) "dylib" #-(or win32 cygwin mswindows macos macosx darwin ccl-5.0) "so") (defun foreign-library-types () "Returns list of string naming possible library types for platform, sorted by preference" #+(or win32 cygwin mswindows) '("dll" "lib" "so") #+(or macos macosx darwin ccl-5.0) '("dylib" "bundle") #-(or win32 cygwin mswindows macos macosx darwin ccl-5.0) '("so" "a" "o")) (defun find-foreign-library (names directories &key types drive-letters) "Looks for a foreign library. directories can be a single string or a list of strings of candidate directories. Use default library type if type is not specified." (unless types (setq types (foreign-library-types))) (unless (listp types) (setq types (list types))) (unless (listp names) (setq names (list names))) (unless (listp directories) (setq directories (list directories))) #+(or win32 mswindows) (unless (listp drive-letters) (setq drive-letters (list drive-letters))) #-(or win32 mswindows) (setq drive-letters '(nil)) (dolist (drive-letter drive-letters) (dolist (name names) (dolist (dir directories) (dolist (type types) (let ((path (make-pathname #+lispworks :host #+lispworks (when drive-letter drive-letter) #-lispworks :device #-lispworks (when drive-letter drive-letter) :name name :type type :directory (etypecase dir (pathname (pathname-directory dir)) (list dir) (string (pathname-directory (parse-namestring dir))))))) (when (probe-file path) (return-from find-foreign-library path))))))) nil) (defun convert-supporting-libraries-to-string (libs) (let (lib-load-list) (dolist (lib libs) (push (format nil "-l~A" lib) lib-load-list)) (nreverse lib-load-list))) (defun load-foreign-library (filename &key module supporting-libraries force-load) #+(or allegro mcl sbcl clisp) (declare (ignore module supporting-libraries)) #+(or cmucl scl sbcl) (declare (ignore module)) (when (and filename (or (null (pathname-directory filename)) (probe-file filename))) (if (pathnamep filename) ;; ensure filename is a string to check if (setq filename (namestring filename))) ; already loaded (if (and (not force-load) (find filename *loaded-libraries* :test #'string-equal)) t ;; return T, but don't reload library (progn ;; FIXME: Hmm, what are these two for? #+cmucl (let ((type (pathname-type (parse-namestring filename)))) (if (string-equal type "so") (sys::load-object-file filename) (alien:load-foreign filename :libraries (convert-supporting-libraries-to-string supporting-libraries)))) #+scl (let ((type (pathname-type (parse-namestring filename)))) (if (string-equal type "so") (sys::load-dynamic-object filename) (alien:load-foreign filename :libraries (convert-supporting-libraries-to-string supporting-libraries)))) #-(or cmucl scl) (cffi:load-foreign-library filename) (push filename *loaded-libraries*) t)))) ;; Taken from UFFI's src/os.lisp (defun getenv (var) "Return the value of the environment variable." #+allegro (sys::getenv (string var)) #+clisp (sys::getenv (string var)) #+(or cmucl scl) (cdr (assoc (string var) ext:*environment-list* :test #'equalp :key #'string)) #+(or ecl gcl) (si:getenv (string var)) #+lispworks (lw:environment-variable (string var)) #+lucid (lcl:environment-variable (string var)) #+(or mcl ccl) (ccl::getenv var) #+sbcl (sb-ext:posix-getenv var) #-(or allegro clisp cmucl ecl scl gcl lispworks lucid mcl ccl sbcl) (error 'not-implemented :proc (list 'getenv var))) ;; Taken from UFFI's src/os.lisp ;; modified from function ASDF -- Copyright Dan Barlow and Contributors (defun run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with output to *trace-output*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args)) (output *trace-output*)) #+sbcl (sb-impl::process-exit-code (sb-ext:run-program "/bin/sh" (list "-c" command) :input nil :output output)) #+(or cmucl scl) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :input nil :output output)) #+allegro (excl:run-shell-command command :input nil :output output) #+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" :output-stream output) #+clisp ;XXX not exactly *trace-output*, I know (ext:run-shell-command command :output :terminal :wait t) #+openmcl (nth-value 1 (ccl:external-process-status (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output output :wait t))) #+ecl (nth-value 1 (ext:run-program "/bin/sh" (list "-c" command) :input nil :output output :error nil :wait t)) #-(or openmcl ecl clisp lispworks allegro scl cmucl sbcl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) ;;; Some undocumented UFFI operators... (defmacro convert-from-foreign-string (obj &key length (locale :default) (encoding 'cffi:*default-foreign-encoding*) (null-terminated-p t)) ;; in effect, (eq NULL-TERMINATED-P (null LENGTH)). Hopefully, ;; that's compatible with the intended semantics, which are ;; undocumented. If that's not the case, we can implement ;; NULL-TERMINATED-P in CFFI:FOREIGN-STRING-TO-LISP. (declare (ignore locale null-terminated-p)) (let ((ret (gensym))) `(let ((,ret (cffi:foreign-string-to-lisp ,obj :count ,length :encoding ,encoding))) (if (equal ,ret "") nil ,ret)))) ;; What's the difference between this and convert-to-cstring? (defmacro convert-to-foreign-string (obj &optional (encoding 'cffi:*default-foreign-encoding*)) (let ((str (gensym))) `(let ((,str ,obj)) (if (null ,str) (cffi:null-pointer) (cffi:foreign-string-alloc ,str :encoding ,encoding))))) (defmacro allocate-foreign-string (size &key unsigned) (declare (ignore unsigned)) `(cffi:foreign-alloc :char :count ,size)) ;; Ditto. (defmacro with-foreign-string ((foreign-string lisp-string) &body body) (let ((str (gensym))) `(let ((,str ,lisp-string)) (if (null ,str) (let ((,foreign-string (cffi:null-pointer))) ,@body) (cffi:with-foreign-string (,foreign-string ,str) ,@body))))) (defmacro with-foreign-strings (bindings &body body) `(with-foreign-string ,(car bindings) ,@(if (cdr bindings) `((with-foreign-strings ,(cdr bindings) ,@body)) body))) ;; This function returns a form? Where is this used in user-code? (defun foreign-string-length (foreign-string) (declare (ignore foreign-string)) (error "FOREIGN-STRING-LENGTH not implemented.")) ;; This should be optimized. (defun convert-from-foreign-usb8 (s len) (let ((a (make-array len :element-type '(unsigned-byte 8)))) (dotimes (i len a) (setf (aref a i) (cffi:mem-ref s :unsigned-char i))))) ;;;; String Encodings (defmacro string-to-octets (str &key encoding null-terminate) `(babel:concatenate-strings-to-octets (or ,encoding cffi:*default-foreign-encoding*) ,str (if ,null-terminate #.(string #\Nul) ""))) (defmacro octets-to-string (octets &key encoding) `(babel:octets-to-string ,octets :encoding (or ,encoding cffi:*default-foreign-encoding*))) (defun foreign-encoded-octet-count (str &key encoding) (babel:string-size-in-octets str :encoding (or encoding cffi:*default-foreign-encoding*))) cffi_0.19.0/uffi-compat/uffi.asd0000644000175000017500000000012213103031266015126 0ustar luisluis;;;; uffi.asd -*- Mode: Lisp -*- (defsystem uffi :depends-on (cffi-uffi-compat)) cffi_0.19.0/cffi-libffi.asd0000644000175000017500000000355713103031266014142 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-libffi.asd --- Foreign Structures By Value ;;; ;;; Copyright (C) 2011 Liam M. Healy ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package :asdf) (eval-when (:compile-toplevel :execute) (asdf:oos 'asdf:load-op :cffi-grovel) (asdf:oos 'asdf:load-op :trivial-features)) (defsystem cffi-libffi :description "Foreign structures by value" :author "Liam Healy " :maintainer "Liam Healy " :defsystem-depends-on (#:trivial-features #:cffi-grovel) :components ((:module libffi :serial t :components ((:file "libffi") (cffi-grovel:grovel-file "libffi-types") (:file "libffi-functions") (:file "type-descriptors") (:file "funcall")))) :depends-on (#:cffi #:cffi-grovel #:trivial-features)) cffi_0.19.0/examples/0000755000175000017500000000000013103031266013115 5ustar luisluiscffi_0.19.0/examples/grovel-example.lisp0000644000175000017500000000064413103031266016741 0ustar luisluis(in-package #:cffi-example) (define "a0(x)" "+x+x") (define "a1(x)" "a0(+x+x)") (define "a2(x)" "a1(+x+x)") (define "a3(x)" "a2(+x+x)") (define "a4(x)" "a3(+x+x)") (define "a5(x)" "a4(+x+x)") (define "A0" "a0(1)") (define "A1" "a1(1)") (define "A2" "a2(1)") (define "A3" "a3(1)") (define "A4" "a4(1)") (constant (+a0+ "A0")) (constant (+a1+ "A1")) (constant (+a2+ "A2")) (constant (+a3+ "A3")) (constant (+a4+ "A4")) cffi_0.19.0/examples/mapping.lisp0000644000175000017500000000553613103031266015452 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; mapping.lisp --- An example for mapping Lisp objects to ints. ;;; ;;; Copyright (C) 2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; This is an example on how to tackle the problem of passing Lisp ;;; object identifiers to foreign code. It is not a great example, ;;; but might be useful nevertheless. ;;; ;;; Requires trivial-garbage: (defpackage #:cffi-mapping-test (:use #:common-lisp #:cffi #:trivial-garbage) (:export #:run)) (in-package #:cffi-mapping-test) (define-foreign-type lisp-object-type () ((weakp :initarg :weakp)) (:actual-type :unsigned-int)) (define-parse-method lisp-object (&key weak-mapping) (make-instance 'lisp-object-type :weakp weak-mapping)) (defvar *regular-hashtable* (make-hash-table)) (defvar *weak-hashtable* (make-weak-hash-table :weakness :value)) (defvar *regular-counter* 0) (defvar *weak-counter* 0) (defun increment-counter (value) (mod (1+ value) (expt 2 (* 8 (foreign-type-size :unsigned-int))))) (define-modify-macro incf-counter () increment-counter) (defmethod translate-to-foreign (value (type lisp-object-type)) (with-slots (weakp) type (let ((id (if weakp (incf-counter *weak-counter*) (incf-counter *regular-counter*))) (ht (if weakp *weak-hashtable* *regular-hashtable*))) (setf (gethash id ht) value) id))) (defmethod translate-from-foreign (int (type lisp-object-type)) (with-slots (weakp) type (gethash int (if weakp *weak-hashtable* *regular-hashtable*)))) ;;;; Silly example. (defctype weak-mapping (lisp-object :weak-mapping t)) ;;; (run) => # (defun run () (foreign-funcall "abs" weak-mapping (lambda (x) x) weak-mapping)) cffi_0.19.0/examples/translator-test.lisp0000644000175000017500000000675513103031266017171 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; translator-test.lisp --- Testing type translators. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (defpackage #:cffi-translator-test (:use #:common-lisp #:cffi)) (in-package #:cffi-translator-test) ;;;# Verbose Pointer Translator ;;; ;;; This is a silly type translator that doesn't actually do any ;;; translating, but it prints out a debug message when the pointer is ;;; converted to/from its foreign representation. (define-foreign-type verbose-pointer-type () () (:actual-type :pointer)) (defmethod translate-to-foreign (value (type verbose-pointer-type)) (format *debug-io* "~&;; to foreign: VERBOSE-POINTER: ~S~%" value) value) (defmethod translate-from-foreign (value (type verbose-pointer-type)) (format *debug-io* "~&;; from foreign: VERBOSE-POINTER: ~S~%" value) value) ;;;# Verbose String Translator ;;; ;;; A VERBOSE-STRING extends VERBOSE-POINTER and converts Lisp strings ;;; C strings. If things are working properly, both type translators ;;; should be called when converting a Lisp string to/from a C string. ;;; ;;; The translators should be called most-specific-first when ;;; translating to C, and most-specific-last when translating from C. (define-foreign-type verbose-string-type (verbose-pointer-type) () (:simple-parser verbose-string)) (defmethod translate-to-foreign ((s string) (type verbose-string-type)) (let ((value (foreign-string-alloc s))) (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~S~%" s value) (values (call-next-method value type) t))) (defmethod translate-to-foreign (value (type verbose-string-type)) (if (pointerp value) (progn (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~:*~S~%" value) (values (call-next-method) nil)) (error "Cannot convert ~S to a foreign string: it is not a Lisp ~ string or pointer." value))) (defmethod translate-from-foreign (ptr (type verbose-string-type)) (let ((value (foreign-string-to-lisp (call-next-method)))) (format *debug-io* "~&;; from foreign: VERBOSE-STRING: ~S -> ~S~%" ptr value) value)) (defmethod free-translated-object (ptr (type verbose-string-type) free-p) (when free-p (format *debug-io* "~&;; freeing VERBOSE-STRING: ~S~%" ptr) (foreign-string-free ptr))) (defun test-verbose-string () (foreign-funcall "getenv" verbose-string "SHELL" verbose-string)) cffi_0.19.0/examples/main-example.lisp0000644000175000017500000000077713103031266016376 0ustar luisluis(in-package #:cffi-example) (defcfun "puts" :int "Put a string to standard output, return non-negative length output, or EOF" (string :string)) (defun check-groveller () (assert (equal (list +a0+ +a1+ +a2+ +a3+ +a4+) '(2 4 8 16 32))) (assert (equal (bn 1) 32))) (defun entry-point () (when uiop:*command-line-arguments* (uiop:format! t "Arguments: ~A~%" (uiop:escape-command uiop:*command-line-arguments*))) (puts "hello, world!") (check-groveller) (uiop:finish-outputs) (uiop:quit 0)) cffi_0.19.0/examples/gettimeofday.lisp0000644000175000017500000000730213103031266016471 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2) ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# CFFI Example: gettimeofday binding ;;; ;;; This example illustrates the use of foreign structures, typedefs, ;;; and using type translators to do checking of input and output ;;; arguments to a foreign function. (defpackage #:cffi-example-gettimeofday (:use #:common-lisp #:cffi) (:export #:gettimeofday)) (in-package #:cffi-example-gettimeofday) ;;; Define the TIMEVAL structure used by 'gettimeofday'. This assumes ;;; that 'time_t' is a 'long' --- it would be nice if CFFI could ;;; provide a proper :TIME-T type to help make this portable. (defcstruct timeval (tv-sec :long) (tv-usec :long)) ;;; A NULL-POINTER is a foreign :POINTER that must always be NULL. ;;; Both a NULL pointer and NIL are legal values---any others will ;;; result in a runtime error. (define-foreign-type null-pointer-type () () (:actual-type :pointer) (:simple-parser null-pointer)) ;;; This type translator is used to ensure that a NULL-POINTER has a ;;; null value. It also converts NIL to a null pointer. (defmethod translate-to-foreign (value (type null-pointer-type)) (cond ((null value) (null-pointer)) ((null-pointer-p value) value) (t (error "~A is not a null pointer." value)))) ;;; The SYSCALL-RESULT type is an integer type used for the return ;;; value of C functions that return -1 and set errno on errors. ;;; Someday when CFFI has a portable interface for dealing with ;;; 'errno', this error reporting can be more useful. (define-foreign-type syscall-result-type () () (:actual-type :int) (:simple-parser syscall-result)) ;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error ;;; if the value is negative. (defmethod translate-from-foreign (value (type syscall-result-type)) (if (minusp value) (error "System call failed with return value ~D." value) value)) ;;; Define the Lisp function %GETTIMEOFDAY to call the C function ;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill ;;; in. The TZP parameter is deprecated and should be NULL --- we can ;;; enforce this by using our NULL-POINTER type defined above. (defcfun ("gettimeofday" %gettimeofday) syscall-result (tp :pointer) (tzp null-pointer)) ;;; Define a Lispy interface to 'gettimeofday' that returns the ;;; seconds and microseconds as multiple values. (defun gettimeofday () (with-foreign-object (tv 'timeval) (%gettimeofday tv nil) (with-foreign-slots ((tv-sec tv-usec) tv timeval) (values tv-sec tv-usec)))) cffi_0.19.0/examples/gethostname.lisp0000644000175000017500000000410013103031266016317 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; gethostname.lisp --- A simple CFFI example. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# CFFI Example: gethostname binding ;;; ;;; This is a very simple CFFI example that illustrates calling a C ;;; function that fills in a user-supplied string buffer. (defpackage #:cffi-example-gethostname (:use #:common-lisp #:cffi) (:export #:gethostname)) (in-package #:cffi-example-gethostname) ;;; Define the Lisp function %GETHOSTNAME to call the C 'gethostname' ;;; function, which will fill BUF with up to BUFSIZE characters of the ;;; system's hostname. (defcfun ("gethostname" %gethostname) :int (buf :pointer) (bufsize :int)) ;;; Define a Lispy interface to 'gethostname'. The utility macro ;;; WITH-FOREIGN-POINTER-AS-STRING is used to allocate a temporary ;;; buffer and return it as a Lisp string. (defun gethostname () (with-foreign-pointer-as-string ((buf bufsize) 255) (%gethostname buf bufsize))) cffi_0.19.0/examples/wrapper-example.lisp0000644000175000017500000000155513103031266017125 0ustar luisluis(in-package #:cffi-example) (defwrapper* "b0" :long ((x :long)) "return x;") (defwrapper* "b1" :long ((x :long)) "return x;") (defwrapper* "b2" :long ((x :long)) "return x;") (defwrapper* "b3" :long ((x :long)) "return x;") (defwrapper* "b4" :long ((x :long)) "return x;") (define "b0_cffi_wrap(x)" "b0_cffi_wrap(b1_cffi_wrap(b2_cffi_wrap(b3_cffi_wrap(b4_cffi_wrap(+x+x)))))") (define "b1_cffi_wrap(x)" "b0_cffi_wrap(b1_cffi_wrap(b2_cffi_wrap(b3_cffi_wrap(b4_cffi_wrap(+x+x)))))") (define "b2_cffi_wrap(x)" "b0_cffi_wrap(b1_cffi_wrap(b2_cffi_wrap(b3_cffi_wrap(b4_cffi_wrap(+x+x)))))") ;;(define "b3_cffi_wrap(x)" ;; "b0_cffi_wrap(b1_cffi_wrap(b2_cffi_wrap(b3_cffi_wrap(b4_cffi_wrap(+x+x)))))") ;;(define "b4_cffi_wrap(x)" ;; "b0_cffi_wrap(b1_cffi_wrap(b2_cffi_wrap(b3_cffi_wrap(b4_cffi_wrap(+x+x)))))") (defwrapper* "bn" :long ((x :long)) "return b0_cffi_wrap(x);") cffi_0.19.0/examples/package.lisp0000644000175000017500000000255313103031266015406 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; package.lisp --- CFFI-EXAMPLES package definition. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (defpackage #:cffi-example (:use #:cl #:cffi #:cffi-sys) (:export #:check-groveller #:entry-point)) cffi_0.19.0/examples/run-examples.lisp0000644000175000017500000000277113103031266016435 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; run-examples.lisp --- Simple script to run the examples. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (setf *load-verbose* nil *compile-verbose* nil) #-asdf (ignore-errors (require "asdf")) #-asdf (load "~/common-lisp/asdf/build/asdf.lisp") (asdf:load-system 'cffi-examples :verbose nil) (cffi-examples:run-examples) (force-output) (quit) cffi_0.19.0/examples/examples.lisp0000644000175000017500000000522113103031266015624 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; examples.lisp --- Simple test examples of CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (defpackage #:cffi-examples (:use #:cl #:cffi) (:export #:run-examples #:sqrtf #:getenv)) (in-package #:cffi-examples) ;; A simple libc function. (defcfun "sqrtf" :float (n :float)) ;; This definition uses the STRING type translator to automatically ;; convert Lisp strings to foreign strings and vice versa. (defcfun "getenv" :string (name :string)) ;; Calling a varargs function. (defun sprintf-test () "Test calling a varargs function." (with-foreign-pointer-as-string ((buf buf-size) 255) (foreign-funcall "snprintf" :pointer buf :int buf-size :string "%d %f #x%x!" :int 666 :double (coerce pi 'double-float) :unsigned-int #xcafebabe :void))) ;; Defining an emerated type. (defcenum test-enum (:invalid 0) (:positive 1) (:negative -1)) ;; Use the absolute value function to test keyword/enum translation. (defcfun ("abs" c-abs) test-enum (n test-enum)) (defun cffi-version () (asdf:component-version (asdf:find-system 'cffi))) (defun run-examples () (format t "~&;;; CFFI version ~A on ~A ~A:~%" (cffi-version) (lisp-implementation-type) (lisp-implementation-version)) (format t "~&;; shell: ~A~%" (getenv "SHELL")) (format t "~&;; sprintf test: ~A~%" (sprintf-test)) (format t "~&;; (c-abs :positive): ~A~%" (c-abs :positive)) (format t "~&;; (c-abs :negative): ~A~%" (c-abs :negative)) (force-output)) cffi_0.19.0/src/0000755000175000017500000000000013103031266012066 5ustar luisluiscffi_0.19.0/src/libraries.lisp0000644000175000017500000004455613103031266014751 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; libraries.lisp --- Finding and loading foreign libraries. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2006-2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;;;# Finding Foreign Libraries ;;; ;;; We offer two ways for the user of a CFFI library to define ;;; his/her own library directories: *FOREIGN-LIBRARY-DIRECTORIES* ;;; for regular libraries and *DARWIN-FRAMEWORK-DIRECTORIES* for ;;; Darwin frameworks. ;;; ;;; These two special variables behave similarly to ;;; ASDF:*CENTRAL-REGISTRY* as its arguments are evaluated before ;;; being used. We used our MINI-EVAL instead of the full-blown EVAL ;;; and the evaluated form should yield a single pathname or a list of ;;; pathnames. ;;; ;;; Only after failing to find a library through the normal ways ;;; (eg: on Linux LD_LIBRARY_PATH, /etc/ld.so.cache, /usr/lib/, /lib) ;;; do we try to find the library ourselves. (defun explode-path-environment-variable (name) (mapcar #'uiop:ensure-directory-pathname (split-if (lambda (c) (eql #\: c)) (uiop:getenv name) :elide))) (defun darwin-fallback-library-path () (or (explode-path-environment-variable "DYLD_FALLBACK_LIBRARY_PATH") (list (merge-pathnames #p"lib/" (user-homedir-pathname)) #p"/usr/local/lib/" #p"/usr/lib/"))) (defvar *foreign-library-directories* (if (featurep :darwin) '((explode-path-environment-variable "LD_LIBRARY_PATH") (explode-path-environment-variable "DYLD_LIBRARY_PATH") (uiop:getcwd) (darwin-fallback-library-path)) '()) "List onto which user-defined library paths can be pushed.") (defun fallback-darwin-framework-directories () (or (explode-path-environment-variable "DYLD_FALLBACK_FRAMEWORK_PATH") (list (uiop:getcwd) (merge-pathnames #p"Library/Frameworks/" (user-homedir-pathname)) #p"/Library/Frameworks/" #p"/System/Library/Frameworks/"))) (defvar *darwin-framework-directories* '((explode-path-environment-variable "DYLD_FRAMEWORK_PATH") (fallback-darwin-framework-directories)) "List of directories where Frameworks are searched for.") (defun mini-eval (form) "Simple EVAL-like function to evaluate the elements of *FOREIGN-LIBRARY-DIRECTORIES* and *DARWIN-FRAMEWORK-DIRECTORIES*." (typecase form (cons (apply (car form) (mapcar #'mini-eval (cdr form)))) (symbol (symbol-value form)) (t form))) (defun parse-directories (list) (mappend (compose #'ensure-list #'mini-eval) list)) (defun find-file (path directories) "Searches for PATH in a list of DIRECTORIES and returns the first it finds." (some (lambda (directory) (probe-file (merge-pathnames path directory))) directories)) (defun find-darwin-framework (framework-name) "Searches for FRAMEWORK-NAME in *DARWIN-FRAMEWORK-DIRECTORIES*." (dolist (directory (parse-directories *darwin-framework-directories*)) (let ((path (make-pathname :name framework-name :directory (append (pathname-directory directory) (list (format nil "~A.framework" framework-name)))))) (when (probe-file path) (return-from find-darwin-framework path))))) ;;;# Defining Foreign Libraries ;;; ;;; Foreign libraries can be defined using the ;;; DEFINE-FOREIGN-LIBRARY macro. Example usage: ;;; ;;; (define-foreign-library opengl ;;; (:darwin (:framework "OpenGL")) ;;; (:unix (:or "libGL.so" "libGL.so.1" ;;; #p"/myhome/mylibGL.so")) ;;; (:windows "opengl32.dll") ;;; ;; an hypothetical example of a particular platform ;;; ((:and :some-system :some-cpu) "libGL-support.lib") ;;; ;; if no other clauses apply, this one will and a type will be ;;; ;; automagically appended to the name passed to :default ;;; (t (:default "libGL"))) ;;; ;;; This information is stored in the *FOREIGN-LIBRARIES* hashtable ;;; and when the library is loaded through LOAD-FOREIGN-LIBRARY (or ;;; USE-FOREIGN-LIBRARY) the first clause matched by FEATUREP is ;;; processed. (defvar *foreign-libraries* (make-hash-table :test 'eq) "Hashtable of defined libraries.") (defclass foreign-library () ((name :initform nil :initarg :name :accessor foreign-library-name) (type :initform :system :initarg :type) (spec :initarg :spec) (options :initform nil :initarg :options) (handle :initform nil :initarg :handle :accessor foreign-library-handle) (pathname :initform nil))) (defmethod print-object ((library foreign-library) stream) (with-slots (name pathname) library (print-unreadable-object (library stream :type t) (when name (format stream "~A" name)) (when pathname (format stream " ~S" (file-namestring pathname)))))) (define-condition foreign-library-undefined-error (error) ((name :initarg :name :reader fl-name)) (:report (lambda (c s) (format s "Undefined foreign library: ~S" (fl-name c))))) (defun get-foreign-library (lib) "Look up a library by NAME, signalling an error if not found." (if (typep lib 'foreign-library) lib (or (gethash lib *foreign-libraries*) (error 'foreign-library-undefined-error :name lib)))) (defun (setf get-foreign-library) (value name) (setf (gethash name *foreign-libraries*) value)) (defun foreign-library-type (lib) (slot-value (get-foreign-library lib) 'type)) (defun foreign-library-pathname (lib) (slot-value (get-foreign-library lib) 'pathname)) (defun %foreign-library-spec (lib) (assoc-if (lambda (feature) (or (eq feature t) (featurep feature))) (slot-value lib 'spec))) (defun foreign-library-spec (lib) (second (%foreign-library-spec lib))) (defun foreign-library-options (lib) (append (cddr (%foreign-library-spec lib)) (slot-value lib 'options))) (defun foreign-library-search-path (lib) (loop for (opt val) on (foreign-library-options lib) by #'cddr when (eql opt :search-path) append (ensure-list val) into search-path finally (return (mapcar #'pathname search-path)))) (defun foreign-library-loaded-p (lib) (not (null (foreign-library-handle (get-foreign-library lib))))) (defun list-foreign-libraries (&key (loaded-only t) type) "Return a list of defined foreign libraries. If LOADED-ONLY is non-null only loaded libraries are returned. TYPE restricts the output to a specific library type: if NIL all libraries are returned." (let ((libs (hash-table-values *foreign-libraries*))) (remove-if (lambda (lib) (or (and type (not (eql type (foreign-library-type lib)))) (and loaded-only (not (foreign-library-loaded-p lib))))) libs))) ;; :CONVENTION, :CALLING-CONVENTION and :CCONV are coalesced, ;; the former taking priority ;; options with NULL values are removed (defun clean-spec-up (spec) (mapcar (lambda (x) (list* (first x) (second x) (let* ((opts (cddr x)) (cconv (getf opts :cconv)) (calling-convention (getf opts :calling-convention)) (convention (getf opts :convention)) (search-path (getf opts :search-path))) (remf opts :cconv) (remf opts :calling-convention) (when cconv (warn-obsolete-argument :cconv :convention)) (when calling-convention (warn-obsolete-argument :calling-convention :convention)) (setf (getf opts :convention) (or convention calling-convention cconv)) (setf (getf opts :search-path) (mapcar #'pathname (ensure-list search-path))) (loop for (opt val) on opts by #'cddr when val append (list opt val) into new-opts finally (return new-opts))))) spec)) (defmethod initialize-instance :after ((lib foreign-library) &key search-path (cconv :cdecl cconv-p) (calling-convention cconv calling-convention-p) (convention calling-convention)) (with-slots (type options spec) lib (check-type type (member :system :test :grovel-wrapper)) (setf spec (clean-spec-up spec)) (let ((all-options (apply #'append options (mapcar #'cddr spec)))) (assert (subsetp (loop for (key . nil) on all-options by #'cddr collect key) '(:convention :search-path))) (when cconv-p (warn-obsolete-argument :cconv :convention)) (when calling-convention-p (warn-obsolete-argument :calling-convention :convention)) (flet ((set-option (key value) (when value (setf (getf options key) value)))) (set-option :convention convention) (set-option :search-path (mapcar #'pathname (ensure-list search-path))))))) (defun register-foreign-library (name spec &rest options) (let ((old-handle (when-let ((old-lib (gethash name *foreign-libraries*))) (foreign-library-handle old-lib)))) (setf (get-foreign-library name) (apply #'make-instance 'foreign-library :name name :spec spec :handle old-handle options)) name)) (defmacro define-foreign-library (name-and-options &body pairs) "Defines a foreign library NAME that can be posteriorly used with the USE-FOREIGN-LIBRARY macro." (destructuring-bind (name . options) (ensure-list name-and-options) (check-type name symbol) `(register-foreign-library ',name ',pairs ,@options))) ;;;# LOAD-FOREIGN-LIBRARY-ERROR condition ;;; ;;; The various helper functions that load foreign libraries can ;;; signal this error when something goes wrong. We ignore the host's ;;; error. We should probably reuse its error message. (define-condition load-foreign-library-error (simple-error) ()) (defun read-new-value () (format *query-io* "~&Enter a new value (unevaluated): ") (force-output *query-io*) (read *query-io*)) (defun fl-error (control &rest arguments) (error 'load-foreign-library-error :format-control control :format-arguments arguments)) ;;;# Loading Foreign Libraries (defun load-darwin-framework (name framework-name) "Tries to find and load a darwin framework in one of the directories in *DARWIN-FRAMEWORK-DIRECTORIES*. If unable to find FRAMEWORK-NAME, it signals a LOAD-FOREIGN-LIBRARY-ERROR." (let ((framework (find-darwin-framework framework-name))) (if framework (load-foreign-library-path name (native-namestring framework)) (fl-error "Unable to find framework ~A" framework-name)))) (defun report-simple-error (name error) (fl-error "Unable to load foreign library (~A).~% ~A" name (format nil "~?" (simple-condition-format-control error) (simple-condition-format-arguments error)))) ;;; FIXME: haven't double checked whether all Lisps signal a ;;; SIMPLE-ERROR on %load-foreign-library failure. In any case they ;;; should be throwing a more specific error. (defun load-foreign-library-path (name path &optional search-path) "Tries to load PATH using %LOAD-FOREIGN-LIBRARY which should try and find it using the OS's usual methods. If that fails we try to find it ourselves." (handler-case (values (%load-foreign-library name path) (pathname path)) (error (error) (let ((dirs (parse-directories *foreign-library-directories*))) (if-let (file (find-file path (append search-path dirs))) (handler-case (values (%load-foreign-library name (native-namestring file)) file) (simple-error (error) (report-simple-error name error))) (report-simple-error name error)))))) (defun try-foreign-library-alternatives (name library-list &optional search-path) "Goes through a list of alternatives and only signals an error when none of alternatives were successfully loaded." (dolist (lib library-list) (multiple-value-bind (handle pathname) (ignore-errors (load-foreign-library-helper name lib search-path)) (when handle (return-from try-foreign-library-alternatives (values handle pathname))))) ;; Perhaps we should show the error messages we got for each ;; alternative if we can figure out a nice way to do that. (fl-error "Unable to load any of the alternatives:~% ~S" library-list)) (defparameter *cffi-feature-suffix-map* '((:windows . ".dll") (:darwin . ".dylib") (:unix . ".so") (t . ".so")) "Mapping of OS feature keywords to shared library suffixes.") (defun default-library-suffix () "Return a string to use as default library suffix based on the operating system. This is used to implement the :DEFAULT option. This will need to be extended as we test on more OSes." (or (cdr (assoc-if #'featurep *cffi-feature-suffix-map*)) (fl-error "Unable to determine the default library suffix on this OS."))) (defun load-foreign-library-helper (name thing &optional search-path) (etypecase thing ((or pathname string) (load-foreign-library-path (filter-pathname name) thing search-path)) (cons (ecase (first thing) (:framework (load-darwin-framework name (second thing))) (:default (unless (stringp (second thing)) (fl-error "Argument to :DEFAULT must be a string.")) (let ((library-path (concatenate 'string (second thing) (default-library-suffix)))) (load-foreign-library-path name library-path search-path))) (:or (try-foreign-library-alternatives name (rest thing) search-path)))))) (defun %do-load-foreign-library (library search-path) (flet ((%do-load (lib name spec) (when (foreign-library-spec lib) (with-slots (handle pathname) lib (setf (values handle pathname) (load-foreign-library-helper name spec (foreign-library-search-path lib))))) lib)) (etypecase library (symbol (let* ((lib (get-foreign-library library)) (spec (foreign-library-spec lib))) (%do-load lib library spec))) ((or string list) (let* ((lib-name (gensym (format nil "~:@(~A~)-" (if (listp library) (first library) (file-namestring library))))) (lib (make-instance 'foreign-library :type :system :name lib-name :spec `((t ,library)) :search-path search-path))) ;; first try to load the anonymous library ;; and register it only if that worked (%do-load lib lib-name library) (setf (get-foreign-library lib-name) lib)))))) (defun filter-pathname (thing) (typecase thing (pathname (namestring thing)) (t thing))) (defun load-foreign-library (library &key search-path) "Loads a foreign LIBRARY which can be a symbol denoting a library defined through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we try to load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIES*; or finally list: either (:or lib1 lib2) or (:framework )." (let ((library (filter-pathname library))) (restart-case (progn ;; dlopen/dlclose does reference counting, but the CFFI-SYS ;; API has no infrastructure to track that. Therefore if we ;; want to avoid increasing the internal dlopen reference ;; counter, and thus thwarting dlclose, then we need to try ;; to call CLOSE-FOREIGN-LIBRARY and ignore any signaled ;; errors. (ignore-some-conditions (foreign-library-undefined-error) (close-foreign-library library)) (%do-load-foreign-library library search-path)) ;; Offer these restarts that will retry the call to ;; %LOAD-FOREIGN-LIBRARY. (retry () :report "Try loading the foreign library again." (load-foreign-library library :search-path search-path)) (use-value (new-library) :report "Use another library instead." :interactive read-new-value (load-foreign-library new-library :search-path search-path))))) (defmacro use-foreign-library (name) `(load-foreign-library ',name)) ;;;# Closing Foreign Libraries (defun close-foreign-library (library) "Closes a foreign library." (let* ((library (filter-pathname library)) (lib (get-foreign-library library)) (handle (foreign-library-handle lib))) (when handle (%close-foreign-library handle) (setf (foreign-library-handle lib) nil) t))) (defun reload-foreign-libraries (&key (test #'foreign-library-loaded-p)) "(Re)load all currently loaded foreign libraries." (let ((libs (list-foreign-libraries))) (loop for l in libs for name = (foreign-library-name l) when (funcall test name) do (load-foreign-library name)) libs)) cffi_0.19.0/src/cffi-corman.lisp0000644000175000017500000002647713103031266015163 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp. ;;; ;;; Copyright (C) 2005-2008, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; This port is suffering from bitrot as of 2007-03-29. Corman Lisp ;;; is too funky with ASDF, crashes easily, makes it very painful to ;;; do any testing. -- luis ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:c-types) (:import-from #:alexandria #:with-unique-names) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:native-namestring #:%mem-ref #:%mem-set ;#:make-shareable-byte-vector ;#:with-pointer-to-vector-data #:foreign-symbol-pointer #:defcfun-helper-forms #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Misfeatures (pushnew 'no-long-long *features*) (pushnew 'no-foreign-funcall *features*) ;;;$ Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Basic Pointer Operations (deftype foreign-pointer () 'cl::foreign) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (cpointerp ptr)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (cpointer= ptr1 ptr2)) (defun null-pointer () "Return a null pointer." (create-foreign-ptr)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (cpointer-null ptr)) (defun inc-pointer (ptr offset) "Return a pointer pointing OFFSET bytes past PTR." (let ((new-ptr (create-foreign-ptr))) (setf (cpointer-value new-ptr) (+ (cpointer-value ptr) offset)) new-ptr)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (int-to-foreign-ptr address)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (foreign-ptr-to-int ptr)) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage ;;; when the memory has dynamic extent. (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (malloc size)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." (free ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let* ((,size-var ,size) (,var (malloc ,size-var))) (unwind-protect (progn ,@body) (free ,var)))) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. ;(defun make-shareable-byte-vector (size) ; "Create a Lisp vector of SIZE bytes can passed to ;WITH-POINTER-TO-VECTOR-DATA." ; (make-array size :element-type '(unsigned-byte 8))) ; ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) ; "Bind PTR-VAR to a foreign pointer to the data in VECTOR." ; `(sb-sys:without-gcing ; (let ((,ptr-var (sb-sys:vector-sap ,vector))) ; ,@body))) ;;;# Dereferencing ;;; According to the docs, Corman's C Function Definition Parser ;;; converts int to long, so we'll assume that. (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to a CormanCL type." (ecase type-keyword (:char :char) (:unsigned-char :unsigned-char) (:short :short) (:unsigned-short :unsigned-short) (:int :long) (:unsigned-int :unsigned-long) (:long :long) (:unsigned-long :unsigned-long) (:float :single-float) (:double :double-float) (:pointer :handle) (:void :void))) (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of TYPE at OFFSET bytes from PTR." (unless (eql offset 0) (setq ptr (inc-pointer ptr offset))) (ecase type (:char (cref (:char *) ptr 0)) (:unsigned-char (cref (:unsigned-char *) ptr 0)) (:short (cref (:short *) ptr 0)) (:unsigned-short (cref (:unsigned-short *) ptr 0)) (:int (cref (:long *) ptr 0)) (:unsigned-int (cref (:unsigned-long *) ptr 0)) (:long (cref (:long *) ptr 0)) (:unsigned-long (cref (:unsigned-long *) ptr 0)) (:float (cref (:single-float *) ptr 0)) (:double (cref (:double-float *) ptr 0)) (:pointer (cref (:handle *) ptr 0)))) ;(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) ; (if (constantp type) ; `(cref (,(convert-foreign-type type) *) ,ptr ,offset) ; form)) (defun %mem-set (value ptr type &optional (offset 0)) "Set the object of TYPE at OFFSET bytes from PTR." (unless (eql offset 0) (setq ptr (inc-pointer ptr offset))) (ecase type (:char (setf (cref (:char *) ptr 0) value)) (:unsigned-char (setf (cref (:unsigned-char *) ptr 0) value)) (:short (setf (cref (:short *) ptr 0) value)) (:unsigned-short (setf (cref (:unsigned-short *) ptr 0) value)) (:int (setf (cref (:long *) ptr 0) value)) (:unsigned-int (setf (cref (:unsigned-long *) ptr 0) value)) (:long (setf (cref (:long *) ptr 0) value)) (:unsigned-long (setf (cref (:unsigned-long *) ptr 0) value)) (:float (setf (cref (:single-float *) ptr 0) value)) (:double (setf (cref (:double-float *) ptr 0) value)) (:pointer (setf (cref (:handle *) ptr 0) value)))) ;;;# Calling Foreign Functions (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (sizeof (convert-foreign-type type-keyword))) ;;; Couldn't find anything in sys/ffi.lisp and the C declaration parser ;;; doesn't seem to care about alignment so we'll assume that it's the ;;; same as its size. (defun %foreign-type-alignment (type-keyword) (sizeof (convert-foreign-type type-keyword))) (defun find-dll-containing-function (name) "Searches for NAME in the loaded DLLs. If found, returns the DLL's name (a string), else returns NIL." (dolist (dll ct::*dlls-loaded*) (when (ignore-errors (ct::get-dll-proc-address name (ct::dll-record-handle dll))) (return (ct::dll-record-name dll))))) ;;; This won't work at all... #|| (defmacro %foreign-funcall (name &rest args) (let ((sym (gensym))) `(let (,sym) (ct::install-dll-function ,(find-dll-containing-function name) ,name ,sym) (funcall ,sym ,@(loop for (type arg) on args by #'cddr if arg collect arg))))) ||# ;;; It *might* be possible to implement by copying most of the code ;;; from Corman's DEFUN-DLL. Alternatively, it could implemented the ;;; same way as Lispworks' foreign-funcall. In practice, nobody uses ;;; Corman with CFFI, apparently. :) (defmacro %foreign-funcall (name &rest args) "Call a foreign function NAME passing arguments ARGS." `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args)) (defun defcfun-helper-forms (name lisp-name rettype args types) "Return 2 values for DEFCFUN. A prelude form and a caller form." (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))) ;; XXX This will only work if the dll is already loaded, fix this. (dll (find-dll-containing-function name))) (values `(defun-dll ,ff-name ,(mapcar (lambda (type) (list (gensym) (convert-foreign-type type))) types) :return-type ,(convert-foreign-type rettype) :library-name ,dll :entry-name ,name ;; we want also :pascal linkage type to access ;; the win32 api for instance.. :linkage-type :c) `(,ff-name ,@args)))) ;;;# Callbacks ;;; defun-c-callback vs. defun-direct-c-callback? ;;; same issue as Allegro, no return type declaration, should we coerce? (defmacro %defcallback (name rettype arg-names arg-types body-form) (declare (ignore rettype)) (with-unique-names (cb-sym) `(progn (defun-c-callback ,cb-sym ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types) ,body-form) (setf (get ',name 'callback-ptr) (get-callback-procinst ',cb-sym))))) ;;; Just continue to use the plist for now even though this really ;;; should use a *CALLBACKS* hash table and not define the callbacks ;;; as gensyms. Someone with access to Corman should update this. (defun %callback (name) (get name 'callback-ptr)) ;;;# Loading Foreign Libraries (defun %load-foreign-library (name) "Load the foreign library NAME." (ct::get-dll-record name)) (defun %close-foreign-library (name) "Close the foreign library NAME." (error "Not implemented.")) (defun native-namestring (pathname) (namestring pathname)) ; TODO: confirm ;;;# Foreign Globals ;;; FFI to GetProcAddress from the Win32 API. ;;; "The GetProcAddress function retrieves the address of an exported ;;; function or variable from the specified dynamic-link library (DLL)." (defun-dll get-proc-address ((module HMODULE) (name LPCSTR)) :return-type FARPROC :library-name "Kernel32.dll" :entry-name "GetProcAddress" :linkage-type :pascal) (defun foreign-symbol-pointer (name) "Returns a pointer to a foreign symbol NAME." (let ((str (lisp-string-to-c-string name))) (unwind-protect (dolist (dll ct::*dlls-loaded*) (let ((ptr (get-proc-address (int-to-foreign-ptr (ct::dll-record-handle dll)) str))) (when (not (cpointer-null ptr)) (return ptr)))) (free str)))) cffi_0.19.0/src/cffi-allegro.lisp0000644000175000017500000003765413103031266015330 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL. ;;; ;;; Copyright (C) 2005-2009, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp) (:import-from #:alexandria #:if-let #:with-unique-names #:once-only) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:defcfun-helper-forms #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Mis-features #-64bit (pushnew 'no-long-long *features*) (pushnew 'flat-namespace *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (if (eq excl:*current-case-mode* :case-sensitive-lower) (string-downcase name) (string-upcase name))) ;;;# Basic Pointer Operations (deftype foreign-pointer () 'ff:foreign-address) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (ff:foreign-address-p ptr)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (eql ptr1 ptr2)) (defun null-pointer () "Return a null pointer." 0) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (zerop ptr)) (defun inc-pointer (ptr offset) "Return a pointer pointing OFFSET bytes past PTR." (+ ptr offset)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (check-type address ff:foreign-address) address) (defun pointer-address (ptr) "Return the address pointed to by PTR." (check-type ptr ff:foreign-address) ptr) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage ;;; when the memory has dynamic extent. (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (ff:allocate-fobject :char :c size)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." (ff:free-fobject ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) #+(version>= 8 1) (when (and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*)) (return-from with-foreign-pointer `(let ((,size-var ,(eval size))) (declare (ignorable ,size-var)) (ff:with-static-fobject (,var '(:array :char ,(eval size)) :allocation :foreign-static-gc) ;; (excl::stack-allocated-p var) => T (let ((,var (ff:fslot-address ,var))) ,@body))))) `(let* ((,size-var ,size) (,var (ff:allocate-fobject :char :c ,size-var))) (unwind-protect (progn ,@body) (ff:free-fobject ,var)))) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8) :allocation :static-reclaimable)) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." ;; An array allocated in static-reclamable is a non-simple array in ;; the normal Lisp allocation area, pointing to a simple array in ;; the static-reclaimable allocation area. Therefore we have to get ;; out the simple-array to find the pointer to the actual contents. (with-unique-names (simple-vec) `(excl:with-underlying-simple-vector (,vector ,simple-vec) (let ((,ptr-var (ff:fslot-address-typed :unsigned-char :lisp ,simple-vec))) ,@body)))) ;;;# Dereferencing (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to an Allegro type." (ecase type-keyword (:char :char) (:unsigned-char :unsigned-char) (:short :short) (:unsigned-short :unsigned-short) (:int :int) (:unsigned-int :unsigned-int) (:long :long) (:unsigned-long :unsigned-long) (:long-long #+64bit :nat #-64bit (error "this platform does not support :long-long.")) (:unsigned-long-long #+64bit :unsigned-nat #-64bit (error "this platform does not support :unsigned-long-long")) (:float :float) (:double :double) (:pointer :unsigned-nat) (:void :void))) (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of TYPE at OFFSET bytes from PTR." (unless (zerop offset) (setf ptr (inc-pointer ptr offset))) (ff:fslot-value-typed (convert-foreign-type type) :c ptr)) ;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the ;;; CFFI type is constant. Allegro does its own transformation on the ;;; call that results in efficient code. (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) (if (constantp type) (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) `(ff:fslot-value-typed ',(convert-foreign-type (eval type)) :c ,ptr-form)) form)) (defun %mem-set (value ptr type &optional (offset 0)) "Set the object of TYPE at OFFSET bytes from PTR." (unless (zerop offset) (setf ptr (inc-pointer ptr offset))) (setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value)) ;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED) ;;; when the CFFI type is constant. Allegro does its own ;;; transformation on the call that results in efficient code. (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0)) (if (constantp type) (once-only (val) (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval type)) :c ,ptr-form) ,val))) form)) ;;;# Calling Foreign Functions (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (ff:sizeof-fobject (convert-foreign-type type-keyword))) (defun %foreign-type-alignment (type-keyword) "Returns the alignment in bytes of a foreign type." #+(and powerpc macosx32) (when (eq type-keyword :double) (return-from %foreign-type-alignment 8)) ;; No override necessary for the remaining types.... (ff::sized-ftype-prim-align (ff::iforeign-type-sftype (ff:get-foreign-type (convert-foreign-type type-keyword))))) (defun foreign-funcall-type-and-args (args) "Returns a list of types, list of args and return type." (let ((return-type :void)) (loop for (type arg) on args by #'cddr if arg collect type into types and collect arg into fargs else do (setf return-type type) finally (return (values types fargs return-type))))) (defun convert-to-lisp-type (type) (ecase type ((:char :short :int :long :nat) `(signed-byte ,(* 8 (ff:sizeof-fobject type)))) ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsigned-nat) `(unsigned-byte ,(* 8 (ff:sizeof-fobject type)))) (:float 'single-float) (:double 'double-float) (:void 'null))) (defun allegro-type-pair (cffi-type) ;; the :FOREIGN-ADDRESS pseudo-type accepts both pointers and ;; arrays. We need the latter for shareable byte vector support. (if (eq cffi-type :pointer) (list :foreign-address) (let ((ftype (convert-foreign-type cffi-type))) (list ftype (convert-to-lisp-type ftype))))) #+ignore (defun note-named-foreign-function (symbol name types rettype) "Give Allegro's compiler a hint to perform a direct call." `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',symbol 'system::direct-ff-call) (list '(,name :language :c) t ; callback :c ; convention ;; return type '(:c-type lisp-type) ',(allegro-type-pair rettype) ;; arg types '({(:c-type lisp-type)}*) '(,@(mapcar #'allegro-type-pair types)) nil ; arg-checking ff::ep-flag-never-release)))) (defmacro %foreign-funcall (name args &key convention library) (declare (ignore convention library)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(system::ff-funcall (load-time-value (excl::determine-foreign-address '(,name :language :c) #-(version>= 8 1) ff::ep-flag-never-release #+(version>= 8 1) ff::ep-flag-always-release nil ; method-index )) ;; arg types {'(:c-type lisp-type) argN}* ,@(mapcan (lambda (type arg) `(',(allegro-type-pair type) ,arg)) types fargs) ;; return type '(:c-type lisp-type) ',(allegro-type-pair rettype)))) (defun defcfun-helper-forms (name lisp-name rettype args types options) "Return 2 values for DEFCFUN. A prelude form and a caller form." (declare (ignore options)) (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name)))) (values `(ff:def-foreign-call (,ff-name ,name) ,(loop for type in types collect (list* (gensym) (allegro-type-pair type))) :returning ,(allegro-type-pair rettype) ;; Don't use call-direct when there are no arguments. ,@(unless (null args) '(:call-direct t)) :arg-checking nil :strings-convert nil #+(version>= 8 1) ,@'(:release-heap :when-ok :release-heap-ignorable t) #+smp ,@'(:release-heap-implies-allow-gc t)) `(,ff-name ,@args)))) ;;; See doc/allegro-internals.txt for a clue about entry-vec. (defmacro %foreign-funcall-pointer (ptr args &key convention) (declare (ignore convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) (with-unique-names (entry-vec) `(let ((,entry-vec (excl::make-entry-vec-boa))) (setf (aref ,entry-vec 1) ,ptr) ; set jump address (system::ff-funcall ,entry-vec ;; arg types {'(:c-type lisp-type) argN}* ,@(mapcan (lambda (type arg) `(',(allegro-type-pair type) ,arg)) types fargs) ;; return type '(:c-type lisp-type) ',(allegro-type-pair rettype)))))) ;;;# Callbacks ;;; The *CALLBACKS* hash table contains information about a callback ;;; for the Allegro FFI. The key is the name of the CFFI callback, ;;; and the value is a cons, the car containing the symbol the ;;; callback was defined on in the CFFI-CALLBACKS package, the cdr ;;; being an Allegro FFI pointer (a fixnum) that can be passed to C ;;; functions. ;;; ;;; These pointers must be restored when a saved Lisp image is loaded. ;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to ;;; re-register the callbacks during Lisp startup. (defvar *callbacks* (make-hash-table)) ;;; Register a callback in the *CALLBACKS* hash table. (defun register-callback (cffi-name callback-name) (setf (gethash cffi-name *callbacks*) (cons callback-name (ff:register-foreign-callable callback-name :reuse t)))) ;;; Restore the saved pointers in *CALLBACKS* when loading an image. (defun restore-callbacks () (maphash (lambda (key value) (register-callback key (car value))) *callbacks*)) ;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing ;;; CFFI is restarted. (eval-when (:load-toplevel :execute) (pushnew 'restore-callbacks excl:*restart-actions*)) ;;; Create a package to contain the symbols for callback functions. (defpackage #:cffi-callbacks (:use)) (defun intern-callback (name) (intern (format nil "~A::~A" (if-let (package (symbol-package name)) (package-name package) "#") (symbol-name name)) '#:cffi-callbacks)) (defun convert-calling-convention (convention) (ecase convention (:cdecl :c) (:stdcall :stdcall))) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (declare (ignore rettype)) (let ((cb-name (intern-callback name))) `(progn (ff:defun-foreign-callable ,cb-name ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types) (declare (:convention ,(convert-calling-convention convention))) ,body) (register-callback ',name ',cb-name)))) ;;; Return the saved Lisp callback pointer from *CALLBACKS* for the ;;; CFFI callback named NAME. (defun %callback (name) (or (cdr (gethash name *callbacks*)) (error "Undefined callback: ~S" name))) ;;;# Loading and Closing Foreign Libraries (defun %load-foreign-library (name path) "Load a foreign library." ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load ;; the argument. However, previous versions do not and will only ;; foreign load the argument if its type is a member of the ;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special ;; to a list containing whatever type NAME has. (declare (ignore name)) (let ((excl::*load-foreign-types* (list (pathname-type (parse-namestring path))))) (handler-case (progn #+(version>= 7) (load path :foreign t) #-(version>= 7) (load path)) (file-error (fe) (error (change-class fe 'simple-error)))) path)) (defun %close-foreign-library (name) "Close the foreign library NAME." (ff:unload-foreign-library name)) (defun native-namestring (pathname) (namestring pathname)) ;;;# Foreign Globals (defun convert-external-name (name) "Add an underscore to NAME if necessary for the ABI." #+macosx (concatenate 'string "_" name) #-macosx name) (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (prog1 (ff:get-entry-point (convert-external-name name)))) cffi_0.19.0/src/cffi-scl.lisp0000644000175000017500000002553313103031266014455 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2006-2007, Scieneer Pty Ltd. ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:alien #:c-call) (:import-from #:alexandria #:once-only #:with-unique-names) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Mis-features (pushnew 'flat-namespace *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (if (eq ext:*case-mode* :upper) (string-upcase name) (string-downcase name))) ;;;# Basic Pointer Operations (deftype foreign-pointer () 'sys:system-area-pointer) (declaim (inline pointerp)) (defun pointerp (ptr) "Return true if 'ptr is a foreign pointer." (sys:system-area-pointer-p ptr)) (declaim (inline pointer-eq)) (defun pointer-eq (ptr1 ptr2) "Return true if 'ptr1 and 'ptr2 point to the same address." (sys:sap= ptr1 ptr2)) (declaim (inline null-pointer)) (defun null-pointer () "Construct and return a null pointer." (sys:int-sap 0)) (declaim (inline null-pointer-p)) (defun null-pointer-p (ptr) "Return true if 'ptr is a null pointer." (zerop (sys:sap-int ptr))) (declaim (inline inc-pointer)) (defun inc-pointer (ptr offset) "Return a pointer pointing 'offset bytes past 'ptr." (sys:sap+ ptr offset)) (declaim (inline make-pointer)) (defun make-pointer (address) "Return a pointer pointing to 'address." (sys:int-sap address)) (declaim (inline pointer-address)) (defun pointer-address (ptr) "Return the address pointed to by 'ptr." (sys:sap-int ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind 'var to 'size bytes of foreign memory during 'body. The pointer in 'var is invalid beyond the dynamic extent of 'body, and may be stack-allocated if supported by the implementation. If 'size-var is supplied, it will be bound to 'size during 'body." (unless size-var (setf size-var (gensym (symbol-name '#:size)))) ;; If the size is constant we can stack-allocate. (cond ((constantp size) (let ((alien-var (gensym (symbol-name '#:alien)))) `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) (let ((,size-var ,size) (,var (alien-sap ,alien-var))) (declare (ignorable ,size-var)) ,@body)))) (t `(let ((,size-var ,size)) (alien:with-bytes (,var ,size-var) ,@body))))) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack and on the ;;; heap. The main CFFI package defines macros that wrap 'foreign-alloc and ;;; 'foreign-free in 'unwind-protect for the common usage when the memory has ;;; dynamic extent. (defun %foreign-alloc (size) "Allocate 'size bytes on the heap and return a pointer." (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size)) (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned)) size)) (defun foreign-free (ptr) "Free a 'ptr allocated by 'foreign-alloc." (declare (type system-area-pointer ptr)) (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) ptr)) ;;;# Shareable Vectors (defun make-shareable-byte-vector (size) "Create a Lisp vector of 'size bytes that can passed to 'with-pointer-to-vector-data." (make-array size :element-type '(unsigned-byte 8))) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind 'ptr-var to a foreign pointer to the data in 'vector." (let ((vector-var (gensym (symbol-name '#:vector)))) `(let ((,vector-var ,vector)) (ext:with-pinned-object (,vector-var) (let ((,ptr-var (sys:vector-sap ,vector-var))) ,@body))))) ;;;# Dereferencing ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler ;;; macros that optimize the case where the type keyword is constant ;;; at compile-time. (defmacro define-mem-accessors (&body pairs) `(progn (defun %mem-ref (ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (,fn ptr offset))))) (defun %mem-set (value ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) (if (constantp type) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) (if (constantp type) (once-only (value) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) form)))) (define-mem-accessors (:char sys:signed-sap-ref-8) (:unsigned-char sys:sap-ref-8) (:short sys:signed-sap-ref-16) (:unsigned-short sys:sap-ref-16) (:int sys:signed-sap-ref-32) (:unsigned-int sys:sap-ref-32) (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64) (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64) (:long-long sys:signed-sap-ref-64) (:unsigned-long-long sys:sap-ref-64) (:float sys:sap-ref-single) (:double sys:sap-ref-double) #+long-float (:long-double sys:sap-ref-long) (:pointer sys:sap-ref-sap)) ;;;# Calling Foreign Functions (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to an ALIEN type." (ecase type-keyword (:char 'char) (:unsigned-char 'unsigned-char) (:short 'short) (:unsigned-short 'unsigned-short) (:int 'int) (:unsigned-int 'unsigned-int) (:long 'long) (:unsigned-long 'unsigned-long) (:long-long '(signed 64)) (:unsigned-long-long '(unsigned 64)) (:float 'single-float) (:double 'double-float) #+long-float (:long-double 'long-float) (:pointer 'system-area-pointer) (:void 'void))) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (values (truncate (alien-internals:alien-type-bits (alien-internals:parse-alien-type (convert-foreign-type type-keyword))) 8))) (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (values (truncate (alien-internals:alien-type-alignment (alien-internals:parse-alien-type (convert-foreign-type type-keyword))) 8))) (defun foreign-funcall-type-and-args (args) "Return an 'alien function type for 'args." (let ((return-type nil)) (loop for (type arg) on args by #'cddr if arg collect (convert-foreign-type type) into types and collect arg into fargs else do (setf return-type (convert-foreign-type type)) finally (return (values types fargs return-type))))) (defmacro %%foreign-funcall (name types fargs rettype) "Internal guts of '%foreign-funcall." `(alien-funcall (extern-alien ,name (function ,rettype ,@types)) ,@fargs)) (defmacro %foreign-funcall (name args &key library convention) "Perform a foreign function call, document it more later." (declare (ignore library convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(%%foreign-funcall ,name ,types ,fargs ,rettype))) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Funcall a pointer to a foreign function." (declare (ignore convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) (with-unique-names (function) `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr)) (alien-funcall ,function ,@fargs))))) ;;; Callbacks (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (declare (ignore convention)) `(alien:defcallback ,name (,(convert-foreign-type rettype) ,@(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types)) ,body)) (declaim (inline %callback)) (defun %callback (name) (alien:callback-sap name)) ;;;# Loading and Closing Foreign Libraries (defun %load-foreign-library (name path) "Load the foreign library 'name." (declare (ignore name)) (ext:load-dynamic-object path)) (defun %close-foreign-library (name) "Closes the foreign library 'name." (ext:close-dynamic-object name)) (defun native-namestring (pathname) (ext:unix-namestring pathname nil)) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol 'name." (declare (ignore library)) (let ((sap (sys:foreign-symbol-address name))) (if (zerop (sys:sap-int sap)) nil sap))) cffi_0.19.0/src/functions.lisp0000644000175000017500000004433013103031266014773 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; functions.lisp --- High-level interface to foreign functions. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;;;# Calling Foreign Functions ;;; ;;; FOREIGN-FUNCALL is the main primitive for calling foreign ;;; functions. It converts each argument based on the installed ;;; translators for its type, then passes the resulting list to ;;; CFFI-SYS:%FOREIGN-FUNCALL. ;;; ;;; For implementation-specific reasons, DEFCFUN doesn't use ;;; FOREIGN-FUNCALL directly and might use something else (passed to ;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of ;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function. (defun translate-objects (syms args types rettype call-form &optional indirect) "Helper function for FOREIGN-FUNCALL and DEFCFUN. If 'indirect is T, all arguments are represented by foreign pointers, even those that can be represented by CL objects." (if (null args) (expand-from-foreign call-form (parse-type rettype)) (funcall (if indirect #'expand-to-foreign-dyn-indirect #'expand-to-foreign-dyn) (car args) (car syms) (list (translate-objects (cdr syms) (cdr args) (cdr types) rettype call-form indirect)) (parse-type (car types))))) (defun parse-args-and-types (args) "Returns 4 values: types, canonicalized types, args and return type." (let* ((len (length args)) (return-type (if (oddp len) (lastcar args) :void))) (loop repeat (floor len 2) for (type arg) on args by #'cddr collect type into types collect (canonicalize-foreign-type type) into ctypes collect arg into fargs finally (return (values types ctypes fargs return-type))))) ;;; While the options passed directly to DEFCFUN/FOREIGN-FUNCALL have ;;; precedence, we also grab its library's options, if possible. (defun parse-function-options (options &key pointer) (destructuring-bind (&key (library :default libraryp) (cconv nil cconv-p) (calling-convention cconv calling-convention-p) (convention calling-convention)) options (when cconv-p (warn-obsolete-argument :cconv :convention)) (when calling-convention-p (warn-obsolete-argument :calling-convention :convention)) (list* :convention (or convention (when libraryp (let ((lib-options (foreign-library-options (get-foreign-library library)))) (getf lib-options :convention))) :cdecl) ;; Don't pass the library option if we're dealing with ;; FOREIGN-FUNCALL-POINTER. (unless pointer (list :library library))))) (defun structure-by-value-p (ctype) "A structure or union is to be called or returned by value." (let ((actual-type (ensure-parsed-base-type ctype))) (or (and (typep actual-type 'foreign-struct-type) (not (bare-struct-type-p actual-type))) #+cffi::no-long-long (typep actual-type 'emulated-llong-type)))) (defun fn-call-by-value-p (argument-types return-type) "One or more structures in the arguments or return from the function are called by value." (or (some 'structure-by-value-p argument-types) (structure-by-value-p return-type))) (defvar *foreign-structures-by-value* (lambda (&rest args) (declare (ignore args)) (restart-case (error "Unable to call structures by value without cffi-libffi loaded.") (load-cffi-libffi () :report "Load cffi-libffi." (asdf:operate 'asdf:load-op 'cffi-libffi)))) "A function that produces a form suitable for calling structures by value.") (defun foreign-funcall-form (thing options args pointerp) (multiple-value-bind (types ctypes fargs rettype) (parse-args-and-types args) (let ((syms (make-gensym-list (length fargs))) (fsbvp (fn-call-by-value-p ctypes rettype))) (if fsbvp ;; Structures by value call through *foreign-structures-by-value* (funcall *foreign-structures-by-value* thing fargs syms types rettype ctypes pointerp) (translate-objects syms fargs types rettype `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall) ;; No structures by value, direct call ,thing (,@(mapcan #'list ctypes syms) ,(canonicalize-foreign-type rettype)) ,@(parse-function-options options :pointer pointerp))))))) (defmacro foreign-funcall (name-and-options &rest args) "Wrapper around %FOREIGN-FUNCALL that translates its arguments." (let ((name (car (ensure-list name-and-options))) (options (cdr (ensure-list name-and-options)))) (foreign-funcall-form name options args nil))) (defmacro foreign-funcall-pointer (pointer options &rest args) (foreign-funcall-form pointer options args t)) (defun promote-varargs-type (builtin-type) "Default argument promotions." (case builtin-type (:float :double) ((:char :short) :int) ((:unsigned-char :unsigned-short) :unsigned-int) (t builtin-type))) (defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp) (multiple-value-bind (fixed-types fixed-ctypes fixed-fargs) (parse-args-and-types fixed-args) (multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype) (parse-args-and-types varargs) (let ((fixed-syms (make-gensym-list (length fixed-fargs))) (varargs-syms (make-gensym-list (length varargs-fargs)))) (translate-objects (append fixed-syms varargs-syms) (append fixed-fargs varargs-fargs) (append fixed-types varargs-types) rettype `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall) ,thing ,(append (mapcan #'list (nconc fixed-ctypes (mapcar #'promote-varargs-type varargs-ctypes)) (append fixed-syms (loop for sym in varargs-syms and type in varargs-ctypes if (eq type :float) collect `(float ,sym 1.0d0) else collect sym))) (list (canonicalize-foreign-type rettype))) ,@options)))))) ;;; For now, the only difference between this macro and ;;; FOREIGN-FUNCALL is that it does argument promotion for that ;;; variadic argument. This could be useful to call an hypothetical ;;; %foreign-funcall-varargs on some hypothetical lisp on an ;;; hypothetical platform that has different calling conventions for ;;; varargs functions. :-) (defmacro foreign-funcall-varargs (name-and-options fixed-args &rest varargs) "Wrapper around %FOREIGN-FUNCALL that translates its arguments and does type promotion for the variadic arguments." (let ((name (car (ensure-list name-and-options))) (options (cdr (ensure-list name-and-options)))) (foreign-funcall-varargs-form name options fixed-args varargs nil))) (defmacro foreign-funcall-pointer-varargs (pointer options fixed-args &rest varargs) "Wrapper around %FOREIGN-FUNCALL-POINTER that translates its arguments and does type promotion for the variadic arguments." (foreign-funcall-varargs-form pointer options fixed-args varargs t)) ;;;# Defining Foreign Functions ;;; ;;; The DEFCFUN macro provides a declarative interface for defining ;;; Lisp functions that call foreign functions. ;; If cffi-sys doesn't provide a defcfun-helper-forms, ;; we define one that uses %foreign-funcall. (eval-when (:compile-toplevel :load-toplevel :execute) (unless (fboundp 'defcfun-helper-forms) (defun defcfun-helper-forms (name lisp-name rettype args types options) (declare (ignore lisp-name)) (values '() `(%foreign-funcall ,name ,(append (mapcan #'list types args) (list rettype)) ,@options))))) (defun %defcfun (lisp-name foreign-name return-type args options docstring) (let* ((arg-names (mapcar #'first args)) (arg-types (mapcar #'second args)) (syms (make-gensym-list (length args))) (call-by-value (fn-call-by-value-p arg-types return-type))) (multiple-value-bind (prelude caller) (if call-by-value (values nil nil) (defcfun-helper-forms foreign-name lisp-name (canonicalize-foreign-type return-type) syms (mapcar #'canonicalize-foreign-type arg-types) options)) `(progn ,prelude (defun ,lisp-name ,arg-names ,@(ensure-list docstring) ,(if call-by-value `(foreign-funcall ,(cons foreign-name options) ,@(append (mapcan #'list arg-types arg-names) (list return-type))) (translate-objects syms arg-names arg-types return-type caller))))))) (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) ,@(ensure-list doc) `(foreign-funcall-varargs ,'(,foreign-name ,@options) ,,`(list ,@(loop for (name type) in args collect `',type collect name)) ,@,varargs ,',return-type))))) (defgeneric translate-underscore-separated-name (name) (:method ((name string)) (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name))))) (:method ((name symbol)) (substitute #\_ #\- (string-downcase (symbol-name name))))) (defun collapse-prefix (l special-words) (unless (null l) (multiple-value-bind (newpre skip) (check-prefix l special-words) (cons newpre (collapse-prefix (nthcdr skip l) special-words))))) (defun check-prefix (l special-words) (let ((pl (loop for i from (1- (length l)) downto 0 collect (apply #'concatenate 'simple-string (butlast l i))))) (loop for w in special-words for p = (position-if #'(lambda (s) (string= s w)) pl) when p do (return-from check-prefix (values (nth p pl) (1+ p)))) (values (first l) 1))) (defgeneric translate-camelcase-name (name &key upper-initial-p special-words) (:method ((name string) &key upper-initial-p special-words) (declare (ignore upper-initial-p)) (values (intern (reduce #'(lambda (s1 s2) (concatenate 'simple-string s1 "-" s2)) (mapcar #'string-upcase (collapse-prefix (split-if #'(lambda (ch) (or (upper-case-p ch) (digit-char-p ch))) name) special-words)))))) (:method ((name symbol) &key upper-initial-p special-words) (apply #'concatenate 'string (loop for str in (split-if #'(lambda (ch) (eq ch #\-)) (string name) :elide) for first-word-p = t then nil for e = (member str special-words :test #'equal :key #'string-upcase) collect (cond ((and first-word-p (not upper-initial-p)) (string-downcase str)) (e (first e)) (t (string-capitalize str))))))) (defgeneric translate-name-from-foreign (foreign-name package &optional varp) (:method (foreign-name package &optional varp) (declare (ignore package)) (let ((sym (translate-underscore-separated-name foreign-name))) (if varp (values (intern (format nil "*~A*" (canonicalize-symbol-name-case (symbol-name sym))))) sym)))) (defgeneric translate-name-to-foreign (lisp-name package &optional varp) (:method (lisp-name package &optional varp) (declare (ignore package)) (let ((name (translate-underscore-separated-name lisp-name))) (if varp (string-trim '(#\*) name) name)))) (defun lisp-name (spec varp) (check-type spec string) (translate-name-from-foreign spec *package* varp)) (defun foreign-name (spec varp) (check-type spec (and symbol (not null))) (translate-name-to-foreign spec *package* varp)) (defun foreign-options (opts varp) (if varp (funcall 'parse-defcvar-options opts) (parse-function-options opts))) (defun lisp-name-p (name) (and name (symbolp name) (not (keywordp name)))) (defun %parse-name-and-options (spec varp) (cond ((stringp spec) (values (lisp-name spec varp) spec nil)) ((symbolp spec) (assert (not (null spec))) (values spec (foreign-name spec varp) nil)) ((and (consp spec) (stringp (first spec))) (destructuring-bind (foreign-name &rest options) spec (cond ((or (null options) (keywordp (first options))) (values (lisp-name foreign-name varp) foreign-name options)) (t (assert (lisp-name-p (first options))) (values (first options) foreign-name (rest options)))))) ((and (consp spec) (lisp-name-p (first spec))) (destructuring-bind (lisp-name &rest options) spec (cond ((or (null options) (keywordp (first options))) (values lisp-name (foreign-name spec varp) options)) (t (assert (stringp (first options))) (values lisp-name (first options) (rest options)))))) (t (error "Not a valid foreign function specifier: ~A" spec)))) ;;; DEFCFUN's first argument has can have the following syntax: ;;; ;;; 1. string ;;; 2. symbol ;;; 3. \( string [symbol] options* ) ;;; 4. \( symbol [string] options* ) ;;; ;;; The string argument denotes the foreign function's name. The ;;; symbol argument is used to name the Lisp function. If one isn't ;;; present, its name is derived from the other. See the user ;;; documentation for an explanation of the derivation rules. (defun parse-name-and-options (spec &optional varp) (multiple-value-bind (lisp-name foreign-name options) (%parse-name-and-options spec varp) (values lisp-name foreign-name (foreign-options options varp)))) ;;; If we find a &REST token at the end of ARGS, it means this is a ;;; varargs foreign function therefore we define a lisp macro using ;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with ;;; %DEFCFUN. (defmacro defcfun (name-and-options return-type &body args) "Defines a Lisp function that calls a foreign function." (let ((docstring (when (stringp (car args)) (pop args)))) (multiple-value-bind (lisp-name foreign-name options) (parse-name-and-options name-and-options) (if (eq (lastcar args) '&rest) (%defcfun-varargs lisp-name foreign-name return-type (butlast args) options docstring) (%defcfun lisp-name foreign-name return-type args options docstring))))) ;;;# Defining Callbacks (defun inverse-translate-objects (args types declarations rettype call) `(let (,@(loop for arg in args and type in types collect (list arg (expand-from-foreign arg (parse-type type))))) ,@declarations ,(expand-to-foreign call (parse-type rettype)))) (defun parse-defcallback-options (options) (destructuring-bind (&key (cconv :cdecl cconv-p) (calling-convention cconv calling-convention-p) (convention calling-convention)) options (when cconv-p (warn-obsolete-argument :cconv :convention)) (when calling-convention-p (warn-obsolete-argument :calling-convention :convention)) (list :convention convention))) (defmacro defcallback (name-and-options return-type args &body body) (multiple-value-bind (body declarations) (parse-body body :documentation t) (let ((arg-names (mapcar #'car args)) (arg-types (mapcar #'cadr args)) (name (car (ensure-list name-and-options))) (options (cdr (ensure-list name-and-options)))) `(progn (%defcallback ,name ,(canonicalize-foreign-type return-type) ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types) ,(inverse-translate-objects arg-names arg-types declarations return-type `(block ,name ,@body)) ,@(parse-defcallback-options options)) ',name)))) (declaim (inline get-callback)) (defun get-callback (symbol) (%callback symbol)) (defmacro callback (name) `(%callback ',name)) cffi_0.19.0/src/cffi-sbcl.lisp0000644000175000017500000003474513103031266014624 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:sb-alien) (:import-from #:alexandria #:once-only #:with-unique-names #:when-let #:removef) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Misfeatures (pushnew 'flat-namespace *features*) ;;;# Symbol Case (declaim (inline canonicalize-symbol-name-case)) (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Basic Pointer Operations (deftype foreign-pointer () 'sb-sys:system-area-pointer) (declaim (inline pointerp)) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (sb-sys:system-area-pointer-p ptr)) (declaim (inline pointer-eq)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (declare (type system-area-pointer ptr1 ptr2)) (sb-sys:sap= ptr1 ptr2)) (declaim (inline null-pointer)) (defun null-pointer () "Construct and return a null pointer." (sb-sys:int-sap 0)) (declaim (inline null-pointer-p)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (declare (type system-area-pointer ptr)) (zerop (sb-sys:sap-int ptr))) (declaim (inline inc-pointer)) (defun inc-pointer (ptr offset) "Return a pointer pointing OFFSET bytes past PTR." (declare (type system-area-pointer ptr) (type integer offset)) (sb-sys:sap+ ptr offset)) (declaim (inline make-pointer)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." ;; (declare (type (unsigned-byte 32) address)) (sb-sys:int-sap address)) (declaim (inline pointer-address)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (declare (type system-area-pointer ptr)) (sb-sys:sap-int ptr)) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage ;;; when the memory has dynamic extent. (declaim (inline %foreign-alloc)) (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." ;; (declare (type (unsigned-byte 32) size)) (alien-sap (make-alien (unsigned 8) size))) (declaim (inline foreign-free)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." (declare (type system-area-pointer ptr) (optimize speed)) (free-alien (sap-alien ptr (* (unsigned 8))))) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) ;; If the size is constant we can stack-allocate. (if (constantp size) (let ((alien-var (gensym "ALIEN"))) `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) (let ((,size-var ,(eval size)) (,var (alien-sap ,alien-var))) (declare (ignorable ,size-var)) ,@body))) `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect (progn ,@body) (foreign-free ,var))))) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (declaim (inline make-shareable-byte-vector)) (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes can passed to WITH-POINTER-TO-VECTOR-DATA." ; (declare (type sb-int:index size)) (make-array size :element-type '(unsigned-byte 8))) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." (let ((vector-var (gensym "VECTOR"))) `(let ((,vector-var ,vector)) (declare (type (sb-kernel:simple-unboxed-array (*)) ,vector-var)) (sb-sys:with-pinned-objects (,vector-var) (let ((,ptr-var (sb-sys:vector-sap ,vector-var))) ,@body))))) ;;;# Dereferencing ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler ;;; macros that optimize the case where the type keyword is constant ;;; at compile-time. (defmacro define-mem-accessors (&body pairs) `(progn (defun %mem-ref (ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (,fn ptr offset))))) (defun %mem-set (value ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) (if (constantp type) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) (if (constantp type) (once-only (value) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) form)))) ;;; Look up alien type information and build both define-mem-accessors form ;;; and convert-foreign-type function definition. (defmacro define-type-mapping (accessor-table alien-table) (let* ((accessible-types (remove 'void alien-table :key #'second)) (size-and-signedp-forms (mapcar (lambda (name) (list (eval `(alien-size ,(second name))) (typep -1 `(alien ,(second name))))) accessible-types))) `(progn (define-mem-accessors ,@(loop for (cffi-keyword alien-type fixed-accessor) in accessible-types and (alien-size signedp) in size-and-signedp-forms for (signed-ref unsigned-ref) = (cdr (assoc alien-size accessor-table)) collect `(,cffi-keyword ,(or fixed-accessor (if signedp signed-ref unsigned-ref) (error "No accessor found for ~S" alien-type))))) (defun convert-foreign-type (type-keyword) (ecase type-keyword ,@(loop for (cffi-keyword alien-type) in alien-table collect `(,cffi-keyword (quote ,alien-type)))))))) (define-type-mapping ((8 sb-sys:signed-sap-ref-8 sb-sys:sap-ref-8) (16 sb-sys:signed-sap-ref-16 sb-sys:sap-ref-16) (32 sb-sys:signed-sap-ref-32 sb-sys:sap-ref-32) (64 sb-sys:signed-sap-ref-64 sb-sys:sap-ref-64)) ((:char char) (:unsigned-char unsigned-char) (:short short) (:unsigned-short unsigned-short) (:int int) (:unsigned-int unsigned-int) (:long long) (:unsigned-long unsigned-long) (:long-long long-long) (:unsigned-long-long unsigned-long-long) (:float single-float sb-sys:sap-ref-single) (:double double-float sb-sys:sap-ref-double) (:pointer system-area-pointer sb-sys:sap-ref-sap) (:void void))) ;;;# Calling Foreign Functions (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (/ (sb-alien-internals:alien-type-bits (sb-alien-internals:parse-alien-type (convert-foreign-type type-keyword) nil)) 8)) (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." #+(and darwin ppc (not ppc64)) (case type-keyword ((:double :long-long :unsigned-long-long) (return-from %foreign-type-alignment 8))) ;; No override necessary for other types... (/ (sb-alien-internals:alien-type-alignment (sb-alien-internals:parse-alien-type (convert-foreign-type type-keyword) nil)) 8)) (defun foreign-funcall-type-and-args (args) "Return an SB-ALIEN function type for ARGS." (let ((return-type 'void)) (loop for (type arg) on args by #'cddr if arg collect (convert-foreign-type type) into types and collect arg into fargs else do (setf return-type (convert-foreign-type type)) finally (return (values types fargs return-type))))) (defmacro %%foreign-funcall (name types fargs rettype) "Internal guts of %FOREIGN-FUNCALL." `(alien-funcall (extern-alien ,name (function ,rettype ,@types)) ,@fargs)) (defmacro %foreign-funcall (name args &key library convention) "Perform a foreign function call, document it more later." (declare (ignore library convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(%%foreign-funcall ,name ,types ,fargs ,rettype))) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Funcall a pointer to a foreign function." (declare (ignore convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) (with-unique-names (function) `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr)) (alien-funcall ,function ,@fargs))))) ;;;# Callbacks ;;; The *CALLBACKS* hash table contains a direct mapping of CFFI ;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA. ;;; SBCL will maintain the addresses of the callbacks across saved ;;; images, so it is safe to store the pointers directly. (defvar *callbacks* (make-hash-table)) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (check-type convention (member :stdcall :cdecl)) `(setf (gethash ',name *callbacks*) (alien-sap (sb-alien::alien-lambda #+alien-callback-conventions (,convention ,(convert-foreign-type rettype)) #-alien-callback-conventions ,(convert-foreign-type rettype) ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types) ,body)))) (defun %callback (name) (or (gethash name *callbacks*) (error "Undefined callback: ~S" name))) ;;;# Loading and Closing Foreign Libraries #+darwin (defun call-within-initial-thread (fn &rest args) (let (result error (sem (sb-thread:make-semaphore))) (sb-thread:interrupt-thread ;; KLUDGE: find a better way to get the initial thread. (car (last (sb-thread:list-all-threads))) (lambda () (multiple-value-setq (result error) (ignore-errors (apply fn args))) (sb-thread:signal-semaphore sem))) (sb-thread:wait-on-semaphore sem) (if error (signal error) result))) (declaim (inline %load-foreign-library)) (defun %load-foreign-library (name path) "Load a foreign library." (declare (ignore name)) ;; As of MacOS X 10.6.6, loading things like CoreFoundation from a ;; thread other than the initial one results in a crash. #+darwin (call-within-initial-thread 'load-shared-object path) #-darwin (load-shared-object path)) ;;; SBCL 1.0.21.15 renamed SB-ALIEN::SHARED-OBJECT-FILE but introduced ;;; SB-ALIEN:UNLOAD-SHARED-OBJECT which we can use instead. (eval-when (:compile-toplevel :load-toplevel :execute) (defun unload-shared-object-present-p () (multiple-value-bind (foundp kind) (find-symbol "UNLOAD-SHARED-OBJECT" "SB-ALIEN") (if (and foundp (eq kind :external)) '(:and) '(:or))))) (defun %close-foreign-library (handle) "Closes a foreign library." #+#.(cffi-sys::unload-shared-object-present-p) (sb-alien:unload-shared-object handle) #-#.(cffi-sys::unload-shared-object-present-p) (sb-thread:with-mutex (sb-alien::*shared-objects-lock*) (let ((obj (find (sb-ext:native-namestring handle) sb-alien::*shared-objects* :key #'sb-alien::shared-object-file :test #'string=))) (when obj (sb-alien::dlclose-or-lose obj) (removef sb-alien::*shared-objects* obj) #+(and linkage-table (not win32)) (sb-alien::update-linkage-table))))) (defun native-namestring (pathname) (sb-ext:native-namestring pathname)) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (when-let (address (sb-sys:find-foreign-symbol-address name)) (sb-sys:int-sap address))) cffi_0.19.0/src/enum.lisp0000644000175000017500000003674513103031266013742 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; enum.lisp --- Defining foreign constants as Lisp keywords. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;; TODO the accessors names are rather inconsistent: ;; FOREIGN-ENUM-VALUE FOREIGN-BITFIELD-VALUE ;; FOREIGN-ENUM-KEYWORD FOREIGN-BITFIELD-SYMBOLS ;; FOREIGN-ENUM-KEYWORD-LIST FOREIGN-BITFIELD-SYMBOL-LIST ;; I'd rename them to: FOREIGN-*-KEY(S) and FOREIGN-*-ALL-KEYS -- attila ;; TODO bitfield is a confusing name, because the C standard calls ;; the "int foo : 3" type as a bitfield. Maybe rename to defbitmask? ;; -- attila ;;;# Foreign Constants as Lisp Keywords ;;; ;;; This module defines the DEFCENUM macro, which provides an ;;; interface for defining a type and associating a set of integer ;;; constants with keyword symbols for that type. ;;; ;;; The keywords are automatically translated to the appropriate ;;; constant for the type by a type translator when passed as ;;; arguments or a return value to a foreign function. (defclass foreign-enum (named-foreign-type enhanced-foreign-type) ((keyword-values :initform (error "Must specify KEYWORD-VALUES.") :initarg :keyword-values :reader keyword-values) (value-keywords :initform (error "Must specify VALUE-KEYWORDS.") :initarg :value-keywords :reader value-keywords)) (:documentation "Describes a foreign enumerated type.")) (deftype enum-key () '(and symbol (not null))) (defparameter +valid-enum-base-types+ *built-in-integer-types*) (defun parse-foreign-enum-like (type-name base-type values &optional field-mode-p) (let ((keyword-values (make-hash-table :test 'eq)) (value-keywords (make-hash-table)) (field-keywords (list)) (bit-index->keyword (make-array 0 :adjustable t :element-type t)) (default-value (if field-mode-p 1 0)) (most-extreme-value 0) (has-negative-value? nil)) (dolist (pair values) (destructuring-bind (keyword &optional (value default-value valuep)) (ensure-list pair) (check-type keyword enum-key) ;;(check-type value integer) (when (> (abs value) (abs most-extreme-value)) (setf most-extreme-value value)) (when (minusp value) (setf has-negative-value? t)) (if field-mode-p (if valuep (when (and (>= value default-value) (single-bit-p value)) (setf default-value (ash value 1))) (setf default-value (ash default-value 1))) (setf default-value (1+ value))) (if (gethash keyword keyword-values) (error "A foreign enum cannot contain duplicate keywords: ~S." keyword) (setf (gethash keyword keyword-values) value)) ;; This is completely arbitrary behaviour: we keep the last ;; value->keyword mapping. I suppose the opposite would be ;; just as good (keeping the first). Returning a list with all ;; the keywords might be a solution too? Suggestions ;; welcome. --luis (setf (gethash value value-keywords) keyword) (when (and field-mode-p (single-bit-p value)) (let ((bit-index (1- (integer-length value)))) (push keyword field-keywords) (when (<= (array-dimension bit-index->keyword 0) bit-index) (setf bit-index->keyword (adjust-array bit-index->keyword (1+ bit-index) :initial-element nil))) (setf (aref bit-index->keyword bit-index) keyword))))) (if base-type (progn (setf base-type (canonicalize-foreign-type base-type)) ;; I guess we don't lose much by not strictly adhering to ;; the C standard here, and some libs out in the wild are ;; already using e.g. :double. #+nil (assert (member base-type +valid-enum-base-types+ :test 'eq) () "Invalid base type ~S for enum type ~S. Must be one of ~S." base-type type-name +valid-enum-base-types+)) ;; details: https://stackoverflow.com/questions/1122096/what-is-the-underlying-type-of-a-c-enum (let ((bits (integer-length most-extreme-value))) (setf base-type (let ((most-uint-bits (load-time-value (* (foreign-type-size :unsigned-int) 8))) (most-ulong-bits (load-time-value (* (foreign-type-size :unsigned-long) 8))) (most-ulonglong-bits (load-time-value (* (foreign-type-size :unsigned-long-long) 8)))) (or (if has-negative-value? (cond ((<= (1+ bits) most-uint-bits) :int) ((<= (1+ bits) most-ulong-bits) :long) ((<= (1+ bits) most-ulonglong-bits) :long-long)) (cond ((<= bits most-uint-bits) :unsigned-int) ((<= bits most-ulong-bits) :unsigned-long) ((<= bits most-ulonglong-bits) :unsigned-long-long))) (error "Enum value ~S of enum ~S is too large to store." most-extreme-value type-name)))))) (values base-type keyword-values value-keywords field-keywords (when field-mode-p (alexandria:copy-array bit-index->keyword :adjustable nil :fill-pointer nil))))) (defun make-foreign-enum (type-name base-type values) "Makes a new instance of the foreign-enum class." (multiple-value-bind (base-type keyword-values value-keywords) (parse-foreign-enum-like type-name base-type values) (make-instance 'foreign-enum :name type-name :actual-type (parse-type base-type) :keyword-values keyword-values :value-keywords value-keywords))) (defun %defcenum-like (name-and-options enum-list type-factory) (discard-docstring enum-list) (destructuring-bind (name &optional base-type) (ensure-list name-and-options) (let ((type (funcall type-factory name base-type enum-list))) `(eval-when (:compile-toplevel :load-toplevel :execute) (notice-foreign-type ',name ;; ,type is not enough here, someone needs to ;; define it when we're being loaded from a fasl. (,type-factory ',name ',base-type ',enum-list)) ,@(remove nil (mapcar (lambda (key) (unless (keywordp key) `(defconstant ,key ,(foreign-enum-value type key)))) (foreign-enum-keyword-list type))))))) (defmacro defcenum (name-and-options &body enum-list) "Define an foreign enumerated type." (%defcenum-like name-and-options enum-list 'make-foreign-enum)) (defun hash-keys-to-list (ht) (loop for k being the hash-keys in ht collect k)) (defun foreign-enum-keyword-list (enum-type) "Return a list of KEYWORDS defined in ENUM-TYPE." (hash-keys-to-list (keyword-values (ensure-parsed-base-type enum-type)))) ;;; These [four] functions could be good canditates for compiler macros ;;; when the value or keyword is constant. I am not going to bother ;;; until someone has a serious performance need to do so though. --jamesjb (defun %foreign-enum-value (type keyword &key errorp) (check-type keyword enum-key) (or (gethash keyword (keyword-values type)) (when errorp (error "~S is not defined as a keyword for enum type ~S." keyword type)))) (defun foreign-enum-value (type keyword &key (errorp t)) "Convert a KEYWORD into an integer according to the enum TYPE." (let ((type-obj (ensure-parsed-base-type type))) (if (not (typep type-obj 'foreign-enum)) (error "~S is not a foreign enum type." type) (%foreign-enum-value type-obj keyword :errorp errorp)))) (defun %foreign-enum-keyword (type value &key errorp) (check-type value integer) (or (gethash value (value-keywords type)) (when errorp (error "~S is not defined as a value for enum type ~S." value type)))) (defun foreign-enum-keyword (type value &key (errorp t)) "Convert an integer VALUE into a keyword according to the enum TYPE." (let ((type-obj (ensure-parsed-base-type type))) (if (not (typep type-obj 'foreign-enum)) (error "~S is not a foreign enum type." type) (%foreign-enum-keyword type-obj value :errorp errorp)))) (defmethod translate-to-foreign (value (type foreign-enum)) (if (keywordp value) (%foreign-enum-value type value :errorp t) value)) (defmethod translate-into-foreign-memory (value (type foreign-enum) pointer) (setf (mem-aref pointer (unparse-type (actual-type type))) (translate-to-foreign value type))) (defmethod translate-from-foreign (value (type foreign-enum)) (%foreign-enum-keyword type value :errorp t)) (defmethod expand-to-foreign (value (type foreign-enum)) (once-only (value) `(if (keywordp ,value) (%foreign-enum-value ,type ,value :errorp t) ,value))) ;;; There are two expansions necessary for an enum: first, the enum ;;; keyword needs to be translated to an int, and then the int needs ;;; to be made indirect. (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-enum)) (expand-to-foreign-dyn-indirect ; Make the integer indirect (with-unique-names (feint) (call-next-method value feint (list feint) type)) ; TRANSLATABLE-FOREIGN-TYPE method var body (actual-type type))) ;;;# Foreign Bitfields as Lisp keywords ;;; ;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM. ;;; With some changes to DEFCENUM, this could certainly be implemented on ;;; top of it. (defclass foreign-bitfield (foreign-enum) ((field-keywords :initform (error "Must specify FIELD-KEYWORDS.") :initarg :field-keywords :reader field-keywords) (bit-index->keyword :initform (error "Must specify BIT-INDEX->KEYWORD") :initarg :bit-index->keyword :reader bit-index->keyword)) (:documentation "Describes a foreign bitfield type.")) (defun make-foreign-bitfield (type-name base-type values) "Makes a new instance of the foreign-bitfield class." (multiple-value-bind (base-type keyword-values value-keywords field-keywords bit-index->keyword) (parse-foreign-enum-like type-name base-type values t) (make-instance 'foreign-bitfield :name type-name :actual-type (parse-type base-type) :keyword-values keyword-values :value-keywords value-keywords :field-keywords field-keywords :bit-index->keyword bit-index->keyword))) (defmacro defbitfield (name-and-options &body masks) "Define an foreign enumerated type." (%defcenum-like name-and-options masks 'make-foreign-bitfield)) (defun foreign-bitfield-symbol-list (bitfield-type) "Return a list of SYMBOLS defined in BITFIELD-TYPE." (field-keywords (ensure-parsed-base-type bitfield-type))) (defun %foreign-bitfield-value (type symbols) (declare (optimize speed)) (labels ((process-one (symbol) (check-type symbol symbol) (or (gethash symbol (keyword-values type)) (error "~S is not a valid symbol for bitfield type ~S." symbol type)))) (declare (dynamic-extent #'process-one)) (cond ((consp symbols) (reduce #'logior symbols :key #'process-one)) ((null symbols) 0) (t (process-one symbols))))) (defun foreign-bitfield-value (type symbols) "Convert a list of symbols into an integer according to the TYPE bitfield." (let ((type-obj (ensure-parsed-base-type type))) (assert (typep type-obj 'foreign-bitfield) () "~S is not a foreign bitfield type." type) (%foreign-bitfield-value type-obj symbols))) (define-compiler-macro foreign-bitfield-value (&whole form type symbols) "Optimize for when TYPE and SYMBOLS are constant." (declare (notinline foreign-bitfield-value)) (if (and (constantp type) (constantp symbols)) (foreign-bitfield-value (eval type) (eval symbols)) form)) (defun %foreign-bitfield-symbols (type value) (check-type value integer) (check-type type foreign-bitfield) (loop :with bit-index->keyword = (bit-index->keyword type) :for bit-index :from 0 :below (array-dimension bit-index->keyword 0) :for mask = 1 :then (ash mask 1) :for key = (aref bit-index->keyword bit-index) :when (and key (= (logand value mask) mask)) :collect key)) (defun foreign-bitfield-symbols (type value) "Convert an integer VALUE into a list of matching symbols according to the bitfield TYPE." (let ((type-obj (ensure-parsed-base-type type))) (if (not (typep type-obj 'foreign-bitfield)) (error "~S is not a foreign bitfield type." type) (%foreign-bitfield-symbols type-obj value)))) (define-compiler-macro foreign-bitfield-symbols (&whole form type value) "Optimize for when TYPE and SYMBOLS are constant." (declare (notinline foreign-bitfield-symbols)) (if (and (constantp type) (constantp value)) `(quote ,(foreign-bitfield-symbols (eval type) (eval value))) form)) (defmethod translate-to-foreign (value (type foreign-bitfield)) (if (integerp value) value (%foreign-bitfield-value type (ensure-list value)))) (defmethod translate-from-foreign (value (type foreign-bitfield)) (%foreign-bitfield-symbols type value)) (defmethod expand-to-foreign (value (type foreign-bitfield)) (flet ((expander (value type) `(if (integerp ,value) ,value (%foreign-bitfield-value ,type (ensure-list ,value))))) (if (constantp value) (eval (expander value type)) (expander value type)))) (defmethod expand-from-foreign (value (type foreign-bitfield)) (flet ((expander (value type) `(%foreign-bitfield-symbols ,type ,value))) (if (constantp value) (eval (expander value type)) (expander value type)))) cffi_0.19.0/src/cffi-gcl.lisp0000644000175000017500000002407113103031266014435 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp. ;;; ;;; Copyright (C) 2005-2006, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; GCL specific notes: ;;; ;;; On ELF systems, a library can be loaded with the help of this: ;;; http://www.copyleft.de/lisp/gcl-elf-loader.html ;;; ;;; Another way is to link the library when creating a new image: ;;; (compiler::link nil "new_image" "" "-lfoo") ;;; ;;; As GCL's FFI is not dynamic, CFFI declarations will only work ;;; after compiled and loaded. ;;; *** this port is broken *** ;;; gcl doesn't compile the rest of CFFI anyway.. ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:alexandria) (:export #:canonicalize-symbol-name-case #:pointerp #:%foreign-alloc #:foreign-free #:with-foreign-ptr #:null-ptr #:null-ptr-p #:inc-ptr #:%mem-ref #:%mem-set #:%foreign-funcall #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library ;#:make-shareable-byte-vector ;#:with-pointer-to-vector-data #:foreign-var-ptr #:make-callback)) (in-package #:cffi-sys) ;;;# Mis-*features* (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :cffi/no-foreign-funcall *features*)) ;;; Symbol case. (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common ;;; usage when the memory has dynamic extent. (defentry %foreign-alloc (int) (int "malloc")) ;(defun foreign-alloc (size) ; "Allocate SIZE bytes on the heap and return a pointer." ; (%foreign-alloc size)) (defentry foreign-free (int) (void "free")) ;(defun foreign-free (ptr) ; "Free a PTR allocated by FOREIGN-ALLOC." ; (%free ptr)) (defmacro with-foreign-ptr ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let* ((,size-var ,size) (,var (foreign-alloc ,size-var))) (unwind-protect (progn ,@body) (foreign-free ,var)))) ;;;# Misc. Pointer Operations (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (integerp ptr)) (defun null-ptr () "Construct and return a null pointer." 0) (defun null-ptr-p (ptr) "Return true if PTR is a null pointer." (= ptr 0)) (defun inc-ptr (ptr offset) "Return a pointer OFFSET bytes past PTR." (+ ptr offset)) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. ;(defun make-shareable-byte-vector (size) ; "Create a Lisp vector of SIZE bytes that can passed to ;WITH-POINTER-TO-VECTOR-DATA." ; (make-array size :element-type '(unsigned-byte 8))) ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) ; "Bind PTR-VAR to a foreign pointer to the data in VECTOR." ; `(ccl:with-pointer-to-ivector (,ptr-var ,vector) ; ,@body)) ;;;# Dereferencing (defmacro define-mem-ref/set (type gcl-type &optional c-name) (unless c-name (setq c-name (substitute #\_ #\Space type))) (let ((ref-fn (concatenate 'string "ref_" c-name)) (set-fn (concatenate 'string "set_" c-name))) `(progn ;; ref (defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type) 0 "return *ptr;") (defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn))) (int) (,gcl-type ,ref-fn)) ;; set (defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type) 0 "*ptr = value;") (defentry ,(intern (string-upcase (substitute #\- #\_ set-fn))) (int ,gcl-type) (void ,set-fn))))) (define-mem-ref/set "char" char) (define-mem-ref/set "unsigned char" char) (define-mem-ref/set "short" int) (define-mem-ref/set "unsigned short" int) (define-mem-ref/set "int" int) (define-mem-ref/set "unsigned int" int) (define-mem-ref/set "long" int) (define-mem-ref/set "unsigned long" int) (define-mem-ref/set "float" float) (define-mem-ref/set "double" double) (define-mem-ref/set "void *" int "ptr") (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of TYPE at OFFSET bytes from PTR." (unless (zerop offset) (incf ptr offset)) (ecase type (:char (ref-char ptr)) (:unsigned-char (ref-unsigned-char ptr)) (:short (ref-short ptr)) (:unsigned-short (ref-unsigned-short ptr)) (:int (ref-int ptr)) (:unsigned-int (ref-unsigned-int ptr)) (:long (ref-long ptr)) (:unsigned-long (ref-unsigned-long ptr)) (:float (ref-float ptr)) (:double (ref-double ptr)) (:pointer (ref-ptr ptr)))) (defun %mem-set (value ptr type &optional (offset 0)) (unless (zerop offset) (incf ptr offset)) (ecase type (:char (set-char ptr value)) (:unsigned-char (set-unsigned-char ptr value)) (:short (set-short ptr value)) (:unsigned-short (set-unsigned-short ptr value)) (:int (set-int ptr value)) (:unsigned-int (set-unsigned-int ptr value)) (:long (set-long ptr value)) (:unsigned-long (set-unsigned-long ptr value)) (:float (set-float ptr value)) (:double (set-double ptr value)) (:pointer (set-ptr ptr value))) value) ;;;# Calling Foreign Functions ;; TODO: figure out if these type conversions make any sense... (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to a GCL type." (ecase type-keyword (:char 'char) (:unsigned-char 'char) (:short 'int) (:unsigned-short 'int) (:int 'int) (:unsigned-int 'int) (:long 'int) (:unsigned-long 'int) (:float 'float) (:double 'double) (:pointer 'int) (:void 'void))) (defparameter +cffi-types+ '(:char :unsigned-char :short :unsigned-short :int :unsigned-int :long :unsigned-long :float :double :pointer)) (defcfun "int size_of(int type)" 0 "switch (type) { case 0: return sizeof(char); case 1: return sizeof(unsigned char); case 2: return sizeof(short); case 3: return sizeof(unsigned short); case 4: return sizeof(int); case 5: return sizeof(unsigned int); case 6: return sizeof(long); case 7: return sizeof(unsigned long); case 8: return sizeof(float); case 9: return sizeof(double); case 10: return sizeof(void *); default: return -1; }") (defentry size-of (int) (int "size_of")) ;; TODO: all this is doable inside the defcfun; figure that out.. (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (size-of (position type-keyword +cffi-types+))) (defcfun "int align_of(int type)" 0 "switch (type) { case 0: return __alignof__(char); case 1: return __alignof__(unsigned char); case 2: return __alignof__(short); case 3: return __alignof__(unsigned short); case 4: return __alignof__(int); case 5: return __alignof__(unsigned int); case 6: return __alignof__(long); case 7: return __alignof__(unsigned long); case 8: return __alignof__(float); case 9: return __alignof__(double); case 10: return __alignof__(void *); default: return -1; }") (defentry align-of (int) (int "align_of")) ;; TODO: like %foreign-type-size (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (align-of (position type-keyword +cffi-types+))) #+ignore (defun convert-external-name (name) "Add an underscore to NAME if necessary for the ABI." #+darwinppc-target (concatenate 'string "_" name) #-darwinppc-target name) (defmacro %foreign-funcall (function-name &rest args) "Perform a foreign function all, document it more later." `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args)) (defun defcfun-helper-forms (name rettype args types) "Return 2 values for DEFCFUN. A prelude form and a caller form." (let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name)))) (values `(defentry ,ff-name ,(mapcar #'convert-foreign-type types) (,(convert-foreign-type rettype) ,name)) `(,ff-name ,@args)))) ;;;# Callbacks ;;; XXX unimplemented (defmacro make-callback (name rettype arg-names arg-types body-form) 0) ;;;# Loading Foreign Libraries (defun %load-foreign-library (name) "_Won't_ load the foreign library NAME." (declare (ignore name))) ;;;# Foreign Globals ;;; XXX unimplemented (defmacro foreign-var-ptr (name) "Return a pointer pointing to the foreign symbol NAME." 0) cffi_0.19.0/src/utils.lisp0000644000175000017500000000751213103031266014124 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; utils.lisp --- Various utilities. ;;; ;;; Copyright (C) 2005-2008, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) (defmacro discard-docstring (body-var &optional force) "Discards the first element of the list in body-var if it's a string and the only element (or if FORCE is T)." `(when (and (stringp (car ,body-var)) (or ,force (cdr ,body-var))) (pop ,body-var))) (defun single-bit-p (integer) "Answer whether INTEGER, which must be an integer, is a single set twos-complement bit." (if (<= integer 0) nil ; infinite set bits for negatives (loop until (logbitp 0 integer) do (setf integer (ash integer -1)) finally (return (zerop (ash integer -1)))))) ;;; This function is here because it needs to be defined early. It's ;;; used by DEFINE-PARSE-METHOD and DEFCTYPE to warn users when ;;; they're defining types whose names belongs to the KEYWORD or CL ;;; packages. CFFI itself gets to use keywords without a warning. (defun warn-if-kw-or-belongs-to-cl (name) (let ((package (symbol-package name))) (when (and (not (eq *package* (find-package '#:cffi))) (member package '(#:common-lisp #:keyword) :key #'find-package)) (warn "Defining a foreign type named ~S. This symbol belongs to the ~A ~ package and that may interfere with other code using CFFI." name (package-name package))))) (define-condition obsolete-argument-warning (style-warning) ((old-arg :initarg :old-arg :reader old-arg) (new-arg :initarg :new-arg :reader new-arg)) (:report (lambda (c s) (format s "Keyword ~S is obsolete, please use ~S" (old-arg c) (new-arg c))))) (defun warn-obsolete-argument (old-arg new-arg) (warn 'obsolete-argument-warning :old-arg old-arg :new-arg new-arg)) (defun split-if (test seq &optional (dir :before)) (remove-if #'(lambda (x) (equal x (subseq seq 0 0))) (loop for start fixnum = 0 then (if (eq dir :before) stop (the fixnum (1+ (the fixnum stop)))) while (< start (length seq)) for stop = (position-if test seq :start (if (eq dir :elide) start (the fixnum (1+ start)))) collect (subseq seq start (if (and stop (eq dir :after)) (the fixnum (1+ (the fixnum stop))) stop)) while stop))) cffi_0.19.0/src/cffi-abcl.lisp0000644000175000017500000006267613103031266014606 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-abcl.lisp --- CFFI-SYS implementation for ABCL/JNA. ;;; ;;; Copyright (C) 2009, Luis Oliveira ;;; Copyright (C) 2012, Mark Evenson ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; This implementation requires the Java Native Access (JNA) library. ;;; ;;; ;;; JNA may be automatically loaded into the current JVM process from ;;; abcl-1.1.0-dev via the contrib mechanism. (eval-when (:compile-toplevel :load-toplevel :execute) (require :abcl-contrib) (require :jna) (require :jss)) ;;; This is a preliminary version that will have to be cleaned up, ;;; optimized, etc. Nevertheless, it passes all of the relevant CFFI ;;; tests except MAKE-POINTER.HIGH. Shareable Vectors are not ;;; implemented yet. ;;;# Administrivia (defpackage #:cffi-sys (:use #:cl #:java) (:import-from #:alexandria #:hash-table-values #:length= #:format-symbol) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set ;; #:make-shareable-byte-vector ;; #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback #:with-pointer-to-vector-data #:make-shareable-byte-vector)) (in-package #:cffi-sys) ;;;# Loading and Closing Foreign Libraries (defparameter *loaded-libraries* (make-hash-table)) (defun %load-foreign-library (name path) "Load a foreign library, signals a simple error on failure." (flet ((load-and-register (name path) (let ((lib (jstatic "getInstance" "com.sun.jna.NativeLibrary" path))) (setf (gethash name *loaded-libraries*) lib) lib)) (foreign-library-type-p (type) (find type '("so" "dll" "dylib") :test #'string=)) (java-error (e) (error (jcall (jmethod "java.lang.Exception" "getMessage") (java-exception-cause e))))) (handler-case (load-and-register name path) (java-exception (e) ;; From JNA http://jna.java.net/javadoc/com/sun/jna/NativeLibrary.html ;; ``[The name] can be short form (e.g. "c"), an explicit ;; version (e.g. "libc.so.6"), or the full path to the library ;; (e.g. "/lib/libc.so.6")'' ;; ;; Try to deal with the occurance "libXXX" and "libXXX.so" as ;; "libXXX.so.6" and "XXX" should have succesfully loaded. (let ((p (pathname path))) (if (and (not (pathname-directory p)) (= (search "lib" (pathname-name p)) 0)) (let ((short-name (if (foreign-library-type-p (pathname-type p)) (subseq (pathname-name p) 3) (pathname-name p)))) (handler-case (load-and-register name short-name) (java-exception (e) (java-error e)))) (java-error e))))))) ;;; FIXME. Should remove libraries from the hash table. (defun %close-foreign-library (handle) "Closes a foreign library." #+#:ignore (setf *loaded-libraries* (remove handle *loaded-libraries*)) (jcall-raw (jmethod "com.sun.jna.NativeLibrary" "dispose") handle)) ;;; ;;; FIXME! We should probably define a private-jfield-accessor that does the hard work once! (let ((get-declared-fields-jmethod (jmethod "java.lang.Class" "getDeclaredFields"))) (defun private-jfield (class-name field-name instance) (let ((field (find field-name (jcall get-declared-fields-jmethod (jclass class-name)) :key #'jfield-name :test #'string=))) (jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean") field +true+) (jcall (jmethod "java.lang.reflect.Field" "get" "java.lang.Object") field instance)))) ;;; XXX: doesn't match jmethod-arguments. (let ((get-declared-methods-jmethod (jmethod "java.lang.Class" "getDeclaredMethods"))) (defun private-jmethod (class-name method-name) (let ((method (find method-name (jcall get-declared-methods-jmethod (jclass class-name)) :key #'jmethod-name :test #'string=))) (jcall (jmethod "java.lang.reflect.Method" "setAccessible" "boolean") method +true+) method))) (let ((get-declared-constructors-jmethod (jmethod "java.lang.Class" "getDeclaredConstructors")) (set-accessible-jmethod (jmethod "java.lang.reflect.Constructor" "setAccessible" "boolean"))) (defun private-jconstructor (class-name &rest params) (let* ((param-classes (mapcar #'jclass params)) (cons (find-if (lambda (x &aux (cons-params (jconstructor-params x))) (and (length= param-classes cons-params) (loop for param in param-classes and param-x across cons-params always (string= (jclass-name param) (jclass-name param-x))))) (jcall get-declared-constructors-jmethod (jclass class-name))))) (jcall set-accessible-jmethod cons +true+) cons))) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (string-upcase name)) ;;;# Pointers (deftype foreign-pointer () '(satisfies pointerp)) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (let ((jclass (jclass-of ptr))) (when jclass (jclass-superclass-p (jclass "com.sun.jna.Pointer") jclass)))) (let ((jconstructor (private-jconstructor "com.sun.jna.Pointer" "long"))) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (jnew jconstructor address))) (defun make-private-jfield-accessor (class-name field-name) (let ((field (find field-name (jcall (jmethod "java.lang.Class" "getDeclaredFields") (jclass class-name)) :key #'jfield-name :test #'string=))) (jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean") field +true+) (let ((get-jmethod (jmethod "java.lang.reflect.Field" "get" "java.lang.Object"))) (lambda (instance) (jcall get-jmethod field instance))))) (let ((accessor (make-private-jfield-accessor "com.sun.jna.Pointer" "peer"))) (defun %pointer-address (pointer) (funcall accessor pointer))) (defun pointer-address (pointer) "Return the address pointed to by PTR." (let ((peer (%pointer-address pointer))) (if (< peer 0) (+ #.(ash 1 64) peer) peer))) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (= (%pointer-address ptr1) (%pointer-address ptr2))) (defun null-pointer () "Construct and return a null pointer." (make-pointer 0)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (zerop (%pointer-address ptr))) (defun inc-pointer (ptr offset) "Return a fresh pointer pointing OFFSET bytes past PTR." (make-pointer (+ (%pointer-address ptr) offset))) ;;;# Allocation (let ((malloc-jmethod (private-jmethod "com.sun.jna.Memory" "malloc"))) (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (make-pointer (jstatic-raw malloc-jmethod nil size)))) (let ((free-jmethod (private-jmethod "com.sun.jna.Memory" "free"))) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." (jstatic-raw free-jmethod nil (%pointer-address ptr)) nil)) ;;; TODO: stack allocation. (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect (progn ,@body) (foreign-free ,var)))) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun jna-setter (type) (ecase type ((:char :unsigned-char) "setByte") (:double "setDouble") (:float "setFloat") ((:int :unsigned-int) "setInt") ((:long :unsigned-long) "setNativeLong") ((:long-long :unsigned-long-long) "setLong") (:pointer "setPointer") ((:short :unsigned-short) "setShort"))) (defun jna-setter-arg-type (type) (ecase type ((:char :unsigned-char) "byte") (:double "double") (:float "float") ((:int :unsigned-int) "int") ((:long :unsigned-long) "com.sun.jna.NativeLong") ((:long-long :unsigned-long-long) "long") (:pointer "com.sun.jna.Pointer") ((:short :unsigned-short) "short"))) (defun jna-getter (type) (ecase type ((:char :unsigned-char) "getByte") (:double "getDouble") (:float "getFloat") ((:int :unsigned-int) "getInt") ((:long :unsigned-long) "getNativeLong") ((:long-long :unsigned-long-long) "getLong") (:pointer "getPointer") ((:short :unsigned-short) "getShort"))) (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) (let ((method (jmethod "com.sun.jna.Pointer" (jna-setter :char) "long" (jna-setter-arg-type :char)))) (defun copy-to-foreign-vector (vector foreign-pointer) (loop for i below (length vector) do (jcall-raw method foreign-pointer i (aref vector i))))) ;; hand-roll the jna-getter method instead of calling %mem-ref every time through (let ((method (jmethod "com.sun.jna.Pointer" (jna-getter :char) "long"))) (defun copy-from-foreign-vector (vector foreign-pointer) (loop for i below (length vector) do (setf (aref vector i) (java:jobject-lisp-value (jcall-raw method foreign-pointer i)))))) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." (let ((vector-sym (gensym "VECTOR"))) `(let ((,vector-sym ,vector)) (with-foreign-pointer (,ptr-var (length ,vector-sym)) (copy-to-foreign-vector ,vector-sym ,ptr-var) (unwind-protect (progn ,@body) (copy-from-foreign-vector ,vector-sym ,ptr-var)))))) ;;;# Dereferencing (defun foreign-type-to-java-class (type) (jclass (ecase type ((:int :unsigned-int) "java.lang.Integer") ((:long :unsigned-long) "com.sun.jna.NativeLong") ((:long-long :unsigned-long-long) "java.lang.Long") (:pointer "com.sun.jna.Pointer") ;; void * is pointer? (:float "java.lang.Float") (:double "java.lang.Double") ((:char :unsigned-char) "java.lang.Byte") ((:short :unsigned-short) "java.lang.Short")))) (defun %foreign-type-size (type) "Return the size in bytes of a foreign type." (jstatic "getNativeSize" "com.sun.jna.Native" (foreign-type-to-java-class type))) ;;; FIXME. (defun %foreign-type-alignment (type) "Return the alignment in bytes of a foreign type." (%foreign-type-size type)) (defun unsigned-type-p (type) (case type ((:unsigned-char :unsigned-int :unsigned-short :unsigned-long :unsigned-long-long) t) (t nil))) (defun lispify-value (value type) (when (and (eq type :pointer) (or (null (java:jobject-lisp-value value)) (eq +null+ (java:jobject-lisp-value value)))) (return-from lispify-value (null-pointer))) (when (or (eq type :long) (eq type :unsigned-long)) (setq value (jcall-raw (jmethod "com.sun.jna.NativeLong" "longValue") (java:jobject-lisp-value value)))) (let ((bit-size (* 8 (%foreign-type-size type)))) (let ((lisp-value (java:jobject-lisp-value value))) (if (and (unsigned-type-p type) (logbitp (1- bit-size) lisp-value)) (lognot (logxor lisp-value (1- (expt 2 bit-size)))) lisp-value)))) (defun %mem-ref (ptr type &optional (offset 0)) (lispify-value (jcall-raw (jmethod "com.sun.jna.Pointer" (jna-getter type) "long") ptr offset) type)) (defun %mem-set (value ptr type &optional (offset 0)) (let* ((bit-size (* 8 (%foreign-type-size type))) (val (if (and (unsigned-type-p type) (logbitp (1- bit-size) value)) (lognot (logxor value (1- (expt 2 bit-size)))) value))) (jcall-raw (jmethod "com.sun.jna.Pointer" (jna-setter type) "long" (jna-setter-arg-type type)) ptr offset (if (or (eq type :long) (eq type :unsigned-long)) (jnew (jconstructor "com.sun.jna.NativeLong" "long") val) val))) value) ;;;# Foreign Globals (let ((get-symbol-address-jmethod (private-jmethod "com.sun.jna.NativeLibrary" "getSymbolAddress"))) (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (flet ((find-it (library) (ignore-errors (make-pointer (jcall-raw get-symbol-address-jmethod library name))))) (if (eq library :default) (or (find-it (jstatic "getProcess" "com.sun.jna.NativeLibrary")) ;; The above should find it, but I'm not exactly sure, so ;; let's still do it manually just in case. (loop for lib being the hash-values of *loaded-libraries* thereis (find-it lib))) (find-it library))))) ;;;# Calling Foreign Functions (defun find-foreign-function (name library) (flet ((find-it (library) (ignore-errors (jcall-raw (jmethod "com.sun.jna.NativeLibrary" "getFunction" "java.lang.String") library name)))) (if (eq library :default) (or (find-it (jstatic "getProcess" "com.sun.jna.NativeLibrary")) ;; The above should find it, but I'm not exactly sure, so ;; let's still do it manually just in case. (loop for lib being the hash-values of *loaded-libraries* thereis (find-it lib))) (find-it (gethash library *loaded-libraries*))))) (defun convert-calling-convention (convention) (ecase convention (:stdcall "ALT_CONVENTION") (:cdecl "C_CONVENTION"))) (defparameter *jna-string-encoding* "UTF-8" "Encoding for conversion between Java and native strings that occurs within JNA. Used with jna-4.0.0 or later.") ;;; c.f. (defvar *jna-4.0.0-or-later-p* (ignore-errors (private-jconstructor "com.sun.jna.Function" "com.sun.jna.Pointer" "int" "java.lang.String"))) (let ((jconstructor (if *jna-4.0.0-or-later-p* (private-jconstructor "com.sun.jna.Function" "com.sun.jna.Pointer" "int" "java.lang.String") (private-jconstructor "com.sun.jna.Function" "com.sun.jna.Pointer" "int")))) (defun make-function-pointer (pointer convention) (apply #'jnew jconstructor pointer (jfield "com.sun.jna.Function" (convert-calling-convention convention)) (when *jna-4.0.0-or-later-p* (list *jna-string-encoding*))))) (defun lisp-value-to-java (value foreign-type) (case foreign-type (:pointer value) (:void nil) (t (jnew (ecase foreign-type ((:int :unsigned-int) (jconstructor "java.lang.Integer" "int")) ((:long-long :unsigned-long-long) (jconstructor "java.lang.Long" "long")) ((:long :unsigned-long) (jconstructor "com.sun.jna.NativeLong" "long")) ((:short :unsigned-short) (jconstructor "java.lang.Short" "short")) ((:char :unsigned-char) (jconstructor "java.lang.Byte" "byte")) (:float (jconstructor "java.lang.Float" "float")) (:double (jconstructor "java.lang.Double" "double"))) value)))) (defun %%foreign-funcall (function args arg-types return-type) (let ((jargs (jnew-array "java.lang.Object" (length args)))) (loop for arg in args and type in arg-types and i from 0 do (setf (jarray-ref jargs i) (lisp-value-to-java arg type))) (if (eq return-type :void) (progn (jcall-raw (jmethod "com.sun.jna.Function" "invoke" "[Ljava.lang.Object;") function jargs) (values)) (lispify-value (jcall-raw (jmethod "com.sun.jna.Function" "invoke" "java.lang.Class" "[Ljava.lang.Object;") function (foreign-type-to-java-class return-type) jargs) return-type)))) (defun foreign-funcall-type-and-args (args) (let ((return-type :void)) (loop for (type arg) on args by #'cddr if arg collect type into types and collect arg into fargs else do (setf return-type type) finally (return (values types fargs return-type))))) (defmacro %foreign-funcall (name args &key library convention) (declare (ignore convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(%%foreign-funcall (find-foreign-function ',name ',library) (list ,@fargs) ',types ',rettype))) (defmacro %foreign-funcall-pointer (ptr args &key convention) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(%%foreign-funcall (make-function-pointer ,ptr ',convention) (list ,@fargs) ',types ',rettype))) ;;;# Callbacks (defun foreign-to-callback-type (type) (ecase type ((:int :unsigned-int) :int) ((:long :unsigned-long) (jvm::make-jvm-class-name "com.sun.jna.NativeLong")) ((:long-long :unsigned-long-long) (jvm::make-jvm-class-name "java.lang.Long")) (:pointer (jvm::make-jvm-class-name "com.sun.jna.Pointer")) (:float :float) (:double :double) ((:char :unsigned-char) :byte) ((:short :unsigned-short) :short) (:wchar_t :int) (:void :void))) (defvar *callbacks* (make-hash-table)) (defmacro convert-args-to-lisp-values (arg-names arg-types &body body) (let ((gensym-args (loop for name in arg-names collect (format-symbol t '#:callback-arg-~a- name)))) `(lambda (,@gensym-args) (let ,(loop for arg in arg-names for type in arg-types for gensym-arg in gensym-args collecting `(,arg (if (typep ,gensym-arg 'java:java-object) (lispify-value ,gensym-arg ,type) ,gensym-arg))) ,@body)))) (defmacro %defcallback (name return-type arg-names arg-types body &key convention) (declare (ignore convention)) ;; I'm always up for ignoring convention, but this is probably wrong. `(setf (gethash ',name *callbacks*) (jinterface-implementation (ensure-callback-interface ',return-type ',arg-types) "callback" (convert-args-to-lisp-values ,arg-names ,arg-types (lisp-value-to-java ,body ',return-type))))) ;; (lambda (,@arg-names) ,body)))) (jvm::define-class-name +callback-object+ "com.sun.jna.Callback") (defconstant +dynamic-callback-package+ "org/armedbear/jna/dynamic/callbacks" "The slash-delimited Java package in which we create classes dynamically to specify callback interfaces.") (defun ensure-callback-interface (returns args) "Ensure that the jvm interface for the callback exists in the current JVM. Returns the fully dot qualified name of the interface." (let* ((jvm-returns (foreign-to-callback-type returns)) (jvm-args (mapcar #'foreign-to-callback-type args)) (interface-name (qualified-callback-interface-classname jvm-returns jvm-args))) (handler-case (jss:find-java-class interface-name) (java-exception (e) (when (jinstance-of-p (java:java-exception-cause e) "java.lang.ClassNotFoundException") (let ((interface-class-bytes (%define-jna-callback-interface jvm-returns jvm-args)) (simple-interface-name (callback-interface-classname jvm-returns jvm-args))) (load-class interface-name interface-class-bytes))))) interface-name)) (defun qualified-callback-interface-classname (returns args) (format nil "~A.~A" (substitute #\. #\/ +dynamic-callback-package+) (callback-interface-classname returns args))) (defun callback-interface-classname (returns args) (flet ((stringify (thing) (typecase thing (jvm::jvm-class-name (substitute #\_ #\/ (jvm::class-name-internal thing))) (t (string thing))))) (format nil "~A__~{~A~^__~}" (stringify returns) (mapcar #'stringify args)))) (defun %define-jna-callback-interface (returns args) "Returns the Java byte[] array of a class representing a Java interface descending form +CALLBACK-OBJECT+ which contains the single function 'callback' which takes ARGS returning RETURNS. The fully qualified dotted name of the generated class is returned as the second value." (let ((name (callback-interface-classname returns args))) (values (define-java-interface name +dynamic-callback-package+ `(("callback" ,returns ,args)) `(,+callback-object+)) (qualified-callback-interface-classname returns args)))) (defun define-java-interface (name package methods &optional (superinterfaces nil)) "Returns the bytes of the Java class interface called NAME in PACKAGE with METHODS. METHODS is a list of (NAME RETURN-TYPE (ARG-TYPES)) entries. NAME is a string. The values of RETURN-TYPE and the list of ARG-TYPES for the defined method follow the are either references to Java objects as created by JVM::MAKE-JVM-CLASS-NAME, or keywords representing Java primtive types as contained in JVM::MAP-PRIMITIVE-TYPE. SUPERINTERFACES optionally contains a list of interfaces that this interface extends specified as fully qualifed dotted Java names." (let* ((class-name-string (format nil "~A/~A" package name)) (class-name (jvm::make-jvm-class-name class-name-string)) (class (jvm::make-class-interface-file class-name))) (dolist (superinterface superinterfaces) (jvm::class-add-superinterface class (if (typep superinterface 'jvm::jvm-class-name) superinterface (jvm::make-jvm-class-name superinterface)))) (dolist (method methods) (let ((name (first method)) (returns (second method)) (args (third method))) (jvm::class-add-method class (jvm::make-jvm-method name returns args :flags '(:public :abstract))))) (jvm::finalize-class-file class) (let ((s (sys::%make-byte-array-output-stream))) (jvm::write-class-file class s) (sys::%get-output-stream-bytes s)))) (defun load-class (name bytes) "Load the byte[] array BYTES as a Java class called NAME." (#"loadClassFromByteArray" java::*classloader* name bytes)) ;;; Test function: unused in CFFI (defun write-class (class-bytes pathname) "Write the Java byte[] array CLASS-BYTES to PATHNAME." (with-open-file (stream pathname :direction :output :element-type '(signed-byte 8)) (dotimes (i (jarray-length class-bytes)) (write-byte (jarray-ref class-bytes i) stream)))) (defun %callback (name) (or (#"getFunctionPointer" 'com.sun.jna.CallbackReference (gethash name *callbacks*)) (error "Undefined callback: ~S" name))) (defun native-namestring (pathname) (namestring pathname)) cffi_0.19.0/src/cffi-clasp.lisp0000644000175000017500000001426213103031266014773 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-clasp.lisp --- CFFI-SYS implementation for Clasp. ;;; ;;; Copyright (C) 2017 Frank Goenninger ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:alexandria) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%mem-ref #:%mem-set #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%defcallback #:%callback #:%foreign-symbol-pointer)) (in-package #:cffi-sys) ;;;# Mis-features (pushnew 'flat-namespace cl:*features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Allocation (defun %foreign-alloc (size) "Allocate SIZE bytes of foreign-addressable memory." (clasp-ffi:%foreign-alloc size)) (defun foreign-free (ptr) "Free a pointer PTR allocated by FOREIGN-ALLOC." (clasp-ffi:%foreign-free ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect (progn ,@body) (foreign-free ,var)))) ;;;# Misc. Pointer Operations (deftype foreign-pointer () 'clasp-ffi:foreign-data) (defun null-pointer-p (ptr) "Test if PTR is a null pointer." (clasp-ffi:%null-pointer-p ptr)) (defun null-pointer () "Construct and return a null pointer." (clasp-ffi:%make-nullpointer)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (clasp-ffi:%make-pointer address)) (defun inc-pointer (ptr offset) "Return a pointer OFFSET bytes past PTR." (clasp-ffi:%inc-pointer ptr offset)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (clasp-ffi:%foreign-data-address ptr)) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (typep ptr 'clasp-ffi:foreign-data)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (check-type ptr1 clasp-ffi:foreign-data) (check-type ptr2 clasp-ffi:foreign-data) (eql (pointer-address ptr1) (pointer-address ptr2))) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes that can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) ;; frgo, 2016-07-02: TODO: Implemenent! ;; (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) ;; "Bind PTR-VAR to a foreign pointer to the data in VECTOR." ;; `(let ((,ptr-var (si:make-foreign-data-from-array ,vector))) ;; ,@body)) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (clasp-ffi:%foreign-type-size type-keyword)) (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (clasp-ffi:%foreign-type-alignment type-keyword)) ;;;# Dereferencing (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of TYPE at OFFSET bytes from PTR." (clasp-ffi:%mem-ref ptr type offset)) (defun %mem-set (value ptr type &optional (offset 0)) "Set an object of TYPE at OFFSET bytes from PTR." (clasp-ffi:%mem-set ptr type value offset)) (defmacro %foreign-funcall (name args &key library convention) "Call a foreign function." (declare (ignore library convention)) `(clasp-ffi:%foreign-funcall ,name ,@args)) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Funcall a pointer to a foreign function." (declare (ignore convention)) `(clasp-ffi:%foreign-funcall-pointer ,ptr ,@args)) ;;;# Foreign Libraries (defun %load-foreign-library (name path) "Load a foreign library." (clasp-ffi:%load-foreign-library name path)) (defun %close-foreign-library (handle) "Close a foreign library." (clasp-ffi:%close-foreign-library handle)) (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (clasp-ffi:%foreign-symbol-pointer name library)) (defun native-namestring (pathname) (namestring pathname)) ;;;# Callbacks (defmacro %defcallback (name rettype arg-names arg-types body &key convention) `(clasp-ffi:%defcallback (,name ,@(when convention `(:convention ,convention))) ,rettype ,arg-names ,arg-types ,body)) (defun %callback (name) (clasp-ffi:%get-callback name)) cffi_0.19.0/src/strings.lisp0000644000175000017500000003173213103031266014456 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; strings.lisp --- Operations on foreign strings. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;;;# Foreign String Conversion ;;; ;;; Functions for converting NULL-terminated C-strings to Lisp strings ;;; and vice versa. The string functions accept an ENCODING keyword ;;; argument which is used to specify the encoding to use when ;;; converting to/from foreign strings. (defvar *default-foreign-encoding* :utf-8 "Default foreign encoding.") ;;; TODO: refactor, sigh. Also, this should probably be a function. (defmacro bget (ptr off &optional (bytes 1) (endianness :ne)) (let ((big-endian (member endianness '(:be #+big-endian :ne #+little-endian :re)))) (once-only (ptr off) (ecase bytes (1 `(mem-ref ,ptr :uint8 ,off)) (2 (if big-endian #+big-endian `(mem-ref ,ptr :uint16 ,off) #-big-endian `(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 8) (mem-ref ,ptr :uint8 (1+ ,off))) #+little-endian `(mem-ref ,ptr :uint16 ,off) #-little-endian `(dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8) (mem-ref ,ptr :uint8 ,off)))) (4 (if big-endian #+big-endian `(mem-ref ,ptr :uint32 ,off) #-big-endian `(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 24) (dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 16) (dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 8) (mem-ref ,ptr :uint8 (+ ,off 3))))) #+little-endian `(mem-ref ,ptr :uint32 ,off) #-little-endian `(dpb (mem-ref ,ptr :uint8 (+ ,off 3)) (byte 8 24) (dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 16) (dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8) (mem-ref ,ptr :uint8 ,off)))))))))) (defmacro bset (val ptr off &optional (bytes 1) (endianness :ne)) (let ((big-endian (member endianness '(:be #+big-endian :ne #+little-endian :re)))) (ecase bytes (1 `(setf (mem-ref ,ptr :uint8 ,off) ,val)) (2 (if big-endian #+big-endian `(setf (mem-ref ,ptr :uint16 ,off) ,val) #-big-endian `(setf (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 0) ,val) (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 8) ,val)) #+little-endian `(setf (mem-ref ,ptr :uint16 ,off) ,val) #-little-endian `(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) ,val) (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) ,val)))) (4 (if big-endian #+big-endian `(setf (mem-ref ,ptr :uint32 ,off) ,val) #-big-endian `(setf (mem-ref ,ptr :uint8 (+ 3 ,off)) (ldb (byte 8 0) ,val) (mem-ref ,ptr :uint8 (+ 2 ,off)) (ldb (byte 8 8) ,val) (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 16) ,val) (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 24) ,val)) #+little-endian `(setf (mem-ref ,ptr :uint32 ,off) ,val) #-little-endian `(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) ,val) (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) ,val) (mem-ref ,ptr :uint8 (+ ,off 2)) (ldb (byte 8 16) ,val) (mem-ref ,ptr :uint8 (+ ,off 3)) (ldb (byte 8 24) ,val))))))) ;;; TODO: tackle optimization notes. (defparameter *foreign-string-mappings* (instantiate-concrete-mappings ;; :optimize ((speed 3) (debug 0) (compilation-speed 0) (safety 0)) :octet-seq-getter bget :octet-seq-setter bset :octet-seq-type foreign-pointer :code-point-seq-getter babel::string-get :code-point-seq-setter babel::string-set :code-point-seq-type babel:simple-unicode-string)) (defun null-terminator-len (encoding) (length (enc-nul-encoding (get-character-encoding encoding)))) (defun lisp-string-to-foreign (string buffer bufsize &key (start 0) end offset (encoding *default-foreign-encoding*)) (check-type string string) (when offset (setq buffer (inc-pointer buffer offset))) (with-checked-simple-vector ((string (coerce string 'babel:unicode-string)) (start start) (end end)) (declare (type simple-string string)) (let ((mapping (lookup-mapping *foreign-string-mappings* encoding)) (nul-len (null-terminator-len encoding))) (assert (plusp bufsize)) (multiple-value-bind (size end) (funcall (octet-counter mapping) string start end (- bufsize nul-len)) (funcall (encoder mapping) string start end buffer 0) (dotimes (i nul-len) (setf (mem-ref buffer :char (+ size i)) 0)))) buffer)) ;;; Expands into a loop that calculates the length of the foreign ;;; string at PTR plus OFFSET, using ACCESSOR and looking for a null ;;; terminator of LENGTH bytes. (defmacro %foreign-string-length (ptr offset type length) (once-only (ptr offset) `(do ((i 0 (+ i ,length))) ((zerop (mem-ref ,ptr ,type (+ ,offset i))) i) (declare (fixnum i))))) ;;; Return the length in octets of the null terminated foreign string ;;; at POINTER plus OFFSET octets, assumed to be encoded in ENCODING, ;;; a CFFI encoding. This should be smart enough to look for 8-bit vs ;;; 16-bit null terminators, as appropriate for the encoding. (defun foreign-string-length (pointer &key (encoding *default-foreign-encoding*) (offset 0)) (ecase (null-terminator-len encoding) (1 (%foreign-string-length pointer offset :uint8 1)) (2 (%foreign-string-length pointer offset :uint16 2)) (4 (%foreign-string-length pointer offset :uint32 4)))) (defun foreign-string-to-lisp (pointer &key (offset 0) count (max-chars (1- array-total-size-limit)) (encoding *default-foreign-encoding*)) "Copy at most COUNT bytes from POINTER plus OFFSET encoded in ENCODING into a Lisp string and return it. If POINTER is a null pointer, NIL is returned." (unless (null-pointer-p pointer) (let ((count (or count (foreign-string-length pointer :encoding encoding :offset offset))) (mapping (lookup-mapping *foreign-string-mappings* encoding))) (assert (plusp max-chars)) (multiple-value-bind (size new-end) (funcall (code-point-counter mapping) pointer offset (+ offset count) max-chars) (let ((string (make-string size :element-type 'babel:unicode-char))) (funcall (decoder mapping) pointer offset new-end string 0) (values string (- new-end offset))))))) ;;;# Using Foreign Strings (defun foreign-string-alloc (string &key (encoding *default-foreign-encoding*) (null-terminated-p t) (start 0) end) "Allocate a foreign string containing Lisp string STRING. The string must be freed with FOREIGN-STRING-FREE." (check-type string string) (with-checked-simple-vector ((string (coerce string 'babel:unicode-string)) (start start) (end end)) (declare (type simple-string string)) (let* ((mapping (lookup-mapping *foreign-string-mappings* encoding)) (count (funcall (octet-counter mapping) string start end 0)) (nul-length (if null-terminated-p (null-terminator-len encoding) 0)) (length (+ count nul-length)) (ptr (foreign-alloc :char :count length))) (funcall (encoder mapping) string start end ptr 0) (dotimes (i nul-length) (setf (mem-ref ptr :char (+ count i)) 0)) (values ptr length)))) (defun foreign-string-free (ptr) "Free a foreign string allocated by FOREIGN-STRING-ALLOC." (foreign-free ptr)) (defmacro with-foreign-string ((var-or-vars lisp-string &rest args) &body body) "VAR-OR-VARS is not evaluated and should be a list of the form \(VAR &OPTIONAL BYTE-SIZE-VAR) or just a VAR symbol. VAR is bound to a foreign string containing LISP-STRING in BODY. When BYTE-SIZE-VAR is specified then bind the C buffer size \(including the possible null terminator\(s)) to this variable." (destructuring-bind (var &optional size-var) (ensure-list var-or-vars) `(multiple-value-bind (,var ,@(when size-var (list size-var))) (foreign-string-alloc ,lisp-string ,@args) (unwind-protect (progn ,@body) (foreign-string-free ,var))))) (defmacro with-foreign-strings (bindings &body body) "See WITH-FOREIGN-STRING's documentation." (if bindings `(with-foreign-string ,(first bindings) (with-foreign-strings ,(rest bindings) ,@body)) `(progn ,@body))) (defmacro with-foreign-pointer-as-string ((var-or-vars size &rest args) &body body) "VAR-OR-VARS is not evaluated and should be a list of the form \(VAR &OPTIONAL SIZE-VAR) or just a VAR symbol. VAR is bound to a foreign buffer of size SIZE within BODY. The return value is constructed by calling FOREIGN-STRING-TO-LISP on the foreign buffer along with ARGS." ; fix wording, sigh (destructuring-bind (var &optional size-var) (ensure-list var-or-vars) `(with-foreign-pointer (,var ,size ,size-var) (progn ,@body (values (foreign-string-to-lisp ,var ,@args)))))) ;;;# Automatic Conversion of Foreign Strings (define-foreign-type foreign-string-type () (;; CFFI encoding of this string. (encoding :initform nil :initarg :encoding :reader encoding) ;; Should we free after translating from foreign? (free-from-foreign :initarg :free-from-foreign :reader fst-free-from-foreign-p :initform nil :type boolean) ;; Should we free after translating to foreign? (free-to-foreign :initarg :free-to-foreign :reader fst-free-to-foreign-p :initform t :type boolean)) (:actual-type :pointer) (:simple-parser :string)) ;;; describe me (defun fst-encoding (type) (or (encoding type) *default-foreign-encoding*)) ;;; Display the encoding when printing a FOREIGN-STRING-TYPE instance. (defmethod print-object ((type foreign-string-type) stream) (print-unreadable-object (type stream :type t) (format stream "~S" (fst-encoding type)))) (defmethod translate-to-foreign ((s string) (type foreign-string-type)) (values (foreign-string-alloc s :encoding (fst-encoding type)) (fst-free-to-foreign-p type))) (defmethod translate-to-foreign (obj (type foreign-string-type)) (cond ((pointerp obj) (values obj nil)) ;; FIXME: we used to support UB8 vectors but not anymore. ;; ((typep obj '(array (unsigned-byte 8))) ;; (values (foreign-string-alloc obj) t)) (t (error "~A is not a Lisp string or pointer." obj)))) (defmethod translate-from-foreign (ptr (type foreign-string-type)) (unwind-protect (values (foreign-string-to-lisp ptr :encoding (fst-encoding type))) (when (fst-free-from-foreign-p type) (foreign-free ptr)))) (defmethod free-translated-object (ptr (type foreign-string-type) free-p) (when free-p (foreign-string-free ptr))) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-string-type)) (alexandria:with-gensyms (str) (expand-to-foreign-dyn value str (list (expand-to-foreign-dyn-indirect str var body (parse-type :pointer))) type))) ;;;# STRING+PTR (define-foreign-type foreign-string+ptr-type (foreign-string-type) () (:simple-parser :string+ptr)) (defmethod translate-from-foreign (value (type foreign-string+ptr-type)) (list (call-next-method) value)) cffi_0.19.0/src/types.lisp0000644000175000017500000012653613103031266014140 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; types.lisp --- User-defined CFFI types. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;;;# Built-In Types ;; NOTE: In the C standard there's a "signed-char": ;; https://stackoverflow.com/questions/436513/char-signed-char-char-unsigned-char ;; and "char" may be either signed or unsigned, i.e. treating it as a small int ;; is not wise. At the level of CFFI we can safely ignore this and assume that ;; :char is mapped to "signed-char" by the CL implementation under us. (define-built-in-foreign-type :char) (define-built-in-foreign-type :unsigned-char) (define-built-in-foreign-type :short) (define-built-in-foreign-type :unsigned-short) (define-built-in-foreign-type :int) (define-built-in-foreign-type :unsigned-int) (define-built-in-foreign-type :long) (define-built-in-foreign-type :unsigned-long) (define-built-in-foreign-type :float) (define-built-in-foreign-type :double) (define-built-in-foreign-type :void) #-cffi-sys::no-long-long (progn (define-built-in-foreign-type :long-long) (define-built-in-foreign-type :unsigned-long-long)) ;;; Define emulated LONG-LONG types. Needs checking whether we're ;;; using the right sizes on various platforms. ;;; ;;; A possibly better, certainly faster though more intrusive, ;;; alternative is available here: ;;; #+cffi-sys::no-long-long (eval-when (:compile-toplevel :load-toplevel :execute) (defclass emulated-llong-type (foreign-type) ()) (defmethod foreign-type-size ((tp emulated-llong-type)) 8) (defmethod foreign-type-alignment ((tp emulated-llong-type)) ;; better than assuming that the alignment is 8 (foreign-type-alignment :long)) (defmethod aggregatep ((tp emulated-llong-type)) nil) (define-foreign-type emulated-llong (emulated-llong-type) () (:simple-parser :long-long)) (define-foreign-type emulated-ullong (emulated-llong-type) () (:simple-parser :unsigned-long-long)) (defmethod canonicalize ((tp emulated-llong)) :long-long) (defmethod unparse-type ((tp emulated-llong)) :long-long) (defmethod canonicalize ((tp emulated-ullong)) :unsigned-long-long) (defmethod unparse-type ((tp emulated-ullong)) :unsigned-long-long) (defun %emulated-mem-ref-64 (ptr type offset) (let ((value #+big-endian (+ (ash (mem-ref ptr :unsigned-long offset) 32) (mem-ref ptr :unsigned-long (+ offset 4))) #+little-endian (+ (mem-ref ptr :unsigned-long offset) (ash (mem-ref ptr :unsigned-long (+ offset 4)) 32)))) (if (and (eq type :long-long) (logbitp 63 value)) (lognot (logxor value #xFFFFFFFFFFFFFFFF)) value))) (defun %emulated-mem-set-64 (value ptr type offset) (when (and (eq type :long-long) (minusp value)) (setq value (lognot (logxor value #xFFFFFFFFFFFFFFFF)))) (%mem-set (ldb (byte 32 0) value) ptr :unsigned-long #+big-endian (+ offset 4) #+little-endian offset) (%mem-set (ldb (byte 32 32) value) ptr :unsigned-long #+big-endian offset #+little-endian (+ offset 4)) value)) ;;; When some lisp other than SCL supports :long-double we should ;;; use #-cffi-sys::no-long-double here instead. #+(and scl long-float) (define-built-in-foreign-type :long-double) (defparameter *possible-float-types* '(:float :double :long-double)) (defparameter *other-builtin-types* '(:pointer :void) "List of types other than integer or float built in to CFFI.") (defparameter *built-in-integer-types* (set-difference cffi:*built-in-foreign-types* (append *possible-float-types* *other-builtin-types*)) "List of integer types supported by CFFI.") (defparameter *built-in-float-types* (set-difference cffi:*built-in-foreign-types* (append *built-in-integer-types* *other-builtin-types*)) "List of real float types supported by CFFI.") ;;;# Foreign Pointers (define-modify-macro incf-pointer (&optional (offset 1)) inc-pointer) (defun mem-ref (ptr type &optional (offset 0)) "Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggregate, we don't return its 'value' but a pointer to it, which is PTR itself." (let* ((parsed-type (parse-type type)) (ctype (canonicalize parsed-type))) #+cffi-sys::no-long-long (when (member ctype '(:long-long :unsigned-long-long)) (return-from mem-ref (translate-from-foreign (%emulated-mem-ref-64 ptr ctype offset) parsed-type))) ;; normal branch (if (aggregatep parsed-type) (if (bare-struct-type-p parsed-type) (inc-pointer ptr offset) (translate-from-foreign (inc-pointer ptr offset) parsed-type)) (translate-from-foreign (%mem-ref ptr ctype offset) parsed-type)))) (define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0)) "Compiler macro to open-code MEM-REF when TYPE is constant." (if (constantp type) (let* ((parsed-type (parse-type (eval type))) (ctype (canonicalize parsed-type))) ;; Bail out when using emulated long long types. #+cffi-sys::no-long-long (when (member ctype '(:long-long :unsigned-long-long)) (return-from mem-ref form)) (if (aggregatep parsed-type) (if (bare-struct-type-p parsed-type) `(inc-pointer ,ptr ,offset) (expand-from-foreign `(inc-pointer ,ptr ,offset) parsed-type)) (expand-from-foreign `(%mem-ref ,ptr ,ctype ,offset) parsed-type))) form)) (defun mem-set (value ptr type &optional (offset 0)) "Set the value of TYPE at OFFSET bytes from PTR to VALUE." (let* ((ptype (parse-type type)) (ctype (canonicalize ptype))) #+cffi-sys::no-long-long (when (or (eq ctype :long-long) (eq ctype :unsigned-long-long)) (return-from mem-set (%emulated-mem-set-64 (translate-to-foreign value ptype) ptr ctype offset))) (if (aggregatep ptype) ; XXX: backwards incompatible? (translate-into-foreign-memory value ptype (inc-pointer ptr offset)) (%mem-set (translate-to-foreign value ptype) ptr ctype offset)))) (define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env) "SETF expander for MEM-REF that doesn't rebind TYPE. This is necessary for the compiler macro on MEM-SET to be able to open-code (SETF MEM-REF) forms." (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion ptr env) (declare (ignore setter newval)) ;; if either TYPE or OFFSET are constant, we avoid rebinding them ;; so that the compiler macros on MEM-SET and %MEM-SET work. (with-unique-names (store type-tmp offset-tmp) (values (append (unless (constantp type) (list type-tmp)) (unless (constantp offset) (list offset-tmp)) dummies) (append (unless (constantp type) (list type)) (unless (constantp offset) (list offset)) vals) (list store) `(progn (mem-set ,store ,getter ,@(if (constantp type) (list type) (list type-tmp)) ,@(if (constantp offset) (list offset) (list offset-tmp))) ,store) `(mem-ref ,getter ,@(if (constantp type) (list type) (list type-tmp)) ,@(if (constantp offset) (list offset) (list offset-tmp))))))) (define-compiler-macro mem-set (&whole form value ptr type &optional (offset 0)) "Compiler macro to open-code (SETF MEM-REF) when type is constant." (if (constantp type) (let* ((parsed-type (parse-type (eval type))) (ctype (canonicalize parsed-type))) ;; Bail out when using emulated long long types. #+cffi-sys::no-long-long (when (member ctype '(:long-long :unsigned-long-long)) (return-from mem-set form)) (if (aggregatep parsed-type) (expand-into-foreign-memory value parsed-type `(inc-pointer ,ptr ,offset)) `(%mem-set ,(expand-to-foreign value parsed-type) ,ptr ,ctype ,offset))) form)) ;;;# Dereferencing Foreign Arrays ;;; Maybe this should be named MEM-SVREF? [2007-02-28 LO] (defun mem-aref (ptr type &optional (index 0)) "Like MEM-REF except for accessing 1d arrays." (mem-ref ptr type (* index (foreign-type-size type)))) (define-compiler-macro mem-aref (&whole form ptr type &optional (index 0)) "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)." (if (constantp type) (if (constantp index) `(mem-ref ,ptr ,type ,(* (eval index) (foreign-type-size (eval type)))) `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type))))) form)) (define-setf-expander mem-aref (ptr type &optional (index 0) &environment env) "SETF expander for MEM-AREF." (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion ptr env) (declare (ignore setter newval)) ;; we avoid rebinding type and index, if possible (and if type is not ;; constant, we don't bother about the index), so that the compiler macros ;; on MEM-SET or %MEM-SET can work. (with-unique-names (store type-tmp index-tmp) (values (append (unless (constantp type) (list type-tmp)) (unless (and (constantp type) (constantp index)) (list index-tmp)) dummies) (append (unless (constantp type) (list type)) (unless (and (constantp type) (constantp index)) (list index)) vals) (list store) ;; Here we'll try to calculate the offset from the type and index, ;; or if not possible at least get the type size early. `(progn ,(if (constantp type) (if (constantp index) `(mem-set ,store ,getter ,type ,(* (eval index) (foreign-type-size (eval type)))) `(mem-set ,store ,getter ,type (* ,index-tmp ,(foreign-type-size (eval type))))) `(mem-set ,store ,getter ,type-tmp (* ,index-tmp (foreign-type-size ,type-tmp)))) ,store) `(mem-aref ,getter ,@(if (constantp type) (list type) (list type-tmp)) ,@(if (and (constantp type) (constantp index)) (list index) (list index-tmp))))))) (defmethod translate-into-foreign-memory (value (type foreign-pointer-type) pointer) (setf (mem-aref pointer :pointer) value)) (defmethod translate-into-foreign-memory (value (type foreign-built-in-type) pointer) (setf (mem-aref pointer (unparse-type type)) value)) (defun mem-aptr (ptr type &optional (index 0)) "The pointer to the element." (inc-pointer ptr (* index (foreign-type-size type)))) (define-compiler-macro mem-aptr (&whole form ptr type &optional (index 0)) "The pointer to the element." (cond ((not (constantp type)) form) ((not (constantp index)) `(inc-pointer ,ptr (* ,index ,(foreign-type-size (eval type))))) ((zerop (eval index)) ptr) (t `(inc-pointer ,ptr ,(* (eval index) (foreign-type-size (eval type))))))) (define-foreign-type foreign-array-type () ((dimensions :reader dimensions :initarg :dimensions) (element-type :reader element-type :initarg :element-type)) (:actual-type :pointer)) (defmethod aggregatep ((type foreign-array-type)) t) (defmethod print-object ((type foreign-array-type) stream) "Print a FOREIGN-ARRAY-TYPE instance to STREAM unreadably." (print-unreadable-object (type stream :type t :identity nil) (format stream "~S ~S" (element-type type) (dimensions type)))) (defun array-element-size (array-type) (foreign-type-size (element-type array-type))) (defmethod foreign-type-size ((type foreign-array-type)) (* (array-element-size type) (reduce #'* (dimensions type)))) (defmethod foreign-type-alignment ((type foreign-array-type)) (foreign-type-alignment (element-type type))) (define-parse-method :array (element-type &rest dimensions) (assert (plusp (length dimensions))) (make-instance 'foreign-array-type :element-type element-type :dimensions dimensions)) (defun indexes-to-row-major-index (dimensions &rest subscripts) (apply #'+ (maplist (lambda (x y) (* (car x) (apply #'* (cdr y)))) subscripts dimensions))) (defun row-major-index-to-indexes (index dimensions) (loop with idx = index with rank = (length dimensions) with indexes = (make-list rank) for dim-index from (- rank 1) downto 0 do (setf (values idx (nth dim-index indexes)) (floor idx (nth dim-index dimensions))) finally (return indexes))) (defun foreign-alloc (type &key (initial-element nil initial-element-p) (initial-contents nil initial-contents-p) (count 1 count-p) null-terminated-p) "Allocate enough memory to hold COUNT objects of type TYPE. If INITIAL-ELEMENT is supplied, each element of the newly allocated memory is initialized with its value. If INITIAL-CONTENTS is supplied, each of its elements will be used to initialize the contents of the newly allocated memory." (let (contents-length) ;; Some error checking, etc... (when (and null-terminated-p (not (eq (canonicalize-foreign-type type) :pointer))) (error "Cannot use :NULL-TERMINATED-P with non-pointer types.")) (when (and initial-element-p initial-contents-p) (error "Cannot specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) (when initial-contents-p (setq contents-length (length initial-contents)) (if count-p (assert (>= count contents-length)) (setq count contents-length))) ;; Everything looks good. (let ((ptr (%foreign-alloc (* (foreign-type-size type) (if null-terminated-p (1+ count) count))))) (when initial-element-p (dotimes (i count) (setf (mem-aref ptr type i) initial-element))) (when initial-contents-p (dotimes (i contents-length) (setf (mem-aref ptr type i) (elt initial-contents i)))) (when null-terminated-p (setf (mem-aref ptr :pointer count) (null-pointer))) ptr))) ;;; Simple compiler macro that kicks in when TYPE is constant and only ;;; the COUNT argument is passed. (Note: hard-coding the type's size ;;; into the fasl will likely break CLISP fasl cross-platform ;;; compatibilty.) (define-compiler-macro foreign-alloc (&whole form type &rest args &key (count 1 count-p) &allow-other-keys) (if (or (and count-p (<= (length args) 2)) (null args)) (cond ((and (constantp type) (constantp count)) `(%foreign-alloc ,(* (eval count) (foreign-type-size (eval type))))) ((constantp type) `(%foreign-alloc (* ,count ,(foreign-type-size (eval type))))) (t form)) form)) (defun lisp-array-to-foreign (array pointer array-type) "Copy elements from a Lisp array to POINTER." (let* ((type (ensure-parsed-base-type array-type)) (el-type (element-type type)) (dimensions (dimensions type))) (loop with foreign-type-size = (array-element-size type) with size = (reduce #'* dimensions) for i from 0 below size for offset = (* i foreign-type-size) for element = (apply #'aref array (row-major-index-to-indexes i dimensions)) do (setf (mem-ref pointer el-type offset) element)))) (defun foreign-array-to-lisp (pointer array-type) "Copy elements from ptr into a Lisp array. If POINTER is a null pointer, returns NIL." (unless (null-pointer-p pointer) (let* ((type (ensure-parsed-base-type array-type)) (el-type (element-type type)) (dimensions (dimensions type)) (array (make-array dimensions))) (loop with foreign-type-size = (array-element-size type) with size = (reduce #'* dimensions) for i from 0 below size for offset = (* i foreign-type-size) for element = (mem-ref pointer el-type offset) do (setf (apply #'aref array (row-major-index-to-indexes i dimensions)) element)) array))) (defun foreign-array-alloc (array array-type) "Allocate a foreign array containing the elements of lisp array. The foreign array must be freed with foreign-array-free." (check-type array array) (let* ((type (ensure-parsed-base-type array-type)) (ptr (foreign-alloc (element-type type) :count (reduce #'* (dimensions type))))) (lisp-array-to-foreign array ptr array-type) ptr)) (defun foreign-array-free (ptr) "Free a foreign array allocated by foreign-array-alloc." (foreign-free ptr)) (defmacro with-foreign-array ((var lisp-array array-type) &body body) "Bind var to a foreign array containing lisp-array elements in body." (with-unique-names (type) `(let ((,type (ensure-parsed-base-type ,array-type))) (with-foreign-pointer (,var (* (reduce #'* (dimensions ,type)) (array-element-size ,type))) (lisp-array-to-foreign ,lisp-array ,var ,array-type) ,@body)))) (defun foreign-aref (ptr array-type &rest indexes) (let* ((type (ensure-parsed-base-type array-type)) (offset (* (array-element-size type) (apply #'indexes-to-row-major-index (dimensions type) indexes)))) (mem-ref ptr (element-type type) offset))) (defun (setf foreign-aref) (value ptr array-type &rest indexes) (let* ((type (ensure-parsed-base-type array-type)) (offset (* (array-element-size type) (apply #'indexes-to-row-major-index (dimensions type) indexes)))) (setf (mem-ref ptr (element-type type) offset) value))) ;;; Automatic translations for the :ARRAY type. Notice that these ;;; translators will also invoke the appropriate translators for for ;;; each of the array's elements since that's the normal behaviour of ;;; the FOREIGN-ARRAY-* operators, but there's a FIXME: **it doesn't ;;; free them yet** ;;; This used to be in a separate type but let's experiment with just ;;; one type for a while. [2008-12-30 LO] ;;; FIXME: those ugly invocations of UNPARSE-TYPE suggest that these ;;; foreign array operators should take the type and dimention ;;; arguments "unboxed". [2008-12-31 LO] (defmethod translate-to-foreign (array (type foreign-array-type)) (foreign-array-alloc array (unparse-type type))) (defmethod translate-aggregate-to-foreign (ptr value (type foreign-array-type)) (lisp-array-to-foreign value ptr (unparse-type type))) (defmethod translate-from-foreign (pointer (type foreign-array-type)) (foreign-array-to-lisp pointer (unparse-type type))) (defmethod free-translated-object (pointer (type foreign-array-type) param) (declare (ignore param)) (foreign-array-free pointer)) ;;;# Foreign Structures ;;;## Foreign Structure Slots (defgeneric foreign-struct-slot-pointer (ptr slot) (:documentation "Get the address of SLOT relative to PTR.")) (defgeneric foreign-struct-slot-pointer-form (ptr slot) (:documentation "Return a form to get the address of SLOT in PTR.")) (defgeneric foreign-struct-slot-value (ptr slot) (:documentation "Return the value of SLOT in structure PTR.")) (defgeneric (setf foreign-struct-slot-value) (value ptr slot) (:documentation "Set the value of a SLOT in structure PTR.")) (defgeneric foreign-struct-slot-value-form (ptr slot) (:documentation "Return a form to get the value of SLOT in struct PTR.")) (defgeneric foreign-struct-slot-set-form (value ptr slot) (:documentation "Return a form to set the value of SLOT in struct PTR.")) (defclass foreign-struct-slot () ((name :initarg :name :reader slot-name) (offset :initarg :offset :accessor slot-offset) ;; FIXME: the type should probably be parsed? (type :initarg :type :accessor slot-type)) (:documentation "Base class for simple and aggregate slots.")) (defmethod foreign-struct-slot-pointer (ptr (slot foreign-struct-slot)) "Return the address of SLOT relative to PTR." (inc-pointer ptr (slot-offset slot))) (defmethod foreign-struct-slot-pointer-form (ptr (slot foreign-struct-slot)) "Return a form to get the address of SLOT relative to PTR." (let ((offset (slot-offset slot))) (if (zerop offset) ptr `(inc-pointer ,ptr ,offset)))) (defun foreign-slot-names (type) "Returns a list of TYPE's slot names in no particular order." (loop for value being the hash-values in (slots (ensure-parsed-base-type type)) collect (slot-name value))) ;;;### Simple Slots (defclass simple-struct-slot (foreign-struct-slot) () (:documentation "Non-aggregate structure slots.")) (defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot)) "Return the value of a simple SLOT from a struct at PTR." (mem-ref ptr (slot-type slot) (slot-offset slot))) (defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot)) "Return a form to get the value of a slot from PTR." `(mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot))) (defmethod (setf foreign-struct-slot-value) (value ptr (slot simple-struct-slot)) "Set the value of a simple SLOT to VALUE in PTR." (setf (mem-ref ptr (slot-type slot) (slot-offset slot)) value)) (defmethod foreign-struct-slot-set-form (value ptr (slot simple-struct-slot)) "Return a form to set the value of a simple structure slot." `(setf (mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)) ,value)) ;;;### Aggregate Slots (defclass aggregate-struct-slot (foreign-struct-slot) ((count :initarg :count :accessor slot-count)) (:documentation "Aggregate structure slots.")) ;;; Since MEM-REF returns a pointer for struct types we are able to ;;; chain together slot names when accessing slot values in nested ;;; structures. (defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot)) "Return a pointer to SLOT relative to PTR." (convert-from-foreign (inc-pointer ptr (slot-offset slot)) (slot-type slot))) (defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-slot)) "Return a form to get the value of SLOT relative to PTR." `(convert-from-foreign (inc-pointer ,ptr ,(slot-offset slot)) ',(slot-type slot))) (defmethod translate-aggregate-to-foreign (ptr value (type foreign-struct-type)) ;;; FIXME: use the block memory interface instead. (loop for i below (foreign-type-size type) do (%mem-set (%mem-ref value :char i) ptr :char i))) (defmethod (setf foreign-struct-slot-value) (value ptr (slot aggregate-struct-slot)) "Set the value of an aggregate SLOT to VALUE in PTR." (translate-aggregate-to-foreign (inc-pointer ptr (slot-offset slot)) value (parse-type (slot-type slot)))) (defmethod foreign-struct-slot-set-form (value ptr (slot aggregate-struct-slot)) "Return a form to get the value of an aggregate SLOT relative to PTR." `(translate-aggregate-to-foreign (inc-pointer ,ptr ,(slot-offset slot)) ,value ,(parse-type (slot-type slot)))) ;;;## Defining Foreign Structures (defun make-struct-slot (name offset type count) "Make the appropriate type of structure slot." ;; If TYPE is an aggregate type or COUNT is >1, create an ;; AGGREGATE-STRUCT-SLOT, otherwise a SIMPLE-STRUCT-SLOT. (if (or (> count 1) (aggregatep (parse-type type))) (make-instance 'aggregate-struct-slot :offset offset :type type :name name :count count) (make-instance 'simple-struct-slot :offset offset :type type :name name))) (defun parse-deprecated-struct-type (name struct-or-union) (check-type struct-or-union (member :struct :union)) (let* ((struct-type-name `(,struct-or-union ,name)) (struct-type (parse-type struct-type-name))) (simple-style-warning "bare references to struct types are deprecated. ~ Please use ~S or ~S instead." `(:pointer ,struct-type-name) struct-type-name) (make-instance (class-of struct-type) :alignment (alignment struct-type) :size (size struct-type) :slots (slots struct-type) :name (name struct-type) :bare t))) ;;; Regarding structure alignment, the following ABIs were checked: ;;; - System-V ABI: x86, x86-64, ppc, arm, mips and itanium. (more?) ;;; - Mac OS X ABI Function Call Guide: ppc32, ppc64 and x86. ;;; ;;; Rules used here: ;;; ;;; 1. "An entire structure or union object is aligned on the same ;;; boundary as its most strictly aligned member." ;;; ;;; 2. "Each member is assigned to the lowest available offset with ;;; the appropriate alignment. This may require internal ;;; padding, depending on the previous member." ;;; ;;; 3. "A structure's size is increased, if necessary, to make it a ;;; multiple of the alignment. This may require tail padding, ;;; depending on the last member." ;;; ;;; Special cases from darwin/ppc32's ABI: ;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevelABI/index.html ;;; ;;; 4. "The embedding alignment of the first element in a data ;;; structure is equal to the element's natural alignment." ;;; ;;; 5. "For subsequent elements that have a natural alignment ;;; greater than 4 bytes, the embedding alignment is 4, unless ;;; the element is a vector." (note: this applies for ;;; structures too) ;; FIXME: get a better name for this. --luis (defun get-alignment (type alignment-type firstp) "Return alignment for TYPE according to ALIGNMENT-TYPE." (declare (ignorable firstp)) (ecase alignment-type (:normal #-(and darwin ppc) (foreign-type-alignment type) #+(and darwin ppc) (if firstp (foreign-type-alignment type) (min 4 (foreign-type-alignment type)))))) (defun adjust-for-alignment (type offset alignment-type firstp) "Return OFFSET aligned properly for TYPE according to ALIGNMENT-TYPE." (let* ((align (get-alignment type alignment-type firstp)) (rem (mod offset align))) (if (zerop rem) offset (+ offset (- align rem))))) (defmacro with-tentative-type-definition ((name value namespace) &body body) (once-only (name namespace) `(unwind-protect-case () (progn (notice-foreign-type ,name ,value ,namespace) ,@body) (:abort (undefine-foreign-type ,name ,namespace))))) (defun notice-foreign-struct-definition (name options slots) "Parse and install a foreign structure definition." (destructuring-bind (&key size (class 'foreign-struct-type)) options (let ((struct (make-instance class :name name)) (current-offset 0) (max-align 1) (firstp t)) (with-tentative-type-definition (name struct :struct) ;; determine offsets (dolist (slotdef slots) (destructuring-bind (slotname type &key (count 1) offset) slotdef (when (eq (canonicalize-foreign-type type) :void) (simple-foreign-type-error type :struct "In struct ~S: void type not allowed in field ~S" name slotdef)) (setq current-offset (or offset (adjust-for-alignment type current-offset :normal firstp))) (let* ((slot (make-struct-slot slotname current-offset type count)) (align (get-alignment (slot-type slot) :normal firstp))) (setf (gethash slotname (slots struct)) slot) (when (> align max-align) (setq max-align align))) (incf current-offset (* count (foreign-type-size type)))) (setq firstp nil)) ;; calculate padding and alignment (setf (alignment struct) max-align) ; See point 1 above. (let ((tail-padding (- max-align (rem current-offset max-align)))) (unless (= tail-padding max-align) ; See point 3 above. (incf current-offset tail-padding))) (setf (size struct) (or size current-offset)))))) (defun generate-struct-accessors (name conc-name slot-names) (loop with pointer-arg = (symbolicate '#:pointer-to- name) for slot in slot-names for accessor = (symbolicate conc-name slot) collect `(defun ,accessor (,pointer-arg) (foreign-slot-value ,pointer-arg '(:struct ,name) ',slot)) collect `(defun (setf ,accessor) (value ,pointer-arg) (foreign-slot-set value ,pointer-arg '(:struct ,name) ',slot)))) (define-parse-method :struct (name) (funcall (find-type-parser name :struct))) (defvar *defcstruct-hook* nil) (defmacro defcstruct (name-and-options &body fields) "Define the layout of a foreign structure." (discard-docstring fields) (destructuring-bind (name . options) (ensure-list name-and-options) (let ((conc-name (getf options :conc-name))) (remf options :conc-name) (unless (getf options :class) (setf (getf options :class) (symbolicate name '-tclass))) `(eval-when (:compile-toplevel :load-toplevel :execute) ;; m-f-s-t could do with this with mop:ensure-class. ,(when-let (class (getf options :class)) `(defclass ,class (foreign-struct-type translatable-foreign-type) ())) (notice-foreign-struct-definition ',name ',options ',fields) ,@(when conc-name (generate-struct-accessors name conc-name (mapcar #'car fields))) ,@(when *defcstruct-hook* ;; If non-nil, *defcstruct-hook* should be a function ;; of the arguments that returns NIL or a list of ;; forms to include in the expansion. (apply *defcstruct-hook* name-and-options fields)) (define-parse-method ,name () (parse-deprecated-struct-type ',name :struct)) '(:struct ,name))))) ;;;## Accessing Foreign Structure Slots (defun get-slot-info (type slot-name) "Return the slot info for SLOT-NAME or raise an error." (let* ((struct (ensure-parsed-base-type type)) (info (gethash slot-name (slots struct)))) (unless info (simple-foreign-type-error type :struct "Undefined slot ~A in foreign type ~A." slot-name type)) info)) (defun foreign-slot-pointer (ptr type slot-name) "Return the address of SLOT-NAME in the structure at PTR." (foreign-struct-slot-pointer ptr (get-slot-info type slot-name))) (define-compiler-macro foreign-slot-pointer (&whole whole ptr type slot-name) (if (and (constantp type) (constantp slot-name)) (foreign-struct-slot-pointer-form ptr (get-slot-info (eval type) (eval slot-name))) whole)) (defun foreign-slot-type (type slot-name) "Return the type of SLOT in a struct TYPE." (slot-type (get-slot-info type slot-name))) (defun foreign-slot-offset (type slot-name) "Return the offset of SLOT in a struct TYPE." (slot-offset (get-slot-info type slot-name))) (defun foreign-slot-count (type slot-name) "Return the number of items in SLOT in a struct TYPE." (slot-count (get-slot-info type slot-name))) (defun foreign-slot-value (ptr type slot-name) "Return the value of SLOT-NAME in the foreign structure at PTR." (foreign-struct-slot-value ptr (get-slot-info type slot-name))) (define-compiler-macro foreign-slot-value (&whole form ptr type slot-name) "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant." (if (and (constantp type) (constantp slot-name)) (foreign-struct-slot-value-form ptr (get-slot-info (eval type) (eval slot-name))) form)) (define-setf-expander foreign-slot-value (ptr type slot-name &environment env) "SETF expander for FOREIGN-SLOT-VALUE." (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion ptr env) (declare (ignore setter newval)) (if (and (constantp type) (constantp slot-name)) ;; if TYPE and SLOT-NAME are constant we avoid rebinding them ;; so that the compiler macro on FOREIGN-SLOT-SET works. (with-unique-names (store) (values dummies vals (list store) `(progn (foreign-slot-set ,store ,getter ,type ,slot-name) ,store) `(foreign-slot-value ,getter ,type ,slot-name))) ;; if not... (with-unique-names (store slot-name-tmp type-tmp) (values (list* type-tmp slot-name-tmp dummies) (list* type slot-name vals) (list store) `(progn (foreign-slot-set ,store ,getter ,type-tmp ,slot-name-tmp) ,store) `(foreign-slot-value ,getter ,type-tmp ,slot-name-tmp)))))) (defun foreign-slot-set (value ptr type slot-name) "Set the value of SLOT-NAME in a foreign structure." (setf (foreign-struct-slot-value ptr (get-slot-info type slot-name)) value)) (define-compiler-macro foreign-slot-set (&whole form value ptr type slot-name) "Optimizer when TYPE and SLOT-NAME are constant." (if (and (constantp type) (constantp slot-name)) (foreign-struct-slot-set-form value ptr (get-slot-info (eval type) (eval slot-name))) form)) (defmacro with-foreign-slots ((vars ptr type) &body body) "Create local symbol macros for each var in VARS to reference foreign slots in PTR of TYPE. Similar to WITH-SLOTS. Each var can be of the form: slot-name - in which case slot-name will be bound to the value of the slot or: (:pointer slot-name) - in which case slot-name will be bound to the pointer to that slot." (let ((ptr-var (gensym "PTR"))) `(let ((,ptr-var ,ptr)) (symbol-macrolet ,(loop :for var :in vars :collect (if (listp var) (if (eq (first var) :pointer) `(,(second var) (foreign-slot-pointer ,ptr-var ',type ',(second var))) (error "Malformed slot specification ~a; must be:`name' or `(:pointer name)'" var)) `(,var (foreign-slot-value ,ptr-var ',type ',var)))) ,@body)))) ;;; We could add an option to define a struct instead of a class, in ;;; the unlikely event someone needs something like that. (defmacro define-c-struct-wrapper (class-and-type supers &optional slots) "Define a new class with CLOS slots matching those of a foreign struct type. An INITIALIZE-INSTANCE method is defined which takes a :POINTER initarg that is used to store the slots of a foreign object. This pointer is only used for initialization and it is not retained. CLASS-AND-TYPE is either a list of the form (class-name struct-type) or a single symbol naming both. The class will inherit SUPERS. If a list of SLOTS is specified, only those slots will be defined and stored." (destructuring-bind (class-name &optional (struct-type (list :struct class-name))) (ensure-list class-and-type) (let ((slots (or slots (foreign-slot-names struct-type)))) `(progn (defclass ,class-name ,supers ,(loop for slot in slots collect `(,slot :reader ,(format-symbol t "~A-~A" class-name slot)))) ;; This could be done in a parent class by using ;; FOREIGN-SLOT-NAMES when instantiating but then the compiler ;; macros wouldn't kick in. (defmethod initialize-instance :after ((inst ,class-name) &key pointer) (with-foreign-slots (,slots pointer ,struct-type) ,@(loop for slot in slots collect `(setf (slot-value inst ',slot) ,slot)))) ',class-name)))) ;;;# Foreign Unions ;;; ;;; A union is a subclass of FOREIGN-STRUCT-TYPE in which all slots ;;; have an offset of zero. ;;; See also the notes regarding ABI requirements in ;;; NOTICE-FOREIGN-STRUCT-DEFINITION (defun notice-foreign-union-definition (name-and-options slots) "Parse and install a foreign union definition." (destructuring-bind (name &key size) (ensure-list name-and-options) (let ((union (make-instance 'foreign-union-type :name name)) (max-size 0) (max-align 0)) (with-tentative-type-definition (name union :union) (dolist (slotdef slots) (destructuring-bind (slotname type &key (count 1)) slotdef (when (eq (canonicalize-foreign-type type) :void) (simple-foreign-type-error name :struct "In union ~S: void type not allowed in field ~S" name slotdef)) (let* ((slot (make-struct-slot slotname 0 type count)) (size (* count (foreign-type-size type))) (align (foreign-type-alignment (slot-type slot)))) (setf (gethash slotname (slots union)) slot) (when (> size max-size) (setf max-size size)) (when (> align max-align) (setf max-align align))))) (setf (size union) (or size max-size)) (setf (alignment union) max-align))))) (define-parse-method :union (name) (funcall (find-type-parser name :union))) (defmacro defcunion (name-and-options &body fields) "Define the layout of a foreign union." (discard-docstring fields) (destructuring-bind (name &key size) (ensure-list name-and-options) (declare (ignore size)) `(eval-when (:compile-toplevel :load-toplevel :execute) (notice-foreign-union-definition ',name-and-options ',fields) (define-parse-method ,name () (parse-deprecated-struct-type ',name :union)) '(:union ,name)))) ;;;# Operations on Types (defmethod foreign-type-alignment (type) "Return the alignment in bytes of a foreign type." (foreign-type-alignment (parse-type type))) (defmacro with-foreign-object ((var type &optional (count 1)) &body body) "Bind VAR to a pointer to COUNT objects of TYPE during BODY. The buffer has dynamic extent and may be stack allocated." `(with-foreign-pointer (,var ,(if (constantp type) ;; with-foreign-pointer may benefit from constant folding: (if (constantp count) (* (eval count) (foreign-type-size (eval type))) `(* ,count ,(foreign-type-size (eval type)))) `(* ,count (foreign-type-size ,type)))) ,@body)) (defmacro with-foreign-objects (bindings &body body) (if bindings `(with-foreign-object ,(car bindings) (with-foreign-objects ,(cdr bindings) ,@body)) `(progn ,@body))) ;;;## Anonymous Type Translators ;;; ;;; (:wrapper :to-c some-function :from-c another-function) ;;; ;;; TODO: We will need to add a FREE function to this as well I think. ;;; --james (define-foreign-type foreign-type-wrapper () ((to-c :initarg :to-c :reader wrapper-to-c) (from-c :initarg :from-c :reader wrapper-from-c)) (:documentation "Wrapper type.")) (define-parse-method :wrapper (base-type &key to-c from-c) (make-instance 'foreign-type-wrapper :actual-type (parse-type base-type) :to-c (or to-c 'identity) :from-c (or from-c 'identity))) (defmethod translate-to-foreign (value (type foreign-type-wrapper)) (translate-to-foreign (funcall (slot-value type 'to-c) value) (actual-type type))) (defmethod translate-from-foreign (value (type foreign-type-wrapper)) (funcall (slot-value type 'from-c) (translate-from-foreign value (actual-type type)))) ;;;# Other types ;;; Boolean type. Maps to an :int by default. Only accepts integer types. (define-foreign-type foreign-boolean-type () ()) (define-parse-method :boolean (&optional (base-type :int)) (make-instance 'foreign-boolean-type :actual-type (ecase (canonicalize-foreign-type base-type) ((:char :unsigned-char :int :unsigned-int :long :unsigned-long #-cffi-sys::no-long-long :long-long #-cffi-sys::no-long-long :unsigned-long-long) base-type)))) (defmethod translate-to-foreign (value (type foreign-boolean-type)) (if value 1 0)) (defmethod translate-from-foreign (value (type foreign-boolean-type)) (not (zerop value))) (defmethod expand-to-foreign (value (type foreign-boolean-type)) "Optimization for the :boolean type." (if (constantp value) (if (eval value) 1 0) `(if ,value 1 0))) (defmethod expand-from-foreign (value (type foreign-boolean-type)) "Optimization for the :boolean type." (if (constantp value) ; very unlikely, heh (not (zerop (eval value))) `(not (zerop ,value)))) ;;; Boolean type that represents C99 _Bool (defctype :bool (:boolean :char)) ;;;# Typedefs for built-in types. (defctype :uchar :unsigned-char) (defctype :ushort :unsigned-short) (defctype :uint :unsigned-int) (defctype :ulong :unsigned-long) (defctype :llong :long-long) (defctype :ullong :unsigned-long-long) ;;; We try to define the :[u]int{8,16,32,64} types by looking at ;;; the sizes of the built-in integer types and defining typedefs. (eval-when (:compile-toplevel :load-toplevel :execute) (macrolet ((match-types (sized-types mtypes) `(progn ,@(loop for (type . size-or-type) in sized-types for m = (car (member (if (keywordp size-or-type) (foreign-type-size size-or-type) size-or-type) mtypes :key #'foreign-type-size)) when m collect `(defctype ,type ,m))))) ;; signed (match-types ((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8) (:intptr . :pointer)) (:char :short :int :long :long-long)) ;; unsigned (match-types ((:uint8 . 1) (:uint16 . 2) (:uint32 . 4) (:uint64 . 8) (:uintptr . :pointer)) (:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsigned-long-long)))) cffi_0.19.0/src/cffi-mkcl.lisp0000644000175000017500000002742013103031266014617 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-mkcl.lisp --- MKCL backend for CFFI. ;;; ;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:alexandria) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Mis-features (pushnew 'flat-namespace *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Allocation (defun %foreign-alloc (size) "Allocate SIZE bytes of foreign-addressable memory." (si:allocate-foreign-data :void size)) (defun foreign-free (ptr) "Free a pointer PTR allocated by FOREIGN-ALLOC." (si:free-foreign-data ptr) nil) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect (progn ,@body) (foreign-free ,var)))) ;;;# Misc. Pointer Operations (deftype foreign-pointer () 'si:foreign) (defun null-pointer () "Construct and return a null pointer." (si:make-foreign-null-pointer)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (si:null-pointer-p ptr)) (defun inc-pointer (ptr offset) "Return a pointer OFFSET bytes past PTR." (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void)) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." ;;(typep ptr 'si:foreign) (si:foreignp ptr)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2))) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (ffi:make-pointer address :void)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (ffi:pointer-address ptr)) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes that can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) ;;; MKCL, built with the Boehm GC never moves allocated data, so this ;;; isn't nearly as hard to do. (defun %vector-address (vector) "Return the address of VECTOR's data." (check-type vector (vector (unsigned-byte 8))) #-mingw64 (ffi:c-inline (vector) (object) :unsigned-long "(uintptr_t) #0->vector.self.b8" :side-effects nil :one-liner t) #+mingw64 (ffi:c-inline (vector) (object) :unsigned-long-long "(uintptr_t) #0->vector.self.b8" :side-effects nil :one-liner t)) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." `(let ((,ptr-var (make-pointer (%vector-address ,vector)))) ,@body)) ;;;# Dereferencing (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of TYPE at OFFSET bytes from PTR." (let* ((type (cffi-type->mkcl-type type)) (type-size (ffi:size-of-foreign-type type))) (si:foreign-ref-elt (si:foreign-recast ptr (+ offset type-size) :void) offset type))) (defun %mem-set (value ptr type &optional (offset 0)) "Set an object of TYPE at OFFSET bytes from PTR." (let* ((type (cffi-type->mkcl-type type)) (type-size (ffi:size-of-foreign-type type))) (si:foreign-set-elt (si:foreign-recast ptr (+ offset type-size) :void) offset type value))) ;;;# Type Operations (defconstant +translation-table+ '((:char :byte "char") (:unsigned-char :unsigned-byte "unsigned char") (:short :short "short") (:unsigned-short :unsigned-short "unsigned short") (:int :int "int") (:unsigned-int :unsigned-int "unsigned int") (:long :long "long") (:unsigned-long :unsigned-long "unsigned long") (:long-long :long-long "long long") (:unsigned-long-long :unsigned-long-long "unsigned long long") (:float :float "float") (:double :double "double") (:pointer :pointer-void "void*") (:void :void "void"))) (defun cffi-type->mkcl-type (type-keyword) "Convert a CFFI type keyword to an MKCL type keyword." (or (second (find type-keyword +translation-table+ :key #'first)) (error "~S is not a valid CFFI type" type-keyword))) (defun mkcl-type->c-type (type-keyword) "Convert a CFFI type keyword to an valid C type keyword." (or (third (find type-keyword +translation-table+ :key #'second)) (error "~S is not a valid CFFI type" type-keyword))) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (nth-value 0 (ffi:size-of-foreign-type (cffi-type->mkcl-type type-keyword)))) (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (nth-value 1 (ffi:size-of-foreign-type (cffi-type->mkcl-type type-keyword)))) ;;;# Calling Foreign Functions #| (defconstant +mkcl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z") |# (defun produce-function-pointer-call (pointer types values return-type) #| (if (stringp pointer) (produce-function-pointer-call `(%foreign-symbol-pointer ,pointer nil) types values return-type) `(ffi:c-inline ,(list* pointer values) ,(list* :pointer-void types) ,return-type ,(with-output-to-string (s) (let ((types (mapcar #'mkcl-type->c-type types))) ;; On AMD64, the following code only works with the extra ;; argument ",...". If this is not present, functions ;; like sprintf do not work (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)" (mkcl-type->c-type return-type) types (subseq +mkcl-inline-codes+ 3 (max 3 (+ 2 (* (length values) 3))))))) :one-liner t :side-effects t)) |# ;; The version here below is definitely not as efficient as the one above ;; but it has the great vertue of working in all cases, (contrary to the ;; silent and unsafe limitations of the one above). JCB ;; I should re-optimize this one day, when I get time... JCB (progn (when (stringp pointer) (setf pointer `(%foreign-symbol-pointer ,pointer nil))) `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values)))) (defun foreign-funcall-parse-args (args) "Return three values, lists of arg types, values, and result type." (let ((return-type :void)) (loop for (type arg) on args by #'cddr if arg collect (cffi-type->mkcl-type type) into types and collect arg into values else do (setf return-type (cffi-type->mkcl-type type)) finally (return (values types values return-type))))) (defmacro %foreign-funcall (name args &key library convention) "Call a foreign function." (declare (ignore library convention)) (multiple-value-bind (types values return-type) (foreign-funcall-parse-args args) (produce-function-pointer-call name types values return-type))) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Funcall a pointer to a foreign function." (declare (ignore convention)) (multiple-value-bind (types values return-type) (foreign-funcall-parse-args args) (produce-function-pointer-call ptr types values return-type))) ;;;# Foreign Libraries (defun %load-foreign-library (name path) "Load a foreign library." (declare (ignore name)) (handler-case (si:load-foreign-module path) (file-error () (error "file error while trying to load `~A'" path)))) (defun %close-foreign-library (handle) ;;(declare (ignore handle)) ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.") (si:unload-foreign-module handle)) (defun native-namestring (pathname) (namestring pathname)) ;;;# Callbacks ;;; Create a package to contain the symbols for callback functions. ;;; We want to redefine callbacks with the same symbol so the internal ;;; data structures are reused. (defpackage #:cffi-callbacks (:use)) (defvar *callbacks* (make-hash-table)) ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the ;;; internal callback for NAME. (eval-when (:compile-toplevel :load-toplevel :execute) (defun intern-callback (name) (intern (format nil "~A::~A" (if-let (package (symbol-package name)) (package-name package) "#") (symbol-name name)) '#:cffi-callbacks))) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (declare (ignore convention)) (let ((cb-name (intern-callback name))) `(progn (ffi:defcallback (,cb-name :cdecl) ,(cffi-type->mkcl-type rettype) ,(mapcar #'list arg-names (mapcar #'cffi-type->mkcl-type arg-types)) ;;(block ,cb-name ,@body) (block ,cb-name ,body)) (setf (gethash ',name *callbacks*) ',cb-name)))) (defun %callback (name) (multiple-value-bind (symbol winp) (gethash name *callbacks*) (unless winp (error "Undefined callback: ~S" name)) (ffi:callback symbol))) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (values (ignore-errors (si:find-foreign-symbol name :default :pointer-void 0)))) cffi_0.19.0/src/cffi-mcl.lisp0000644000175000017500000003253013103031266014442 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-mcl.lisp --- CFFI-SYS implementation for Digitool MCL. ;;; ;;; Copyright 2010 james.anderson@setf.de ;;; Copyright 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; this is a stop-gap emulation. (at least) three things are not right ;;; - integer vector arguments are copied ;;; - return values are not typed ;;; - a shared library must be packaged as a framework and statically loaded ;;; ;;; on the topic of shared libraries, see ;;; http://developer.apple.com/library/mac/#documentation/DeveloperTools/Conceptual/MachOTopics/1-Articles/loading_code.html ;;; which describes how to package a shared library as a framework. ;;; once a framework exists, load it as, eg. ;;; (ccl::add-framework-bundle "fftw.framework" :pathname "ccl:frameworks;" ) ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:ccl) (:import-from #:alexandria #:once-only #:if-let) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp ; ccl:pointerp #:pointer-eq #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%mem-ref #:%mem-set #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Misfeatures (pushnew 'flat-namespace *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common ;;; usage when the memory has dynamic extent. (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (#_newPtr size)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." ;; TODO: Should we make this a dead macptr? (#_disposePtr ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let ((,size-var ,size)) (ccl:%stack-block ((,var ,size-var)) ,@body))) ;;;# Misc. Pointer Operations (deftype foreign-pointer () 'ccl:macptr) (defun null-pointer () "Construct and return a null pointer." (ccl:%null-ptr)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (ccl:%null-ptr-p ptr)) (defun inc-pointer (ptr offset) "Return a pointer OFFSET bytes past PTR." (ccl:%inc-ptr ptr offset)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (ccl:%ptr-eql ptr1 ptr2)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (ccl:%int-to-ptr address)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (ccl:%ptr-to-int ptr)) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes that can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) ;;; from openmcl::macros.lisp (defmacro with-pointer-to-vector-data ((ptr ivector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." (let* ((v (gensym)) (l (gensym))) `(let* ((,v ,ivector) (,l (length ,v))) (unless (typep ,v 'ccl::ivector) (ccl::report-bad-arg ,v 'ccl::ivector)) ;;;!!! this, unless it's possible to suppress gc (let ((,ptr (#_newPtr ,l))) (unwind-protect (progn (ccl::%copy-ivector-to-ptr ,v 0 ,ptr 0 ,l) (mutliple-value-prog1 (locally ,@body) (ccl::%copy-ptr-to-ivector ,ptr 0 ,v 0 ,l))) (#_disposePtr ,ptr)))))) ;;;# Dereferencing ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler ;;; macros that optimize the case where the type keyword is constant ;;; at compile-time. (defmacro define-mem-accessors (&body pairs) `(progn (defun %mem-ref (ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (,fn ptr offset))))) (defun %mem-set (value ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) (if (constantp type) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) (if (constantp type) (once-only (value) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) form)))) (define-mem-accessors (:char %get-signed-byte) (:unsigned-char %get-unsigned-byte) (:short %get-signed-word) (:unsigned-short %get-unsigned-word) (:int %get-signed-long) (:unsigned-int %get-unsigned-long) (:long %get-signed-long) (:unsigned-long %get-unsigned-long) (:long-long ccl::%get-signed-long-long) (:unsigned-long-long ccl::%get-unsigned-long-long) (:float %get-single-float) (:double %get-double-float) (:pointer %get-ptr)) (defun ccl::%get-unsigned-long-long (ptr offset) (let ((value 0) (bit 0)) (dotimes (i 8) (setf (ldb (byte 8 (shiftf bit (+ bit 8))) value) (ccl:%get-unsigned-byte ptr (+ offset i)))) value)) (setf (fdefinition 'ccl::%get-signed-long-long) (fdefinition 'ccl::%get-unsigned-long-long)) (defun (setf ccl::%get-unsigned-long-long) (value ptr offset) (let ((bit 0)) (dotimes (i 8) (setf (ccl:%get-unsigned-byte ptr (+ offset i)) (ldb (byte 8 (shiftf bit (+ bit 8))) value)))) ptr) (setf (fdefinition '(setf ccl::%get-signed-long-long)) (fdefinition '(setf ccl::%get-unsigned-long-long))) ;;;# Calling Foreign Functions (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to a ppc-ff-call type." (ecase type-keyword (:char :signed-byte) (:unsigned-char :unsigned-byte) (:short :signed-short) (:unsigned-short :unsigned-short) (:int :signed-fullword) (:unsigned-int :unsigned-fullword) (:long :signed-fullword) (:unsigned-long :unsigned-fullword) (:long-long :signed-doubleword) (:unsigned-long-long :unsigned-doubleword) (:float :single-float) (:double :double-float) (:pointer :address) (:void :void))) (defun ppc-ff-call-type=>mactype-name (type-keyword) (ecase type-keyword (:signed-byte :sint8) (:unsigned-byte :uint8) (:signed-short :sint16) (:unsigned-short :uint16) (:signed-halfword :sint16) (:unsigned-halfword :uint16) (:signed-fullword :sint32) (:unsigned-fullword :uint32) ;(:signed-doubleword :long-long) ;(:unsigned-doubleword :unsigned-long-long) (:single-float :single-float) (:double-float :double-float) (:address :pointer) (:void :void))) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (case type-keyword ((:long-long :unsigned-long-long) 8) (t (ccl::mactype-record-size (ccl::find-mactype (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword))))))) ;; There be dragons here. See the following thread for details: ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (case type-keyword ((:long-long :unsigned-long-long) 4) (t (ccl::mactype-record-size (ccl::find-mactype (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword))))))) (defun convert-foreign-funcall-types (args) "Convert foreign types for a call to FOREIGN-FUNCALL." (loop for (type arg) on args by #'cddr collect (convert-foreign-type type) if arg collect arg)) (defun convert-external-name (name) "no '_' is necessary here, the internal lookup operators handle it" name) (defmacro %foreign-funcall (function-name args &key library convention) "Perform a foreign function call, document it more later." (declare (ignore library convention)) `(ccl::ppc-ff-call (ccl::macho-address ,(ccl::get-macho-entry-point (convert-external-name function-name))) ,@(convert-foreign-funcall-types args))) (defmacro %foreign-funcall-pointer (ptr args &key convention) (declare (ignore convention)) `(ccl::ppc-ff-call ,ptr ,@(convert-foreign-funcall-types args))) ;;;# Callbacks ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr" ;;; entry points. It is safe to store the pointers directly because ;;; OpenMCL will update the address of these pointers when a saved image ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS). (defvar *callbacks* (make-hash-table)) ;;; Create a package to contain the symbols for callback functions. We ;;; want to redefine callbacks with the same symbol so the internal data ;;; structures are reused. (defpackage #:cffi-callbacks (:use)) ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal ;;; callback for NAME. (defun intern-callback (name) (intern (format nil "~A::~A" (if-let (package (symbol-package name)) (package-name package) "#") (symbol-name name)) '#:cffi-callbacks)) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (declare (ignore convention)) (let ((cb-name (intern-callback name))) `(progn (ccl::ppc-defpascal ,cb-name (;; ? ,@(when (eq convention :stdcall) '(:discard-stack-args)) ,@(mapcan (lambda (sym type) (list (ppc-ff-call-type=>mactype-name (convert-foreign-type type)) sym)) arg-names arg-types) ,(ppc-ff-call-type=>mactype-name (convert-foreign-type rettype))) ,body) (setf (gethash ',name *callbacks*) (symbol-value ',cb-name))))) (defun %callback (name) (or (gethash name *callbacks*) (error "Undefined callback: ~S" name))) ;;;# Loading Foreign Libraries (defun %load-foreign-library (name path) "Load the foreign library NAME." (declare (ignore path)) (setf name (string name)) ;; for mcl emulate this wrt frameworks (unless (and (> (length name) 10) (string-equal name ".framework" :start1 (- (length name) 10))) (setf name (concatenate 'string name ".framework"))) ;; if the framework was not registered, add it (unless (gethash name ccl::*framework-descriptors*) (ccl::add-framework-bundle name :pathname "ccl:frameworks;" )) (ccl::load-framework-bundle name)) (defun %close-foreign-library (name) "Close the foreign library NAME." ;; for mcl do nothing (declare (ignore name)) nil) (defun native-namestring (pathname) (ccl::posix-namestring (ccl:full-pathname pathname))) ;;;# Foreign Globals (deftrap-inline "_findsymbol" ((map :pointer) (name :pointer)) :pointer ()) (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (ccl::macho-address (ccl::get-macho-entry-point (convert-external-name name)))) cffi_0.19.0/src/package.lisp0000644000175000017500000001165613103031266014363 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; package.lisp --- Package definition for CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cl-user) (defpackage #:cffi (:use #:common-lisp #:cffi-sys #:babel-encodings) (:import-from #:alexandria #:compose #:ensure-list #:featurep #:format-symbol #:hash-table-values #:if-let #:ignore-some-conditions #:lastcar #:make-gensym-list #:make-keyword #:mappend #:once-only #:parse-body #:simple-style-warning #:symbolicate #:unwind-protect-case #:when-let #:with-unique-names) (:export ;; Types. #:foreign-pointer ;; FIXME: the following types are undocumented. They should ;; probably be replaced with a proper type introspection API ;; though. #:*built-in-foreign-types* #:*other-builtin-types* #:*built-in-integer-types* #:*built-in-float-types* ;; Primitive pointer operations. #:foreign-free #:foreign-alloc #:mem-aptr #:mem-aref #:mem-ref #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:incf-pointer #:with-foreign-pointer #:make-pointer #:pointer-address ;; Shareable vectors. #:make-shareable-byte-vector #:with-pointer-to-vector-data ;; Foreign string operations. #:*default-foreign-encoding* #:foreign-string-alloc #:foreign-string-free #:foreign-string-to-lisp #:lisp-string-to-foreign #:with-foreign-string #:with-foreign-strings #:with-foreign-pointer-as-string ;; Foreign array operations. ;; TODO: document these #:foreign-array-alloc #:foreign-array-free #:foreign-array-to-lisp #:lisp-array-to-foreign #:with-foreign-array #:foreign-aref ;; Foreign function operations. #:defcfun #:foreign-funcall #:foreign-funcall-pointer #:translate-camelcase-name #:translate-name-from-foreign #:translate-name-to-foreign #:translate-underscore-separated-name ;; Foreign library operations. #:*foreign-library-directories* #:*darwin-framework-directories* #:foreign-library #:foreign-library-name #:foreign-library-pathname #:foreign-library-type #:foreign-library-loaded-p #:list-foreign-libraries #:define-foreign-library #:load-foreign-library #:load-foreign-library-error #:use-foreign-library #:close-foreign-library #:reload-foreign-libraries ;; Callbacks. #:callback #:get-callback #:defcallback ;; Foreign type operations. #:defcstruct #:defcunion #:defctype #:defcenum #:defbitfield #:define-foreign-type #:define-parse-method #:define-c-struct-wrapper #:foreign-enum-keyword #:foreign-enum-keyword-list #:foreign-enum-value #:foreign-bitfield-symbol-list #:foreign-bitfield-symbols #:foreign-bitfield-value #:foreign-slot-pointer #:foreign-slot-value #:foreign-slot-type #:foreign-slot-offset #:foreign-slot-count #:foreign-slot-names #:foreign-type-alignment #:foreign-type-size #:with-foreign-object #:with-foreign-objects #:with-foreign-slots #:convert-to-foreign #:convert-from-foreign #:convert-into-foreign-memory #:free-converted-object #:translation-forms-for-class ;; Extensible foreign type operations. #:define-translation-method ; FIXME: undocumented #:translate-to-foreign #:translate-from-foreign #:translate-into-foreign-memory #:free-translated-object #:expand-to-foreign-dyn #:expand-to-foreign #:expand-from-foreign #:expand-into-foreign-memory ;; Foreign globals. #:defcvar #:get-var-pointer #:foreign-symbol-pointer )) cffi_0.19.0/src/cffi-lispworks.lisp0000644000175000017500000003705413103031266015732 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-lispworks.lisp --- Lispworks CFFI-SYS implementation. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:cl #:alexandria) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:defcfun-helper-forms #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Misfeatures #-lispworks-64bit (pushnew 'no-long-long *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Basic Pointer Operations (deftype foreign-pointer () 'fli::pointer) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (fli:pointerp ptr)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (fli:pointer-eq ptr1 ptr2)) ;; We use FLI:MAKE-POINTER here instead of FLI:*NULL-POINTER* since old ;; versions of Lispworks don't seem to have it. (defun null-pointer () "Return a null foreign pointer." (fli:make-pointer :address 0 :type :void)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (check-type ptr fli::pointer) (fli:null-pointer-p ptr)) ;; FLI:INCF-POINTER won't work on FLI pointers to :void so we ;; increment "manually." (defun inc-pointer (ptr offset) "Return a pointer OFFSET bytes past PTR." (fli:make-pointer :type :void :address (+ (fli:pointer-address ptr) offset))) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (fli:make-pointer :type :void :address address)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (fli:pointer-address ptr)) ;;;# Allocation (defun %foreign-alloc (size) "Allocate SIZE bytes of memory and return a pointer." (fli:allocate-foreign-object :type :byte :nelems size)) (defun foreign-free (ptr) "Free a pointer PTR allocated by FOREIGN-ALLOC." (fli:free-foreign-object ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. Both the pointer in VAR and the memory it points to have dynamic extent and may be stack allocated if supported by the implementation." (unless size-var (setf size-var (gensym "SIZE"))) `(fli:with-dynamic-foreign-objects () (let* ((,size-var ,size) (,var (fli:alloca :type :byte :nelems ,size-var))) ,@body))) ;;;# Shareable Vectors (defun make-shareable-byte-vector (size) "Create a shareable byte vector." #+(or lispworks3 lispworks4 lispworks5.0) (sys:in-static-area (make-array size :element-type '(unsigned-byte 8))) #-(or lispworks3 lispworks4 lispworks5.0) (make-array size :element-type '(unsigned-byte 8) :allocation :static)) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a pointer at the data in VECTOR." `(fli:with-dynamic-lisp-array-pointer (,ptr-var ,vector) ,@body)) ;;;# Dereferencing (defun convert-foreign-type (cffi-type) "Convert a CFFI type keyword to an FLI type." (ecase cffi-type (:char :byte) (:unsigned-char '(:unsigned :byte)) (:short :short) (:unsigned-short '(:unsigned :short)) (:int :int) (:unsigned-int '(:unsigned :int)) (:long :long) (:unsigned-long '(:unsigned :long)) ;; On 32-bit platforms, Lispworks 5.0+ supports long-long for ;; DEFCFUN and FOREIGN-FUNCALL. (:long-long '(:long :long)) (:unsigned-long-long '(:unsigned :long :long)) (:float :float) (:double :double) (:pointer :pointer) (:void :void))) ;;; Convert a CFFI type keyword to a symbol suitable for passing to ;;; FLI:FOREIGN-TYPED-AREF. #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (defun convert-foreign-typed-aref-type (cffi-type) (ecase cffi-type ((:char :short :int :long #+lispworks-64bit :long-long) `(signed-byte ,(* 8 (%foreign-type-size cffi-type)))) ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long #+lispworks-64bit :unsigned-long-long) `(unsigned-byte ,(* 8 (%foreign-type-size cffi-type)))) (:float 'single-float) (:double 'double-float))) (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of type TYPE OFFSET bytes from PTR." (unless (zerop offset) (setf ptr (inc-pointer ptr offset))) (fli:dereference ptr :type (convert-foreign-type type))) ;; Lispworks 5.0 on 64-bit platforms doesn't have [u]int64 support in ;; FOREIGN-TYPED-AREF. That was implemented in 5.1. #+(and lispworks-64bit lispworks5.0) (defun 64-bit-type-p (type) (member type '(:long :unsigned-long :long-long :unsigned-long-long))) ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF. #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) (if (constantp type) (let ((type (eval type))) (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type) (eql type :pointer)) (let ((fli-type (convert-foreign-type type)) (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))) `(fli:dereference ,ptr-form :type ',fli-type)) (let ((lisp-type (convert-foreign-typed-aref-type type))) `(locally (declare (optimize (speed 3) (safety 0))) (fli:foreign-typed-aref ',lisp-type ,ptr (the fixnum ,off)))))) form)) ;;; Open-code the call to FLI:DEREFERENCE when TYPE is constant at ;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available. #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) (if (constantp type) (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))) (type (convert-foreign-type (eval type)))) `(fli:dereference ,ptr-form :type ',type)) form)) (defun %mem-set (value ptr type &optional (offset 0)) "Set the object of TYPE at OFFSET bytes from PTR." (unless (zerop offset) (setf ptr (inc-pointer ptr offset))) (setf (fli:dereference ptr :type (convert-foreign-type type)) value)) ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET. #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0)) (if (constantp type) (once-only (val) (let ((type (eval type))) (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type) (eql type :pointer)) (let ((fli-type (convert-foreign-type type)) (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))) `(setf (fli:dereference ,ptr-form :type ',fli-type) ,val)) (let ((lisp-type (convert-foreign-typed-aref-type type))) `(locally (declare (optimize (speed 3) (safety 0))) (setf (fli:foreign-typed-aref ',lisp-type ,ptr (the fixnum ,off)) ,val)))))) form)) ;;; Open-code the call to (SETF FLI:DEREFERENCE) when TYPE is constant ;;; at macroexpansion time. #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0)) (if (constantp type) (once-only (val) (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))) (type (convert-foreign-type (eval type)))) `(setf (fli:dereference ,ptr-form :type ',type) ,val))) form)) ;;;# Foreign Type Operations (defun %foreign-type-size (type) "Return the size in bytes of a foreign type." (fli:size-of (convert-foreign-type type))) (defun %foreign-type-alignment (type) "Return the structure alignment in bytes of foreign type." #+(and darwin harp::powerpc) (when (eq type :double) (return-from %foreign-type-alignment 8)) ;; Override not necessary for the remaining types... (fli:align-of (convert-foreign-type type))) ;;;# Calling Foreign Functions (defvar *foreign-funcallable-cache* (make-hash-table :test 'equal) "Caches foreign funcallables created by %FOREIGN-FUNCALL or %FOREIGN-FUNCALL-POINTER. We only need to have one per each signature.") (defun foreign-funcall-type-and-args (args) "Returns a list of types, list of args and return type." (let ((return-type :void)) (loop for (type arg) on args by #'cddr if arg collect (convert-foreign-type type) into types and collect arg into fargs else do (setf return-type (convert-foreign-type type)) finally (return (values types fargs return-type))))) (defun create-foreign-funcallable (types rettype convention) "Creates a foreign funcallable for the signature TYPES -> RETTYPE." #+mac (declare (ignore convention)) (format t "~&Creating foreign funcallable for signature ~S -> ~S~%" types rettype) ;; yes, ugly, this most likely wants to be a top-level form... (let ((internal-name (gensym))) (funcall (compile nil `(lambda () (fli:define-foreign-funcallable ,internal-name ,(loop for type in types collect (list (gensym) type)) :result-type ,rettype :language :ansi-c ;; avoid warning about cdecl not being supported on mac #-mac ,@(list :calling-convention convention))))) internal-name)) (defun get-foreign-funcallable (types rettype convention) "Returns a foreign funcallable for the signature TYPES -> RETTYPE - either from the cache or newly created." (let ((signature (cons rettype types))) (or (gethash signature *foreign-funcallable-cache*) ;; (SETF GETHASH) is supposed to be thread-safe (setf (gethash signature *foreign-funcallable-cache*) (create-foreign-funcallable types rettype convention))))) (defmacro %%foreign-funcall (foreign-function args convention) "Does the actual work for %FOREIGN-FUNCALL-POINTER and %FOREIGN-FUNCALL. Checks if a foreign funcallable which fits ARGS already exists and creates and caches it if necessary. Finally calls it." (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(funcall (load-time-value (get-foreign-funcallable ',types ',rettype ',convention)) ,foreign-function ,@fargs))) (defmacro %foreign-funcall (name args &key library convention) "Calls a foreign function named NAME passing arguments ARGS." `(%%foreign-funcall (fli:make-pointer :symbol-name ,name :module ',(if (eq library :default) nil library)) ,args ,convention)) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Calls a foreign function pointed at by PTR passing arguments ARGS." `(%%foreign-funcall ,ptr ,args ,convention)) (defun defcfun-helper-forms (name lisp-name rettype args types options) "Return 2 values for DEFCFUN. A prelude form and a caller form." (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name)))) (values `(fli:define-foreign-function (,ff-name ,name :source) ,(mapcar (lambda (ty) (list (gensym) (convert-foreign-type ty))) types) :result-type ,(convert-foreign-type rettype) :language :ansi-c :module ',(let ((lib (getf options :library))) (if (eq lib :default) nil lib)) ;; avoid warning about cdecl not being supported on mac platforms #-mac ,@(list :calling-convention (getf options :convention))) `(,ff-name ,@args)))) ;;;# Callbacks (defvar *callbacks* (make-hash-table)) ;;; Create a package to contain the symbols for callback functions. We ;;; want to redefine callbacks with the same symbol so the internal data ;;; structures are reused. (defpackage #:cffi-callbacks (:use)) ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal ;;; callback for NAME. (eval-when (:compile-toplevel :load-toplevel :execute) (defun intern-callback (name) (intern (format nil "~A::~A" (if-let (package (symbol-package name)) (package-name package) "#") (symbol-name name)) '#:cffi-callbacks))) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (let ((cb-name (intern-callback name))) `(progn (fli:define-foreign-callable (,cb-name :encode :lisp :result-type ,(convert-foreign-type rettype) :calling-convention ,convention :language :ansi-c :no-check nil) ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types) ,body) (setf (gethash ',name *callbacks*) ',cb-name)))) (defun %callback (name) (multiple-value-bind (symbol winp) (gethash name *callbacks*) (unless winp (error "Undefined callback: ~S" name)) (fli:make-pointer :symbol-name symbol :module :callbacks))) ;;;# Loading Foreign Libraries (defun %load-foreign-library (name path) "Load the foreign library NAME." (fli:register-module (or name path) :connection-style :immediate :real-name path)) (defun %close-foreign-library (name) "Close the foreign library NAME." (fli:disconnect-module name :remove t)) (defun native-namestring (pathname) (namestring pathname)) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (values (ignore-errors (fli:make-pointer :symbol-name name :type :void :module (if (eq library :default) nil library))))) cffi_0.19.0/src/features.lisp0000644000175000017500000000757513103031266014613 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; features.lisp --- CFFI-specific features (DEPRECATED). ;;; ;;; Copyright (C) 2006-2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :cffi *features*)) ;;; CFFI-SYS backends take care of pushing the appropriate features to ;;; *features*. See each cffi-*.lisp file. ;;; ;;; Not anymore, I think we should use TRIVIAL-FEATURES for the ;;; platform features instead. Less pain. CFFI-FEATURES is now ;;; deprecated and this code will stay here for a while for backwards ;;; compatibility purposes, to be removed in a future release. (defpackage #:cffi-features (:use #:cl) (:export #:cffi-feature-p ;; Features related to the CFFI-SYS backend. Why no-*? This ;; reflects the hope that these symbols will go away completely ;; meaning that at some point all lisps will support long-longs, ;; the foreign-funcall primitive, etc... #:no-long-long #:no-foreign-funcall #:no-stdcall #:flat-namespace ;; Only SCL supports long-double... ;;#:no-long-double ;; Features related to the operating system. ;; More should be added. #:darwin #:unix #:windows ;; Features related to the processor. ;; More should be added. #:ppc32 #:x86 #:x86-64 #:sparc #:sparc64 #:hppa #:hppa64)) (in-package #:cffi-features) (defun cffi-feature-p (feature-expression) "Matches a FEATURE-EXPRESSION against those symbols in *FEATURES* that belong to the CFFI-FEATURES package." (when (eql feature-expression t) (return-from cffi-feature-p t)) (let ((features-package (find-package '#:cffi-features))) (flet ((cffi-feature-eq (name feature-symbol) (and (eq (symbol-package feature-symbol) features-package) (string= name (symbol-name feature-symbol))))) (etypecase feature-expression (symbol (not (null (member (symbol-name feature-expression) *features* :test #'cffi-feature-eq)))) (cons (ecase (first feature-expression) (:and (every #'cffi-feature-p (rest feature-expression))) (:or (some #'cffi-feature-p (rest feature-expression))) (:not (not (cffi-feature-p (cadr feature-expression)))))))))) ;;; for backwards compatibility (mapc (lambda (sym) (pushnew sym *features*)) '(#+darwin darwin #+unix unix #+windows windows #+ppc ppc32 #+x86 x86 #+x86-64 x86-64 #+sparc sparc #+sparc64 sparc64 #+hppa hppa #+hppa64 hppa64 #+cffi-sys::no-long-long no-long-long #+cffi-sys::flat-namespace flat-namespace #+cffi-sys::no-foreign-funcall no-foreign-funcall #+cffi-sys::no-stdcall no-stdcall )) cffi_0.19.0/src/cffi-ecl.lisp0000644000175000017500000003732013103031266014434 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-ecl.lisp --- ECL backend for CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:alexandria) (:import-from #:si #:null-pointer-p) (:export #:*cffi-ecl-method* #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%mem-ref #:%mem-set #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%defcallback #:%callback #:%foreign-symbol-pointer)) (in-package #:cffi-sys) ;;; ;;; ECL allows many ways of calling a foreign function, and also many ;;; ways of finding the pointer associated to a function name. They ;;; depend on whether the FFI relies on libffi or on the C/C++ compiler, ;;; and whether they use the shared library loader to locate symbols ;;; or they are linked by the linker. ;;; ;;; :DFFI ;;; ;;; ECL uses libffi to call foreign functions. The only way to find out ;;; foreign symbols is by loading shared libraries and using dlopen() ;;; or similar. ;;; ;;; :DLOPEN ;;; ;;; ECL compiles FFI code as C/C++ statements. The names are resolved ;;; at run time by the shared library loader every time the function ;;; is called ;;; ;;; :C/C++ ;;; ;;; ECL compiles FFI code as C/C++ statements, but the name resolution ;;; happens at link time. In this case you have to tell the ECL ;;; compiler which are the right ld-flags (c:*ld-flags*) to link in ;;; the library. ;;; (defvar *cffi-ecl-method* #+dffi :dffi #+(and dlopen (not dffi)) :dlopen #-(or dffi dlopen) :c/c++ "The type of code that CFFI generates for ECL: :DFFI when using the dynamical foreign function interface; :DLOPEN when using C code and dynamical references to symbols; :C/C++ for C/C++ code with static references to symbols.") ;;;# Mis-features #-long-long (pushnew 'no-long-long *features*) (pushnew 'flat-namespace *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Allocation (defun %foreign-alloc (size) "Allocate SIZE bytes of foreign-addressable memory." (si:allocate-foreign-data :void size)) (defun foreign-free (ptr) "Free a pointer PTR allocated by FOREIGN-ALLOC." (si:free-foreign-data ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect (progn ,@body) (foreign-free ,var)))) ;;;# Misc. Pointer Operations (deftype foreign-pointer () 'si:foreign-data) (defun null-pointer () "Construct and return a null pointer." (si:allocate-foreign-data :void 0)) (defun inc-pointer (ptr offset) "Return a pointer OFFSET bytes past PTR." (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void)) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (typep ptr 'si:foreign-data)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2))) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (ffi:make-pointer address :void)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (ffi:pointer-address ptr)) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes that can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." `(let ((,ptr-var (si:make-foreign-data-from-array ,vector))) ,@body)) ;;;# Type Operations (defconstant +translation-table+ '((:char :byte "char") (:unsigned-char :unsigned-byte "unsigned char") (:short :short "short") (:unsigned-short :unsigned-short "unsigned short") (:int :int "int") (:unsigned-int :unsigned-int "unsigned int") (:long :long "long") (:unsigned-long :unsigned-long "unsigned long") #+long-long (:long-long :long-long "long long") #+long-long (:unsigned-long-long :unsigned-long-long "unsigned long long") (:float :float "float") (:double :double "double") (:pointer :pointer-void "void*") (:void :void "void"))) (defun cffi-type->ecl-type (type-keyword) "Convert a CFFI type keyword to an ECL type keyword." (or (second (find type-keyword +translation-table+ :key #'first)) (error "~S is not a valid CFFI type" type-keyword))) (defun ecl-type->c-type (type-keyword) "Convert a CFFI type keyword to an valid C type keyword." (or (third (find type-keyword +translation-table+ :key #'second)) (error "~S is not a valid CFFI type" type-keyword))) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (nth-value 0 (ffi:size-of-foreign-type (cffi-type->ecl-type type-keyword)))) (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (nth-value 1 (ffi:size-of-foreign-type (cffi-type->ecl-type type-keyword)))) ;;;# Dereferencing (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of TYPE at OFFSET bytes from PTR." (let* ((type (cffi-type->ecl-type type)) (type-size (ffi:size-of-foreign-type type))) (si:foreign-data-ref-elt (si:foreign-data-recast ptr (+ offset type-size) :void) offset type))) (defun %mem-set (value ptr type &optional (offset 0)) "Set an object of TYPE at OFFSET bytes from PTR." (let* ((type (cffi-type->ecl-type type)) (type-size (ffi:size-of-foreign-type type))) (si:foreign-data-set-elt (si:foreign-data-recast ptr (+ offset type-size) :void) offset type value))) ;;; Inline versions that use C expressions instead of function calls. (defparameter +mem-ref-strings+ (loop for (cffi-type ecl-type c-string) in +translation-table+ for string = (format nil "*((~A *)(((char*)#0)+#1))" c-string) collect (list cffi-type ecl-type string))) (defparameter +mem-set-strings+ (loop for (cffi-type ecl-type c-string) in +translation-table+ for string = (format nil "*((~A *)(((char*)#0)+#1))=#2" c-string) collect (list cffi-type ecl-type string))) (define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset 0)) (if (and (constantp type) (constantp offset)) (let ((record (assoc (eval type) +mem-ref-strings+))) `(ffi:c-inline (,ptr ,offset) (:pointer-void :cl-index) ; argument types ,(second record) ; return type ,(third record) ; the precomputed expansion :one-liner t)) whole)) (define-compiler-macro %mem-set (&whole whole value ptr type &optional (offset 0)) (if (and (constantp type) (constantp offset)) (let ((record (assoc (eval type) +mem-set-strings+))) `(ffi:c-inline (,ptr ,offset ,value) ; arguments with type translated (:pointer-void :cl-index ,(second record)) :void ; does not return anything ,(third record) ; precomputed expansion :one-liner t)) whole)) ;;;# Calling Foreign Functions (defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z") (defun c-inline-function-pointer-call (pointer types values return-type) (cond ((not (stringp pointer)) `(ffi:c-inline ,(list* pointer values) ,(list* :pointer-void types) ,return-type ,(with-output-to-string (s) (let ((types (mapcar #'ecl-type->c-type types))) ;; On AMD64, the following code only works with the extra ;; argument ",...". If this is not present, functions ;; like sprintf do not work (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)" (ecl-type->c-type return-type) types (subseq +ecl-inline-codes+ 3 (max 3 (+ 2 (* (length values) 3))))))) :one-liner t :side-effects t)) ((eq *cffi-ecl-method* :c/c++) `(ffi:c-inline ,values ,types ,return-type ,(with-output-to-string (s) (let ((types (mapcar #'ecl-type->c-type types))) ;; On AMD64, the following code only works with the extra ;; argument ",...". If this is not present, functions ;; like sprintf do not work (format s "{ extern ~A ~A(~@[~{~A~^, ~}~]); ~A~A(~A); }" (ecl-type->c-type return-type) pointer types (if (eq return-type :void) "" "@(return) = ") pointer (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3))))))) :one-liner nil :side-effects t)) (t (c-inline-function-pointer-call `(%foreign-symbol-pointer ,pointer nil) types values return-type)))) (defun dffi-function-pointer-call (pointer types values return-type) (when (stringp pointer) (setf pointer `(%foreign-symbol-pointer ,pointer nil))) #-dffi `(error "In interpreted code, attempted to call a foreign function~% ~A~%~ but ECL was built without support for that." ,pointer) #+dffi `(si::call-cfun ,pointer ,return-type (list ,@types) (list ,@values))) #.(cl:when (>= ext:+ecl-version-number+ 100402) (cl:pushnew :ecl-with-backend cl:*features*) cl:nil) (defun produce-function-pointer-call (pointer types values return-type) #-ecl-with-backend (progn (if (eq *cffi-ecl-method* :dffi) (dffi-function-pointer-call pointer types values return-type) (c-inline-function-pointer-call pointer types values return-type))) #+ecl-with-backend `(ext:with-backend :bytecodes ,(dffi-function-pointer-call pointer types values return-type) :c/c++ (if (eq *cffi-ecl-method* :dffi) ,(dffi-function-pointer-call pointer types values return-type) ,(c-inline-function-pointer-call pointer types values return-type)))) (defun foreign-funcall-parse-args (args) "Return three values, lists of arg types, values, and result type." (let ((return-type :void)) (loop for (type arg) on args by #'cddr if arg collect (cffi-type->ecl-type type) into types and collect arg into values else do (setf return-type (cffi-type->ecl-type type)) finally (return (values types values return-type))))) (defmacro %foreign-funcall (name args &key library convention) "Call a foreign function." (declare (ignore library convention)) (multiple-value-bind (types values return-type) (foreign-funcall-parse-args args) (produce-function-pointer-call name types values return-type))) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Funcall a pointer to a foreign function." (declare (ignore convention)) (multiple-value-bind (types values return-type) (foreign-funcall-parse-args args) (produce-function-pointer-call ptr types values return-type))) ;;;# Foreign Libraries (defun %load-foreign-library (name path) "Load a foreign library." (declare (ignore name)) #-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~ FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.") #+dffi (handler-case (si:load-foreign-module path) (file-error () (error "file error while trying to load `~A'" path)))) (defun %close-foreign-library (handle) "Close a foreign library." (handler-case (si::unload-foreign-module handle) (undefined-function () (restart-case (error "Detected ECL prior to version 15.2.21. ~ Function CFFI:CLOSE-FOREIGN-LIBRARY isn't implemented yet.") (ignore () :report "Continue anyway (foreign library will remain opened)."))))) (defun native-namestring (pathname) (namestring pathname)) ;;;# Callbacks ;;; Create a package to contain the symbols for callback functions. ;;; We want to redefine callbacks with the same symbol so the internal ;;; data structures are reused. (defpackage #:cffi-callbacks (:use)) (defvar *callbacks* (make-hash-table)) ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the ;;; internal callback for NAME. (eval-when (:compile-toplevel :load-toplevel :execute) (defun intern-callback (name) (intern (format nil "~A::~A" (if-let (package (symbol-package name)) (package-name package) "#") (symbol-name name)) '#:cffi-callbacks))) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (declare (ignore convention)) (let ((cb-name (intern-callback name)) (cb-type #.(if (> ext:+ecl-version-number+ 160102) :default :cdecl))) `(progn (ffi:defcallback (,cb-name ,cb-type) ,(cffi-type->ecl-type rettype) ,(mapcar #'list arg-names (mapcar #'cffi-type->ecl-type arg-types)) ,body) (setf (gethash ',name *callbacks*) ',cb-name)))) (defun %callback (name) (multiple-value-bind (symbol winp) (gethash name *callbacks*) (unless winp (error "Undefined callback: ~S" name)) (ffi:callback symbol))) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (handler-case (si:find-foreign-symbol (coerce name 'base-string) :default :pointer-void 0) (error (c) nil))) cffi_0.19.0/src/cffi-clisp.lisp0000644000175000017500000003711513103031266015005 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2006, Joerg Hoehle ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:alexandria) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback)) (in-package #:cffi-sys) (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package :ffi) (error "CFFI requires CLISP compiled with dynamic FFI support."))) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Built-In Foreign Types (defun convert-foreign-type (type) "Convert a CFFI built-in type keyword to a CLisp FFI type." (ecase type (:char 'ffi:char) (:unsigned-char 'ffi:uchar) (:short 'ffi:short) (:unsigned-short 'ffi:ushort) (:int 'ffi:int) (:unsigned-int 'ffi:uint) (:long 'ffi:long) (:unsigned-long 'ffi:ulong) (:long-long 'ffi:sint64) (:unsigned-long-long 'ffi:uint64) (:float 'ffi:single-float) (:double 'ffi:double-float) ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now ;; we have a workaround in the pointer operations... (:pointer 'ffi:c-pointer) (:void nil))) (defun %foreign-type-size (type) "Return the size in bytes of objects having foreign type TYPE." (nth-value 0 (ffi:sizeof (convert-foreign-type type)))) ;; Remind me to buy a beer for whoever made getting the alignment ;; of foreign types part of the public interface in CLisp. :-) (defun %foreign-type-alignment (type) "Return the structure alignment in bytes of foreign TYPE." #+(and darwin ppc) (case type ((:double :long-long :unsigned-long-long) (return-from %foreign-type-alignment 8))) ;; Override not necessary for the remaining types... (nth-value 1 (ffi:sizeof (convert-foreign-type type)))) ;;;# Basic Pointer Operations (deftype foreign-pointer () 'ffi:foreign-address) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (typep ptr 'ffi:foreign-address)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (eql (ffi:foreign-address-unsigned ptr1) (ffi:foreign-address-unsigned ptr2))) (defun null-pointer () "Return a null foreign pointer." (ffi:unsigned-foreign-address 0)) (defun null-pointer-p (ptr) "Return true if PTR is a null foreign pointer." (zerop (ffi:foreign-address-unsigned ptr))) (defun inc-pointer (ptr offset) "Return a pointer pointing OFFSET bytes past PTR." (ffi:unsigned-foreign-address (+ offset (ffi:foreign-address-unsigned ptr)))) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (ffi:unsigned-foreign-address address)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (ffi:foreign-address-unsigned ptr)) ;;;# Foreign Memory Allocation (defun %foreign-alloc (size) "Allocate SIZE bytes of foreign-addressable memory and return a pointer to the allocated block. An implementation-specific error is signalled if the memory cannot be allocated." (ffi:foreign-address (ffi:allocate-shallow 'ffi:uint8 :count (if (zerop size) 1 size)))) (defun foreign-free (ptr) "Free a pointer PTR allocated by FOREIGN-ALLOC. The results are undefined if PTR is used after being freed." (ffi:foreign-free ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to a pointer to SIZE bytes of foreign-addressable memory during BODY. Both PTR and the memory block pointed to have dynamic extent and may be stack allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) (let ((obj-var (gensym))) `(let ((,size-var ,size)) (ffi:with-foreign-object (,obj-var `(ffi:c-array ffi:uint8 ,,size-var)) (let ((,var (ffi:foreign-address ,obj-var))) ,@body))))) ;;;# Memory Access ;;; %MEM-REF and its compiler macro work around CLISP's FFI:C-POINTER ;;; type and convert NILs back to null pointers. (defun %mem-ref (ptr type &optional (offset 0)) "Dereference a pointer OFFSET bytes from PTR to an object of built-in foreign TYPE. Returns the object as a foreign pointer or Lisp number." (let ((value (ffi:memory-as ptr (convert-foreign-type type) offset))) (if (eq type :pointer) (or value (null-pointer)) value))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) "Compiler macro to open-code when TYPE is constant." (if (constantp type) (let* ((ftype (convert-foreign-type (eval type))) (form `(ffi:memory-as ,ptr ',ftype ,offset))) (if (eq type :pointer) `(or ,form (null-pointer)) form)) form)) (defun %mem-set (value ptr type &optional (offset 0)) "Set a pointer OFFSET bytes from PTR to an object of built-in foreign TYPE to VALUE." (setf (ffi:memory-as ptr (convert-foreign-type type) offset) value)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) (if (constantp type) ;; (setf (ffi:memory-as) value) is exported, but not so nice ;; w.r.t. the left to right evaluation rule `(ffi::write-memory-as ,value ,ptr ',(convert-foreign-type (eval type)) ,offset) form)) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (declaim (inline make-shareable-byte-vector)) (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) (deftype shareable-byte-vector () `(vector (unsigned-byte 8))) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." (with-unique-names (vector-var size-var) `(let ((,vector-var ,vector)) (check-type ,vector-var shareable-byte-vector) (with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var) ;; copy-in (loop for i below ,size-var do (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i)) (unwind-protect (progn ,@body) ;; copy-out (loop for i below ,size-var do (setf (aref ,vector-var i) (%mem-ref ,ptr-var :unsigned-char i)))))))) ;;;# Foreign Function Calling (defun parse-foreign-funcall-args (args) "Return three values, a list of CLISP FFI types, a list of values to pass to the function, and the CLISP FFI return type." (let ((return-type nil)) (loop for (type arg) on args by #'cddr if arg collect (list (gensym) (convert-foreign-type type)) into types and collect arg into fargs else do (setf return-type (convert-foreign-type type)) finally (return (values types fargs return-type))))) (defun convert-calling-convention (convention) (ecase convention (:stdcall :stdc-stdcall) (:cdecl :stdc))) (defun c-function-type (arg-types rettype convention) "Generate the apropriate CLISP foreign type specification. Also takes care of converting the calling convention names." `(ffi:c-function (:arguments ,@arg-types) (:return-type ,rettype) (:language ,(convert-calling-convention convention)))) ;;; Quick hack around the fact that the CFFI package is not yet ;;; defined when this file is loaded. I suppose we could arrange for ;;; the CFFI package to be defined a bit earlier, though. (defun library-handle-form (name) (flet ((find-cffi-symbol (symbol) (find-symbol (symbol-name symbol) '#:cffi))) `(,(find-cffi-symbol '#:foreign-library-handle) (,(find-cffi-symbol '#:get-foreign-library) ',name)))) (eval-when (:compile-toplevel :load-toplevel :execute) ;; version 2.40 (CVS 2006-09-03, to be more precise) added a ;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION. (defun post-2.40-ffi-interface-p () (let ((f-l-f (find-symbol (string '#:foreign-library-function) '#:ffi))) (if (and f-l-f (= (length (ext:arglist f-l-f)) 5)) '(:and) '(:or)))) ;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE ;; were deprecated in 2.41 and removed in 2.45. (defun post-2.45-ffi-interface-p () (if (find-symbol (string '#:foreign-library-function) '#:ffi) '(:or) '(:and)))) #+#.(cffi-sys::post-2.45-ffi-interface-p) (defun %foreign-funcall-aux (name type library) `(ffi::find-foreign-function ,name ,type nil ,library nil nil)) #-#.(cffi-sys::post-2.45-ffi-interface-p) (defun %foreign-funcall-aux (name type library) `(ffi::foreign-library-function ,name ,library nil #+#.(cffi-sys::post-2.40-ffi-interface-p) nil ,type)) (defmacro %foreign-funcall (name args &key library convention) "Invoke a foreign function called NAME, taking pairs of foreign-type/value pairs from ARGS. If a single element is left over at the end of ARGS, it specifies the foreign return type of the function call." (multiple-value-bind (types fargs rettype) (parse-foreign-funcall-args args) (let* ((fn (%foreign-funcall-aux name `(ffi:parse-c-type ',(c-function-type types rettype convention)) (if (eq library :default) :default (library-handle-form library)))) (form `(funcall (load-time-value (handler-case ,fn (error (err) (warn "~A" err)))) ,@fargs))) (if (eq rettype 'ffi:c-pointer) `(or ,form (null-pointer)) form)))) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Similar to %foreign-funcall but takes a pointer instead of a string." (multiple-value-bind (types fargs rettype) (parse-foreign-funcall-args args) `(funcall (ffi:foreign-function ,ptr (load-time-value (ffi:parse-c-type ',(c-function-type types rettype convention)))) ,@fargs))) ;;;# Callbacks ;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK ;;; macro. The symbol naming the callback is the key, and the value ;;; is a list containing a Lisp function, the parsed CLISP FFI type of ;;; the callback, and a saved pointer that should not persist across ;;; saved images. (defvar *callbacks* (make-hash-table)) ;;; Return a CLISP FFI function type for a CFFI callback function ;;; given a return type and list of argument names and types. (eval-when (:compile-toplevel :load-toplevel :execute) (defun callback-type (rettype arg-names arg-types convention) (ffi:parse-c-type `(ffi:c-function (:arguments ,@(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types)) (:return-type ,(convert-foreign-type rettype)) (:language ,(convert-calling-convention convention)))))) ;;; Register and create a callback function. (defun register-callback (name function parsed-type) (setf (gethash name *callbacks*) (list function parsed-type (ffi:with-foreign-object (ptr 'ffi:c-pointer) ;; Create callback by converting Lisp function to foreign (setf (ffi:memory-as ptr parsed-type) function) (ffi:foreign-value ptr))))) ;;; Restore all saved callback pointers when restarting the Lisp ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*. ;;; Needs clisp > 2.35, bugfix 2005-09-29 (defun restore-callback-pointers () (maphash (lambda (name list) (register-callback name (first list) (second list))) *callbacks*)) ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run ;;; when an image is restarted. (eval-when (:load-toplevel :execute) (pushnew 'restore-callback-pointers custom:*init-hooks*)) ;;; Define a callback function NAME to run BODY with arguments ;;; ARG-NAMES translated according to ARG-TYPES and the return type ;;; translated according to RETTYPE. Obtain a pointer that can be ;;; passed to C code for this callback by calling %CALLBACK. (defmacro %defcallback (name rettype arg-names arg-types body &key convention) `(register-callback ',name (lambda ,arg-names ;; Work around CLISP's FFI:C-POINTER type and convert NIL values ;; back into a null pointers. (let (,@(loop for name in arg-names and type in arg-types when (eq type :pointer) collect `(,name (or ,name (null-pointer))))) ,body)) ,(callback-type rettype arg-names arg-types convention))) ;;; Look up the name of a callback and return a pointer that can be ;;; passed to a C function. Signals an error if no callback is ;;; defined called NAME. (defun %callback (name) (multiple-value-bind (list winp) (gethash name *callbacks*) (unless winp (error "Undefined callback: ~S" name)) (third list))) ;;;# Loading and Closing Foreign Libraries (defun %load-foreign-library (name path) "Load a foreign library from PATH." (declare (ignore name)) #+#.(cffi-sys::post-2.45-ffi-interface-p) (ffi:open-foreign-library path) #-#.(cffi-sys::post-2.45-ffi-interface-p) (ffi::foreign-library path)) (defun %close-foreign-library (handle) "Close a foreign library." (ffi:close-foreign-library handle)) (defun native-namestring (pathname) (namestring pathname)) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (prog1 (ignore-errors (ffi:foreign-address #+#.(cffi-sys::post-2.45-ffi-interface-p) (ffi::find-foreign-variable name nil library nil nil) #-#.(cffi-sys::post-2.45-ffi-interface-p) (ffi::foreign-library-variable name library nil nil))))) cffi_0.19.0/src/foreign-vars.lisp0000644000175000017500000000774213103031266015373 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; foreign-vars.lisp --- High-level interface to foreign globals. ;;; ;;; Copyright (C) 2005-2008, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;;;# Accessing Foreign Globals ;;; Called by FOREIGN-OPTIONS in functions.lisp. (defun parse-defcvar-options (options) (destructuring-bind (&key (library :default) read-only) options (list :library library :read-only read-only))) (defun get-var-pointer (symbol) "Return a pointer to the foreign global variable relative to SYMBOL." (foreign-symbol-pointer (get symbol 'foreign-var-name) :library (get symbol 'foreign-var-library))) ;;; Note: this will lookup not only variables but also functions. (defun foreign-symbol-pointer (name &key (library :default)) (check-type name string) (%foreign-symbol-pointer name (if (eq library :default) :default (foreign-library-handle (get-foreign-library library))))) (defun fs-pointer-or-lose (foreign-name library) "Like foreign-symbol-ptr but throws an error instead of returning nil when foreign-name is not found." (or (foreign-symbol-pointer foreign-name :library library) (error "Trying to access undefined foreign variable ~S." foreign-name))) (defmacro defcvar (name-and-options type &optional documentation) "Define a foreign global variable." (multiple-value-bind (lisp-name foreign-name options) (parse-name-and-options name-and-options t) (let ((fn (symbolicate '#:%var-accessor- lisp-name)) (read-only (getf options :read-only)) (library (getf options :library))) ;; We can't really setf an aggregate type. (when (aggregatep (parse-type type)) (setq read-only t)) `(progn (setf (documentation ',lisp-name 'variable) ,documentation) ;; Save foreign-name and library for posterior access by ;; GET-VAR-POINTER. (setf (get ',lisp-name 'foreign-var-name) ,foreign-name) (setf (get ',lisp-name 'foreign-var-library) ',library) ;; Getter (defun ,fn () (mem-ref (fs-pointer-or-lose ,foreign-name ',library) ',type)) ;; Setter (defun (setf ,fn) (value) ,(if read-only '(declare (ignore value)) (values)) ,(if read-only `(error ,(format nil "Trying to modify read-only foreign var: ~A." lisp-name)) `(setf (mem-ref (fs-pointer-or-lose ,foreign-name ',library) ',type) value))) ;; While most Lisps already expand DEFINE-SYMBOL-MACRO to an ;; EVAL-WHEN form like this, that is not required by the ;; standard so we do it ourselves. (eval-when (:compile-toplevel :load-toplevel :execute) (define-symbol-macro ,lisp-name (,fn))))))) cffi_0.19.0/src/structures.lisp0000644000175000017500000001515413103031266015210 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; structures.lisp --- Methods for translating foreign structures. ;;; ;;; Copyright (C) 2011, Liam M. Healy ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;;; Definitions for conversion of foreign structures. (defmethod translate-into-foreign-memory ((object list) (type foreign-struct-type) p) (unless (bare-struct-type-p type) (loop for (name value) on object by #'cddr do (setf (foreign-slot-value p (unparse-type type) name) (let ((slot (gethash name (structure-slots type)))) (convert-to-foreign value (slot-type slot))))))) (defmethod translate-to-foreign (value (type foreign-struct-type)) (let ((ptr (foreign-alloc type))) (translate-into-foreign-memory value type ptr) ptr)) (defmethod translate-from-foreign (p (type foreign-struct-type)) ;; Iterate over slots, make plist (if (bare-struct-type-p type) p (let ((plist (list))) (loop for slot being the hash-value of (structure-slots type) for name = (slot-name slot) do (setf (getf plist name) (foreign-struct-slot-value p slot))) plist))) (defmethod free-translated-object (ptr (type foreign-struct-type) freep) (unless (bare-struct-type-p type) ;; Look for any pointer slots and free them first (loop for slot being the hash-value of (structure-slots type) when (and (listp (slot-type slot)) (eq (first (slot-type slot)) :pointer)) do ;; Free if the pointer is to a specific type, not generic :pointer (free-translated-object (foreign-slot-value ptr type (slot-name slot)) (rest (slot-type slot)) freep)) (foreign-free ptr))) (defmacro define-translation-method ((object type method) &body body) "Define a translation method for the foreign structure type; 'method is one of :into, :from, or :to, meaning relation to foreign memory. If :into, the variable 'pointer is the foreign pointer. Note: type must be defined and loaded before this macro is expanded, and just the bare name (without :struct) should be specified." (let ((tclass (class-name (class-of (cffi::parse-type `(:struct ,type)))))) (when (eq tclass 'foreign-struct-type) (error "Won't replace existing translation method for foreign-struct-type")) `(defmethod ,(case method (:into 'translate-into-foreign-memory) (:from 'translate-from-foreign) (:to 'translate-to-foreign)) ;; Arguments to the method (,object (type ,tclass) ,@(when (eq method :into) '(pointer))) ; is intentional variable capture a good idea? ;; The body (declare (ignorable type)) ; I can't think of a reason why you'd want to use this ,@body))) (defmacro translation-forms-for-class (class type-class) "Make forms for translation of foreign structures to and from a standard class. The class slots are assumed to have the same name as the foreign structure." ;; Possible improvement: optional argument to map structure slot names to/from class slot names. `(progn (defmethod translate-from-foreign (pointer (type ,type-class)) ;; Make the instance from the plist (apply 'make-instance ',class (call-next-method))) (defmethod translate-into-foreign-memory ((object ,class) (type ,type-class) pointer) (call-next-method ;; Translate into a plist and call the general method (loop for slot being the hash-value of (structure-slots type) for name = (slot-name slot) append (list slot-name (slot-value object slot-name))) type pointer)))) ;;; For a class already defined and loaded, and a defcstruct already defined, use ;;; (translation-forms-for-class class type-class) ;;; to connnect the two. It would be nice to have a macro to do all three simultaneously. ;;; (defmacro define-foreign-structure (class )) #| (defmacro define-structure-conversion (value-symbol type lisp-class slot-names to-form from-form &optional (struct-name type)) "Define the functions necessary to convert to and from a foreign structure. The to-form sets each of the foreign slots in succession, assume the foreign object exists. The from-form creates the Lisp object, making it with the correct value by reference to foreign slots." `(flet ((map-slots (fn val) (maphash (lambda (name slot-struct) (funcall fn (foreign-slot-value val ',type name) (slot-type slot-struct))) (slots (follow-typedefs (parse-type ',type)))))) ;; Convert this to a separate function so it doesn't have to be recomputed on the fly each time. (defmethod translate-to-foreign ((,value-symbol ,lisp-class) (type ,type)) (let ((p (foreign-alloc ',struct-name))) ;;(map-slots #'translate-to-foreign ,value-symbol) ; recursive translation of slots (with-foreign-slots (,slot-names p ,struct-name) ,to-form) (values p t))) ; second value is passed to FREE-TRANSLATED-OBJECT (defmethod free-translated-object (,value-symbol (p ,type) freep) (when freep ;; Is this redundant? (map-slots #'free-translated-object value) ; recursively free slots (foreign-free ,value-symbol))) (defmethod translate-from-foreign (,value-symbol (type ,type)) (with-foreign-slots (,slot-names ,value-symbol ,struct-name) ,from-form)))) |# cffi_0.19.0/src/c2ffi/0000755000175000017500000000000013103031266013057 5ustar luisluiscffi_0.19.0/src/c2ffi/asdf.lisp0000644000175000017500000002072713103031266014675 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; asdf.lisp --- ASDF components for cffi/c2ffi. ;;; ;;; Copyright (C) 2015, Attila Lendvai ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi/c2ffi) (defclass c2ffi-file (cl-source-file) ((package :initarg :package :initform nil :accessor c2ffi-file/package) (c2ffi-executable :initarg :c2ffi-executable :accessor c2ffi-file/c2ffi-executable) (trace-c2ffi :initarg :trace-c2ffi :accessor c2ffi-file/trace-c2ffi) (prelude :initform nil :initarg :prelude :accessor c2ffi-file/prelude) (sys-include-paths :initarg :sys-include-paths :initform nil :accessor c2ffi-file/sys-include-paths) (exclude-archs :initarg :exclude-archs :initform nil :accessor c2ffi-file/exclude-archs) ;; The following slots correspond to an arg of the same name for ;; the generator function. No accessors are needed, they just hold ;; the data until it gets delegated to the generator function using ;; SLOT-VALUE and a LOOP. (ffi-name-transformer :initarg :ffi-name-transformer :initform 'default-ffi-name-transformer) (ffi-name-export-predicate :initarg :ffi-name-export-predicate :initform 'default-ffi-name-export-predicate) (ffi-type-transformer :initarg :ffi-type-transformer :initform 'default-ffi-type-transformer) (callback-factory :initarg :callback-factory :initform 'default-callback-factory) (foreign-library-name :initarg :foreign-library-name :initform nil) (foreign-library-spec :initarg :foreign-library-spec :initform nil) (emit-generated-name-mappings :initarg :emit-generated-name-mappings :initform :t) (include-sources :initarg :include-sources :initform :all) (exclude-sources :initarg :exclude-sources :initform nil) (include-definitions :initarg :include-definitions :initform :all) (exclude-definitions :initarg :exclude-definitions :initform nil)) (:default-initargs :type nil) (:documentation "The input of this ASDF component is a C header file, plus configuration for the binding generation process. This header file will define the initial scope of the generation process, which can further be filtered by other configuration parameters. An external program based on clang/llvm called 'c2ffi' is then invoked with this header file to generate a json file for various platforms. The generation of the underlying platform's json file must succeed to continue, but the generation for the other platforms is allowed to fail \(see ENSURE-SPEC-FILE-EXISTS). It's advisable to deliver these json files with the project, so that users don't need to have c2ffi installed. Once/if the json file is available for the underlying platform, then the json file is used to generate a lisp file with CFFI definitions (see PROCESS-C2FFI-SPEC-FILE). This file will then be compiled as any other lisp file, except that it's will be stored in the fasl cache.")) (defun input-file (operation component) (let ((files (input-files operation component))) (assert (length=n-p files 1)) (first files))) (defclass generate-spec-op (downward-operation) ()) (defmethod input-files ((op generate-spec-op) (c c2ffi-file)) (list (component-pathname c))) (defmethod component-depends-on ((op generate-spec-op) (c c2ffi-file)) `((prepare-op ,c) ,@(call-next-method))) (defmethod output-files ((op generate-spec-op) (c c2ffi-file)) (let* ((input-file (input-file op c)) (spec-file (spec-path input-file))) (values (list spec-file) ;; Tell ASDF not to apply output translation. t))) (defmethod perform ((op generate-spec-op) (c c2ffi-file)) (let ((input-file (input-file op c)) (*c2ffi-executable* (if (slot-boundp c 'c2ffi-executable) (c2ffi-file/c2ffi-executable c) *c2ffi-executable*)) (*trace-c2ffi* (if (slot-boundp c 'trace-c2ffi) (c2ffi-file/trace-c2ffi c) *trace-c2ffi*))) ;; NOTE: we don't call OUTPUT-FILE here, which may be a violation ;; of the ASDF contract, that promises that OUTPUT-FILE can be ;; customized by users. (ensure-spec-file-exists input-file :exclude-archs (c2ffi-file/exclude-archs c) :sys-include-paths (c2ffi-file/sys-include-paths c)))) (defclass generate-lisp-op (downward-operation) ()) (defmethod component-depends-on ((op generate-lisp-op) (c c2ffi-file)) `((generate-spec-op ,c) ,@(call-next-method))) (defmethod component-depends-on ((op compile-op) (c c2ffi-file)) `((generate-lisp-op ,c) ,@(call-next-method))) (defmethod component-depends-on ((op load-source-op) (c c2ffi-file)) `((generate-lisp-op ,c) ,@(call-next-method))) (defmethod input-files ((op generate-lisp-op) (c c2ffi-file)) (list (output-file 'generate-spec-op c))) (defmethod input-files ((op compile-op) (c c2ffi-file)) (list (output-file 'generate-lisp-op c))) (defmethod output-files ((op generate-lisp-op) (c c2ffi-file)) (let* ((spec-file (input-file op c)) (generated-lisp-file (make-pathname :type "lisp" :defaults spec-file))) (values (list generated-lisp-file) ;; Tell ASDF not to apply output translation. t))) (defmethod perform ((op generate-lisp-op) (c c2ffi-file)) (let ((spec-file (input-file op c)) (generated-lisp-file (output-file op c))) (with-staging-pathname (tmp-output generated-lisp-file) (format *debug-io* "~&; CFFI/C2FFI is generating the file ~S~%" generated-lisp-file) (unless (component-loaded-p :cffi/c2ffi-generator) (load-system :cffi/c2ffi-generator)) (apply 'process-c2ffi-spec-file spec-file (c2ffi-file/package c) :output tmp-output :output-encoding (asdf:component-encoding c) :prelude (let ((prelude (c2ffi-file/prelude c))) (if (and (pathnamep prelude) (not (absolute-pathname-p prelude))) (merge-pathnames* prelude (component-pathname c)) prelude)) ;; The following slots and keyword args have the same name in the ASDF ;; component and in PROCESS-C2FFI-SPEC-FILE, and this loop copies them. (loop :for arg :in '(ffi-name-transformer ffi-name-export-predicate ffi-type-transformer callback-factory foreign-library-name foreign-library-spec emit-generated-name-mappings include-sources exclude-sources include-definitions exclude-definitions) :append (list (make-keyword arg) (slot-value c arg))))))) ;; Allow for naked :cffi/c2ffi-file in asdf definitions. (setf (find-class 'asdf::cffi/c2ffi-file) (find-class 'c2ffi-file)) cffi_0.19.0/src/c2ffi/package.lisp0000644000175000017500000000372313103031266015350 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; Copyright (C) 2015, Attila Lendvai ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (uiop:define-package #:cffi/c2ffi (:mix #:uiop #:alexandria #:common-lisp) (:import-from :asdf #:cl-source-file #:output-file #:output-files #:input-files #:perform #:compile-op #:load-op #:load-source-op #:prepare-op #:component-pathname #:component-depends-on #:downward-operation #:load-system #:component-loaded-p) (:export #:c2ffi-file #:default-ffi-name-transformer #:default-ffi-type-transformer #:change-case-to-readtable-case #:camelcased? #:camelcase-to-dash-separated #:maybe-camelcase-to-dash-separated)) cffi_0.19.0/src/c2ffi/c2ffi.lisp0000644000175000017500000002014113103031266014737 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; c2ffi.lisp --- c2ffi related code ;;; ;;; Copyright (C) 2013, Ryan Pavlik ;;; Copyright (C) 2015, Attila Lendvai ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi/c2ffi) ;;; NOTE: Most of this has been taken over from cl-autowrap. ;;; Note this is rather untested and not very extensive at the moment; ;;; it should probably work on linux/win/osx though. Patches welcome. (defun local-cpu () #+x86-64 "x86_64" #+(and (not (or x86-64 freebsd)) x86) "i686" #+(and (not x86-64) x86 freebsd) "i386" #+arm "arm") (defun local-vendor () #+(or linux windows) "-pc" #+darwin "-apple" #+(not (or linux windows darwin)) "-unknown") (defun local-os () #+linux "-linux" #+windows "-windows-msvc" #+darwin "-darwin9" #+freebsd "-freebsd") (defun local-environment () #+linux "-gnu" #-linux "") (defun local-arch () (strcat (local-cpu) (local-vendor) (local-os) (local-environment))) (defparameter *known-archs* '("i686-pc-linux-gnu" "x86_64-pc-linux-gnu" "i686-pc-windows-msvc" "x86_64-pc-windows-msvc" "i686-apple-darwin9" "x86_64-apple-darwin9" "i386-unknown-freebsd" "x86_64-unknown-freebsd")) (defvar *c2ffi-executable* "c2ffi") (defvar *trace-c2ffi* nil) (defun c2ffi-executable-available? () ;; This is a hack to determine if c2ffi exists; it assumes if it ;; doesn't exist, we will get a return code other than 0. (zerop (nth-value 2 (uiop:run-program `(,*c2ffi-executable* "-h") :ignore-error-status t)))) (defun run-program* (program args &key (output (if *trace-c2ffi* *standard-output* nil)) (error-output (if *trace-c2ffi* *error-output* nil)) ignore-error-status) (when *trace-c2ffi* (format *debug-io* "~&; Invoking: ~A~{ ~A~}~%" program args)) (zerop (nth-value 2 (uiop:run-program (list* program args) :output output :error-output error-output :ignore-error-status ignore-error-status)))) (defun generate-spec-with-c2ffi (input-header-file output-spec-path &key arch sys-include-paths ignore-error-status) "Run c2ffi on `INPUT-HEADER-FILE`, outputting to `OUTPUT-FILE` and `MACRO-OUTPUT-FILE`, optionally specifying a target triple `ARCH`." (uiop:with-temporary-file (:pathname tmp-macro-file :keep *trace-c2ffi*) nil ; workaround for an UIOP bug; delme eventually (attila, 2016-01-27). :close-stream (let* ((arch (when arch (list "--arch" arch))) (sys-include-paths (loop :for dir :in sys-include-paths :append (list "--sys-include" dir)))) ;; Invoke c2ffi to first emit C #define's into TMP-MACRO-FILE. We ask c2ffi ;; to first generate a file of C global variables that are assigned the ;; value of the corresponding #define's, so that in the second pass below ;; the C compiler evaluates for us their right hand side and thus we can ;; get hold of their value. This is a kludge and eventually we could/should ;; support generating cffi-grovel files, and in grovel mode not rely ;; on this kludge anymore. (when (run-program* *c2ffi-executable* (list* (namestring input-header-file) "--driver" "null" "--macro-file" (namestring tmp-macro-file) (append arch sys-include-paths)) :output *standard-output* :ignore-error-status ignore-error-status) ;; Write a tmp header file that #include's the original input file and ;; the above generated macros file which will form the input for our ;; final, second pass. (uiop:with-temporary-file (:stream tmp-include-file-stream :pathname tmp-include-file :keep *trace-c2ffi*) (format tmp-include-file-stream "#include \"~A\"~%" input-header-file) (format tmp-include-file-stream "#include \"~A\"~%" tmp-macro-file) :close-stream ;; Invoke c2ffi again to generate the final output. (run-program* *c2ffi-executable* (list* (namestring tmp-include-file) "--output" (namestring output-spec-path) (append arch sys-include-paths)) :output *standard-output* :ignore-error-status ignore-error-status)))))) (defun spec-path (base-name &key version (arch (local-arch))) (check-type base-name pathname) (make-pathname :defaults base-name :name (strcat (pathname-name base-name) (if version (strcat "-" version) "") "." arch) :type "spec")) (defun find-local-spec (base-name &optional (errorp t)) (let* ((spec-path (spec-path base-name)) (probed (probe-file spec-path))) (if probed spec-path (when errorp (error "c2ffi spec file not found for base name ~S" base-name))))) (defun ensure-spec-file-exists (header-file-path &key exclude-archs sys-include-paths version) (multiple-value-bind (h-name m-name) (find-local-spec header-file-path nil) (if h-name (values h-name m-name) (let ((local-arch (local-arch))) (unless (c2ffi-executable-available?) (error "No spec found for ~S on arch '~A' and c2ffi not found" header-file-path local-arch)) (generate-spec-with-c2ffi header-file-path (spec-path header-file-path :arch local-arch :version version) :arch local-arch :sys-include-paths sys-include-paths) ;; also run c2ffi for other architectures, but tolerate failure (dolist (arch *known-archs*) (unless (or (string= local-arch arch) (member arch exclude-archs :test #'string=)) (unless (generate-spec-with-c2ffi header-file-path (spec-path header-file-path :arch arch :version version) :arch arch :sys-include-paths sys-include-paths :ignore-error-status t) (warn "Failed to generate spec for other arch: ~S" arch)))) (find-local-spec header-file-path))))) cffi_0.19.0/src/c2ffi/generator.lisp0000644000175000017500000011310213103031266015734 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; generator.lisp --- Generate CFFI bindings for a c2ffi output. ;;; ;;; Copyright (C) 2015, Attila Lendvai ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi/c2ffi) ;;; Output generation happens in one phase, straight into the output ;;; stream. There's minimal look-ahead (for source-location and name) ;;; which is needed to apply user specified filters in time. ;;; ;;; Each CFFI form is also EVAL'd during generation because the CFFI ;;; type lookup/parsing mechanism is used while generating the output. ;;; ;;; Nomenclature: ;;; ;;; - variable names in this file are to be interpreted in the ;;; C,c2ffi,json context, and 'cffi' is added to names that denote ;;; the cffi name. ;;; ;;; Possible improvments: ;;; ;;; - generate an additional grovel file for C inline function ;;; declarations found in header files ;;; ;;; - generate struct-by-value DEFCFUN's into a separate file so that ;;; users can decide whether to depend on libffi, or they can make do ;;; without those definitions (defvar *allow-pointer-type-simplification* t) (defvar *allow-skipping-struct-fields* t) (defvar *assume-struct-by-value-support* t) ;; Called on the json name and may return a symbol to be used, or a string. (defvar *ffi-name-transformer* 'default-ffi-name-transformer) ;; Called on the already transformed name to decide whether to export it (defvar *ffi-name-export-predicate* 'default-ffi-name-export-predicate) ;; Called on the CFFI type, e.g. to turn (:pointer :char) into a :string. (defvar *ffi-type-transformer* 'default-ffi-type-transformer) ;; May return up to two closures using VALUES. The first one will be called ;; with each emitted form, and the second one once, at the end. They both may ;; return a list of forms that will be emitted using OUTPUT/CODE. (defvar *callback-factory* 'default-callback-factory) (define-constant +generated-file-header+ ";;; -*- Mode: lisp -*-~%~ ;;;~%~ ;;; This file has been automatically generated by cffi/c2ffi. Editing it by hand is not wise.~%~ ;;;~%~%" :test 'equal) (defvar *c2ffi-output-stream*) (defun output/export (names package) (let ((names (uiop:ensure-list names))) ;; Make sure we have something PRINT-READABLY as a package name, ;; i.e. not a SIMPLE-BASE-STRING on SBCL. (output/code `(export ',names ',(make-symbol (package-name package)))))) (defun output/code (form) (check-type form cons) (format *c2ffi-output-stream* "~&") (write form :stream *c2ffi-output-stream* :circle t :pretty t :escape t :readably t) (format *c2ffi-output-stream* "~%~%") (unless (member (first form) '(cffi:defcfun alexandria:define-constant) :test 'eq) (eval form))) (defun output/string (message-control &rest message-arguments) (apply 'format *c2ffi-output-stream* message-control message-arguments)) ;; NOTE: as per c2ffi json output. A notable difference to ;; CFFI::*BUILT-IN-FOREIGN-TYPES* is the presence of :SIGNED-CHAR. (define-constant +c-builtin-types+ '(":void" ":_Bool" ":char" ":signed-char" ":unsigned-char" ":short" ":unsigned-short" ":int" ":unsigned-int" ":long" ":unsigned-long" ":long-long" ":unsigned-long-long" ":float" ":double" ":long-double") :test 'equal) (define-condition unsupported-type (cffi::foreign-type-error) ((json-definition :initarg :json-definition :accessor json-definition-of))) (defun unsupported-type (json-entry) (error 'unsupported-type :type-name nil :json-definition json-entry)) ;;;;;; ;;; Utilities (defun compile-rules (rules) (case rules (:all rules) (t (mapcar (lambda (pattern) (check-type pattern string "Patterns in the inclusion/exclusion rules must be strings.") (let ((scanner (cl-ppcre:create-scanner pattern))) (named-lambda cffi/c2ffi/cl-ppcre-rule-matcher (string) (funcall scanner string 0 (length string))))) rules)))) (defun include-definition? (name source-location include-definitions exclude-definitions include-sources exclude-sources) (labels ((covered-by-a-rule? (name rules) (or (eq rules :all) (not (null (some (rcurry #'funcall name) rules))))) (weak? (rules) (eq :all rules)) (strong? (name rules) (and name (not (weak? rules)) (covered-by-a-rule? name rules)))) (let* ((excl-def/weak (weak? exclude-definitions)) (excl-def/strong (strong? name exclude-definitions)) (incl-def/weak (weak? include-definitions)) (incl-def/strong (strong? name include-definitions)) (excl-src/weak (weak? exclude-sources)) (excl-src/strong (strong? source-location exclude-sources)) (incl-src/weak (weak? include-sources)) (incl-src/strong (strong? source-location include-sources)) (incl/strong (or incl-def/strong incl-src/strong)) (excl/strong (or excl-def/strong excl-src/strong)) (incl/weak (or incl-def/weak incl-src/weak)) (excl/weak (or excl-def/weak excl-src/weak))) (or incl-def/strong (and (not excl/strong) (or incl/strong (and incl/weak ;; we want src exclude rules to be stronger (not excl-src/weak)) (not excl/weak))))))) (defun coerce-to-byte-size (bit-size) (let ((byte-size (/ bit-size 8))) (unless (integerp byte-size) (error "Non-byte size encountered where it wasn't expected (~A bits)" bit-size)) byte-size)) (defmacro assume (condition &optional format-control &rest format-arguments) "Similar to ASSERT, but WARN's only." `(unless ,condition ,(if format-control `(warn ,format-control ,@format-arguments) `(warn "ASSUME failed: ~S" ',condition)))) (defun canonicalize-transformer-hook (hook) (etypecase hook ((and (or function symbol) (not null)) hook) (string (the symbol (safe-read-from-string hook))))) ;;;;;; ;;; Json access (defun json-value (alist key &key (otherwise nil otherwise?)) (check-type alist list) (check-type key (and symbol (not null))) (let* ((entry (assoc key alist)) (result (cond (entry (cdr entry)) (otherwise? otherwise) (t (error "Key ~S not found in json entry ~S." key alist))))) (if (equal result "") nil result))) (defmacro with-json-values ((json-entry &rest args) &body body) (if (null args) `(progn ,@body) (once-only (json-entry) `(let (,@(loop :for entry :in args :collect (let* ((args (ensure-list entry)) (name (pop args)) (key (or (pop args) (make-keyword (symbol-name name))))) (destructuring-bind ;; using &optional would trigger a warning (on SBCL) (&key (otherwise nil otherwise?)) args `(,name (json-value ,json-entry ,key ,@(when otherwise? `(:otherwise ,otherwise)))))))) ,@body)))) (defun expected-json-keys (alist &rest keys) (let* ((keys (list* :location keys)) (outliers (remove-if (lambda (el) (member (car el) keys :test 'eq)) alist))) (when outliers (warn "Unexpected key(s) in json entry ~S: ~S" alist outliers)))) ;;;;;; ;;; Namespaces, names and conversions ;; an alist of (name . hashtable) (defvar *generated-names*) (defvar *anon-name-counter*) (defvar *anon-entities*) (defun register-anon-entity (id name) (check-type id integer) (check-type name string) (assert (not (zerop (length name)))) (setf (gethash id *anon-entities*) name) name) (defun lookup-anon-entity (id) (or (gethash id *anon-entities*) (error "Could not find anonymous entity with id ~S." id))) (defun generate-anon-name (base-name) (format nil "~A" (strcat (symbol-name base-name) (princ-to-string (incf *anon-name-counter*))))) (defun valid-name-or-die (name) ;; checks for valid json names (*not* CFFI names) (etypecase name (string (assert (not (zerop (length name))))) (cons (assert (= 2 (length name))) (assert (member (first name) '(:struct :union :enum))) (valid-name-or-die (second name))))) (defun call-hook (hook &rest args) (apply hook ;; indiscriminately add one keyword arg entry to warn (append args '(just-a-warning "Make sure your transformer hook has &key &allow-other-keys for future extendability.")))) (defun find-cffi-type-or-die (type-name &optional (namespace :default)) (when (eq namespace :enum) ;; TODO FIXME this should be cleaned up in CFFI. more about namespace confusion at: ;; https://bugs.launchpad.net/cffi/+bug/1527947 (setf namespace :default)) (cffi::find-type-parser type-name namespace)) (define-constant +name-kinds+ '(:struct :union :function :variable :type :constant :field :argument :enum :member) :test 'equal) (deftype ffi-name-kind () '#.(list* 'member +name-kinds+)) (defun json-name-to-cffi-name (name kind &optional anonymous) (check-type name string) (check-type kind ffi-name-kind) (when *ffi-name-transformer* (setf name (call-hook *ffi-name-transformer* name kind)) (unless (or (and (symbolp name) (not (null name))) (stringp name)) (error "The FFI-NAME-TRANSFORMER ~S returned with ~S which is not a valid name." *ffi-name-transformer* name))) (let ((cffi-name (if (symbolp name) name (intern name)))) (when (and (not anonymous) (boundp '*generated-names*)) (setf (gethash name (cdr (assoc kind *generated-names*))) cffi-name)) cffi-name)) (defun default-callback-factory (&key &allow-other-keys) (values)) (defun default-ffi-name-transformer (name kind &key &allow-other-keys) (check-type name string) (case kind #+nil ((:constant :member) (assert (not (symbolp name))) (format nil "+~A+" name)) (t name))) (defun change-case-to-readtable-case (name &optional (reatable *readtable*)) (ecase (readtable-case reatable) (:upcase (string-upcase name)) (:downcase (string-downcase name)) (:preserve name) ;; (:invert no, you don't) )) (defun camelcased? (name) (and (>= (length name) 3) (let ((lower 0) (upper 0)) (loop :for char :across name :do (cond ((upper-case-p char) (incf upper)) ((lower-case-p char) (incf lower)))) (unless (or (zerop lower) (zerop upper)) (let ((ratio (/ upper lower))) (and (<= 0.05 ratio 0.5))))))) (defun camelcase-to-dash-separated (name) (coerce (loop :for char :across name :for index :from 0 :when (and (upper-case-p char) (not (zerop index))) :collect #\- :collect (char-downcase char)) 'string)) (defun maybe-camelcase-to-dash-separated (name) (if (camelcased? name) (camelcase-to-dash-separated name) name)) (defun default-ffi-name-export-predicate (symbol &key &allow-other-keys) (declare (ignore symbol)) nil) (defun default-ffi-type-transformer (type context &key &allow-other-keys) (declare (ignore context)) (cond ((and (consp type) (eq :pointer (first type))) (let ((pointed-to-type (second type))) (if (eq pointed-to-type :char) :string type))) (t type))) (defun function-pointer-type-name () (symbolicate '#:function-pointer)) (defmacro with-allowed-foreign-type-errors ((on-failure-form &key (enabled t)) &body body) (with-unique-names (type-block) `(block ,type-block (handler-bind ((cffi::foreign-type-error (lambda (_) (declare (ignore _)) (when ,enabled (return-from ,type-block ,on-failure-form))))) ,@body)))) (defun %json-type-to-cffi-type (json-entry) (with-json-values (json-entry tag) (let ((cffi-type (cond ((switch (tag :test 'equal) (":void" :void) (":_Bool" :bool) ;; regarding :signed-char see https://stackoverflow.com/questions/436513/char-signed-char-char-unsigned-char (":char" :char) (":signed-char" :char) (":unsigned-char" :unsigned-char) (":short" :short) (":unsigned-short" :unsigned-short) (":int" :int) (":unsigned-int" :unsigned-int) (":long" :long) (":unsigned-long" :unsigned-long) (":long-long" :long-long) (":unsigned-long-long" :unsigned-long-long) (":float" :float) (":double" :double) ;; TODO FIXME ;;(":long-double" :long-double) ) ;; return the result of the condition expression ) ((or (progn (assert (not (member tag +c-builtin-types+ :test 'equal)) () "Not all C basic types are covered! The outlier is: ~S" tag) nil) (equal tag ":struct") (equal tag ":union")) ;; ":struct" is a "struct foo-struct var" kind of reference (expected-json-keys json-entry :name :tag :id) (with-json-values (json-entry name id) (let* ((kind (if (equal tag ":struct") :struct :union)) (cffi-name (if name (json-name-to-cffi-name name kind) (lookup-anon-entity id)))) (find-cffi-type-or-die cffi-name kind) `(,kind ,cffi-name)))) ((or (equal tag "struct") (equal tag "union")) ;; "struct" denotes a "struct {} var", or "typedef struct {} my_type" ;; kind of inline anonymous declaration. Let's call PROCESS-C2FFI-ENTRY ;; to emit it for us, and return with the generated name (first value) ;; as if it was a standalone toplevel struct definition. ;; TODO is it a problem that we don't invoke the CALLBACK-FACTORY stuff here? (let ((form (process-c2ffi-entry json-entry)) (kind (if (equal tag "struct") :struct :union))) (assert (and (consp form) (member (first form) '(cffi:defcstruct cffi:defcunion)))) `(,kind ,(first (ensure-list (second form)))))) ((equal tag ":enum") ;; ":enum" is an "enum foo var" kind of reference (expected-json-keys json-entry :name :tag :id) (with-json-values (json-entry name id) (let ((cffi-name (json-name-to-cffi-name (or name (lookup-anon-entity id)) :enum))) (find-cffi-type-or-die cffi-name :enum) ;; TODO FIXME this would be the proper one, but CFFI is broken: `(:enum ,cffi-name) cffi-name))) ((equal tag "enum") ;; "enum" is an inline "typedef enum {m1, m2} var" kind of inline declaration (expected-json-keys json-entry :name :tag :id) ;; TODO FIXME similarly to struct, but it would be nice to see an example (error "not yet implemented")) ((equal tag ":array") (expected-json-keys json-entry :tag :type :size) (with-json-values (json-entry type size) (check-type size integer) `(:array ,(json-type-to-cffi-type type) ,size))) ((equal tag ":pointer") (expected-json-keys json-entry :tag :type :id) (with-json-values (json-entry type) `(:pointer ,(with-allowed-foreign-type-errors (:void :enabled *allow-pointer-type-simplification*) (json-type-to-cffi-type type))))) ((equal tag ":function-pointer") (expected-json-keys json-entry :tag) (function-pointer-type-name)) ((equal tag ":function") (unsupported-type json-entry)) (t (assert (not (starts-with #\: tag))) (let ((cffi-name (json-name-to-cffi-name tag :type))) (find-cffi-type-or-die cffi-name) cffi-name))))) (assert cffi-type () "Failed to map ~S to a cffi type" json-entry) cffi-type))) (defun should-export-p (symbol) (and symbol (symbolp symbol) (not (keywordp symbol)) *ffi-name-export-predicate* (call-hook *ffi-name-export-predicate* symbol))) (defun json-type-to-cffi-type (json-entry &optional (context nil context?)) (let ((cffi-type (%json-type-to-cffi-type json-entry))) (if context? (call-hook *ffi-type-transformer* cffi-type context) cffi-type))) ;;;;;; ;;; Entry point, the "API" (defun process-c2ffi-spec-file (c2ffi-spec-file package-name &key (allow-pointer-type-simplification *allow-pointer-type-simplification*) (allow-skipping-struct-fields *allow-skipping-struct-fields*) (assume-struct-by-value-support *assume-struct-by-value-support*) ;; either a pathname or a string (will be copied as is), ;; or a function that will be funcall'd with one argument ;; to emit a form (i.e. OUTPUT/CODE). prelude (output (make-pathname :name (strcat (pathname-name c2ffi-spec-file) ".cffi-tmp") :type "lisp" :defaults c2ffi-spec-file)) (output-encoding asdf:*default-encoding*) ;; The args following this point are mirrored in the ASDF ;; component on the same name. (ffi-name-transformer *ffi-name-transformer*) (ffi-name-export-predicate *ffi-name-export-predicate*) ;; as per CFFI:DEFINE-FOREIGN-LIBRARY and CFFI:LOAD-FOREIGN-LIBRARY (ffi-type-transformer *ffi-type-transformer*) (callback-factory *callback-factory*) foreign-library-name foreign-library-spec (emit-generated-name-mappings t) (include-sources :all) exclude-sources (include-definitions :all) exclude-definitions) "Generates a lisp file with CFFI definitions from C2FFI-SPEC-FILE. PACKAGE-NAME will be overwritten, it assumes full control over the target package." (check-type c2ffi-spec-file (or pathname string)) (macrolet ((@ (var) `(setf ,var (compile-rules ,var)))) (@ include-sources) (@ exclude-sources) (@ include-definitions) (@ exclude-definitions)) (with-standard-io-syntax (with-input-from-file (in c2ffi-spec-file :external-format (asdf/driver:encoding-external-format :utf-8)) (with-output-to-file (*c2ffi-output-stream* output :if-exists :supersede :external-format (asdf/driver:encoding-external-format output-encoding)) (let* ((*package* (or (find-package package-name) (make-package package-name))) ;; Make sure we use an uninterned symbol, so that it's neutral to READTABLE-CASE. (package-name (make-symbol (package-name *package*))) ;; Let's rebind a copy, so that when we are done with ;; the generation (which also EVAL's the forms) then ;; the CFFI type repository is also reverted back to ;; the previous state. This avoids redefinition warning ;; when the generated file gets compiled and loaded ;; later. (cffi::*type-parsers* (copy-hash-table cffi::*type-parsers*)) (*anon-name-counter* 0) (*anon-entities* (make-hash-table)) (*generated-names* (mapcar (lambda (key) `(,key . ,(make-hash-table :test 'equal))) +name-kinds+)) (*allow-pointer-type-simplification* allow-pointer-type-simplification) (*allow-skipping-struct-fields* allow-skipping-struct-fields) (*assume-struct-by-value-support* assume-struct-by-value-support) (*ffi-name-transformer* (canonicalize-transformer-hook ffi-name-transformer)) (*ffi-name-export-predicate* (canonicalize-transformer-hook ffi-name-export-predicate)) (*ffi-type-transformer* (canonicalize-transformer-hook ffi-type-transformer)) (*callback-factory* (canonicalize-transformer-hook callback-factory)) (*read-default-float-format* 'double-float) (json (json:decode-json in))) (output/string +generated-file-header+) ;; some forms that are always emitted (mapc 'output/code ;; Make sure the package exists. We don't even want to :use COMMON-LISP here, ;; to avoid any possible name clashes. `((uiop:define-package ,package-name (:use)) (in-package ,package-name) (cffi:defctype ,(function-pointer-type-name) :pointer))) (when (and foreign-library-name foreign-library-spec) (when (stringp foreign-library-name) (setf foreign-library-name (safe-read-from-string foreign-library-name))) (output/code `(cffi:define-foreign-library ,foreign-library-name ,@foreign-library-spec)) ;; TODO: Unconditionally emitting a USE-FOREIGN-LIBRARY may not be smart. ;; For details see: https://bugs.launchpad.net/cffi/+bug/1593635 (output/code `(cffi:use-foreign-library ,foreign-library-name))) (etypecase prelude (null) (string (output/string prelude)) (pathname (with-input-from-file (prelude-stream prelude) (alexandria:copy-stream prelude-stream *c2ffi-output-stream* :element-type 'character))) ((or symbol function) (funcall prelude 'output/code))) ;; ;; Let's enumerate the entries (multiple-value-bind (form-callback epilogue-callback) (funcall *callback-factory*) (dolist (json-entry json) (with-json-values (json-entry name location) (let ((source-location-file (subseq location 0 (or (position #\: location) 0)))) (if (include-definition? name source-location-file include-definitions exclude-definitions include-sources exclude-sources) (progn (output/string "~&~%;; ~S" location) (let ((emitted-definition (process-c2ffi-entry json-entry))) ;; ;; Call the plugin to let the user emit a form after the given ;; definition (when (and emitted-definition form-callback) (map nil 'output/code (call-hook form-callback emitted-definition))))) (output/string "~&;; Skipped ~S due to filters" name))))) ;; ;; Call the plugin to let the user append multiple forms after the ;; emitted definitions (when epilogue-callback (map nil 'output/code (call-hook epilogue-callback)))) ;; ;; emit optional exports (maphash (lambda (package-name symbols) (output/export (sort (remove-if-not #'should-export-p symbols) #'string<) package-name)) (get-all-names-by-package *generated-names*)) ;; ;; emit optional mappings (when emit-generated-name-mappings (mapcar (lambda (entry) (destructuring-bind (kind variable-name) entry (output/code `(defparameter ,(intern (symbol-name variable-name)) ',(hash-table-alist (cdr (assoc kind *generated-names*))))))) `((:function #:+function-names+) (:struct #:+struct-names+) (:union #:+union-names+) (:variable #:+variable-names+) (:type #:+type-names+) (:constant #:+constant-names+) (:argument #:+argument-names+) (:field #:+field-names+)))))))) output) (defun get-all-names-by-package (name-collection) (let ((tables (mapcar #'cdr name-collection)) all (grouped (make-hash-table))) (loop :for table :in tables :do (loop :for s :being :the :hash-values :of table :do (push s all))) (remove-duplicates all :test #'eq) (loop :for name :in all :for package-name := (package-name (symbol-package name)) :do (setf (gethash package-name grouped) (cons name (gethash package-name grouped)))) grouped)) ;;;;;; ;;; Processors for various definitions (defvar *c2ffi-entry-processors* (make-hash-table :test 'equal)) (defun process-c2ffi-entry (json-entry) (let* ((kind (json-value json-entry :tag)) (processor (gethash kind *c2ffi-entry-processors*))) (if processor (let ((definition-form (handler-bind ((unsupported-type (lambda (e) (warn "Skip definition because cannot map ~S to any CFFI type. The definition is ~S" (json-definition-of e) json-entry) (return-from process-c2ffi-entry (values)))) (cffi::undefined-foreign-type-error (lambda (e) (output/string "~&;; Skipping definition ~S because of missing type ~S" json-entry (cffi::foreign-type-error/compound-name e)) (return-from process-c2ffi-entry (values))))) (funcall processor json-entry)))) (when definition-form (output/code definition-form) definition-form)) (progn (warn "No cffi/c2ffi processor defined for ~A" json-entry) (values))))) (defmacro define-processor (kind args &body body) `(setf (gethash ,(string-downcase kind) *c2ffi-entry-processors*) (named-lambda ,(symbolicate 'c2ffi-processor/ kind) (-json-entry-) (with-json-values (-json-entry- ,@args) ,@body)))) (defun %process-struct-like (json-entry kind definer anon-base-name) (expected-json-keys json-entry :tag :ns :name :id :bit-size :bit-alignment :fields) (with-json-values (json-entry tag (struct-name :name) fields bit-size id) (assert (member tag '(":struct" "struct" ":union" "union") :test 'equal)) (flet ((process-field (json-entry) (with-json-values (json-entry (field-name :name) bit-offset type) (let ((cffi-type (with-allowed-foreign-type-errors ('failed :enabled *allow-skipping-struct-fields*) (json-type-to-cffi-type type `(,kind ,struct-name ,field-name))))) (if (eq cffi-type 'failed) (output/string "~&;; skipping field due to missing type ~S, full json entry: ~S" type json-entry) `(,(json-name-to-cffi-name field-name :field) ,cffi-type ,@(unless (eq kind :union) `(:offset ,(coerce-to-byte-size bit-offset))))))))) `(,definer (,(json-name-to-cffi-name (or struct-name (register-anon-entity id (generate-anon-name anon-base-name))) kind (null struct-name)) :size ,(coerce-to-byte-size bit-size)) ,@(remove nil (mapcar #'process-field fields)))))) (define-processor struct () (%process-struct-like -json-entry- :struct 'cffi:defcstruct '#:anon-struct-)) (define-processor union () (%process-struct-like -json-entry- :union 'cffi:defcunion '#:anon-union-)) (define-processor typedef (name type) (expected-json-keys -json-entry- :tag :name :ns :type) `(cffi:defctype ,(json-name-to-cffi-name name :type) ,(json-type-to-cffi-type type `(:typedef ,name)))) (define-processor function (return-type (function-name :name) parameters inline variadic storage-class) (declare (ignore storage-class)) ;; TODO does storage-class matter for FFI accessibility? #+nil (assume (equal "extern" storage-class) "Unexpected function STORAGE-CLASS: ~S for function ~S" storage-class function-name) (expected-json-keys -json-entry- :tag :name :return-type :parameters :variadic :inline :storage-class :ns) (let ((uses-struct-by-value? nil)) (flet ((process-arg (json-entry index) (expected-json-keys json-entry :tag :name :type) (with-json-values (json-entry tag (argument-name :name) type) (assert (equal tag "parameter")) (let* ((cffi-type (json-type-to-cffi-type type `(:function ,function-name ,argument-name))) (canonicalized-type (cffi::canonicalize-foreign-type cffi-type))) (when (and (consp canonicalized-type) (member (first canonicalized-type) '(:struct :union))) (setf uses-struct-by-value? t)) `(,(if argument-name (json-name-to-cffi-name argument-name :argument) (symbolicate '#:arg (princ-to-string index))) ,cffi-type))))) (let ((cffi-args (loop :for arg :in parameters :for index :upfrom 1 :collect (process-arg arg index)))) (cond ((and uses-struct-by-value? (not *assume-struct-by-value-support*)) (values)) (inline ;; TODO inline functions should go into a separate grovel file? (output/string "~&;; Skipping inline function ~S" function-name) (values)) (t `(cffi:defcfun (,function-name ,(json-name-to-cffi-name function-name :function)) ,(json-type-to-cffi-type return-type `(:function ,function-name :return-type)) ,@(append cffi-args (when variadic '(&rest)))))))))) (define-processor extern (name type) (expected-json-keys -json-entry- :tag :name :type) `(cffi:defcvar (,name ,(json-name-to-cffi-name name :variable)) ,(json-type-to-cffi-type type `(:variable ,name)))) ;; ((TAG . enum) (NS . 0) (NAME . ) (ID . 3) (LOCATION . /usr/include/bits/confname.h:24:1) (FIELDS ((TAG . field) (NAME . _PC_LINK_MAX) (VALUE . 0)) ((TAG . field) (NAME . _PC_MAX_CANON) (VALUE . 1)) ((TAG . field) (NAME . _PC_MAX_INPUT) (VALUE . 2)) ((TAG . field) (NAME . _PC_NAME_MAX) (VALUE . 3)) ((TAG . field) (NAME . _PC_PATH_MAX) (VALUE . 4)) ((TAG . field) (NAME . _PC_PIPE_BUF) (VALUE . 5)) ((TAG . field) (NAME . _PC_CHOWN_RESTRICTED) (VALUE . 6)) ((TAG . field) (NAME . _PC_NO_TRUNC) (VALUE . 7)) ((TAG . field) (NAME . _PC_VDISABLE) (VALUE . 8)) ((TAG . field) (NAME . _PC_SYNC_IO) (VALUE . 9)) ((TAG . field) (NAME . _PC_ASYNC_IO) (VALUE . 10)) ((TAG . field) (NAME . _PC_PRIO_IO) (VALUE . 11)) ((TAG . field) (NAME . _PC_SOCK_MAXBUF) (VALUE . 12)) ((TAG . field) (NAME . _PC_FILESIZEBITS) (VALUE . 13)) ((TAG . field) (NAME . _PC_REC_INCR_XFER_SIZE) (VALUE . 14)) ((TAG . field) (NAME . _PC_REC_MAX_XFER_SIZE) (VALUE . 15)) ((TAG . field) (NAME . _PC_REC_MIN_XFER_SIZE) (VALUE . 16)) ((TAG . field) (NAME . _PC_REC_XFER_ALIGN) (VALUE . 17)) ((TAG . field) (NAME . _PC_ALLOC_SIZE_MIN) (VALUE . 18)) ((TAG . field) (NAME . _PC_SYMLINK_MAX) (VALUE . 19)) ((TAG . field) (NAME . _PC_2_SYMLINKS) (VALUE . 20)))) (define-processor enum (name fields id) (let ((bitmasks 0) (non-bitmasks 0)) (labels ((for-bitmask-statistics (name value) (declare (ignore name)) (if (cffi::single-bit-p value) (incf bitmasks) (incf non-bitmasks))) (for-enum-body (name value) `(,(json-name-to-cffi-name name :member) ,value)) (process-fields (visitor) (loop :for json-entry :in fields :do (expected-json-keys json-entry :tag :name :value) :collect (with-json-values (json-entry tag name value) (assert (equal tag "field")) (check-type value integer) (funcall visitor name value))))) (process-fields #'for-bitmask-statistics) `(,(if (> (/ bitmasks (+ non-bitmasks bitmasks)) 0.8) 'cffi:defbitfield 'cffi:defcenum) ,(json-name-to-cffi-name (or name (register-anon-entity id (generate-anon-name '#:anon-enum-))) :enum (null name)) ,@(process-fields #'for-enum-body))))) (defun make-define-constant-form (name value) (valid-name-or-die name) (let ((test-fn (typecase value (number) (t 'equal)))) `(alexandria:define-constant ,(json-name-to-cffi-name name :constant) ,value ,@(when test-fn `(:test ',test-fn))))) (define-processor const (name type (value :value :otherwise nil)) (expected-json-keys -json-entry- :tag :name :type :value :ns) (let ((cffi-type (json-type-to-cffi-type type `(:contant ,name)))) (cond ((not value) ;; #define __FOO_H and friends... just ignore them. (values)) ((and (member cffi-type '(:int :unsigned-int :long :unsigned-long :long-long :unsigned-long-long)) (integerp value)) (make-define-constant-form name value)) ((and (member cffi-type '(:float :double)) (floatp value)) (make-define-constant-form name value)) ((member cffi-type '(:string (:pointer :char)) :test 'equal) (make-define-constant-form name value)) (t (warn "Don't know how to emit a constant of CFFI type ~S, with value ~S (json type is ~S)." cffi-type value type) (values))))) cffi_0.19.0/src/early-types.lisp0000644000175000017500000006413613103031266015247 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; early-types.lisp --- Low-level foreign type operations. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Early Type Definitions ;;; ;;; This module contains basic operations on foreign types. These ;;; definitions are in a separate file because they may be used in ;;; compiler macros defined later on. (in-package #:cffi) ;;;# Foreign Types ;;; ;;; Type specifications are of the form (type {args}*). The type ;;; parser can specify how its arguments should look like through a ;;; lambda list. ;;; ;;; "type" is a shortcut for "(type)", ie, no args were specified. ;;; ;;; Examples of such types: boolean, (boolean), (boolean :int) If the ;;; boolean type parser specifies the lambda list: &optional ;;; (base-type :int), then all of the above three type specs would be ;;; parsed to an identical type. ;;; ;;; Type parsers, defined with DEFINE-PARSE-METHOD should return a ;;; subtype of the foreign-type class. (defvar *type-parsers* (make-hash-table :test 'equal) "Hash table of defined type parsers.") (define-condition cffi-error (error) ()) (define-condition foreign-type-error (cffi-error) ((type-name :initarg :type-name :initform (error "Must specify TYPE-NAME.") :accessor foreign-type-error/type-name) (namespace :initarg :namespace :initform :default :accessor foreign-type-error/namespace))) (defun foreign-type-error/compound-name (e) (let ((name (foreign-type-error/type-name e)) (namespace (foreign-type-error/namespace e))) (if (eq namespace :default) name `(,namespace ,name)))) (define-condition simple-foreign-type-error (simple-error foreign-type-error) ()) (defun simple-foreign-type-error (type-name namespace format-control &rest format-arguments) (error 'simple-foreign-type-error :type-name type-name :namespace namespace :format-control format-control :format-arguments format-arguments)) (define-condition undefined-foreign-type-error (foreign-type-error) () (:report (lambda (e stream) (format stream "Unknown CFFI type ~S" (foreign-type-error/compound-name e))))) (defun undefined-foreign-type-error (type-name &optional (namespace :default)) (error 'undefined-foreign-type-error :type-name type-name :namespace namespace)) ;; TODO this is not according to the C namespace rules, ;; see bug: https://bugs.launchpad.net/cffi/+bug/1527947 (deftype c-namespace-name () '(member :default :struct :union)) ;; for C namespaces read: https://stackoverflow.com/questions/12579142/type-namespace-in-c ;; (section 6.2.3 Name spaces of identifiers) ;; NOTE: :struct is probably an unfortunate name for the tagged (?) namespace (defun find-type-parser (symbol &optional (namespace :default)) "Return the type parser for SYMBOL. NAMESPACE is either :DEFAULT (for variables, functions, and typedefs) or :STRUCT (for structs, unions, and enums)." (check-type symbol (and symbol (not null))) (check-type namespace c-namespace-name) (or (gethash (cons namespace symbol) *type-parsers*) (undefined-foreign-type-error symbol namespace))) (defun (setf find-type-parser) (func symbol &optional (namespace :default)) "Set the type parser for SYMBOL." (check-type symbol (and symbol (not null))) (check-type namespace c-namespace-name) ;; TODO Shall we signal a redefinition warning here? (setf (gethash (cons namespace symbol) *type-parsers*) func)) (defun undefine-foreign-type (symbol &optional (namespace :default)) (remhash (cons namespace symbol) *type-parsers*) (values)) ;;; Using a generic function would have been nicer but generates lots ;;; of style warnings in SBCL. (Silly reason, yes.) (defmacro define-parse-method (name lambda-list &body body) "Define a type parser on NAME and lists whose CAR is NAME." (discard-docstring body) (warn-if-kw-or-belongs-to-cl name) `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (find-type-parser ',name) (lambda ,lambda-list ,@body)) ',name)) ;;; Utility function for the simple case where the type takes no ;;; arguments. (defun notice-foreign-type (name type &optional (namespace :default)) (setf (find-type-parser name namespace) (lambda () type)) name) ;;;# Generic Functions on Types (defgeneric canonicalize (foreign-type) (:documentation "Return the most primitive foreign type for FOREIGN-TYPE, either a built-in type--a keyword--or a struct/union type--a list of the form (:STRUCT/:UNION name). Signals an error if FOREIGN-TYPE is undefined.")) (defgeneric aggregatep (foreign-type) (:documentation "Return true if FOREIGN-TYPE is an aggregate type.")) (defgeneric foreign-type-alignment (foreign-type) (:documentation "Return the structure alignment in bytes of a foreign type.")) (defgeneric foreign-type-size (foreign-type) (:documentation "Return the size in bytes of a foreign type.")) (defgeneric unparse-type (foreign-type) (:documentation "Unparse FOREIGN-TYPE to a type specification (symbol or list).")) ;;;# Foreign Types (defclass foreign-type () () (:documentation "Base class for all foreign types.")) (defmethod make-load-form ((type foreign-type) &optional env) "Return the form used to dump types to a FASL file." (declare (ignore env)) `(parse-type ',(unparse-type type))) (defmethod foreign-type-size (type) "Return the size in bytes of a foreign type." (foreign-type-size (parse-type type))) (defclass named-foreign-type (foreign-type) ((name ;; Name of this foreign type, a symbol. :initform (error "Must specify a NAME.") :initarg :name :accessor name))) (defmethod print-object ((type named-foreign-type) stream) "Print a FOREIGN-TYPEDEF instance to STREAM unreadably." (print-unreadable-object (type stream :type t :identity nil) (format stream "~S" (name type)))) ;;; Return the type's name which can be passed to PARSE-TYPE. If ;;; that's not the case for some subclass of NAMED-FOREIGN-TYPE then ;;; it should specialize UNPARSE-TYPE. (defmethod unparse-type ((type named-foreign-type)) (name type)) ;;;# Built-In Foreign Types (defclass foreign-built-in-type (foreign-type) ((type-keyword ;; Keyword in CFFI-SYS representing this type. :initform (error "A type keyword is required.") :initarg :type-keyword :accessor type-keyword)) (:documentation "A built-in foreign type.")) (defmethod canonicalize ((type foreign-built-in-type)) "Return the built-in type keyword for TYPE." (type-keyword type)) (defmethod aggregatep ((type foreign-built-in-type)) "Returns false, built-in types are never aggregate types." nil) (defmethod foreign-type-alignment ((type foreign-built-in-type)) "Return the alignment of a built-in type." (%foreign-type-alignment (type-keyword type))) (defmethod foreign-type-size ((type foreign-built-in-type)) "Return the size of a built-in type." (%foreign-type-size (type-keyword type))) (defmethod unparse-type ((type foreign-built-in-type)) "Returns the symbolic representation of a built-in type." (type-keyword type)) (defmethod print-object ((type foreign-built-in-type) stream) "Print a FOREIGN-TYPE instance to STREAM unreadably." (print-unreadable-object (type stream :type t :identity nil) (format stream "~S" (type-keyword type)))) (defvar *built-in-foreign-types* nil) (defmacro define-built-in-foreign-type (keyword) "Defines a built-in foreign-type." `(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew ,keyword *built-in-foreign-types*) (notice-foreign-type ,keyword (make-instance 'foreign-built-in-type :type-keyword ,keyword)))) ;;;# Foreign Pointer Types (defclass foreign-pointer-type (foreign-built-in-type) ((pointer-type ;; Type of object pointed at by this pointer, or nil for an ;; untyped (void) pointer. :initform nil :initarg :pointer-type :accessor pointer-type)) (:default-initargs :type-keyword :pointer)) ;;; Define the type parser for the :POINTER type. If no type argument ;;; is provided, a void pointer will be created. (let ((void-pointer (make-instance 'foreign-pointer-type))) (define-parse-method :pointer (&optional type) (if type (make-instance 'foreign-pointer-type :pointer-type (parse-type type)) ;; A bit of premature optimization here. void-pointer))) ;;; Unparse a foreign pointer type when dumping to a fasl. (defmethod unparse-type ((type foreign-pointer-type)) (if (pointer-type type) `(:pointer ,(unparse-type (pointer-type type))) :pointer)) ;;; Print a foreign pointer type unreadably in unparsed form. (defmethod print-object ((type foreign-pointer-type) stream) (print-unreadable-object (type stream :type t :identity nil) (format stream "~S" (unparse-type type)))) ;;;# Structure Type (defgeneric bare-struct-type-p (foreign-type) (:documentation "Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. ")) (defmethod bare-struct-type-p ((type foreign-type)) "Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. " nil) (defclass foreign-struct-type (named-foreign-type) ((slots ;; Hash table of slots in this structure, keyed by name. :initform (make-hash-table) :initarg :slots :accessor slots) (size ;; Cached size in bytes of this structure. :initarg :size :accessor size) (alignment ;; This struct's alignment requirements :initarg :alignment :accessor alignment) (bare ;; we use this flag to support the (old, deprecated) semantics of ;; bare struct types. FOO means (:POINTER (:STRUCT FOO) in ;; functions declarations whereas FOO in a structure definition is ;; a proper aggregate type: (:STRUCT FOO), etc. :initform nil :initarg :bare :reader bare-struct-type-p))) (defun slots-in-order (structure-type) "A list of the structure's slots in order." (sort (loop for slots being the hash-value of (structure-slots structure-type) collect slots) #'< :key 'slot-offset)) (defmethod canonicalize ((type foreign-struct-type)) (if (bare-struct-type-p type) :pointer `(:struct ,(name type)))) (defmethod unparse-type ((type foreign-struct-type)) (if (bare-struct-type-p type) (name type) (canonicalize type))) (defmethod aggregatep ((type foreign-struct-type)) "Returns true, structure types are aggregate." t) (defmethod foreign-type-size ((type foreign-struct-type)) "Return the size in bytes of a foreign structure type." (size type)) (defmethod foreign-type-alignment ((type foreign-struct-type)) "Return the alignment requirements for this struct." (alignment type)) (defclass foreign-union-type (foreign-struct-type) ()) (defmethod canonicalize ((type foreign-union-type)) (if (bare-struct-type-p type) :pointer `(:union ,(name type)))) ;;;# Foreign Typedefs (defclass foreign-type-alias (foreign-type) ((actual-type ;; The FOREIGN-TYPE instance this type is an alias for. :initarg :actual-type :accessor actual-type :initform (error "Must specify an ACTUAL-TYPE."))) (:documentation "A type that aliases another type.")) (defmethod canonicalize ((type foreign-type-alias)) "Return the built-in type keyword for TYPE." (canonicalize (actual-type type))) (defmethod aggregatep ((type foreign-type-alias)) "Return true if TYPE's actual type is aggregate." (aggregatep (actual-type type))) (defmethod foreign-type-alignment ((type foreign-type-alias)) "Return the alignment of a foreign typedef." (foreign-type-alignment (actual-type type))) (defmethod foreign-type-size ((type foreign-type-alias)) "Return the size in bytes of a foreign typedef." (foreign-type-size (actual-type type))) (defclass foreign-typedef (foreign-type-alias named-foreign-type) ()) (defun follow-typedefs (type) (if (typep type 'foreign-typedef) (follow-typedefs (actual-type type)) type)) (defmethod bare-struct-type-p ((type foreign-typedef)) (bare-struct-type-p (follow-typedefs type))) (defun structure-slots (type) "The hash table of slots for the structure type." (slots (follow-typedefs type))) ;;;# Type Translators ;;; ;;; Type translation is done with generic functions at runtime for ;;; subclasses of TRANSLATABLE-FOREIGN-TYPE. ;;; ;;; The main interface for defining type translations is through the ;;; generic functions TRANSLATE-{TO,FROM}-FOREIGN and ;;; FREE-TRANSLATED-OBJECT. (defclass translatable-foreign-type (foreign-type) ()) ;;; ENHANCED-FOREIGN-TYPE is used to define translations on top of ;;; previously defined foreign types. (defclass enhanced-foreign-type (translatable-foreign-type foreign-type-alias) ((unparsed-type :accessor unparsed-type))) ;;; If actual-type isn't parsed already, let's parse it. This way we ;;; don't have to export PARSE-TYPE and users don't have to worry ;;; about this in DEFINE-FOREIGN-TYPE or DEFINE-PARSE-METHOD. (defmethod initialize-instance :after ((type enhanced-foreign-type) &key) (unless (typep (actual-type type) 'foreign-type) (setf (actual-type type) (parse-type (actual-type type))))) (defmethod unparse-type ((type enhanced-foreign-type)) (unparsed-type type)) ;;; Checks NAMEs, not object identity. (defun check-for-typedef-cycles (type) (let ((seen (make-hash-table :test 'eq))) (labels ((%check (cur-type) (when (typep cur-type 'foreign-typedef) (when (gethash (name cur-type) seen) (simple-foreign-type-error type :default "Detected cycle in type ~S." type)) (setf (gethash (name cur-type) seen) t) (%check (actual-type cur-type))))) (%check type)))) ;;; Only now we define PARSE-TYPE because it needs to do some extra ;;; work for ENHANCED-FOREIGN-TYPES. (defun parse-type (type) (let* ((spec (ensure-list type)) (ptype (apply (find-type-parser (car spec)) (cdr spec)))) (when (typep ptype 'foreign-typedef) (check-for-typedef-cycles ptype)) (when (typep ptype 'enhanced-foreign-type) (setf (unparsed-type ptype) type)) ptype)) (defun ensure-parsed-base-type (type) (follow-typedefs (if (typep type 'foreign-type) type (parse-type type)))) (defun canonicalize-foreign-type (type) "Convert TYPE to a built-in type by following aliases. Signals an error if the type cannot be resolved." (canonicalize (parse-type type))) ;;; Translate VALUE to a foreign object of the type represented by ;;; TYPE, which will be a subclass of TRANSLATABLE-FOREIGN-TYPE. ;;; Returns the foreign value and an optional second value which will ;;; be passed to FREE-TRANSLATED-OBJECT as the PARAM argument. (defgeneric translate-to-foreign (value type) (:method (value type) (declare (ignore type)) value)) (defgeneric translate-into-foreign-memory (value type pointer) (:documentation "Translate the Lisp value into the foreign memory location given by pointer. Return value is not used.") (:argument-precedence-order type value pointer)) ;;; Similar to TRANSLATE-TO-FOREIGN, used exclusively by ;;; (SETF FOREIGN-STRUCT-SLOT-VALUE). (defgeneric translate-aggregate-to-foreign (ptr value type)) ;;; Translate the foreign object VALUE from the type repsented by ;;; TYPE, which will be a subclass of TRANSLATABLE-FOREIGN-TYPE. ;;; Returns the converted Lisp value. (defgeneric translate-from-foreign (value type) (:argument-precedence-order type value) (:method (value type) (declare (ignore type)) value)) ;;; Free an object allocated by TRANSLATE-TO-FOREIGN. VALUE is a ;;; foreign object of the type represented by TYPE, which will be a ;;; TRANSLATABLE-FOREIGN-TYPE subclass. PARAM, if present, contains ;;; the second value returned by TRANSLATE-TO-FOREIGN, and is used to ;;; communicate between the two functions. ;;; ;;; FIXME: I don't think this PARAM argument is necessary anymore ;;; because the TYPE object can contain that information. [2008-12-31 LO] (defgeneric free-translated-object (value type param) (:method (value type param) (declare (ignore value type param)))) ;;;## Macroexpansion Time Translation ;;; ;;; The following EXPAND-* generic functions are similar to their ;;; TRANSLATE-* counterparts but are usually called at macroexpansion ;;; time. They offer a way to optimize the runtime translators. ;;; This special variable is bound by the various :around methods ;;; below to the respective form generated by the above %EXPAND-* ;;; functions. This way, an expander can "bail out" by calling the ;;; next method. All 6 of the below-defined GFs have a default method ;;; that simply answers the rtf bound by the default :around method. (defvar *runtime-translator-form*) ;;; EXPAND-FROM-FOREIGN (defgeneric expand-from-foreign (value type) (:method (value type) (declare (ignore type)) value)) (defmethod expand-from-foreign :around (value (type translatable-foreign-type)) (let ((*runtime-translator-form* `(translate-from-foreign ,value ,type))) (call-next-method))) (defmethod expand-from-foreign (value (type translatable-foreign-type)) (declare (ignore value)) *runtime-translator-form*) ;;; EXPAND-TO-FOREIGN ;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that ;; an unspecialized method was called. (defgeneric expand-to-foreign (value type) (:method (value type) (declare (ignore type)) (values value t))) (defmethod expand-to-foreign :around (value (type translatable-foreign-type)) (let ((*runtime-translator-form* `(translate-to-foreign ,value ,type))) (call-next-method))) (defmethod expand-to-foreign (value (type translatable-foreign-type)) (declare (ignore value)) (values *runtime-translator-form* t)) ;;; EXPAND-INTO-FOREIGN-MEMORY (defgeneric expand-into-foreign-memory (value type ptr) (:method (value type ptr) (declare (ignore type)) value)) (defmethod expand-into-foreign-memory :around (value (type translatable-foreign-type) ptr) (let ((*runtime-translator-form* `(translate-into-foreign-memory ,value ,type ,ptr))) (call-next-method))) (defmethod expand-into-foreign-memory (value (type translatable-foreign-type) ptr) (declare (ignore value)) *runtime-translator-form*) ;;; EXPAND-TO-FOREIGN-DYN (defgeneric expand-to-foreign-dyn (value var body type) (:method (value var body type) (declare (ignore type)) `(let ((,var ,value)) ,@body))) (defmethod expand-to-foreign-dyn :around (value var body (type enhanced-foreign-type)) (let ((*runtime-translator-form* (with-unique-names (param) `(multiple-value-bind (,var ,param) (translate-to-foreign ,value ,type) (unwind-protect (progn ,@body) (free-translated-object ,var ,type ,param)))))) (call-next-method))) ;;; If this method is called it means the user hasn't defined a ;;; to-foreign-dyn expansion, so we use the to-foreign expansion. ;;; ;;; However, we do so *only* if there's a specialized ;;; EXPAND-TO-FOREIGN for TYPE because otherwise we want to use the ;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to ;;; FREE-TRANSLATED-OBJECT. (Or else there would occur no translation ;;; at all.) (defun foreign-expand-runtime-translator-or-binding (value var body type) (multiple-value-bind (expansion default-etp-p) (expand-to-foreign value type) (if default-etp-p *runtime-translator-form* `(let ((,var ,expansion)) ,@body)))) (defmethod expand-to-foreign-dyn (value var body (type enhanced-foreign-type)) (foreign-expand-runtime-translator-or-binding value var body type)) ;;; EXPAND-TO-FOREIGN-DYN-INDIRECT ;;; Like expand-to-foreign-dyn, but always give form that returns a ;;; pointer to the object, even if it's directly representable in ;;; CL, e.g. numbers. (defgeneric expand-to-foreign-dyn-indirect (value var body type) (:method (value var body type) (declare (ignore type)) `(let ((,var ,value)) ,@body))) (defmethod expand-to-foreign-dyn-indirect :around (value var body (type translatable-foreign-type)) (let ((*runtime-translator-form* `(with-foreign-object (,var ',(unparse-type type)) (translate-into-foreign-memory ,value ,type ,var) ,@body))) (call-next-method))) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-pointer-type)) `(with-foreign-object (,var :pointer) (translate-into-foreign-memory ,value ,type ,var) ,@body)) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-built-in-type)) `(with-foreign-object (,var ,type) (translate-into-foreign-memory ,value ,type ,var) ,@body)) (defmethod expand-to-foreign-dyn-indirect (value var body (type translatable-foreign-type)) (foreign-expand-runtime-translator-or-binding value var body type)) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-type-alias)) (expand-to-foreign-dyn-indirect value var body (actual-type type))) ;;; User interface for converting values from/to foreign using the ;;; type translators. The compiler macros use the expanders when ;;; possible. (defun convert-to-foreign (value type) (translate-to-foreign value (parse-type type))) (define-compiler-macro convert-to-foreign (value type) (if (constantp type) (expand-to-foreign value (parse-type (eval type))) `(translate-to-foreign ,value (parse-type ,type)))) (defun convert-from-foreign (value type) (translate-from-foreign value (parse-type type))) (define-compiler-macro convert-from-foreign (value type) (if (constantp type) (expand-from-foreign value (parse-type (eval type))) `(translate-from-foreign ,value (parse-type ,type)))) (defun convert-into-foreign-memory (value type ptr) (translate-into-foreign-memory value (parse-type type) ptr)) (define-compiler-macro convert-into-foreign-memory (value type ptr) (if (constantp type) (expand-into-foreign-memory value (parse-type (eval type)) ptr) `(translate-into-foreign-memory ,value (parse-type ,type) ,ptr))) (defun free-converted-object (value type param) (free-translated-object value (parse-type type) param)) ;;;# Enhanced typedefs (defclass enhanced-typedef (foreign-typedef) ()) (defmethod translate-to-foreign (value (type enhanced-typedef)) (translate-to-foreign value (actual-type type))) (defmethod translate-into-foreign-memory (value (type enhanced-typedef) pointer) (translate-into-foreign-memory value (actual-type type) pointer)) (defmethod translate-from-foreign (value (type enhanced-typedef)) (translate-from-foreign value (actual-type type))) (defmethod free-translated-object (value (type enhanced-typedef) param) (free-translated-object value (actual-type type) param)) (defmethod expand-from-foreign (value (type enhanced-typedef)) (expand-from-foreign value (actual-type type))) (defmethod expand-to-foreign (value (type enhanced-typedef)) (expand-to-foreign value (actual-type type))) (defmethod expand-to-foreign-dyn (value var body (type enhanced-typedef)) (expand-to-foreign-dyn value var body (actual-type type))) (defmethod expand-into-foreign-memory (value (type enhanced-typedef) ptr) (expand-into-foreign-memory value (actual-type type) ptr)) ;;;# User-defined Types and Translations. (defmacro define-foreign-type (name supers slots &rest options) (multiple-value-bind (new-options simple-parser actual-type initargs) (let ((keywords '(:simple-parser :actual-type :default-initargs))) (apply #'values (remove-if (lambda (opt) (member (car opt) keywords)) options) (mapcar (lambda (kw) (cdr (assoc kw options))) keywords))) `(eval-when (:compile-toplevel :load-toplevel :execute) (defclass ,name ,(or supers '(enhanced-foreign-type)) ,slots (:default-initargs ,@(when actual-type `(:actual-type ',actual-type)) ,@initargs) ,@new-options) ,(when simple-parser `(define-parse-method ,(car simple-parser) (&rest args) (apply #'make-instance ',name args))) ',name))) (defmacro defctype (name base-type &optional documentation) "Utility macro for simple C-like typedefs." (declare (ignore documentation)) (warn-if-kw-or-belongs-to-cl name) (let* ((btype (parse-type base-type)) (dtype (if (typep btype 'enhanced-foreign-type) 'enhanced-typedef 'foreign-typedef))) `(eval-when (:compile-toplevel :load-toplevel :execute) (notice-foreign-type ',name (make-instance ',dtype :name ',name :actual-type ,btype))))) ;;; For Verrazano. We memoize the type this way to help detect cycles. (defmacro defctype* (name base-type) "Like DEFCTYPE but defers instantiation until parse-time." `(eval-when (:compile-toplevel :load-toplevel :execute) (let (memoized-type) (define-parse-method ,name () (unless memoized-type (setf memoized-type (make-instance 'foreign-typedef :name ',name :actual-type nil) (actual-type memoized-type) (parse-type ',base-type))) memoized-type)))) cffi_0.19.0/src/cffi-openmcl.lisp0000644000175000017500000002464613103031266015335 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:ccl) (:import-from #:alexandria #:once-only #:if-let) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp ; ccl:pointerp #:pointer-eq #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%mem-ref #:%mem-set #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Misfeatures (pushnew 'flat-namespace *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common ;;; usage when the memory has dynamic extent. (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (ccl::malloc size)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." ;; TODO: Should we make this a dead macptr? (ccl::free ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let ((,size-var ,size)) (%stack-block ((,var ,size-var)) ,@body))) ;;;# Misc. Pointer Operations (deftype foreign-pointer () 'ccl:macptr) (defun null-pointer () "Construct and return a null pointer." (ccl:%null-ptr)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (ccl:%null-ptr-p ptr)) (defun inc-pointer (ptr offset) "Return a pointer OFFSET bytes past PTR." (ccl:%inc-ptr ptr offset)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (ccl:%ptr-eql ptr1 ptr2)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (ccl:%int-to-ptr address)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (ccl:%ptr-to-int ptr)) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes that can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." `(ccl:with-pointer-to-ivector (,ptr-var ,vector) ,@body)) ;;;# Dereferencing ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler ;;; macros that optimize the case where the type keyword is constant ;;; at compile-time. (defmacro define-mem-accessors (&body pairs) `(progn (defun %mem-ref (ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (,fn ptr offset))))) (defun %mem-set (value ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) (if (constantp type) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) (if (constantp type) (once-only (value) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) form)))) (define-mem-accessors (:char %get-signed-byte) (:unsigned-char %get-unsigned-byte) (:short %get-signed-word) (:unsigned-short %get-unsigned-word) (:int %get-signed-long) (:unsigned-int %get-unsigned-long) #+(or 32-bit-target windows-target) (:long %get-signed-long) #+(and (not windows-target) 64-bit-target) (:long ccl::%%get-signed-longlong) #+(or 32-bit-target windows-target) (:unsigned-long %get-unsigned-long) #+(and 64-bit-target (not windows-target)) (:unsigned-long ccl::%%get-unsigned-longlong) (:long-long ccl::%get-signed-long-long) (:unsigned-long-long ccl::%get-unsigned-long-long) (:float %get-single-float) (:double %get-double-float) (:pointer %get-ptr)) ;;;# Calling Foreign Functions (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to an OpenMCL type." (ecase type-keyword (:char :signed-byte) (:unsigned-char :unsigned-byte) (:short :signed-short) (:unsigned-short :unsigned-short) (:int :signed-int) (:unsigned-int :unsigned-int) (:long :signed-long) (:unsigned-long :unsigned-long) (:long-long :signed-doubleword) (:unsigned-long-long :unsigned-doubleword) (:float :single-float) (:double :double-float) (:pointer :address) (:void :void))) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (/ (ccl::foreign-type-bits (ccl::parse-foreign-type (convert-foreign-type type-keyword))) 8)) ;; There be dragons here. See the following thread for details: ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (/ (ccl::foreign-type-alignment (ccl::parse-foreign-type (convert-foreign-type type-keyword))) 8)) (defun convert-foreign-funcall-types (args) "Convert foreign types for a call to FOREIGN-FUNCALL." (loop for (type arg) on args by #'cddr collect (convert-foreign-type type) if arg collect arg)) (defun convert-external-name (name) "Add an underscore to NAME if necessary for the ABI." #+darwin (concatenate 'string "_" name) #-darwin name) (defmacro %foreign-funcall (function-name args &key library convention) "Perform a foreign function call, document it more later." (declare (ignore library convention)) `(external-call ,(convert-external-name function-name) ,@(convert-foreign-funcall-types args))) (defmacro %foreign-funcall-pointer (ptr args &key convention) (declare (ignore convention)) `(ff-call ,ptr ,@(convert-foreign-funcall-types args))) ;;;# Callbacks ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr" ;;; entry points. It is safe to store the pointers directly because ;;; OpenMCL will update the address of these pointers when a saved image ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS). (defvar *callbacks* (make-hash-table)) ;;; Create a package to contain the symbols for callback functions. We ;;; want to redefine callbacks with the same symbol so the internal data ;;; structures are reused. (defpackage #:cffi-callbacks (:use)) ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal ;;; callback for NAME. (defun intern-callback (name) (intern (format nil "~A::~A" (if-let (package (symbol-package name)) (package-name package) "#") (symbol-name name)) '#:cffi-callbacks)) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (let ((cb-name (intern-callback name))) `(progn (defcallback ,cb-name (,@(when (eq convention :stdcall) '(:discard-stack-args)) ,@(mapcan (lambda (sym type) (list (convert-foreign-type type) sym)) arg-names arg-types) ,(convert-foreign-type rettype)) ,body) (setf (gethash ',name *callbacks*) (symbol-value ',cb-name))))) (defun %callback (name) (or (gethash name *callbacks*) (error "Undefined callback: ~S" name))) ;;;# Loading Foreign Libraries (defun %load-foreign-library (name path) "Load the foreign library NAME." (declare (ignore name)) (open-shared-library path)) (defun %close-foreign-library (name) "Close the foreign library NAME." ;; C-S-L sometimes ends in an endless loop ;; with :COMPLETELY T (close-shared-library name :completely nil)) (defun native-namestring (pathname) (ccl::native-translated-namestring pathname)) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (foreign-symbol-address (convert-external-name name))) cffi_0.19.0/src/cffi-cmucl.lisp0000644000175000017500000003164413103031266014777 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-cmucl.lisp --- CFFI-SYS implementation for CMU CL. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:alien #:c-call) (:import-from #:alexandria #:once-only #:with-unique-names #:if-let) (:export #:canonicalize-symbol-name-case #:foreign-pointer #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:native-namestring #:%mem-ref #:%mem-set #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%foreign-symbol-pointer #:%defcallback #:%callback)) (in-package #:cffi-sys) ;;;# Misfeatures (pushnew 'flat-namespace *features*) ;;;# Symbol Case (defun canonicalize-symbol-name-case (name) (declare (string name)) (string-upcase name)) ;;;# Basic Pointer Operations (deftype foreign-pointer () 'sys:system-area-pointer) (declaim (inline pointerp)) (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (sys:system-area-pointer-p ptr)) (declaim (inline pointer-eq)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (sys:sap= ptr1 ptr2)) (declaim (inline null-pointer)) (defun null-pointer () "Construct and return a null pointer." (sys:int-sap 0)) (declaim (inline null-pointer-p)) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (zerop (sys:sap-int ptr))) (declaim (inline inc-pointer)) (defun inc-pointer (ptr offset) "Return a pointer pointing OFFSET bytes past PTR." (sys:sap+ ptr offset)) (declaim (inline make-pointer)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (sys:int-sap address)) (declaim (inline pointer-address)) (defun pointer-address (ptr) "Return the address pointed to by PTR." (sys:sap-int ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) ;; If the size is constant we can stack-allocate. (if (constantp size) (let ((alien-var (gensym "ALIEN"))) `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) (let ((,size-var ,(eval size)) (,var (alien-sap ,alien-var))) (declare (ignorable ,size-var)) ,@body))) `(let* ((,size-var ,size) (,var (%foreign-alloc ,size-var))) (unwind-protect (progn ,@body) (foreign-free ,var))))) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage ;;; when the memory has dynamic extent. (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (declare (type (unsigned-byte 32) size)) (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned)) size)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." (declare (type system-area-pointer ptr)) (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) ptr)) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. (defun make-shareable-byte-vector (size) "Create a Lisp vector of SIZE bytes that can passed to WITH-POINTER-TO-VECTOR-DATA." (make-array size :element-type '(unsigned-byte 8))) (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." `(sys:without-gcing (let ((,ptr-var (sys:vector-sap ,vector))) ,@body))) ;;;# Dereferencing ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler ;;; macros that optimize the case where the type keyword is constant ;;; at compile-time. (defmacro define-mem-accessors (&body pairs) `(progn (defun %mem-ref (ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (,fn ptr offset))))) (defun %mem-set (value ptr type &optional (offset 0)) (ecase type ,@(loop for (keyword fn) in pairs collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) (if (constantp type) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) (if (constantp type) (once-only (value) (ecase (eval type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) form)))) (define-mem-accessors (:char sys:signed-sap-ref-8) (:unsigned-char sys:sap-ref-8) (:short sys:signed-sap-ref-16) (:unsigned-short sys:sap-ref-16) (:int sys:signed-sap-ref-32) (:unsigned-int sys:sap-ref-32) (:long sys:signed-sap-ref-32) (:unsigned-long sys:sap-ref-32) (:long-long sys:signed-sap-ref-64) (:unsigned-long-long sys:sap-ref-64) (:float sys:sap-ref-single) (:double sys:sap-ref-double) (:pointer sys:sap-ref-sap)) ;;;# Calling Foreign Functions (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to an ALIEN type." (ecase type-keyword (:char 'char) (:unsigned-char 'unsigned-char) (:short 'short) (:unsigned-short 'unsigned-short) (:int 'int) (:unsigned-int 'unsigned-int) (:long 'long) (:unsigned-long 'unsigned-long) (:long-long '(signed 64)) (:unsigned-long-long '(unsigned 64)) (:float 'single-float) (:double 'double-float) (:pointer 'system-area-pointer) (:void 'void))) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (/ (alien-internals:alien-type-bits (alien-internals:parse-alien-type (convert-foreign-type type-keyword))) 8)) (defun %foreign-type-alignment (type-keyword) "Return the alignment in bytes of a foreign type." (/ (alien-internals:alien-type-alignment (alien-internals:parse-alien-type (convert-foreign-type type-keyword))) 8)) (defun foreign-funcall-type-and-args (args) "Return an ALIEN function type for ARGS." (let ((return-type nil)) (loop for (type arg) on args by #'cddr if arg collect (convert-foreign-type type) into types and collect arg into fargs else do (setf return-type (convert-foreign-type type)) finally (return (values types fargs return-type))))) (defmacro %%foreign-funcall (name types fargs rettype) "Internal guts of %FOREIGN-FUNCALL." `(alien-funcall (extern-alien ,name (function ,rettype ,@types)) ,@fargs)) (defmacro %foreign-funcall (name args &key library convention) "Perform a foreign function call, document it more later." (declare (ignore library convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(%%foreign-funcall ,name ,types ,fargs ,rettype))) (defmacro %foreign-funcall-pointer (ptr args &key convention) "Funcall a pointer to a foreign function." (declare (ignore convention)) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) (with-unique-names (function) `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr)) (alien-funcall ,function ,@fargs))))) ;;;# Callbacks (defvar *callbacks* (make-hash-table)) ;;; Create a package to contain the symbols for callback functions. We ;;; want to redefine callbacks with the same symbol so the internal data ;;; structures are reused. (defpackage #:cffi-callbacks (:use)) ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal ;;; callback for NAME. (eval-when (:compile-toplevel :load-toplevel :execute) (defun intern-callback (name) (intern (format nil "~A::~A" (if-let (package (symbol-package name)) (package-name package) name) (symbol-name name)) '#:cffi-callbacks))) (defmacro %defcallback (name rettype arg-names arg-types body &key convention) (declare (ignore convention)) (let ((cb-name (intern-callback name))) `(progn (def-callback ,cb-name (,(convert-foreign-type rettype) ,@(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types)) ,body) (setf (gethash ',name *callbacks*) (callback ,cb-name))))) (defun %callback (name) (multiple-value-bind (pointer winp) (gethash name *callbacks*) (unless winp (error "Undefined callback: ~S" name)) pointer)) ;;; CMUCL makes new callback trampolines when it reloads, so we need ;;; to update CFFI's copies. (defun reset-callbacks () (loop for k being the hash-keys of *callbacks* do (setf (gethash k *callbacks*) (alien::symbol-trampoline (intern-callback k))))) ;; Needs to be after cmucl's restore-callbacks, so put at the end... (unless (member 'reset-callbacks ext:*after-save-initializations*) (setf ext:*after-save-initializations* (append ext:*after-save-initializations* (list 'reset-callbacks)))) ;;;# Loading and Closing Foreign Libraries ;;; Work-around for compiling ffi code without loading the ;;; respective library at compile-time. (setf c::top-level-lambda-max 0) (defun %load-foreign-library (name path) "Load the foreign library NAME." ;; On some platforms SYS::LOAD-OBJECT-FILE signals an error when ;; loading fails, but on others (Linux for instance) it returns ;; two values: NIL and an error string. (declare (ignore name)) (multiple-value-bind (ret message) (sys::load-object-file path) (cond ;; Loading failed. ((stringp message) (error "~A" message)) ;; The library was already loaded. ((null ret) (cdr (rassoc path sys::*global-table* :test #'string=))) ;; The library has been loaded, but since SYS::LOAD-OBJECT-FILE ;; returns an alist of *all* loaded libraries along with their addresses ;; we return only the handler associated with the library just loaded. (t (cdr (rassoc path ret :test #'string=)))))) ;;; XXX: doesn't work on Darwin; does not check for errors. I suppose we'd ;;; want something like SBCL's dlclose-or-lose in foreign-load.lisp:66 (defun %close-foreign-library (handler) "Closes a foreign library." (let ((lib (rassoc (ext:unix-namestring handler) sys::*global-table* :test #'string=))) (sys::dlclose (car lib)) (setf (car lib) (sys:int-sap 0)))) (defun native-namestring (pathname) (ext:unix-namestring pathname nil)) ;;;# Foreign Globals (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (let ((address (sys:alternate-get-global-address (vm:extern-alien-name name)))) (if (zerop address) nil (sys:int-sap address)))) cffi_0.19.0/.gitignore0000644000175000017500000000036513103031266013273 0ustar luisluis*~ *.o *.dylib *.dll *.bundle *.so *.fasl *.xfasl .DS_Store doc/*.aux doc/manual/ doc/spec/ doc/*.log doc/*.info doc/*.aux doc/*.cp doc/*.fn doc/*.fns doc/*.ky doc/*.pg doc/*.toc doc/*.tps doc/*.tp doc/*.vr doc/*.dvi doc/*.cps doc/*.vrs doc/dir cffi_0.19.0/TODO0000644000175000017500000001045513103031266011774 0ustar luisluis-*- Text -*- This is a collection of TODO items and ideas in no particular order. ### Testing -> Test uffi-compat with more UFFI libraries. -> Write more FOREIGN-GLOBALS.SET.* tests. -> Finish tests/random-tester.lisp -> Write benchmarks comparing CFFI vs. native FFIs and also demonstrating performance of each platform. -> Write more STRUCT.ALIGNMENT.* tests (namely involving the :LONG-LONG and :UNSIGNED-LONG-LONG types) and test them in more ABIs. -> Run tests with the different kinds of shared libraries available on MacOS X. ### Ports -> Finish GCL port, port to MCL. -> Update Corman port. [2007-02-22 LO] ### Features -> Implement a declarative interface for FOREIGN-FUNCALL-PTR, similar to DEFCUN/FOREIGN-FUNCALL. -> Implement the proposed interfaces (see doc/). -> Extend FOREIGN-SLOT-VALUE and make it accept multiple "indices" for directly accessing structs inside structs, arrays inside structs, etc... -> Implement EXPLAIN-FOREIGN-SLOT-VALUE. -> Implement :in/:out/:in-out for DEFCFUN (and FOREIGN-FUNCALL?). -> Add support for multiple memory allocation schemes (like CLISP), namely support for allocating with malloc() (so that it can be freed on the C side)> -> Extend DEFCVAR's symbol macro in order to handle memory (de)allocation automatically (see CLISP). -> Implement byte swapping routines (see /usr/include/linux/byteorder) -> Warn about :void in places where it doesn't make sense. ### Underspecified Semantics -> (setf (mem-ref ptr offset) ) -> Review the interface for coherence across Lisps with regard to behaviour in "exceptional" situations. Eg: threads, dumping cores, accessing foreign symbols that don't exist, etc... -> On Lispworks a Lisp float is a double and therefore won't necessarily fit in a C float. Figure out a way to handle this. -> Allegro: callbacks' return values. -> Lack of uniformity with regard to pointers. Allegro: 0 -> NULL. CLISP/Lispworks: NIL -> NULL. -> Some lisps will accept a lisp float being passed to :double and a lisp double to :float. We should either coerce on lisps that don't accept this or check-type on lisps that do. Probably the former is better since on lispworks/x86 double == float. ### Possible Optimizations -> More compiler macros on some of the CFFI-SYS implementations. -> Optimize UFFI-COMPAT when the vector stuff is implemented. -> Being able to declare that some C int will always fit in a Lisp fixnum. Allegro has a :fixnum ftype and CMUCL/SBCL can use (unsigned-byte 29) others could perhaps behave like :int? -> An option for defcfun to expand into a compiler macro which would allow the macroexpansion-time translators to look at the forms passed to the functions. ### Known Issues -> CLISP FASL portability is broken. Fix this by placing LOAD-TIME-VALUE forms in the right places and moving other calculations to load-time. (eg: calculating struct size/alignment.) Ideally we'd only move them to load-time when we actually care about fasl portability. (defmacro maybe-load-time-value (form) (if `(load-time-value ,form) form)) -> cffi-tests.asd's :c-test-lib component is causing the whole testsuite to be recompiled everytime. Figure that out. -> The (if (constantp foo) (do-something-with (eval foo)) ...) pattern used in many places throughout the code is apparently not 100% safe. -> On ECL platforms without DFFI we need to build a non-linked version of libtest. -> foreign-enum-keyword/value should have their own error condition? [2007-02-22 LO] ### Documentation -> Fill the missing sections in the CFFI User Manual. -> Update the CFFI-SYS Specification. -> have two versions of the manual on the website ### CFFI-Grovel -> Look into making the C output more concise. ### CFFI-Toolchain -> Port the toolchain parameter detection to more implementations -> Port the static linking support to more implementations -> Add a mechanism to configure and/or detect dynamic libraries against which to link for instance. It could be a variable in which flags are accumulated, or an autodetection after loading everything, see https://github.com/borodust/cl-bodge/blob/0.3.0/distribution/build.lisp#L79 ### Other -> Type-checking pointer interface. cffi_0.19.0/cffi-tests.asd0000644000175000017500000000732613103031266014047 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-tests.asd --- ASDF system definition for CFFI unit tests. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2011, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (load-systems "trivial-features" "cffi-grovel") (defclass c-test-lib (c-source-file) ()) (defmethod perform ((o load-op) (c c-test-lib)) nil) (defmethod perform ((o load-source-op) (c c-test-lib)) nil) (defmethod output-files ((o compile-op) (c c-test-lib)) (let ((p (component-pathname c))) (values (list (make-pathname :defaults p :type (asdf/bundle:bundle-pathname-type :object)) (make-pathname :defaults p :type (asdf/bundle:bundle-pathname-type :shared-library))) t))) (defmethod perform ((o compile-op) (c c-test-lib)) (let ((cffi-toolchain:*cc-flags* `(,@cffi-toolchain:*cc-flags* "-Wall" "-std=c99" "-pedantic"))) (destructuring-bind (obj dll) (output-files o c) (cffi-toolchain:cc-compile obj (input-files o c)) (cffi-toolchain:link-shared-library dll (list obj))))) (defsystem "cffi-tests" :description "Unit tests for CFFI." :depends-on ("cffi-grovel" "cffi-libffi" "bordeaux-threads" #-ecl "rt" #+ecl (:require "rt")) :components ((:module "tests" :components ((:c-test-lib "libtest") (:c-test-lib "libtest2") (:c-test-lib "libfsbv") (:file "package") (:file "bindings" :depends-on ("package" "libtest" "libtest2" "libfsbv")) (:file "funcall" :depends-on ("bindings")) (:file "defcfun" :depends-on ("bindings")) (:file "callbacks" :depends-on ("bindings")) (:file "foreign-globals" :depends-on ("package")) (:file "memory" :depends-on ("package")) (:file "strings" :depends-on ("package")) (:file "arrays" :depends-on ("package")) (:file "struct" :depends-on ("package")) (:file "union" :depends-on ("package")) (:file "enum" :depends-on ("package")) (:file "fsbv" :depends-on ("bindings" "enum")) (:file "misc-types" :depends-on ("bindings")) (:file "misc" :depends-on ("bindings")) (:file "test-asdf" :depends-on ("package")) (:file "grovel" :depends-on ("package"))))) :perform (test-op (o c) (symbol-call :cffi-tests '#:run-all-cffi-tests))) (defsystem "cffi-tests/example" :defsystem-depends-on ("cffi-grovel") :entry-point "cffi-example::entry-point" :components ((:module "examples" :components ((:file "package") (:cffi-wrapper-file "wrapper-example" :depends-on ("package")) (:cffi-grovel-file "grovel-example" :depends-on ("package")) (:file "main-example" :depends-on ("package")))))) ;;; vim: ft=lisp et cffi_0.19.0/cffi-grovel.asd0000644000175000017500000000322413103031266014174 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-grovel.asd --- ASDF system definition for cffi-grovel. ;;; ;;; Copyright (C) 2007, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (defsystem "cffi-grovel" :description "The CFFI Groveller" :author "Dan Knapp " :depends-on ("cffi" "cffi-toolchain" "alexandria") :licence "MIT" :components ((:module "grovel" :components ((:static-file "common.h") (:file "package") (:file "grovel" :depends-on ("package")) (:file "asdf" :depends-on ("grovel")))))) ;; vim: ft=lisp et cffi_0.19.0/libffi/0000755000175000017500000000000013103031266012532 5ustar luisluiscffi_0.19.0/libffi/libffi-functions.lisp0000644000175000017500000000315713103031266016672 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; init.lisp --- Load libffi and define basics ;;; ;;; Copyright (C) 2009, 2010, 2011 Liam Healy ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) ;;; See file:///usr/share/doc/libffi-dev/html/The-Basics.html#The-Basics (defcfun ("ffi_prep_cif" libffi/prep-cif) status (ffi-cif :pointer) (ffi-abi abi) (nargs :uint) (rtype :pointer) (argtypes :pointer)) (defcfun ("ffi_call" libffi/call) :void (ffi-cif :pointer) (function :pointer) (rvalue :pointer) (avalues :pointer)) cffi_0.19.0/libffi/libffi-types.lisp0000644000175000017500000000647513103031266016034 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; libffi-types.lisp -- CFFI-Grovel definitions for libffi ;;; ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) #+linux (define "_GNU_SOURCE") ;; When installed through Mac Ports, libffi include files ;; will be found in /opt/local/include. #+darwin (cc-flags "-I/opt/local/include/") #+openbsd (cc-flags "-I/usr/local/include") (pkg-config-cflags "libffi" :optional t) #+darwin (include "ffi/ffi.h") #-darwin (include "ffi.h") (cenum status ((:ok "FFI_OK")) ((:bad-typedef "FFI_BAD_TYPEDEF")) ((:bad-abi "FFI_BAD_ABI"))) #+freebsd (cenum abi ((:default-abi "FFI_DEFAULT_ABI"))) #+(and windows x86-64) (cenum abi ((:default-abi "FFI_DEFAULT_ABI")) ((:win64 "FFI_WIN64"))) #+(and windows (not x86-64)) (cenum abi ((:default-abi "FFI_DEFAULT_ABI")) ((:sysv "FFI_SYSV")) ((:stdcall "FFI_STDCALL"))) #-(or freebsd windows) (cenum abi ((:default-abi "FFI_DEFAULT_ABI")) ((:sysv "FFI_SYSV")) ((:unix64 "FFI_UNIX64"))) (ctype ffi-abi "ffi_abi") (ctype size-t "size_t") (cstruct ffi-type "struct _ffi_type" (size "size" :type size-t) (alignment "alignment" :type :unsigned-short) (type "type" :type :unsigned-short) (elements "elements" :type :pointer)) (cstruct ffi-cif "ffi_cif" (abi "abi" :type ffi-abi) (argument-count "nargs" :type :unsigned-int) (argument-types "arg_types" :type :pointer) (return-type "rtype" :type :pointer) (bytes "bytes" :type :unsigned-int) (flags "flags" :type :unsigned-int)) (constant (+type-void+ "FFI_TYPE_VOID")) (constant (+type-int+ "FFI_TYPE_INT")) (constant (+type-float+ "FFI_TYPE_FLOAT")) (constant (+type-double+ "FFI_TYPE_DOUBLE")) (constant (+type-longdouble+ "FFI_TYPE_LONGDOUBLE")) (constant (+type-uint8+ "FFI_TYPE_UINT8")) (constant (+type-sint8+ "FFI_TYPE_SINT8")) (constant (+type-uint16+ "FFI_TYPE_UINT16")) (constant (+type-sint16+ "FFI_TYPE_SINT16")) (constant (+type-uint32+ "FFI_TYPE_UINT32")) (constant (+type-sint32+ "FFI_TYPE_SINT32")) (constant (+type-uint64+ "FFI_TYPE_UINT64")) (constant (+type-sint64+ "FFI_TYPE_SINT64")) (constant (+type-struct+ "FFI_TYPE_STRUCT")) (constant (+type-pointer+ "FFI_TYPE_POINTER")) cffi_0.19.0/libffi/funcall.lisp0000644000175000017500000001420013103031266015044 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; funcall.lisp -- FOREIGN-FUNCALL implementation using libffi ;;; ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) (define-condition libffi-error (cffi-error) ((function-name :initarg :function-name :reader function-name))) (define-condition simple-libffi-error (simple-error libffi-error) ()) (defun libffi-error (function-name format-control &rest format-arguments) (error 'simple-libffi-error :function-name function-name :format-control format-control :format-arguments format-arguments)) (defun make-libffi-cif (function-name return-type argument-types &optional (abi :default-abi)) "Generate or retrieve the Call InterFace needed to call the function through libffi." (let* ((argument-count (length argument-types)) (cif (foreign-alloc '(:struct ffi-cif))) (ffi-argtypes (foreign-alloc :pointer :count argument-count))) (loop :for type :in argument-types :for index :from 0 :do (setf (mem-aref ffi-argtypes :pointer index) (make-libffi-type-descriptor (parse-type type)))) (unless (eql :ok (libffi/prep-cif cif abi argument-count (make-libffi-type-descriptor (parse-type return-type)) ffi-argtypes)) (libffi-error function-name "The 'ffi_prep_cif' libffi call failed for function ~S." function-name)) cif)) (defun free-libffi-cif (ptr) (foreign-free (foreign-slot-value ptr '(:struct ffi-cif) 'argument-types)) (foreign-free ptr)) (defun translate-objects-ret (symbols function-arguments types return-type call-form) (translate-objects symbols function-arguments types return-type (if (or (eql return-type :void) (typep (parse-type return-type) 'translatable-foreign-type)) call-form ;; built-in types won't be translated by ;; expand-from-foreign, we have to do it here `(mem-ref ,call-form ',(canonicalize-foreign-type return-type))) t)) (defun foreign-funcall-form/fsbv-with-libffi (function function-arguments symbols types return-type argument-types &optional pointerp (abi :default-abi)) "A body of foreign-funcall calling the libffi function #'call (ffi_call)." (let ((argument-count (length argument-types))) `(with-foreign-objects ((argument-values :pointer ,argument-count) ,@(unless (eql return-type :void) `((result ',return-type)))) ,(translate-objects-ret symbols function-arguments types return-type ;; NOTE: We must delay the cif creation until the first call ;; because it's FOREIGN-ALLOC'd, i.e. it gets corrupted by an ;; image save/restore cycle. This way a lib will remain usable ;; through a save/restore cycle if the save happens before any ;; FFI calls will have been made, i.e. nothing is malloc'd yet. `(progn (loop :for arg :in (list ,@symbols) :for count :from 0 :do (setf (mem-aref argument-values :pointer count) arg)) (let* ((libffi-cif-cache (load-time-value (cons 'libffi-cif-cache nil))) (libffi-cif (or (cdr libffi-cif-cache) (setf (cdr libffi-cif-cache) ;; FIXME ideally we should install a finalizer on the cons ;; that calls FREE-LIBFFI-CIF on the cif (when the function ;; gets redefined, and the cif becomes unreachable). but a ;; finite world is full of compromises... - attila (make-libffi-cif ,function ',return-type ',argument-types ',abi))))) (libffi/call libffi-cif ,(if pointerp function `(foreign-symbol-pointer ,function)) ,(if (eql return-type :void) '(null-pointer) 'result) argument-values) ,(if (eql return-type :void) '(values) 'result))))))) (setf *foreign-structures-by-value* 'foreign-funcall-form/fsbv-with-libffi) ;; DEPRECATED Its presence encourages the use of #+fsbv which may lead to the ;; situation where a fasl was produced by an image that has fsbv feature ;; and then ends up being loaded into an image later that has no fsbv support ;; loaded. Use explicit ASDF dependencies instead and assume the presence ;; of the feature accordingly. (pushnew :fsbv *features*) ;; DEPRECATED This is here only for backwards compatibility until its fate is ;; decided. See the mailing list discussion for details. (defctype :sizet size-t) cffi_0.19.0/libffi/type-descriptors.lisp0000644000175000017500000001113213103031266016741 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; type-descriptors.lisp --- Build malloc'd libffi type descriptors ;;; ;;; Copyright (C) 2009, 2011 Liam M. Healy ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) (defmacro type-descriptor-ptr (type) `(foreign-symbol-pointer ,(format nil "ffi_type_~(~A~)" type))) (defmacro type-descriptor-ptr/integer (type) `(foreign-symbol-pointer ,(format nil "ffi_type_~Aint~D" (if (string-equal type "unsigned" :end1 (min 8 (length (string type)))) "u" "s") (* 8 (foreign-type-size type))))) (defun %make-libffi-type-descriptor/struct (type) (labels ((slot-multiplicity (slot) (if (typep slot 'aggregate-struct-slot) (slot-count slot) 1)) (number-of-items (structure-type) "Total number of items in the foreign structure." (loop for val being the hash-value of (structure-slots structure-type) sum (slot-multiplicity val)))) (let* ((ptr (foreign-alloc '(:struct ffi-type))) (nitems (number-of-items type)) (type-pointer-array (foreign-alloc :pointer :count (1+ nitems)))) (loop for slot in (slots-in-order type) for ltp = (make-libffi-type-descriptor (parse-type (slot-type slot))) with slot-counter = 0 do (if ltp (loop repeat (slot-multiplicity slot) do (setf (mem-aref type-pointer-array :pointer slot-counter) ltp) (incf slot-counter)) (libffi-error nil "Slot type ~A in foreign structure is unknown to libffi." (unparse-type (slot-type slot))))) (setf (mem-aref type-pointer-array :pointer nitems) (null-pointer)) (macrolet ((store (slot value) `(setf (foreign-slot-value ptr '(:struct ffi-type) ',slot) ,value))) (store size 0) (store alignment 0) (store type +type-struct+) (store elements type-pointer-array)) ptr))) (defgeneric make-libffi-type-descriptor (object) (:documentation "Build a libffi struct that describes the type for libffi. This will be used as a cached static read-only argument when the actual call happens.") (:method ((object foreign-built-in-type)) (let ((type-keyword (type-keyword object))) #.`(case type-keyword ,@(loop :for type :in (append *built-in-float-types* *other-builtin-types*) :collect `(,type (type-descriptor-ptr ,type))) ,@(loop :for type :in *built-in-integer-types* :collect `(,type (type-descriptor-ptr/integer ,type))) ;; there's a generic error report in an :around method ))) (:method ((type foreign-pointer-type)) ;; simplify all pointer types into a void* (type-descriptor-ptr :pointer)) (:method ((type foreign-struct-type)) (%make-libffi-type-descriptor/struct type)) (:method :around (object) (let ((result (call-next-method))) (assert result () "~S failed on ~S. That's bad." 'make-libffi-type-descriptor object) result)) (:method ((type foreign-type-alias)) ;; Set the type pointer on demand for alias types (e.g. typedef, enum, etc) (make-libffi-type-descriptor (actual-type type)))) cffi_0.19.0/libffi/libffi.lisp0000644000175000017500000000316613103031266014664 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; libffi.lisp --- Load libffi ;;; ;;; Copyright (C) 2009, 2011 Liam M. Healy ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package #:cffi) (define-foreign-library (libffi) (:darwin (:or "libffi.dylib" "libffi32.dylib" "/usr/lib/libffi.dylib")) (:solaris (:or "/usr/lib/amd64/libffi.so" "/usr/lib/libffi.so")) (:openbsd "libffi.so") (:unix (:or "libffi.so.6" "libffi32.so.6" "libffi.so.5" "libffi32.so.5")) (:windows (:or "libffi-6.dll" "libffi-5.dll" "libffi.dll")) (t (:default "libffi"))) (load-foreign-library 'libffi) cffi_0.19.0/cffi.asd0000644000175000017500000000745113124312147012711 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi.asd --- ASDF system definition for CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2010, Luis Oliveira ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (in-package :asdf) #-(or openmcl mcl sbcl cmucl scl clisp lispworks ecl allegro cormanlisp abcl mkcl clasp) (error "Sorry, this Lisp is not yet supported. Patches welcome!") (defsystem :cffi :version "0.19.0" :description "The Common Foreign Function Interface" :author "James Bielman " :maintainer "Luis Oliveira " :licence "MIT" :depends-on (:uiop :alexandria :trivial-features :babel) :in-order-to ((test-op (load-op :cffi-tests))) :perform (test-op (o c) (operate 'asdf:test-op :cffi-tests)) :components ((:module "src" :serial t :components (#+openmcl (:file "cffi-openmcl") #+mcl (:file "cffi-mcl") #+sbcl (:file "cffi-sbcl") #+cmucl (:file "cffi-cmucl") #+scl (:file "cffi-scl") #+clisp (:file "cffi-clisp") #+lispworks (:file "cffi-lispworks") #+ecl (:file "cffi-ecl") #+allegro (:file "cffi-allegro") #+cormanlisp (:file "cffi-corman") #+abcl (:file "cffi-abcl") #+mkcl (:file "cffi-mkcl") #+clasp (:file "cffi-clasp") (:file "package") (:file "utils") (:file "libraries") (:file "early-types") (:file "types") (:file "enum") (:file "strings") (:file "structures") (:file "functions") (:file "foreign-vars") (:file "features"))))) ;; when you get CFFI from git, its defsystem doesn't have a version, ;; so we assume it satisfies any version requirements whatsoever. (defmethod version-satisfies ((c (eql (find-system :cffi))) version) (declare (ignorable version)) (or (null (component-version c)) (call-next-method))) (defsystem :cffi/c2ffi :description "CFFI definition generator from the FFI spec generated by c2ffi. This system is enough to use the ASDF machinery (as a :defsystem-depends-on)." :author "Attila Lendvai " :depends-on (:alexandria :cffi) :licence "MIT" :components ((:module "src/c2ffi" :components ((:file "package") (:file "c2ffi" :depends-on ("package")) (:file "asdf" :depends-on ("package" "c2ffi")))))) (defsystem :cffi/c2ffi-generator :description "This system gets loaded lazily when the CFFI bindings need to be regenerated." :author "Attila Lendvai " :depends-on (:cffi/c2ffi :cl-ppcre :cl-json) :licence "MIT" :components ((:module "src/c2ffi" :components ((:file "generator"))))) cffi_0.19.0/cffi-uffi-compat.asd0000644000175000017500000000317013103031266015110 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-uffi-compat.asd --- ASDF system definition for CFFI-UFFI-COMPAT. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (defpackage #:cffi-uffi-compat-system (:use #:cl #:asdf)) (in-package #:cffi-uffi-compat-system) (defsystem cffi-uffi-compat :description "UFFI Compatibility Layer for CFFI" :author "James Bielman " :components ((:module uffi-compat :components ((:file "uffi-compat")))) :depends-on (cffi)) ;; vim: ft=lisp et cffi_0.19.0/HEADER0000644000175000017500000000234513103031266012156 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; filename --- description ;;; ;;; Copyright (C) 2007, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; cffi_0.19.0/cffi-examples.asd0000644000175000017500000000302413103031266014512 0ustar luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-examples.asd --- ASDF system definition for CFFI examples. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, copy, ;;; modify, merge, publish, distribute, sublicense, and/or sell copies ;;; of the Software, and to permit persons to whom the Software is ;;; furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; (defsystem cffi-examples :description "CFFI Examples" :author "James Bielman " :components ((:module examples :components ((:file "examples") (:file "gethostname") (:file "gettimeofday")))) :depends-on (cffi)) cffi_0.19.0/doc/0000755000175000017500000000000013103031266012044 5ustar luisluiscffi_0.19.0/doc/cffi-sys-spec.texinfo0000644000175000017500000002271613103031266016125 0ustar luisluis\input texinfo @c -*-texinfo-*- @c %**start of header @setfilename cffi-sys.info @settitle CFFI-SYS Interface Specification @c Show types in the same index as the functions. @synindex tp fn @copying Copyright @copyright{} 2005-2006, James Bielman @quotation Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ``Software''), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. @sc{The software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall the authors or copyright holders be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the software or the use or other dealings in the software.} @end quotation @end copying @macro impnote {text} @emph{Implementor's note: \text\} @end macro @c %**end of header @dircategory Software development @direntry * CFFI Sys spec: (cffi-sys-spec). CFFI Sys spec. @end direntry @titlepage @title CFFI-SYS Interface Specification @c @subtitle Version X.X @c @author James Bielman @page @vskip 0pt plus 1filll @insertcopying @end titlepage @contents @ifnottex @node Top @top cffi-sys @insertcopying @end ifnottex @menu * Introduction:: * Built-In Foreign Types:: * Operations on Foreign Types:: * Basic Pointer Operations:: * Foreign Memory Allocation:: * Memory Access:: * Foreign Function Calling:: * Loading Foreign Libraries:: * Foreign Globals:: * Symbol Index:: @end menu @node Introduction @chapter Introduction @acronym{CFFI}, the Common Foreign Function Interface, purports to be a portable foreign function interface for Common Lisp. This specification defines a set of low-level primitives that must be defined for each Lisp implementation supported by @acronym{CFFI}. These operators are defined in the @code{CFFI-SYS} package. The @code{CFFI} package uses the @code{CFFI-SYS} interface to implement an extensible foreign type system with support for typedefs, structures, and unions, a declarative interface for defining foreign function calls, and automatic conversion of foreign function arguments to/from Lisp types. Please note the following conventions that apply to everything in @code{CFFI-SYS}: @itemize @bullet @item Functions in @code{CFFI-SYS} that are low-level versions of functions exported from the @code{CFFI} package begin with a leading percent-sign (eg. @code{%mem-ref}). @item Where ``foreign type'' is mentioned as the kind of an argument, the meaning is restricted to that subset of all foreign types defined in @ref{Built-In Foreign Types}. Support for higher-level types is always defined in terms of those lower-level types in @code{CFFI} proper. @end itemize @node Built-In Foreign Types @chapter Built-In Foreign Types @deftp {Foreign Type} :char @deftpx {Foreign Type} :unsigned-char @deftpx {Foreign Type} :short @deftpx {Foreign Type} :unsigned-short @deftpx {Foreign Type} :int @deftpx {Foreign Type} :unsigned-int @deftpx {Foreign Type} :long @deftpx {Foreign Type} :unsigned-long @deftpx {Foreign Type} :long-long @deftpx {Foreign Type} :unsigned-long-long These types correspond to the native C integer types according to the ABI of the system the Lisp implementation is compiled against. @end deftp @deftp {Foreign Type} :int8 @deftpx {Foreign Type} :uint8 @deftpx {Foreign Type} :int16 @deftpx {Foreign Type} :uint16 @deftpx {Foreign Type} :int32 @deftpx {Foreign Type} :uint32 @deftpx {Foreign Type} :int64 @deftpx {Foreign Type} :uint64 Foreign integer types of specific sizes, corresponding to the C types defined in @code{stdint.h}. @end deftp @deftp {Foreign Type} :size @deftpx {Foreign Type} :ssize @deftpx {Foreign Type} :ptrdiff @deftpx {Foreign Type} :time Foreign integer types corresponding to the standard C types (without the @code{_t} suffix). @end deftp @impnote{I'm sure there are more of these that could be useful, let's add any types that can't be defined portably to this list as necessary.} @deftp {Foreign Type} :float @deftpx {Foreign Type} :double The @code{:float} type represents a C @code{float} and a Lisp @code{single-float}. @code{:double} represents a C @code{double} and a Lisp @code{double-float}. @end deftp @deftp {Foreign Type} :pointer A foreign pointer to an object of any type, corresponding to @code{void *}. @end deftp @deftp {Foreign Type} :void No type at all. Only valid as the return type of a function. @end deftp @node Operations on Foreign Types @chapter Operations on Built-in Foreign Types @defun %foreign-type-size type @result{} size Return the @var{size}, in bytes, of objects having foreign type @var{type}. An error is signalled if @var{type} is not a known built-in foreign type. @end defun @defun %foreign-type-alignment type @result{} alignment Return the default alignment in bytes for structure members of foreign type @var{type}. An error is signalled if @var{type} is not a known built-in foreign type. @impnote{Maybe this should take an optional keyword argument specifying an alternate alignment system, eg. :mac68k for 68000-compatible alignment on Darwin.} @end defun @node Basic Pointer Operations @chapter Basic Pointer Operations @defun pointerp ptr @result{} boolean Return true if @var{ptr} is a foreign pointer. @end defun @defun null-pointer @result{} pointer Return a null foreign pointer. @end defun @defun null-pointer-p ptr @result{} boolean Return true if @var{ptr} is a null foreign pointer. @end defun @defun make-pointer address @result{} pointer Return a pointer corresponding to the numeric integer @var{address}. @end defun @defun inc-pointer ptr offset @result{} pointer Return the result of numerically incrementing @var{ptr} by @var{offset}. @end defun @node Foreign Memory Allocation @chapter Foreign Memory Allocation @defun foreign-alloc size @result{} pointer Allocate @var{size} bytes of foreign-addressable memory and return a @var{pointer} to the allocated block. An implementation-specific error is signalled if the memory cannot be allocated. @end defun @defun foreign-free ptr @result{} unspecified Free a pointer @var{ptr} allocated by @code{foreign-alloc}. The results are undefined if @var{ptr} is used after being freed. @end defun @defmac with-foreign-pointer (var size &optional size-var) &body body Bind @var{var} to a pointer to @var{size} bytes of foreign-accessible memory during @var{body}. Both @var{ptr} and the memory block it points to have dynamic extent and may be stack allocated if supported by the implementation. If @var{size-var} is supplied, it will be bound to @var{size} during @var{body}. @end defmac @node Memory Access @chapter Memory Access @deffn {Accessor} %mem-ref ptr type &optional offset Dereference a pointer @var{offset} bytes from @var{ptr} to an object for reading (or writing when used with @code{setf}) of built-in type @var{type}. @end deffn @heading Example @lisp ;; An impractical example, since time returns the time as well, ;; but it demonstrates %MEM-REF. Better (simple) examples wanted! (with-foreign-pointer (p (foreign-type-size :time)) (foreign-funcall "time" :pointer p :time) (%mem-ref p :time)) @end lisp @node Foreign Function Calling @chapter Foreign Function Calling @defmac %foreign-funcall name @{arg-type arg@}* &optional result-type @result{} object @defmacx %foreign-funcall-pointer ptr @{arg-type arg@}* &optional result-type @result{} object Invoke a foreign function called @var{name} in the foreign source code. Each @var{arg-type} is a foreign type specifier, followed by @var{arg}, Lisp data to be converted to foreign data of type @var{arg-type}. @var{result-type} is the foreign type of the function's return value, and is assumed to be @code{:void} if not supplied. @code{%foreign-funcall-pointer} takes a pointer @var{ptr} to the function, as returned by @code{foreign-symbol-pointer}, rather than a string @var{name}. @end defmac @heading Examples @lisp ;; Calling a standard C library function: (%foreign-funcall "sqrtf" :float 16.0 :float) @result{} 4.0 @end lisp @lisp ;; Dynamic allocation of a buffer and passing to a function: (with-foreign-ptr (buf 255 buf-size) (%foreign-funcall "gethostname" :pointer buf :size buf-size :int) ;; Convert buf to a Lisp string using MAKE-STRING and %MEM-REF or ;; a portable CFFI function such as CFFI:FOREIGN-STRING-TO-LISP. ) @end lisp @node Loading Foreign Libraries @chapter Loading Foreign Libraries @defun %load-foreign-library name @result{} unspecified Load the foreign shared library @var{name}. @impnote{There is a lot of behavior to decide here. Currently I lean toward not requiring NAME to be a full path to the library so we can search the system library directories (maybe even get LD_LIBRARY_PATH from the environment) as necessary.} @end defun @node Foreign Globals @chapter Foreign Globals @defun foreign-symbol-pointer name @result{} pointer Return a pointer to a foreign symbol @var{name}. @end defun @node Symbol Index @unnumbered Symbol Index @printindex fn @bye cffi_0.19.0/doc/mem-vector.txt0000644000175000017500000000514713103031266014672 0ustar luisluis # Block Memory Operations Function: mem-fill ptr type count value &optional (offset 0) Fill COUNT objects of TYPE, starting at PTR plus offset, with VALUE. ;; Equivalent to (but possibly more efficient than): (loop for i below count for off from offset by (%foreign-type-size type) do (setf (%mem-ref ptr type off) value)) Function: mem-read-vector vector ptr type count &optional (offset 0) Copy COUNT objects of TYPE from foreign memory at PTR plus OFFSET into VECTOR. If VECTOR is not large enough to contain COUNT objects, it will copy as many objects as necessary to fill the vector. The results are undefined if the foreign memory block is not large enough to supply the data to copy. TYPE must be a built-in foreign type (integer, float, double, or pointer). Returns the number of objects copied. ;; Equivalent to (but possibly more efficient than): (loop for i below (min count (length vector)) for off from offset by (%foreign-type-size type) do (setf (aref vector i) (%mem-ref ptr type off)) finally (return i)) Function: mem-read-c-string string ptr &optional (offset 0) Copy a null-terminated C string from PTR plus OFFSET into STRING, a Lisp string. If STRING is not large enough to contain the data at PTR it will be truncated. Returns the number of characters copied into STRING. ;; Equivalent to (but possibly more efficient than): (loop for i below (length string) for off from offset for char = (%mem-ref ptr :char off) until (zerop char) do (setf (char string i) char) finally (return i)) Function: mem-write-vector vector ptr type &optional (count (length vector)) (offset 0) Copy COUNT objects from VECTOR into objects of TYPE in foreign memory, starting at PTR plus OFFSET. The results are undefined if PTR does not point to a memory block large enough to hold the data copied. TYPE must be a built-in type (integer, float, double, or pointer). Returns the number of objects copied from VECTOR to PTR. ;; Equivalent to (but possibly more efficient than): (loop for i below count for off from offset by (%foreign-type-size type) do (setf (%mem-ref ptr type off) (aref vector i)) finally (return i)) Function: mem-write-c-string string ptr &optional (offset 0) Copy the characters from a Lisp STRING to PTR plus OFFSET, adding a final null terminator at the end. The results are undefined if the memory at PTR is not large enough to accomodate the data. This interface is currently equivalent to MEM-WRITE-VECTOR with a TYPE of :CHAR, but will be useful when proper support for Unicode strings is implemented. cffi_0.19.0/doc/gendocs.sh0000755000175000017500000002512013103031266014025 0ustar luisluis#!/bin/sh # gendocs.sh -- generate a GNU manual in many formats. This script is # mentioned in maintain.texi. See the help message below for usage details. # $Id: gendocs.sh,v 1.16 2005/05/15 00:00:08 karl Exp $ # # Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, you can either send email to this # program's maintainer or write to: The Free Software Foundation, # Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA. # # Original author: Mohit Agarwal. # Send bug reports and any other correspondence to bug-texinfo@gnu.org. #set -e prog="`basename \"$0\"`" srcdir=`pwd` scripturl="https://github.com/cffi/cffi/blob/master/doc/gendocs.sh" templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template" : ${MAKEINFO="makeinfo"} : ${TEXI2DVI="texi2dvi -t @finalout"} : ${DVIPS="dvips"} : ${DOCBOOK2TXT="docbook2txt"} : ${DOCBOOK2HTML="docbook2html"} : ${DOCBOOK2PDF="docbook2pdf"} : ${DOCBOOK2PS="docbook2ps"} : ${GENDOCS_TEMPLATE_DIR="."} unset CDPATH rcs_revision='$Revision: 1.16 $' rcs_version=`set - $rcs_revision; echo $2` program=`echo $0 | sed -e 's!.*/!!'` version="gendocs.sh $rcs_version Copyright (C) 2005 Free Software Foundation, Inc. There is NO warranty. You may redistribute this software under the terms of the GNU General Public License. For more information about these matters, see the files named COPYING." usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source. See the GNU Maintainers document for a more extensive discussion: http://www.gnu.org/prep/maintain_toc.html Options: -o OUTDIR write files into OUTDIR, instead of manual/. --docbook convert to DocBook too (xml, txt, html, pdf and ps). --html ARG pass indicated ARG to makeinfo for HTML targets. --help display this help and exit successfully. --version display version information and exit successfully. Simple example: $prog emacs \"GNU Emacs Manual\" Typical sequence: cd YOURPACKAGESOURCE/doc wget \"$scripturl\" wget \"$templateurl\" $prog YOURMANUAL \"GNU YOURMANUAL - One-line description\" Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR to override). Move all the new files into your web CVS tree, as explained in the Web Pages node of maintain.texi. MANUAL-TITLE is included as part of the HTML of the overall manual/index.html file. It should include the name of the package being documented. manual/index.html is created by substitution from the file $GENDOCS_TEMPLATE_DIR/gendocs_template. (Feel free to modify the generic template for your own purposes.) If you have several manuals, you'll need to run this script several times with different YOURMANUAL values, specifying a different output directory with -o each time. Then write (by hand) an overall index.html with links to them all. You can set the environment variables MAKEINFO, TEXI2DVI, and DVIPS to control the programs that get executed, and GENDOCS_TEMPLATE_DIR to control where the gendocs_template file is looked for. Email bug reports or enhancement requests to bug-texinfo@gnu.org. " calcsize() { size="`ls -ksl $1 | awk '{print $1}'`" echo $size } outdir=manual html= PACKAGE= MANUAL_TITLE= while test $# -gt 0; do case $1 in --help) echo "$usage"; exit 0;; --version) echo "$version"; exit 0;; -o) shift; outdir=$1;; --docbook) docbook=yes;; --html) shift; html=$1;; -*) echo "$0: Unknown or ambiguous option \`$1'." >&2 echo "$0: Try \`--help' for more information." >&2 exit 1;; *) if test -z "$PACKAGE"; then PACKAGE=$1 elif test -z "$MANUAL_TITLE"; then MANUAL_TITLE=$1 else echo "$0: extra non-option argument \`$1'." >&2 exit 1 fi;; esac shift done if test -s $srcdir/$PACKAGE.texinfo; then srcfile=$srcdir/$PACKAGE.texinfo elif test -s $srcdir/$PACKAGE.texi; then srcfile=$srcdir/$PACKAGE.texi elif test -s $srcdir/$PACKAGE.txi; then srcfile=$srcdir/$PACKAGE.txi else echo "$0: cannot find .texinfo or .texi or .txi for $PACKAGE in $srcdir." >&2 exit 1 fi if test ! -r $GENDOCS_TEMPLATE_DIR/gendocs_template; then echo "$0: cannot read $GENDOCS_TEMPLATE_DIR/gendocs_template." >&2 echo "$0: it is available from $templateurl." >&2 exit 1 fi echo Generating output formats for $srcfile cmd="${MAKEINFO} -o $PACKAGE.info $srcfile" echo "Generating info files... ($cmd)" eval $cmd install-info $PACKAGE.info dir mkdir -p $outdir/ tar czf $outdir/$PACKAGE.info.tar.gz $PACKAGE.info* info_tgz_size="`calcsize $outdir/$PACKAGE.info.tar.gz`" # do not mv the info files, there's no point in having them available # separately on the web. cmd="${TEXI2DVI} $srcfile" echo "Generating dvi ... ($cmd)" eval $cmd # now, before we compress dvi: echo Generating postscript... ${DVIPS} $PACKAGE -o gzip -f -9 $PACKAGE.ps ps_gz_size="`calcsize $PACKAGE.ps.gz`" mv $PACKAGE.ps.gz $outdir/ # compress/finish dvi: gzip -f -9 $PACKAGE.dvi dvi_gz_size="`calcsize $PACKAGE.dvi.gz`" mv $PACKAGE.dvi.gz $outdir/ cmd="${TEXI2DVI} --pdf $srcfile" echo "Generating pdf ... ($cmd)" eval $cmd pdf_size="`calcsize $PACKAGE.pdf`" mv $PACKAGE.pdf $outdir/ cmd="${MAKEINFO} -o $PACKAGE.txt --no-split --no-headers $srcfile" echo "Generating ASCII... ($cmd)" eval $cmd ascii_size="`calcsize $PACKAGE.txt`" gzip -f -9 -c $PACKAGE.txt >$outdir/$PACKAGE.txt.gz ascii_gz_size="`calcsize $outdir/$PACKAGE.txt.gz`" mv $PACKAGE.txt $outdir/ # Print a SED expression that will translate references to MANUAL to # the proper page on gnu.org. This is a horrible shell hack done # because \| in sed regexps is a GNU extension. monognuorg () { case "$1" in libtool) echo "s!$1.html!http://www.gnu.org/software/$1/manual.html!" ;; *) echo "s!$1.html!http://www.gnu.org/software/$1/manual/html_mono/$1.html!" ;; esac } polygnuorg () { case "$1" in libtool) echo 's!\.\./'"$1/.*\.html!http://www.gnu.org/software/$1/manual.html!" ;; *) echo 's!\.\./'"$1!http://www.gnu.org/software/$1/manual/html_node!" ;; esac } cmd="${MAKEINFO} --no-split --html -o $PACKAGE.html $html $srcfile" echo "Generating monolithic html... ($cmd)" rm -rf $PACKAGE.html # in case a directory is left over eval $cmd sbcl --no-sysinit --no-userinit --load colorize-lisp-examples.lisp $PACKAGE.html #fix libc/libtool xrefs sed -e `monognuorg libc` -e `monognuorg libtool` $PACKAGE.html >$outdir/$PACKAGE.html rm $PACKAGE.html html_mono_size="`calcsize $outdir/$PACKAGE.html`" gzip -f -9 -c $outdir/$PACKAGE.html >$outdir/$PACKAGE.html.gz html_mono_gz_size="`calcsize $outdir/$PACKAGE.html.gz`" cmd="${MAKEINFO} --html -o $PACKAGE.html $html $srcfile" echo "Generating html by node... ($cmd)" eval $cmd split_html_dir=$PACKAGE.html sbcl --no-userinit --no-sysinit --load colorize-lisp-examples.lisp "${split_html_dir}"/\*.html ( cd ${split_html_dir} || exit 1 #fix libc xrefs for broken_file in *.html; do sed -e `polygnuorg libc` -e `polygnuorg libtool` "$broken_file" > "$broken_file".temp mv -f "$broken_file".temp "$broken_file" done tar -czf ../$outdir/${PACKAGE}.html_node.tar.gz -- *.html ) html_node_tgz_size="`calcsize $outdir/${PACKAGE}.html_node.tar.gz`" rm -f $outdir/html_node/*.html mkdir -p $outdir/html_node/ mv ${split_html_dir}/*.html $outdir/html_node/ rmdir ${split_html_dir} echo Making .tar.gz for sources... srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null` tar cvzfh $outdir/$PACKAGE.texi.tar.gz $srcfiles texi_tgz_size="`calcsize $outdir/$PACKAGE.texi.tar.gz`" if test -n "$docbook"; then cmd="${MAKEINFO} -o - --docbook $srcfile > ${srcdir}/$PACKAGE-db.xml" echo "Generating docbook XML... $(cmd)" eval $cmd docbook_xml_size="`calcsize $PACKAGE-db.xml`" gzip -f -9 -c $PACKAGE-db.xml >$outdir/$PACKAGE-db.xml.gz docbook_xml_gz_size="`calcsize $outdir/$PACKAGE-db.xml.gz`" mv $PACKAGE-db.xml $outdir/ cmd="${DOCBOOK2HTML} -o $split_html_db_dir ${outdir}/$PACKAGE-db.xml" echo "Generating docbook HTML... ($cmd)" eval $cmd split_html_db_dir=html_node_db ( cd ${split_html_db_dir} || exit 1 tar -czf ../$outdir/${PACKAGE}.html_node_db.tar.gz -- *.html ) html_node_db_tgz_size="`calcsize $outdir/${PACKAGE}.html_node_db.tar.gz`" rm -f $outdir/html_node_db/*.html mkdir -p $outdir/html_node_db mv ${split_html_db_dir}/*.html $outdir/html_node_db/ rmdir ${split_html_db_dir} cmd="${DOCBOOK2TXT} ${outdir}/$PACKAGE-db.xml" echo "Generating docbook ASCII... ($cmd)" eval $cmd docbook_ascii_size="`calcsize $PACKAGE-db.txt`" mv $PACKAGE-db.txt $outdir/ cmd="${DOCBOOK2PS} ${outdir}/$PACKAGE-db.xml" echo "Generating docbook PS... $(cmd)" eval $cmd gzip -f -9 -c $PACKAGE-db.ps >$outdir/$PACKAGE-db.ps.gz docbook_ps_gz_size="`calcsize $outdir/$PACKAGE-db.ps.gz`" mv $PACKAGE-db.ps $outdir/ cmd="${DOCBOOK2PDF} ${outdir}/$PACKAGE-db.xml" echo "Generating docbook PDF... ($cmd)" eval $cmd docbook_pdf_size="`calcsize $PACKAGE-db.pdf`" mv $PACKAGE-db.pdf $outdir/ fi echo Writing index file... curdate="`date '+%B %d, %Y'`" sed \ -e "s!%%TITLE%%!$MANUAL_TITLE!g" \ -e "s!%%DATE%%!$curdate!g" \ -e "s!%%PACKAGE%%!$PACKAGE!g" \ -e "s!%%HTML_MONO_SIZE%%!$html_mono_size!g" \ -e "s!%%HTML_MONO_GZ_SIZE%%!$html_mono_gz_size!g" \ -e "s!%%HTML_NODE_TGZ_SIZE%%!$html_node_tgz_size!g" \ -e "s!%%INFO_TGZ_SIZE%%!$info_tgz_size!g" \ -e "s!%%DVI_GZ_SIZE%%!$dvi_gz_size!g" \ -e "s!%%PDF_SIZE%%!$pdf_size!g" \ -e "s!%%PS_GZ_SIZE%%!$ps_gz_size!g" \ -e "s!%%ASCII_SIZE%%!$ascii_size!g" \ -e "s!%%ASCII_GZ_SIZE%%!$ascii_gz_size!g" \ -e "s!%%TEXI_TGZ_SIZE%%!$texi_tgz_size!g" \ -e "s!%%DOCBOOK_HTML_NODE_TGZ_SIZE%%!$html_node_db_tgz_size!g" \ -e "s!%%DOCBOOK_ASCII_SIZE%%!$docbook_ascii_size!g" \ -e "s!%%DOCBOOK_PS_GZ_SIZE%%!$docbook_ps_gz_size!g" \ -e "s!%%DOCBOOK_PDF_SIZE%%!$docbook_pdf_size!g" \ -e "s!%%DOCBOOK_XML_SIZE%%!$docbook_xml_size!g" \ -e "s!%%DOCBOOK_XML_GZ_SIZE%%!$docbook_xml_gz_size!g" \ -e "s,%%SCRIPTURL%%,$scripturl,g" \ -e "s!%%SCRIPTNAME%%!$prog!g" \ $GENDOCS_TEMPLATE_DIR/gendocs_template >$outdir/index.html echo "Done! See $outdir/ subdirectory for new files." ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������cffi_0.19.0/doc/shareable-vectors.txt���������������������������������������������������������������0000644�0001750�0001750�00000003001�13103031266�016210� 0����������������������������������������������������������������������������������������������������ustar �luis����������������������������luis������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # Shareable Byte Vectors Function: make-shareable-byte-vector size Create a vector of element type (UNSIGNED-BYTE 8) suitable for passing to WITH-POINTER-TO-VECTOR-DATA. ;; Minimal implementation: (defun make-shareable-byte-vector (size) (make-array size :element-type '(unsigned-byte 8))) Macro: with-pointer-to-vector-data (ptr-var vector) &body body Bind PTR-VAR to a pointer to the data contained in a shareable byte vector. VECTOR must be a shareable vector created by MAKE-SHAREABLE-BYTE-VECTOR. PTR-VAR may point directly into the Lisp vector data, or it may point to a temporary block of foreign memory which will be copied to and from VECTOR. Both the pointer object in PTR-VAR and the memory it points to have dynamic extent. The results are undefined if foreign code attempts to access this memory outside this dynamic contour. The implementation must guarantee the memory pointed to by PTR-VAR will not be moved during the dynamic contour of this operator, either by creating the vector in a static area or temporarily disabling the garbage collector. ;; Minimal (copying) implementation: (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) (let ((vector-var (gensym)) (size-var (gensym))) `(let* ((,vector-var ,vector) (,size-var (length ,vector-var))) (with-foreign-ptr (,ptr-var ,size-var) (mem-write-vector ,vector-var ,ptr :uint8) (prog1 (progn ,@body) (mem-read-vector ,vector-var ,ptr-var :uint8 ,size-var)))))) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������cffi_0.19.0/doc/allegro-internals.txt���������������������������������������������������������������0000644�0001750�0001750�00000012175�13103031266�016235� 0����������������������������������������������������������������������������������������������������ustar �luis����������������������������luis�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������July 2005 These details were kindly provided by Duane Rettig of Franz. Regarding the following snippet of the macro expansion of FF:DEF-FOREIGN-CALL: (SYSTEM::FF-FUNCALL (LOAD-TIME-VALUE (EXCL::DETERMINE-FOREIGN-ADDRESS '("foo" :LANGUAGE :C) 2 NIL)) '(:INT (INTEGER * *)) ARG1 '(:DOUBLE (DOUBLE-FLOAT * *)) ARG2 '(:INT (INTEGER * *))) " ... in Allegro CL, if you define a foreign call FOO with C entry point "foo" and with :call-direct t in the arguments, and if other things are satisfied, then if a lisp function BAR is compiled which has a call to FOO, that call will not go through ff-funcall (and thus a large amount of argument manipulation and processing) but will instead set up its arguments directly on the stack, and will then perform the "call" more or less directly, through the "entry vec" (a small structure which keeps track of a foreign entry's address and status)." This is the code that generates what the compiler expects to see: (setq call-direct-form (if* call-direct then `(setf (get ',lispname 'sys::direct-ff-call) (list ',external-name ,callback ,convention ',returning ',arg-types ,arg-checking ,entry-vec-flags)) else `(remprop ',lispname 'sys::direct-ff-call))) Thus generating something like: (EVAL-WHEN (COMPILE LOAD EVAL) (SETF (GET 'FOO 'SYSTEM::DIRECT-FF-CALL) (LIST '("foo" :LANGUAGE :C) T :C '(:INT (INTEGER * *)) '((:INT (INTEGER * *)) (:FLOAT (SINGLE-FLOAT * *))) T 2 ; this magic value is explained later ))) " (defun determine-foreign-address (name &optional (flags 0) method-index) ;; return an entry-vec struct suitable for the foreign-call of name. ;; ;; name is either a string, which is taken without conversion, or ;; a list consisting of a string to convert or a conversion function ;; call. ;; flags is an integer representing the flags to place into the entry-vec. ;; method-index, if non-nil, is a word-index into a vtbl (virtual table). ;; If method-index is true, then the name must be a string uniquely ;; represented by the index and by the flags field. Note that not all architectures implement the :method-index argument to def-foreign-call, but your interface likely won't support it anyway, so just leave it nil. As for the flags, they are constants stored into the entry-vec returned by d-f-a and are given here: (defconstant ep-flag-call-semidirect 1) ; Real address stored in alt-address slot (defconstant ep-flag-never-release 2) ; Never release the heap (defconstant ep-flag-always-release 4) ; Always release the heap (defconstant ep-flag-release-when-ok 8) ; Release the heap unless without-interrupts (defconstant ep-flag-tramp-calls #x70) ; Make calls through special trampolines (defconstant ep-flag-tramp-shift 4) (defconstant ep-flag-variable-address #x100) ; Entry-point contains address of C var (defconstant ep-flag-strings-convert #x200) ; Convert strings automatically (defconstant ep-flag-get-errno #x1000) ;; [rfe5060]: Get errno value after call (defconstant ep-flag-get-last-error #x2000) ;; [rfe5060]: call GetLastError after call ;; Leave #x4000 and #x8000 open for expansion Mostly, you'll give the value 2 (never release the heap), but if you give 4 or 8, then d-f-a will automatically set the 1 bit as well, which takes the call through a heap-release/reacquire process. Some docs for entry-vec are: ;; -- entry vec -- ;; An entry-vec is an entry-point descriptor, usually a pointer into ;; a shared-library. It is represented as a 5-element struct of type ;; foreign-vector. The reason for this represntation is ;; that it allows the entry point to be stored in a table, called ;; the .saved-entry-points. table, and to be used by a foreign ;; function. When the location of the foreign function to which the entry ;; point refers changes, it is simply a matter of changing the value in entry ;; point vector and the foreign call code sees it immediately. There is ;; even an address that can be put in the entry point vector that denotes ;; a missing foreign function, thus lookup can happen dynamically. (defstruct (entry-vec (:type (vector excl::foreign (*))) (:constructor make-entry-vec-boa ())) name ; entry point name (address 0) ; jump address for foreign code (handle 0) ; shared-lib handle (flags 0) ; ep-* flags (alt-address 0) ; sometimes holds the real func addr ) [...] " Regarding the arguments to SYSTEM::FF-FUNCALL: '(:int (integer * *)) argN "The type-spec is as it is given in the def-foreign-call syntax, with a C type optionally followed by a lisp type, followed optionally by a user-conversion function name[...]" Getting the alignment: CL-USER(2): (ff:get-foreign-type :int) #S(FOREIGN-FUNCTIONS::IFOREIGN-TYPE :ATTRIBUTES NIL :SFTYPE #S(FOREIGN-FUNCTIONS::SIZED-FTYPE-PRIM :KIND :INT :WIDTH 4 :OFFSET 0 :ALIGN 4) ...) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������cffi_0.19.0/doc/gendocs_template��������������������������������������������������������������������0000644�0001750�0001750�00000013252�13103031266�015307� 0����������������������������������������������������������������������������������������������������ustar �luis����������������������������luis�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<?xml version="1.0" encoding="utf-8" ?> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <!-- $Id: gendocs_template,v 1.7 2005/05/15 00:00:08 karl Exp $ --> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> <!-- This template was adapted from Texinfo: http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template --> <head> <title>%%TITLE%%

%%TITLE%%

last updated %%DATE%%

This document is available in the following formats:

(This page was generated by the %%SCRIPTNAME%% script.)

Return to CFFI's home page.

Copyright (C) 2005 James Bielman <jamesjb at jamesjb.com>
Copyright (C) 2005 Luís Oliveira <loliveira at common-lisp.net>

Updated: %%DATE%%

cffi_0.19.0/doc/colorize-lisp-examples.lisp0000644000175000017500000012632613103031266017356 0ustar luisluis;;; This is code was taken from lisppaste2 and is a quick hack ;;; to colorize lisp examples in the html generated by Texinfo. ;;; It is not general-purpose utility, though it could easily be ;;; turned into one. ;;;; colorize-package.lisp (defpackage :colorize (:use :common-lisp) (:export :scan-string :format-scan :html-colorization :find-coloring-type :autodetect-coloring-type :coloring-types :scan :scan-any :advance :call-parent-formatter :*coloring-css* :make-background-css :*css-background-class* :colorize-file :colorize-file-to-stream :*version-token*)) ;;;; coloring-css.lisp (in-package :colorize) (defparameter *coloring-css* ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;} a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } .special { color : #FF5000; background-color : inherit; } .keyword { color : #770000; background-color : inherit; } .comment { color : #007777; background-color : inherit; } .string { color : #777777; background-color : inherit; } .character { color : #0055AA; background-color : inherit; } .syntaxerror { color : #FF0000; background-color : inherit; } span.paren1:hover { color : inherit; background-color : #BAFFFF; } span.paren2:hover { color : inherit; background-color : #FFCACA; } span.paren3:hover { color : inherit; background-color : #FFFFBA; } span.paren4:hover { color : inherit; background-color : #CACAFF; } span.paren5:hover { color : inherit; background-color : #CAFFCA; } span.paren6:hover { color : inherit; background-color : #FFBAFF; } ") (defvar *css-background-class* "lisp-bg") (defun for-css (thing) (if (symbolp thing) (string-downcase (symbol-name thing)) thing)) (defun make-background-css (color &key (class *css-background-class*) (extra nil)) (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:* .~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%" class color (mapcar #'(lambda (extra) (format nil "~A : ~{~A ~}" (for-css (first extra)) (mapcar #'for-css (cdr extra)))) extra))) ;;;; colorize.lisp ;(in-package :colorize) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *coloring-types* nil) (defparameter *version-token* (gensym))) (defclass coloring-type () ((modes :initarg :modes :accessor coloring-type-modes) (default-mode :initarg :default-mode :accessor coloring-type-default-mode) (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions) (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name) (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter) (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil) (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly "")) (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function :initform (constantly nil)) (parent-type :initarg :parent-type :accessor coloring-type-parent-type :initform nil) (visible :initarg :visible :accessor coloring-type-visible :initform t))) (defun find-coloring-type (type) (if (typep type 'coloring-type) type (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name)))) (defun autodetect-coloring-type (name) (car (find name *coloring-types* :key #'cdr :test #'(lambda (name type) (and (coloring-type-visible type) (funcall (coloring-type-autodetect-function type) name)))))) (defun coloring-types () (loop for type-pair in *coloring-types* if (coloring-type-visible (cdr type-pair)) collect (cons (car type-pair) (coloring-type-fancy-name (cdr type-pair))))) (defun (setf find-coloring-type) (new-value type) (if new-value (let ((found (assoc type *coloring-types*))) (if found (setf (cdr found) new-value) (setf *coloring-types* (nconc *coloring-types* (list (cons type new-value)))))) (setf *coloring-types* (remove type *coloring-types* :key #'car)))) (defvar *scan-calls* 0) (defvar *reset-position* nil) (defmacro with-gensyms ((&rest names) &body body) `(let ,(mapcar #'(lambda (name) (list name `(make-symbol ,(symbol-name name)))) names) ,@body)) (defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body) (with-gensyms (num items position not-preceded-by string item new-mode until advancing) `(labels ((advance (,num) (setf ,position-place (+ ,position-place ,num)) t) (peek-any (,items &key ,not-preceded-by) (incf *scan-calls*) (let* ((,items (if (stringp ,items) (coerce ,items 'list) ,items)) (,not-preceded-by (if (characterp ,not-preceded-by) (string ,not-preceded-by) ,not-preceded-by)) (,position ,position-place) (,string ,string-param)) (let ((,item (and (< ,position (length ,string)) (find ,string ,items :test #'(lambda (,string ,item) #+nil (format t "looking for ~S in ~S starting at ~S~%" ,item ,string ,position) (if (characterp ,item) (char= (elt ,string ,position) ,item) (search ,item ,string :start2 ,position :end2 (min (length ,string) (+ ,position (length ,item)))))))))) (if (characterp ,item) (setf ,item (string ,item))) (if (if ,item (if ,not-preceded-by (if (>= (- ,position (length ,not-preceded-by)) 0) (not (string= (subseq ,string (- ,position (length ,not-preceded-by)) ,position) ,not-preceded-by)) t) t) nil) ,item (progn (and *reset-position* (setf ,position-place *reset-position*)) nil))))) (scan-any (,items &key ,not-preceded-by) (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by))) (and ,item (advance (length ,item))))) (peek (,item &key ,not-preceded-by) (peek-any (list ,item) :not-preceded-by ,not-preceded-by)) (scan (,item &key ,not-preceded-by) (scan-any (list ,item) :not-preceded-by ,not-preceded-by))) (macrolet ((set-mode (,new-mode &key ,until (,advancing t)) (list 'progn (list 'setf ',mode-place ,new-mode) (list 'setf ',mode-wait-place (list 'lambda (list ',position) (list 'let (list (list '*reset-position* ',position)) (list 'values ,until ,advancing))))))) ,@body)))) (defvar *formatter-local-variables*) (defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters autodetect parent formatter-variables (formatter-after-hook '(constantly "")) invisible) (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance) `(let ((,parent-type (or (find-coloring-type ,parent) (and ,parent (error "No such coloring type: ~S" ,parent))))) (setf (find-coloring-type ,name) (make-instance 'coloring-type :fancy-name ',fancy-name :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type))) :default-mode (or ',default-mode (if ,parent-type (coloring-type-default-mode ,parent-type))) ,@(if autodetect `(:autodetect-function ,autodetect)) :parent-type ,parent-type :visible (not ,invisible) :formatter-initial-values (lambda nil (list* ,@(mapcar #'(lambda (e) `(cons ',(car e) ,(second e))) formatter-variables) (if ,parent-type (funcall (coloring-type-formatter-initial-values ,parent-type)) nil))) :formatter-after-hook (lambda nil (symbol-macrolet ,(mapcar #'(lambda (e) `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) formatter-variables) (concatenate 'string (funcall ,formatter-after-hook) (if ,parent-type (funcall (coloring-type-formatter-after-hook ,parent-type)) "")))) :term-formatter (symbol-macrolet ,(mapcar #'(lambda (e) `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) formatter-variables) (lambda (,term) (labels ((call-parent-formatter (&optional (,type (car ,term)) (,string (cdr ,term))) (if ,parent-type (funcall (coloring-type-term-formatter ,parent-type) (cons ,type ,string)))) (call-formatter (&optional (,type (car ,term)) (,string (cdr ,term))) (funcall (case (first ,type) ,@formatters (t (lambda (,type text) (call-parent-formatter ,type text)))) ,type ,string))) (call-formatter)))) :transition-functions (list ,@(loop for transition in transitions collect (destructuring-bind (mode &rest table) transition `(cons ',mode (lambda (,current-mode ,string ,position) (let ((,mode-wait (constantly nil)) (,position-foobage ,position)) (with-scanning-functions ,string ,position-foobage ,current-mode ,mode-wait (let ((*reset-position* ,position)) (cond ,@table)) (values ,position-foobage ,current-mode (lambda (,new-position) (setf ,position-foobage ,new-position) (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage)))) (values ,position-foobage ,advance))))) ))))))))))) (defun full-transition-table (coloring-type-object) (let ((parent (coloring-type-parent-type coloring-type-object))) (if parent (append (coloring-type-transition-functions coloring-type-object) (full-transition-table parent)) (coloring-type-transition-functions coloring-type-object)))) (defun scan-string (coloring-type string) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error "No such coloring type: ~S" coloring-type))) (transitions (full-transition-table coloring-type-object)) (result nil) (low-bound 0) (current-mode (coloring-type-default-mode coloring-type-object)) (mode-stack nil) (current-wait (constantly nil)) (wait-stack nil) (current-position 0) (*scan-calls* 0)) (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop) (let ((to (if extend new-position current-position))) (if (> to low-bound) (setf result (nconc result (list (cons (cons current-mode mode-stack) (subseq string low-bound to)))))) (setf low-bound to) (when pop (pop mode-stack) (pop wait-stack)) (when push (push current-mode mode-stack) (push current-wait wait-stack)) (setf current-mode new-mode current-position new-position current-wait new-wait)))) (loop (if (> current-position (length string)) (return-from scan-string (progn (format *trace-output* "Scan was called ~S times.~%" *scan-calls*) (finish-current (length string) nil (constantly nil)) result)) (or (loop for transition in (mapcar #'cdr (remove current-mode transitions :key #'car :test-not #'(lambda (a b) (or (eql a b) (if (listp b) (member a b)))))) if (and transition (multiple-value-bind (new-position new-mode new-wait) (funcall transition current-mode string current-position) (when (> new-position current-position) (finish-current new-position new-mode new-wait :extend nil :push t) t))) return t) (multiple-value-bind (pos advance) (funcall current-wait current-position) #+nil (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position) (and pos (when (> pos current-position) (finish-current (if advance pos current-position) (car mode-stack) (car wait-stack) :extend advance :pop t) t))) (progn (incf current-position))) ))))) (defun format-scan (coloring-type scan) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error "No such coloring type: ~S" coloring-type))) (color-formatter (coloring-type-term-formatter coloring-type-object)) (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object)))) (format nil "~{~A~}~A" (mapcar color-formatter scan) (funcall (coloring-type-formatter-after-hook coloring-type-object))))) (defun encode-for-pre (string) (declare (simple-string string)) (let ((output (make-array (truncate (length string) 2/3) :element-type 'character :adjustable t :fill-pointer 0))) (with-output-to-string (out output) (loop for char across string do (case char ((#\&) (write-string "&" out)) ((#\<) (write-string "<" out)) ((#\>) (write-string ">" out)) ((#\") (write-string """ out)) ((#\RIGHTWARDS_DOUBLE_ARROW) (write-string "⇒" out)) (t (write-char char out))))) (coerce output 'simple-string))) (defun string-substitute (string substring replacement-string) "String substitute by Larry Hunter. Obtained from Google" (let ((substring-length (length substring)) (last-end 0) (new-string "")) (do ((next-start (search substring string) (search substring string :start2 last-end))) ((null next-start) (concatenate 'string new-string (subseq string last-end))) (setq new-string (concatenate 'string new-string (subseq string last-end next-start) replacement-string)) (setq last-end (+ next-start substring-length))))) (defun decode-from-tt (string) (string-substitute (string-substitute (string-substitute (string-substitute (string-substitute string "&" "&") "<" "<") ">" ">") "⇒" (string #\RIGHTWARDS_DOUBLE_ARROW)) """ "\"")) (defun html-colorization (coloring-type string) (format-scan coloring-type (mapcar #'(lambda (p) (cons (car p) (let ((tt (encode-for-pre (cdr p)))) (if (and (> (length tt) 0) (char= (elt tt (1- (length tt))) #\>)) (format nil "~A~%" tt) tt)))) (scan-string coloring-type string)))) (defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default")) (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) (merge-pathnames input-file-name) (make-pathname :type "lisp" :defaults (merge-pathnames input-file-name)))) (*css-background-class* css-background)) (with-open-file (s input-file :direction :input) (let ((lines nil) (string nil)) (block done (loop (let ((line (read-line s nil nil))) (if line (push line lines) (return-from done))))) (setf string (format nil "~{~A~%~}" (nreverse lines))) (if wrap (format s2 "
~A
" *coloring-css* (make-background-css "white") *css-background-class* (html-colorization coloring-type string)) (write-string (html-colorization coloring-type string) s2)))))) (defun colorize-file (coloring-type input-file-name &optional output-file-name) (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) (merge-pathnames input-file-name) (make-pathname :type "lisp" :defaults (merge-pathnames input-file-name)))) (output-file (or output-file-name (make-pathname :type "html" :defaults input-file)))) (with-open-file (s2 output-file :direction :output :if-exists :supersede) (colorize-file-to-stream coloring-type input-file-name s2)))) ;; coloring-types.lisp ;(in-package :colorize) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *version-token* (gensym))) (defparameter *symbol-characters* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890") (defparameter *non-constituent* '(#\space #\tab #\newline #\linefeed #\page #\return #\" #\' #\( #\) #\, #\; #\` #\[ #\])) (defparameter *special-forms* '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the" "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*" "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally" "return-from" "setq" "multiple-value-call")) (defparameter *common-macros* '("loop" "cond" "lambda")) (defparameter *open-parens* '(#\()) (defparameter *close-parens* '(#\))) (define-coloring-type :lisp "Basic Lisp" :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment :multiline :character :single-escaped :in-list :syntax-error) :default-mode :first-char-on-line :transitions (((:in-list) ((or (scan-any *symbol-characters*) (and (scan #\.) (scan-any *symbol-characters*)) (and (scan #\\) (advance 1))) (set-mode :symbol :until (scan-any *non-constituent*) :advancing nil)) ((or (scan #\:) (scan "#:")) (set-mode :keyword :until (scan-any *non-constituent*) :advancing nil)) ((scan "#\\") (let ((count 0)) (set-mode :character :until (progn (incf count) (if (> count 1) (scan-any *non-constituent*))) :advancing nil))) ((scan #\") (set-mode :string :until (scan #\"))) ((scan #\;) (set-mode :comment :until (scan #\newline))) ((scan "#|") (set-mode :multiline :until (scan "|#"))) ((scan #\() (set-mode :in-list :until (scan #\))))) ((:normal :first-char-on-line) ((scan #\() (set-mode :in-list :until (scan #\))))) (:first-char-on-line ((scan #\;) (set-mode :comment :until (scan #\newline))) ((scan "#|") (set-mode :multiline :until (scan "|#"))) ((advance 1) (set-mode :normal :until (scan #\newline)))) (:multiline ((scan "#|") (set-mode :multiline :until (scan "|#")))) ((:symbol :keyword :escaped-symbol :string) ((scan #\\) (let ((count 0)) (set-mode :single-escaped :until (progn (incf count) (if (< count 2) (advance 1)))))))) :formatter-variables ((paren-counter 0)) :formatter-after-hook (lambda nil (format nil "~{~A~}" (loop for i from paren-counter downto 1 collect ""))) :formatters (((:normal :first-char-on-line) (lambda (type s) (declare (ignore type)) s)) ((:in-list) (lambda (type s) (declare (ignore type)) (labels ((color-parens (s) (let ((paren-pos (find-if-not #'null (mapcar #'(lambda (c) (position c s)) (append *open-parens* *close-parens*))))) (if paren-pos (let ((before-paren (subseq s 0 paren-pos)) (after-paren (subseq s (1+ paren-pos))) (paren (elt s paren-pos)) (open nil) (count 0)) (when (member paren *open-parens* :test #'char=) (setf count (mod paren-counter 6)) (incf paren-counter) (setf open t)) (when (member paren *close-parens* :test #'char=) (decf paren-counter)) (if open (format nil "~A~C~A" before-paren (1+ count) paren *css-background-class* (color-parens after-paren)) (format nil "~A~C~A" before-paren paren (color-parens after-paren)))) s)))) (color-parens s)))) ((:symbol :escaped-symbol) (lambda (type s) (declare (ignore type)) (let* ((colon (position #\: s :from-end t)) (new-s (or (and colon (subseq s (1+ colon))) s))) (cond ((or (member new-s *common-macros* :test #'string-equal) (member new-s *special-forms* :test #'string-equal) (some #'(lambda (e) (and (> (length new-s) (length e)) (string-equal e (subseq new-s 0 (length e))))) '("WITH-" "DEF"))) (format nil "~A" s)) ((and (> (length new-s) 2) (char= (elt new-s 0) #\*) (char= (elt new-s (1- (length new-s))) #\*)) (format nil "~A" s)) (t s))))) (:keyword (lambda (type s) (declare (ignore type)) (format nil "~A" s))) ((:comment :multiline) (lambda (type s) (declare (ignore type)) (format nil "~A" s))) ((:character) (lambda (type s) (declare (ignore type)) (format nil "~A" s))) ((:string) (lambda (type s) (declare (ignore type)) (format nil "~A" s))) ((:single-escaped) (lambda (type s) (call-formatter (cdr type) s))) ((:syntax-error) (lambda (type s) (declare (ignore type)) (format nil "~A" s))))) (define-coloring-type :scheme "Scheme" :autodetect (lambda (text) (or (search "scheme" text :test #'char-equal) (search "chicken" text :test #'char-equal))) :parent :lisp :transitions (((:normal :in-list) ((scan "...") (set-mode :symbol :until (scan-any *non-constituent*) :advancing nil)) ((scan #\[) (set-mode :in-list :until (scan #\]))))) :formatters (((:in-list) (lambda (type s) (declare (ignore type s)) (let ((*open-parens* (cons #\[ *open-parens*)) (*close-parens* (cons #\] *close-parens*))) (call-parent-formatter)))) ((:symbol :escaped-symbol) (lambda (type s) (declare (ignore type)) (let ((result (if (find-package :r5rs-lookup) (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup)) s)))) (if result (format nil "~A" result (call-parent-formatter)) (call-parent-formatter))))))) (define-coloring-type :elisp "Emacs Lisp" :autodetect (lambda (name) (member name '("emacs") :test #'(lambda (name ext) (search ext name :test #'char-equal)))) :parent :lisp :formatters (((:symbol :escaped-symbol) (lambda (type s) (declare (ignore type)) (let ((result (if (find-package :elisp-lookup) (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup)) s)))) (if result (format nil "~A" result (call-parent-formatter)) (call-parent-formatter))))))) (define-coloring-type :common-lisp "Common Lisp" :autodetect (lambda (text) (search "lisp" text :test #'char-equal)) :parent :lisp :transitions (((:normal :in-list) ((scan #\|) (set-mode :escaped-symbol :until (scan #\|))))) :formatters (((:symbol :escaped-symbol) (lambda (type s) (declare (ignore type)) (let* ((colon (position #\: s :from-end t :test #'char=)) (to-lookup (if colon (subseq s (1+ colon)) s)) (result (if (find-package :clhs-lookup) (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup)) to-lookup)))) (if result (format nil "~A" result (call-parent-formatter)) (call-parent-formatter))))))) (define-coloring-type :common-lisp-file "Common Lisp File" :parent :common-lisp :default-mode :in-list :invisible t) (defvar *c-open-parens* "([{") (defvar *c-close-parens* ")]}") (defvar *c-reserved-words* '("auto" "break" "case" "char" "const" "continue" "default" "do" "double" "else" "enum" "extern" "float" "for" "goto" "if" "int" "long" "register" "return" "short" "signed" "sizeof" "static" "struct" "switch" "typedef" "union" "unsigned" "void" "volatile" "while" "__restrict" "_Bool")) (defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") (defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#)) (define-coloring-type :basic-c "Basic C" :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor) :default-mode :normal :invisible t :transitions ((:normal ((scan-any *c-begin-word*) (set-mode :word-ish :until (scan-any *c-terminators*) :advancing nil)) ((scan "/*") (set-mode :comment :until (scan "*/"))) ((or (scan-any *c-open-parens*) (scan-any *c-close-parens*)) (set-mode :paren-ish :until (advance 1) :advancing nil)) ((scan #\") (set-mode :string :until (scan #\"))) ((or (scan "'\\") (scan #\')) (set-mode :character :until (advance 2)))) (:string ((scan #\\) (set-mode :single-escape :until (advance 1))))) :formatter-variables ((paren-counter 0)) :formatter-after-hook (lambda nil (format nil "~{~A~}" (loop for i from paren-counter downto 1 collect ""))) :formatters ((:normal (lambda (type s) (declare (ignore type)) s)) (:comment (lambda (type s) (declare (ignore type)) (format nil "~A" s))) (:string (lambda (type s) (declare (ignore type)) (format nil "~A" s))) (:character (lambda (type s) (declare (ignore type)) (format nil "~A" s))) (:single-escape (lambda (type s) (call-formatter (cdr type) s))) (:paren-ish (lambda (type s) (declare (ignore type)) (let ((open nil) (count 0)) (if (eql (length s) 1) (progn (when (member (elt s 0) (coerce *c-open-parens* 'list)) (setf open t) (setf count (mod paren-counter 6)) (incf paren-counter)) (when (member (elt s 0) (coerce *c-close-parens* 'list)) (setf open nil) (decf paren-counter) (setf count (mod paren-counter 6))) (if open (format nil "~A" (1+ count) s *css-background-class*) (format nil "~A" s))) s)))) (:word-ish (lambda (type s) (declare (ignore type)) (if (member s *c-reserved-words* :test #'string=) (format nil "~A" s) s))) )) (define-coloring-type :c "C" :parent :basic-c :transitions ((:normal ((scan #\#) (set-mode :preprocessor :until (scan-any '(#\return #\newline)))))) :formatters ((:preprocessor (lambda (type s) (declare (ignore type)) (format nil "~A" s))))) (defvar *c++-reserved-words* '("asm" "auto" "bool" "break" "case" "catch" "char" "class" "const" "const_cast" "continue" "default" "delete" "do" "double" "dynamic_cast" "else" "enum" "explicit" "export" "extern" "false" "float" "for" "friend" "goto" "if" "inline" "int" "long" "mutable" "namespace" "new" "operator" "private" "protected" "public" "register" "reinterpret_cast" "return" "short" "signed" "sizeof" "static" "static_cast" "struct" "switch" "template" "this" "throw" "true" "try" "typedef" "typeid" "typename" "union" "unsigned" "using" "virtual" "void" "volatile" "wchar_t" "while")) (define-coloring-type :c++ "C++" :parent :c :transitions ((:normal ((scan "//") (set-mode :comment :until (scan-any '(#\return #\newline)))))) :formatters ((:word-ish (lambda (type s) (declare (ignore type)) (if (member s *c++-reserved-words* :test #'string=) (format nil "~A" s) s))))) (defvar *java-reserved-words* '("abstract" "boolean" "break" "byte" "case" "catch" "char" "class" "const" "continue" "default" "do" "double" "else" "extends" "final" "finally" "float" "for" "goto" "if" "implements" "import" "instanceof" "int" "interface" "long" "native" "new" "package" "private" "protected" "public" "return" "short" "static" "strictfp" "super" "switch" "synchronized" "this" "throw" "throws" "transient" "try" "void" "volatile" "while")) (define-coloring-type :java "Java" :parent :c++ :formatters ((:word-ish (lambda (type s) (declare (ignore type)) (if (member s *java-reserved-words* :test #'string=) (format nil "~A" s) s))))) (let ((terminate-next nil)) (define-coloring-type :objective-c "Objective C" :autodetect (lambda (text) (search "mac" text :test #'char=)) :modes (:begin-message-send :end-message-send) :transitions ((:normal ((scan #\[) (set-mode :begin-message-send :until (advance 1) :advancing nil)) ((scan #\]) (set-mode :end-message-send :until (advance 1) :advancing nil)) ((scan-any *c-begin-word*) (set-mode :word-ish :until (or (and (peek-any '(#\:)) (setf terminate-next t)) (and terminate-next (progn (setf terminate-next nil) (advance 1))) (scan-any *c-terminators*)) :advancing nil))) (:word-ish #+nil ((scan #\:) (format t "hi~%") (set-mode :word-ish :until (advance 1) :advancing nil) (setf terminate-next t)))) :parent :c++ :formatter-variables ((is-keyword nil) (in-message-send nil)) :formatters ((:begin-message-send (lambda (type s) (setf is-keyword nil) (setf in-message-send t) (call-formatter (cons :paren-ish type) s))) (:end-message-send (lambda (type s) (setf is-keyword nil) (setf in-message-send nil) (call-formatter (cons :paren-ish type) s))) (:word-ish (lambda (type s) (declare (ignore type)) (prog1 (let ((result (if (find-package :cocoa-lookup) (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup)) s)))) (if result (format nil "~A" result s) (if (member s *c-reserved-words* :test #'string=) (format nil "~A" s) (if in-message-send (if is-keyword (format nil "~A" s) s) s)))) (setf is-keyword (not is-keyword)))))))) ;#!/usr/bin/clisp ;#+sbcl ;(require :asdf) ;(asdf:oos 'asdf:load-op :colorize) (defmacro with-each-stream-line ((var stream) &body body) (let ((eof (gensym)) (eof-value (gensym)) (strm (gensym))) `(let ((,strm ,stream) (,eof ',eof-value)) (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof))) ((eql ,var ,eof)) ,@body)))) (defun system (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with output to *verbose-out*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (format t "; $ ~A~%" command) #+sbcl (sb-impl::process-exit-code (sb-ext:run-program "/bin/sh" (list "-c" command) :input nil :output *standard-output*)) #+(or cmucl scl) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out*)) #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) )) (defun strcat (&rest strings) (apply #'concatenate 'string strings)) (defun string-starts-with (start str) (and (>= (length str) (length start)) (string-equal start str :end2 (length start)))) (defmacro string-append (outputstr &rest args) `(setq ,outputstr (concatenate 'string ,outputstr ,@args))) (defconstant +indent+ 0 "Indentation used in the examples.") (defun texinfo->raw-lisp (code) "Answer CODE with spurious Texinfo output removed. For use in preprocessing output in a @lisp block before passing to colorize." (decode-from-tt (with-output-to-string (output) (do* ((last-position 0) (next-position #0=(search #1="" code :start2 last-position :test #'char-equal) #0#)) ((eq nil next-position) (write-string code output :start last-position)) (write-string code output :start last-position :end next-position) (let ((end (search #2="" code :start2 (+ next-position (length #1#)) :test #'char-equal))) (assert (integerp end) () "Missing ~A tag in HTML for @lisp block~%~ HTML contents of block:~%~A" #2# code) (write-string code output :start (+ next-position (length #1#)) :end end) (setf last-position (+ end (length #2#)))))))) (defun process-file (from to) (with-open-file (output to :direction :output :if-exists :error) (with-open-file (input from :direction :input) (let ((line-processor nil) (piece-of-code '())) (labels ((process-line-inside-pre (line) (cond ((string-starts-with "" line) (with-input-from-string (stream (colorize:html-colorization :common-lisp (texinfo->raw-lisp (apply #'concatenate 'string (nreverse piece-of-code))))) (with-each-stream-line (cline stream) (format output " ~A~%" cline))) (write-line line output) (setq piece-of-code '() line-processor #'process-regular-line)) (t (let ((to-append (subseq line +indent+))) (push (if (string= "" to-append) " " to-append) piece-of-code) (push (string #\Newline) piece-of-code))))) (process-regular-line (line) (let ((len (some (lambda (test-string) (when (string-starts-with test-string line) (length test-string))) '("
"
                                 "
"))))
                 (cond (len
                         (setq line-processor #'process-line-inside-pre)
                         (write-string "
" output)
                         (push (subseq line (+ len +indent+)) piece-of-code)
                         (push (string #\Newline) piece-of-code))
                       (t (write-line line output))))))
          (setf line-processor #'process-regular-line)
          (with-each-stream-line (line input)
            (funcall line-processor line)))))))

(defun process-dir (dir)
  (dolist (html-file (directory dir))
    (let* ((name (namestring html-file))
           (temp-name (strcat name ".temp")))
      (process-file name temp-name)
      (system "mv ~A ~A" temp-name name))))

;; (go "/tmp/doc/manual/html_node/*.html")

#+clisp
(progn
  (assert (first ext:*args*))
  (process-dir (first ext:*args*)))

#+sbcl
(progn
  (assert (second sb-ext:*posix-argv*))
  (process-dir (second sb-ext:*posix-argv*))
  (sb-ext:quit))
cffi_0.19.0/doc/cffi-manual.texinfo0000644000175000017500000064044713103031266015643 0ustar  luisluis\input texinfo   @c -*- Mode: Texinfo; Mode: auto-fill -*-
@c %**start of header
@setfilename cffi.info
@settitle CFFI User Manual
@exampleindent 2

@c @documentencoding utf-8

@c Style notes:
@c
@c * The reference section names and "See Also" list are roman, not
@c   @code.  This is to follow the format of CLHS.
@c
@c * How it looks in HTML is the priority.

@c ============================= Macros =============================
@c The following macros are used throughout this manual.

@macro Function {args}
@defun \args\
@end defun
@end macro

@macro Macro {args}
@defmac \args\
@end defmac
@end macro

@macro Accessor {args}
@deffn {Accessor} \args\
@end deffn
@end macro

@macro GenericFunction {args}
@deffn {Generic Function} \args\
@end deffn
@end macro

@macro ForeignType {args}
@deftp {Foreign Type} \args\
@end deftp
@end macro

@macro Variable {args}
@defvr {Special Variable} \args\
@end defvr
@end macro

@macro Condition {args}
@deftp {Condition Type} \args\
@end deftp
@end macro

@macro cffi
@acronym{CFFI}
@end macro

@macro impnote {text}
@quotation
@strong{Implementor's note:} @emph{\text\}
@end quotation
@end macro

@c Info "requires" that x-refs end in a period or comma, or ) in the
@c case of @pxref.  So the following implements that requirement for
@c the "See also" subheadings that permeate this manual, but only in
@c Info mode.
@ifinfo
@macro seealso {name}
@ref{\name\}.
@end macro
@end ifinfo

@ifnotinfo
@alias seealso = ref
@end ifnotinfo

@c Typeset comments in roman font for the TeX output.
@iftex
@alias lispcmt = r
@end iftex
@ifnottex
@alias lispcmt = asis
@end ifnottex

@alias res = result

@c ============================= Macros =============================


@c Show types, functions, and concepts in the same index.
@syncodeindex tp cp
@syncodeindex fn cp

@copying
Copyright @copyright{} 2005 James Bielman  @*
Copyright @copyright{} 2005-2015 Lu@'{@dotless{i}}s Oliveira
   @*
Copyright @copyright{} 2005-2006 Dan Knapp  @*
Copyright @copyright{} 2005-2006 Emily Backes  @*
Copyright @copyright{} 2006 Stephen Compall 

@quotation
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
``Software''), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

@sc{The software is provided ``as is'', without warranty of any kind,
express or implied, including but not limited to the warranties of
merchantability, fitness for a particular purpose and noninfringement.
In no event shall the authors or copyright holders be liable for any
claim, damages or other liability, whether in an action of contract,
tort or otherwise, arising from, out of or in connection with the
software or the use or other dealings in the software.}
@end quotation
@end copying
@c %**end of header

@dircategory Software development
@direntry
* CFFI Manual: (cffi-manual).           CFFI Manual.
@end direntry

@titlepage
@title CFFI User Manual
@c @subtitle Version X.X
@c @author James Bielman

@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage

@contents

@ifnottex
@node Top, Introduction, (dir), (dir)
@top cffi
@insertcopying
@end ifnottex

@menu
* Introduction::                What is CFFI?
* Installation::
* Implementation Support::
* Tutorial::                    Interactive intro to using CFFI.
* Wrapper generators::          CFFI forms from munging C source code.
* Foreign Types::
* Pointers::
* Strings::
* Variables::
* Functions::
* Libraries::
* Callbacks::
* The Groveller::
* Static Linking::
* Limitations::
* Platform-specific features::  Details about the underlying system.
* Glossary::                    List of CFFI-specific terms and meanings.
* Comprehensive Index::

@detailmenu
 --- Dictionary ---

Foreign Types

* convert-from-foreign::        Outside interface to backward type translator.
* convert-to-foreign::          Outside interface to forward type translator.
* defbitfield::                 Defines a bitfield.
* defcstruct::                  Defines a C structure type.
* defcunion::                   Defines a C union type.
* defctype::                    Defines a foreign typedef.
* defcenum::                    Defines a C enumeration.
* define-foreign-type::         Defines a foreign type specifier.
* define-parse-method::         Specifies how a type should be parsed.
@c * explain-foreign-slot-value::  
* foreign-bitfield-symbols::    Returns a list of symbols for a bitfield type.
* foreign-bitfield-value::      Calculates a value for a bitfield type.
* foreign-enum-keyword::        Finds a keyword in an enum type.
* foreign-enum-value::          Finds a value in an enum type.
* foreign-slot-names::          Returns a list of slot names in a foreign struct.
* foreign-slot-offset::         Returns the offset of a slot in a foreign struct.
* foreign-slot-pointer::        Returns a pointer to a slot in a foreign struct.
* foreign-slot-value::          Returns the value of a slot in a foreign struct.
* foreign-type-alignment::      Returns the alignment of a foreign type.
* foreign-type-size::           Returns the size of a foreign type.
* free-converted-object::       Outside interface to typed object deallocators.
* free-translated-object::      Defines how to free a oreign object.
* translate-from-foreign::      Defines a foreign-to-Lisp object translation.
* translate-to-foreign::        Defines a Lisp-to-foreign object translation.
* with-foreign-object::         Allocates a foreign object with dynamic extent.
* with-foreign-objects::        Plural form of @code{with-foreign-object}.
* with-foreign-slots::          Accesses the slots of a foreign structure.

Pointers

* foreign-free::                Deallocates memory.
* foreign-alloc::               Allocates memory.
* foreign-symbol-pointer::      Returns a pointer to a foreign symbol.
* inc-pointer::                 Increments the address held by a pointer.
* incf-pointer::                Increments the pointer address in a place.
* make-pointer::                Returns a pointer to a given address.
* mem-aptr::                    The pointer to an element of an array.
* mem-aref::                    Accesses the value of an index in an array.
* mem-ref::                     Dereferences a pointer.
* null-pointer::                Returns a NULL pointer.
* null-pointer-p::              Tests a pointer for NULL value.
* pointerp::                    Tests whether an object is a pointer or not.
* pointer-address::             Returns the address pointed to by a pointer.
* pointer-eq::                  Tests if two pointers point to the same address.
* with-foreign-pointer::        Allocates memory with dynamic extent.

Strings

* *default-foreign-encoding*::  Default encoding for the string types.
* foreign-string-alloc::        Converts a Lisp string to a foreign string.
* foreign-string-free::         Deallocates memory used by a foreign string.
* foreign-string-to-lisp::      Converts a foreign string to a Lisp string.
* lisp-string-to-foreign::      Copies a Lisp string into a foreign string.
* with-foreign-string::         Allocates a foreign string with dynamic extent.
* with-foreign-strings::        Plural form of @code{with-foreign-string}.
* with-foreign-pointer-as-string::  Similar to CL's with-output-to-string.

Variables

* defcvar::                     Defines a C global variable.
* get-var-pointer::             Returns a pointer to a defined global variable.

Functions

* defcfun::                     Defines a foreign function.
* foreign-funcall::             Performs a call to a foreign function.
* foreign-funcall-pointer::     Performs a call through a foreign pointer.
* translate-camelcase-name::    Converts a camelCase foreign name to/from a Lisp name.
* translate-name-from-foreign::  Converts a foreign name to a Lisp name.
* translate-name-to-foreign::   Converts a Lisp name to a foreign name.
* translate-underscore-separated-name::  Converts an underscore_separated foreign name to/from a Lisp name.

Libraries

* close-foreign-library::       Closes a foreign library.
* *darwin-framework-directories*::  Search path for Darwin frameworks.
* define-foreign-library::      Explain how to load a foreign library.
* *foreign-library-directories*::  Search path for shared libraries.
* load-foreign-library::        Load a foreign library.
* load-foreign-library-error::  Signalled on failure of its namesake.
@c * reload-foreign-libraries::    Reload foreign libraries.
* use-foreign-library::         Load a foreign library when needed.

Callbacks

* callback::                    Returns a pointer to a defined callback.
* defcallback::                 Defines a Lisp callback.
* get-callback::                Returns a pointer to a defined callback.

@end detailmenu
@end menu




@c ===================================================================
@c CHAPTER: Introduction

@node Introduction, Installation, Top, Top
@chapter Introduction

@cffi{} is the Common Foreign Function Interface for @acronym{ANSI}
Common Lisp systems.  By @dfn{foreign function} we mean a function
written in another programming language and having different data and
calling conventions than Common Lisp, namely, C.  @cffi{} allows you
to call foreign functions and access foreign variables, all without
leaving the Lisp image.

We consider this manual ever a work in progress.  If you have
difficulty with anything @cffi{}-specific presented in the manual,
please contact @email{cffi-devel@@common-lisp.net,the developers} with
details.


@heading Motivation

@xref{Tutorial-Comparison,, What makes Lisp different}, for
an argument in favor of @acronym{FFI} in general.

@cffi{}'s primary role in any image is to mediate between Lisp
developers and the widely varying @acronym{FFI}s present in the
various Lisp implementations it supports.  With @cffi{}, you can
define foreign function interfaces while still maintaining portability
between implementations.  It is not the first Common Lisp package with
this objective; however, it is meant to be a more malleable framework
than similar packages.


@heading Design Philosophy

@itemize
@item
Pointers do not carry around type information. Instead, type
information is supplied when pointers are dereferenced.

@item
A type safe pointer interface can be developed on top of an
untyped one.  It is difficult to do the opposite.

@item
Functions are better than macros.  When a macro could be used
for performance, use a compiler-macro instead.
@end itemize


@c ===================================================================
@c CHAPTER: Installation

@node Installation, Implementation Support, Introduction, Top
@chapter Installation

@cffi{} can be obtained through one of the following means available
through its @uref{http://common-lisp.net/project/cffi/,,website}:

@itemize
@item
@uref{http://common-lisp.net/project/cffi/releases/?M=D,,official release
tarballs}

@item
@uref{http://common-lisp.net/gitweb?p=projects/cffi/cffi.git,,git
repository}

@c snapshots have been disabled as of
@c @item
@c @uref{http://common-lisp.net/project/cffi/tarballs/?M=D,,nightly-generated
@c snapshots}

@end itemize

In addition, you will need to obtain and install the following
dependencies:

@itemize
@item
@uref{http://common-lisp.net/project/babel/,,Babel}, a charset
encoding/decoding library.

@item
@uref{http://common-lisp.net/project/alexandria/,,Alexandria}, a
collection of portable public-domain utilities.

@item
@uref{http://www.cliki.net/trivial-features,,trivial-features}, a
portability layer that ensures consistent @code{*features*} across
multiple Common Lisp implementations.

@end itemize

Furthermore, if you wish to run the testsuite,
@uref{http://www.cliki.net/rt,,RT} is required.

You may find mechanisms such as
@uref{https://www.quicklisp.org/beta/,Quicklisp} (recommended)
or @uref{http://common-lisp.net/project/clbuild/,,clbuild} (for advanced
uses) helpful in getting and managing @cffi{} and its
dependencies.


@c ===================================================================
@c CHAPTER: Implementation Support

@node Implementation Support, Tutorial, Installation, Top
@chapter Implementation Support

@cffi{} supports various free and commercial Lisp implementations:
@acronym{ABCL}, Allegro CL, Clasp, @sc{clisp}, Clozure CL,
@acronym{CMUCL}, Corman CL, @acronym{ECL}, @acronym{GCL}, LispWorks,
@acronym{MCL}, @acronym{SBCL} and the Scieneer CL.

In general, you should work with the latest versions of each
implementation since those will usually be tested against recent
versions of CFFI more often and might include necessary features or
bug fixes. Reasonable patches for compatibility with earlier versions
are welcome nevertheless.

@section Limitations

Some features are not supported in all implementations.
@c TODO: describe these features here.
@c       flat-namespace too

@subheading Allegro CL

@itemize
@item
Does not support the @code{:long-long} type natively.
@item
Unicode support is limited to the Basic Multilingual Plane (16-bit
code points).
@end itemize

@subheading Clasp

@itemize
@item
Only supports a flat namespace.
@end itemize

@subheading CMUCL

@itemize
@item
No Unicode support. (8-bit code points)
@end itemize

@subheading Corman CL

@itemize
@item
Does not support @code{foreign-funcall}.
@end itemize

@subheading @acronym{ECL}

@itemize
@item
On platforms where ECL's dynamic FFI is not supported (ie. when
@code{:dffi} is not present in @code{*features*}),
@code{cffi:load-foreign-library} does not work and you must use ECL's
own @code{ffi:load-foreign-library} with a constant string argument.
@item
Does not support the @code{:long-long} type natively.
@item
Unicode support is not enabled by default.
@end itemize

@subheading Lispworks

@itemize
@item
Does not completely support the @code{:long-long} type natively in
32-bit platforms.
@item
Unicode support is limited to the Basic Multilingual Plane (16-bit
code points).
@end itemize

@subheading @acronym{SBCL}

@itemize
@item
Not all platforms support callbacks.

@end itemize


@c ===================================================================
@c CHAPTER: An Introduction to Foreign Interfaces and CFFI

@c This macro is merely a marker that I don't think I'll use after
@c all.
@macro tutorialsource {text}
@c \text\
@end macro

@c because I don't want to type this over and over
@macro clikicffi
http://www.cliki.net/CFFI
@end macro
@c TeX puts spurious newlines in when you use the above macro
@c in @examples &c.  So it is expanded below in some places.


@node Tutorial, Wrapper generators, Implementation Support, Top
@chapter An Introduction to Foreign Interfaces and @acronym{CFFI}

@c Above, I don't use the cffi macro because it breaks TeX.

@cindex tutorial, @cffi{}
Users of many popular languages bearing semantic similarity to Lisp,
such as Perl and Python, are accustomed to having access to popular C
libraries, such as @acronym{GTK}, by way of ``bindings''.  In Lisp, we
do something similar, but take a fundamentally different approach.
This tutorial first explains this difference, then explains how you
can use @cffi{}, a powerful system for calling out to C and C++ and
access C data from many Common Lisp implementations.

@cindex foreign functions and data
The concept can be generalized to other languages; at the time of
writing, only @cffi{}'s C support is fairly complete. Therefore, we
will interchangeably refer to @dfn{foreign functions} and @dfn{foreign
data}, and ``C functions'' and ``C data''.  At no time will the word
``foreign'' carry its usual, non-programming meaning.

This tutorial expects you to have a working understanding of both
Common Lisp and C, including the Common Lisp macro system.

@menu
* Tutorial-Comparison::         Why FFI?
* Tutorial-Getting a URL::      An FFI use case.
* Tutorial-Loading::            Load libcurl.so.
* Tutorial-Initializing::       Call a function in libcurl.so.
* Tutorial-easy_setopt::        An advanced libcurl function.
* Tutorial-Abstraction::        Why breaking it is necessary.
* Tutorial-Lisp easy_setopt::   Semi-Lispy option interface.
* Tutorial-Memory::             In C, you collect the garbage.
* Tutorial-Callbacks::          Make useful C function pointers.
* Tutorial-Completion::         Minimal get-url functionality.
* Tutorial-Types::              Defining new foreign types.
* Tutorial-Conclusion::         What's next?
@end menu


@node Tutorial-Comparison, Tutorial-Getting a URL, Tutorial, Tutorial
@section What makes Lisp different

The following sums up how bindings to foreign libraries are usually
implemented in other languages, then in Common Lisp:

@table @asis
@item Perl, Python, Java, other one-implementation languages
@cindex @acronym{SWIG}
@cindex Perl
@cindex Python
Bindings are implemented as shared objects written in C.  In some
cases, the C code is generated by a tool, such as @acronym{SWIG}, but
the result is the same: a new C library that manually translates
between the language implementation's objects, such as @code{PyObject}
in Python, and whatever C object is called for, often using C
functions provided by the implementation.  It also translates between
the calling conventions of the language and C.

@item Common Lisp
@cindex @acronym{SLIME}
Bindings are written in Lisp.  They can be created at-will by Lisp
programs.  Lisp programmers can write new bindings and add them to the
image, using a listener such as @acronym{SLIME}, as easily as with
regular Lisp definitions.  The only foreign library to load is the one
being wrapped---the one with the pure C interface; no C or other
non-Lisp compilation is required.
@end table

@cindex advantages of @acronym{FFI}
@cindex benefits of @acronym{FFI}
We believe the advantages of the Common Lisp approach far outweigh any
disadvantages.  Incremental development with a listener can be as
productive for C binding development as it is with other Lisp
development.  Keeping it ``in the [Lisp] family'', as it were, makes
it much easier for you and other Lisp programmers to load and use the
bindings.  Common Lisp implementations such as @acronym{CMUCL}, freed
from having to provide a C interface to their own objects, are thus
freed to be implemented in another language (as @acronym{CMUCL} is)
while still allowing programmers to call foreign functions.

@cindex minimal bindings
Perhaps the greatest advantage is that using an @acronym{FFI} doesn't
obligate you to become a professional binding developer.  Writers of
bindings for other languages usually end up maintaining or failing to
maintain complete bindings to the foreign library.  Using an
@acronym{FFI}, however, means if you only need one or two functions,
you can write bindings for only those functions, and be assured that
you can just as easily add to the bindings if need be.

@cindex C abstractions
@cindex abstractions in C
The removal of the C compiler, or C interpretation of any kind,
creates the main disadvantage: some of C's ``abstractions'' are not
available, violating information encapsulation.  For example,
@code{struct}s that must be passed on the stack, or used as return
values, without corresponding functional abstractions to create and
manage the @code{struct}s, must be declared explicitly in Lisp.  This
is fine for structs whose contents are ``public'', but is not so
pleasant when a struct is supposed to be ``opaque'' by convention,
even though it is not so defined.@footnote{Admittedly, this is an
advanced issue, and we encourage you to leave this text until you are
more familiar with how @cffi{} works.}

Without an abstraction to create the struct, Lisp needs to be able to
lay out the struct in memory, so must know its internal details.

@cindex workaround for C
In these cases, you can create a minimal C library to provide the
missing abstractions, without destroying all the advantages of the
Common Lisp approach discussed above.  In the case of @code{struct}s,
you can write simple, pure C functions that tell you how many bytes a
struct requires or allocate new structs, read and write fields of the
struct, or whatever operations are supposed to be
public.@footnote{This does not apply to structs whose contents are
intended to be part of the public library interface.  In those cases,
a pure Lisp struct definition is always preferred.  In fact, many
prefer to stay in Lisp and break the encapsulation anyway, placing the
burden of correct library interface definition on the library.}
@ref{The Groveller} automates this and other processes.

Another disadvantage appears when you would rather use the foreign
language than Lisp.  However, someone who prefers C to Lisp is not a
likely candidate for developing a Lisp interface to a C library.


@node Tutorial-Getting a URL, Tutorial-Loading, Tutorial-Comparison, Tutorial
@section Getting a @acronym{URL}

@cindex c@acronym{URL}
The widely available @code{libcurl} is a library for downloading files
over protocols like @acronym{HTTP}.  We will use @code{libcurl} with
@cffi{} to download a web page.

Please note that there are many other ways to download files from the
web, not least the @sc{cl-curl} project to provide bindings to
@code{libcurl} via a similar @acronym{FFI}.@footnote{Specifically,
@acronym{UFFI}, an older @acronym{FFI} that takes a somewhat different
approach compared to @cffi{}.  I believe that these days (December
2005) @cffi{} is more portable and actively developed, though not as
mature yet.  Consensus in the free @sc{unix} Common Lisp community
seems to be that @cffi{} is preferred for new development, though
@acronym{UFFI} will likely go on for quite some time as many projects
already use it.  @cffi{} includes the @code{UFFI-COMPAT} package for
complete compatibility with @acronym{UFFI}.}

@uref{http://curl.haxx.se/libcurl/c/libcurl-tutorial.html,,libcurl-tutorial(3)}
is a tutorial for @code{libcurl} programming in C.  We will follow
that to develop a binding to download a file.  We will also use
@file{curl.h}, @file{easy.h}, and the @command{man} pages for the
@code{libcurl} function, all available in the @samp{curl-dev} package
or equivalent for your system, or in the c@acronym{URL} source code
package.  If you have the development package, the headers should be
installed in @file{/usr/include/curl/}, and the @command{man} pages
may be accessed through your favorite @command{man} facility.


@node Tutorial-Loading, Tutorial-Initializing, Tutorial-Getting a URL, Tutorial
@section Loading foreign libraries

@cindex loading @cffi{}
@cindex requiring @cffi{}
First of all, we will create a package to work in.  You can save these
forms in a file, or just send them to the listener as they are.  If
creating bindings for an @acronym{ASDF} package of yours, you will
want to add @code{:cffi} to the @code{:depends-on} list in your
@file{.asd} file.  Otherwise, just use the @code{asdf:load-system} function to
load @cffi{}.

@tutorialsource{Initialization}
@lisp
(asdf:load-system :cffi)

;;; @lispcmt{Nothing special about the "CFFI-USER" package.  We're just}
;;; @lispcmt{using it as a substitute for your own CL package.}
(defpackage :cffi-user
  (:use :common-lisp :cffi))

(in-package :cffi-user)

(define-foreign-library libcurl
  (:darwin (:or "libcurl.3.dylib" "libcurl.dylib"))
  (:unix (:or "libcurl.so.3" "libcurl.so"))
  (t (:default "libcurl")))

(use-foreign-library libcurl)
@end lisp

@cindex foreign library load
@cindex library, foreign
Using @code{define-foreign-library} and @code{use-foreign-library}, we
have loaded @code{libcurl} into Lisp, much as the linker does when you
start a C program, or @code{common-lisp:load} does with a Lisp source
file or @acronym{FASL} file.  We special-cased for @sc{unix} machines
to always load a particular version, the one this tutorial was tested
with; for those who don't care, the @code{define-foreign-library}
clause @code{(t (:default "libcurl"))} should be satisfactory, and
will adapt to various operating systems.


@node Tutorial-Initializing, Tutorial-easy_setopt, Tutorial-Loading, Tutorial
@section Initializing @code{libcurl}

@cindex function definition
After the introductory matter, the tutorial goes on to present the
first function you should use.

@example
CURLcode curl_global_init(long flags);
@end example

@noindent
Let's pick this apart into appropriate Lisp code:

@tutorialsource{First CURLcode}
@lisp
;;; @lispcmt{A CURLcode is the universal error code.  curl/curl.h says}
;;; @lispcmt{no return code will ever be removed, and new ones will be}
;;; @lispcmt{added to the end.}
(defctype curl-code :int)

;;; @lispcmt{Initialize libcurl with FLAGS.}
(defcfun "curl_global_init" curl-code
  (flags :long))
@end lisp

@impnote{By default, CFFI assumes the UNIX viewpoint that there is one
C symbol namespace, containing all symbols in all loaded objects.
This is not so on Windows and Darwin, but we emulate UNIX's behaviour
there.  @ref{defcfun} for more details.}

Note the parallels with the original C declaration.  We've defined
@code{curl-code} as a wrapping type for @code{:int}; right now, it
only marks it as special, but later we will do something more
interesting with it.  The point is that we don't have to do it yet.

@cindex calling foreign functions
Looking at @file{curl.h}, @code{CURL_GLOBAL_NOTHING}, a possible value
for @code{flags} above, is defined as @samp{0}.  So we can now call
the function:

@example
@sc{cffi-user>} (curl-global-init 0)
@result{} 0
@end example

@cindex looks like it worked
Looking at @file{curl.h} again, @code{0} means @code{CURLE_OK}, so it
looks like the call succeeded.  Note that @cffi{} converted the
function name to a Lisp-friendly name.  You can specify your own name
if you want; use @code{("curl_global_init" @var{your-name-here})} as
the @var{name} argument to @code{defcfun}.

The tutorial goes on to have us allocate a handle.  For good measure,
we should also include the deallocator.  Let's look at these
functions:

@example
CURL *curl_easy_init( );
void curl_easy_cleanup(CURL *handle);
@end example

Advanced users may want to define special pointer types; we will
explore this possibility later.  For now, just treat every pointer as
the same:

@tutorialsource{curl_easy handles}
@lisp
(defcfun "curl_easy_init" :pointer)

(defcfun "curl_easy_cleanup" :void
  (easy-handle :pointer))
@end lisp

Now we can continue with the tutorial:

@example
@sc{cffi-user>} (defparameter *easy-handle* (curl-easy-init))
@result{} *EASY-HANDLE*
@sc{cffi-user>} *easy-handle*
@result{} #
@end example

@cindex pointers in Lisp
Note the print representation of a pointer.  It changes depending on
what Lisp you are using, but that doesn't make any difference to
@cffi{}.


@node Tutorial-easy_setopt, Tutorial-Abstraction, Tutorial-Initializing, Tutorial
@section Setting download options

The @code{libcurl} tutorial says we'll want to set many options before
performing any download actions.  This is done through
@code{curl_easy_setopt}:

@c That is literally ..., not an ellipsis.
@example
CURLcode curl_easy_setopt(CURL *curl, CURLoption option, ...);
@end example

@cindex varargs
@cindex foreign arguments
We've introduced a new twist: variable arguments.  There is no obvious
translation to the @code{defcfun} form, particularly as there are four
possible argument types.  Because of the way C works, we could define
four wrappers around @code{curl_easy_setopt}, one for each type; in
this case, however, we'll use the general-purpose macro
@code{foreign-funcall} to call this function.

@cindex enumeration, C
To make things easier on ourselves, we'll create an enumeration of the
kinds of options we want to set.  The @code{enum CURLoption} isn't the
most straightforward, but reading the @code{CINIT} C macro definition
should be enlightening.

@tutorialsource{CURLoption enumeration}
@lisp
(defmacro define-curl-options (name type-offsets &rest enum-args)
  "As with CFFI:DEFCENUM, except each of ENUM-ARGS is as follows:

    (NAME TYPE NUMBER)

Where the arguments are as they are with the CINIT macro defined
in curl.h, except NAME is a keyword.

TYPE-OFFSETS is a plist of TYPEs to their integer offsets, as
defined by the CURLOPTTYPE_LONG et al constants in curl.h."
  (flet ((enumerated-value (type offset)
           (+ (getf type-offsets type) offset)))
    `(progn
       (defcenum ,name
         ,@@(loop for (name type number) in enum-args
              collect (list name (enumerated-value type number))))
       ',name)))                ;@lispcmt{for REPL users' sanity}

(define-curl-options curl-option
    (long 0 objectpoint 10000 functionpoint 20000 off-t 30000)
  (:noprogress long 43)
  (:nosignal long 99)
  (:errorbuffer objectpoint 10)
  (:url objectpoint 2))
@end lisp

With some well-placed Emacs @code{query-replace-regexp}s, you could
probably similarly define the entire @code{CURLoption} enumeration.  I
have selected to transcribe a few that we will use in this tutorial.

If you're having trouble following the macrology, just macroexpand the
@code{curl-option} definition, or see the following macroexpansion,
conveniently downcased and reformatted:

@tutorialsource{DEFINE-CURL-OPTIONS macroexpansion}
@lisp
(progn
  (defcenum curl-option
    (:noprogress 43)
    (:nosignal 99)
    (:errorbuffer 10010)
    (:url 10002))
  'curl-option)
@end lisp

@noindent
That seems more than reasonable.  You may notice that we only use the
@var{type} to compute the real enumeration offset; we will also need
the type information later.

First, however, let's make sure a simple call to the foreign function
works:

@example
@sc{cffi-user>} (foreign-funcall "curl_easy_setopt"
               :pointer *easy-handle*
               curl-option :nosignal :long 1 curl-code)
@result{} 0
@end example

@code{foreign-funcall}, despite its surface simplicity, can be used to
call any C function.  Its first argument is a string, naming the
function to be called.  Next, for each argument, we pass the name of
the C type, which is the same as in @code{defcfun}, followed by a Lisp
object representing the data to be passed as the argument.  The final
argument is the return type, for which we use the @code{curl-code}
type defined earlier.

@code{defcfun} just puts a convenient fa@,cade on
@code{foreign-funcall}.@footnote{This isn't entirely true; some Lisps
don't support @code{foreign-funcall}, so @code{defcfun} is implemented
without it.  @code{defcfun} may also perform optimizations that
@code{foreign-funcall} cannot.}  Our earlier call to
@code{curl-global-init} could have been written as follows:

@example
@sc{cffi-user>} (foreign-funcall "curl_global_init" :long 0
                            curl-code)
@result{} 0
@end example

Before we continue, we will take a look at what @cffi{} can and can't
do, and why this is so.


@node Tutorial-Abstraction, Tutorial-Lisp easy_setopt, Tutorial-easy_setopt, Tutorial
@section Breaking the abstraction

@cindex breaking the abstraction
@cindex abstraction breaking
In @ref{Tutorial-Comparison,, What makes Lisp different}, we mentioned
that writing an @acronym{FFI} sometimes requires depending on
information not provided as part of the interface.  The easy option
@code{CURLOPT_WRITEDATA}, which we will not provide as part of the
Lisp interface, illustrates this issue.

Strictly speaking, the @code{curl-option} enumeration is not
necessary; we could have used @code{:int 99} instead of
@code{curl-option :nosignal} in our call to @code{curl_easy_setopt}
above.  We defined it anyway, in part to hide the fact that we are
breaking the abstraction that the C @code{enum} provides.  If the
c@acronym{URL} developers decide to change those numbers later, we
must change the Lisp enumeration, because enumeration values are not
provided in the compiled C library, @code{libcurl.so.3}.

@cffi{} works because the most useful things in C libraries ---
non-static functions and non-static variables --- are included
accessibly in @code{libcurl.so.3}.  A C compiler that violated this
would be considered a worthless compiler.

The other thing @code{define-curl-options} does is give the ``type''
of the third argument passed to @code{curl_easy_setopt}.  Using this
information, we can tell that the @code{:nosignal} option should
accept a long integer argument.  We can implicitly assume @code{t}
@equiv{} 1 and @code{nil} @equiv{} 0, as it is in C, which takes care
of the fact that @code{CURLOPT_NOSIGNAL} is really asking for a
boolean.

The ``type'' of @code{CURLOPT_WRITEDATA} is @code{objectpoint}.
However, it is really looking for a @code{FILE*}.
@code{CURLOPT_ERRORBUFFER} is looking for a @code{char*}, so there is
no obvious @cffi{} type but @code{:pointer}.

The first thing to note is that nowhere in the C interface includes
this information; it can only be found in the manual.  We could
disjoin these clearly different types ourselves, by splitting
@code{objectpoint} into @code{filepoint} and @code{charpoint}, but we
are still breaking the abstraction, because we have to augment the
entire enumeration form with this additional
information.@footnote{Another possibility is to allow the caller to
specify the desired C type of the third argument.  This is essentially
what happens in a call to the function written in C.}

@cindex streams and C
@cindex @sc{file}* and streams
The second is that the @code{CURLOPT_WRITEDATA} argument is completely
incompatible with the desired Lisp data, a
stream.@footnote{@xref{Other Kinds of Streams,,, libc, GNU C Library
Reference}, for a @acronym{GNU}-only way to extend the @code{FILE*}
type.  You could use this to convert Lisp streams to the needed C
data.  This would be quite involved and far outside the scope of this
tutorial.}  It is probably acceptable if we are controlling every file
we might want to use as this argument, in which case we can just call
the foreign function @code{fopen}.  Regardless, though, we can't write
to arbitrary streams, which is exactly what we want to do for this
application.

Finally, note that the @code{curl_easy_setopt} interface itself is a
hack, intended to work around some of the drawbacks of C.  The
definition of @code{Curl_setopt}, while long, is far less cluttered
than the equivalent disjoint-function set would be; in addition,
setting a new option in an old @code{libcurl} can generate a run-time
error rather than breaking the compile.  Lisp can just as concisely
generate functions as compare values, and the ``undefined function''
error is just as useful as any explicit error we could define here
might be.


@node Tutorial-Lisp easy_setopt, Tutorial-Memory, Tutorial-Abstraction, Tutorial
@section Option functions in Lisp

We could use @code{foreign-funcall} directly every time we wanted to
call @code{curl_easy_setopt}.  However, we can encapsulate some of the
necessary information with the following.

@lisp
;;; @lispcmt{We will use this type later in a more creative way.  For}
;;; @lispcmt{now, just consider it a marker that this isn't just any}
;;; @lispcmt{pointer.}
(defctype easy-handle :pointer)

(defmacro curl-easy-setopt (easy-handle enumerated-name
                            value-type new-value)
  "Call `curl_easy_setopt' on EASY-HANDLE, using ENUMERATED-NAME
as the OPTION.  VALUE-TYPE is the CFFI foreign type of the third
argument, and NEW-VALUE is the Lisp data to be translated to the
third argument.  VALUE-TYPE is not evaluated."
  `(foreign-funcall "curl_easy_setopt" easy-handle ,easy-handle
                    curl-option ,enumerated-name
                    ,value-type ,new-value curl-code))
@end lisp

Now we define a function for each kind of argument that encodes the
correct @code{value-type} in the above.  This can be done reasonably
in the @code{define-curl-options} macroexpansion; after all, that is
where the different options are listed!

@cindex Lispy C functions
We could make @code{cl:defun} forms in the expansion that simply call
@code{curl-easy-setopt}; however, it is probably easier and clearer to
use @code{defcfun}.  @code{define-curl-options} was becoming unwieldy,
so I defined some helpers in this new definition.

@smalllisp
(defun curry-curl-option-setter (function-name option-keyword)
  "Wrap the function named by FUNCTION-NAME with a version that
curries the second argument as OPTION-KEYWORD.

This function is intended for use in DEFINE-CURL-OPTION-SETTER."
  (setf (symbol-function function-name)
          (let ((c-function (symbol-function function-name)))
            (lambda (easy-handle new-value)
              (funcall c-function easy-handle option-keyword
                       new-value)))))

(defmacro define-curl-option-setter (name option-type
                                     option-value foreign-type)
  "Define (with DEFCFUN) a function NAME that calls
curl_easy_setopt.  OPTION-TYPE and OPTION-VALUE are the CFFI
foreign type and value to be passed as the second argument to
easy_setopt, and FOREIGN-TYPE is the CFFI foreign type to be used
for the resultant function's third argument.

This macro is intended for use in DEFINE-CURL-OPTIONS."
  `(progn
     (defcfun ("curl_easy_setopt" ,name) curl-code
       (easy-handle easy-handle)
       (option ,option-type)
       (new-value ,foreign-type))
     (curry-curl-option-setter ',name ',option-value)))

(defmacro define-curl-options (type-name type-offsets &rest enum-args)
  "As with CFFI:DEFCENUM, except each of ENUM-ARGS is as follows:

    (NAME TYPE NUMBER)

Where the arguments are as they are with the CINIT macro defined
in curl.h, except NAME is a keyword.

TYPE-OFFSETS is a plist of TYPEs to their integer offsets, as
defined by the CURLOPTTYPE_LONG et al constants in curl.h.

Also, define functions for each option named
set-`TYPE-NAME'-`OPTION-NAME', where OPTION-NAME is the NAME from
the above destructuring."
  (flet ((enumerated-value (type offset)
           (+ (getf type-offsets type) offset))
         ;; @lispcmt{map PROCEDURE, destructuring each of ENUM-ARGS}
         (map-enum-args (procedure)
           (mapcar (lambda (arg) (apply procedure arg)) enum-args))
         ;; @lispcmt{build a name like SET-CURL-OPTION-NOSIGNAL}
         (make-setter-name (option-name)
           (intern (concatenate
                    'string "SET-" (symbol-name type-name)
                    "-" (symbol-name option-name)))))
    `(progn
       (defcenum ,type-name
         ,@@(map-enum-args
            (lambda (name type number)
              (list name (enumerated-value type number)))))
       ,@@(map-enum-args
          (lambda (name type number)
            (declare (ignore number))
            `(define-curl-option-setter ,(make-setter-name name)
               ,type-name ,name ,(ecase type
                                   (long :long)
                                   (objectpoint :pointer)
                                   (functionpoint :pointer)
                                   (off-t :long)))))
       ',type-name)))
@end smalllisp

@noindent
Macroexpanding our @code{define-curl-options} form once more, we
see something different:

@lisp
(progn
  (defcenum curl-option
    (:noprogress 43)
    (:nosignal 99)
    (:errorbuffer 10010)
    (:url 10002))
  (define-curl-option-setter set-curl-option-noprogress
    curl-option :noprogress :long)
  (define-curl-option-setter set-curl-option-nosignal
    curl-option :nosignal :long)
  (define-curl-option-setter set-curl-option-errorbuffer
    curl-option :errorbuffer :pointer)
  (define-curl-option-setter set-curl-option-url
    curl-option :url :pointer)
  'curl-option)
@end lisp

@noindent
Macroexpanding one of the new @code{define-curl-option-setter}
forms yields the following:

@lisp
(progn
  (defcfun ("curl_easy_setopt" set-curl-option-nosignal) curl-code
    (easy-handle easy-handle)
    (option curl-option)
    (new-value :long))
  (curry-curl-option-setter 'set-curl-option-nosignal ':nosignal))
@end lisp

@noindent
Finally, let's try this out:

@example
@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1)
@result{} 0
@end example

@noindent
Looks like it works just as well.  This interface is now reasonably
high-level to wash out some of the ugliness of the thinnest possible
@code{curl_easy_setopt} @acronym{FFI}, without obscuring the remaining
C bookkeeping details we will explore.


@node Tutorial-Memory, Tutorial-Callbacks, Tutorial-Lisp easy_setopt, Tutorial
@section Memory management

According to the documentation for @code{curl_easy_setopt}, the type
of the third argument when @var{option} is @code{CURLOPT_ERRORBUFFER}
is @code{char*}.  Above, we've defined
@code{set-curl-option-errorbuffer} to accept a @code{:pointer} as the
new option value.  However, there is a @cffi{} type @code{:string},
which translates Lisp strings to C strings when passed as arguments to
foreign function calls.  Why not, then, use @code{:string} as the
@cffi{} type of the third argument?  There are two reasons, both
related to the necessity of breaking abstraction described in
@ref{Tutorial-Abstraction,, Breaking the abstraction}.

The first reason also applies to @code{CURLOPT_URL}, which we will use
to illustrate the point.  Assuming we have changed the type of the
third argument underlying @code{set-curl-option-url} to
@code{:string}, look at these two equivalent forms.

@lisp
(set-curl-option-url *easy-handle* "http://www.cliki.net/CFFI")

@equiv{} (with-foreign-string (url "http://www.cliki.net/CFFI")
     (foreign-funcall "curl_easy_setopt" easy-handle *easy-handle*
                      curl-option :url :pointer url curl-code))
@end lisp

@noindent
The latter, in fact, is mostly equivalent to what a foreign function
call's macroexpansion actually does.  As you can see, the Lisp string
@code{"@clikicffi{}"} is copied into a @code{char} array and
null-terminated; the pointer to beginning of this array, now a C
string, is passed as a @cffi{} @code{:pointer} to the foreign
function.

@cindex dynamic extent
@cindex foreign values with dynamic extent
Unfortunately, the C abstraction has failed us, and we must break it.
While @code{:string} works well for many @code{char*} arguments, it
does not for cases like this.  As the @code{curl_easy_setopt}
documentation explains, ``The string must remain present until curl no
longer needs it, as it doesn't copy the string.''  The C string
created by @code{with-foreign-string}, however, only has dynamic
extent: it is ``deallocated'' when the body (above containing the
@code{foreign-funcall} form) exits.

@cindex premature deallocation
If we are supposed to keep the C string around, but it goes away, what
happens when some @code{libcurl} function tries to access the
@acronym{URL} string?  We have reentered the dreaded world of C
``undefined behavior''.  In some Lisps, it will probably get a chunk
of the Lisp/C stack.  You may segfault.  You may get some random piece
of other data from the heap.  Maybe, in a world where ``dynamic
extent'' is defined to be ``infinite extent'', everything will turn
out fine.  Regardless, results are likely to be almost universally
unpleasant.@footnote{``@i{But I thought Lisp was supposed to protect
me from all that buggy C crap!}''  Before asking a question like that,
remember that you are a stranger in a foreign land, whose residents
have a completely different set of values.}

Returning to the current @code{set-curl-option-url} interface, here is
what we must do:

@lisp
(let (easy-handle)
  (unwind-protect
    (with-foreign-string (url "http://www.cliki.net/CFFI")
      (setf easy-handle (curl-easy-init))
      (set-curl-option-url easy-handle url)
      #|@lispcmt{do more with the easy-handle, like actually get the URL}|#)
    (when easy-handle
      (curl-easy-cleanup easy-handle))))
@end lisp

@c old comment to luis: I go on to say that this isn't obviously
@c extensible to new option settings that require C strings to stick
@c around, as it would involve re-evaluating the unwind-protect form
@c with more dynamic memory allocation.  So I plan to show how to
@c write something similar to ObjC's NSAutoreleasePool, to be managed
@c with a simple unwind-protect form.

@noindent
That is fine for the single string defined here, but for every string
option we want to pass, we have to surround the body of
@code{with-foreign-string} with another @code{with-foreign-string}
wrapper, or else do some extremely error-prone pointer manipulation
and size calculation in advance.  We could alleviate some of the pain
with a recursively expanding macro, but this would not remove the need
to modify the block every time we want to add an option, anathema as
it is to a modular interface.

Before modifying the code to account for this case, consider the other
reason we can't simply use @code{:string} as the foreign type.  In C,
a @code{char *} is a @code{char *}, not necessarily a string.  The
option @code{CURLOPT_ERRORBUFFER} accepts a @code{char *}, but does
not expect anything about the data there.  However, it does expect
that some @code{libcurl} function we call later can write a C string
of up to 255 characters there.  We, the callers of the function, are
expected to read the C string at a later time, exactly the opposite of
what @code{:string} implies.

With the semantics for an input string in mind --- namely, that the
string should be kept around until we @code{curl_easy_cleanup} the
easy handle --- we are ready to extend the Lisp interface:

@lisp
(defvar *easy-handle-cstrings* (make-hash-table)
  "Hashtable of easy handles to lists of C strings that may be
safely freed after the handle is freed.")

(defun make-easy-handle ()
  "Answer a new CURL easy interface handle, to which the lifetime
of C strings may be tied.  See `add-curl-handle-cstring'."
  (let ((easy-handle (curl-easy-init)))
    (setf (gethash easy-handle *easy-handle-cstrings*) '())
    easy-handle))

(defun free-easy-handle (handle)
  "Free CURL easy interface HANDLE and any C strings created to
be its options."
  (curl-easy-cleanup handle)
  (mapc #'foreign-string-free
        (gethash handle *easy-handle-cstrings*))
  (remhash handle *easy-handle-cstrings*))

(defun add-curl-handle-cstring (handle cstring)
  "Add CSTRING to be freed when HANDLE is, answering CSTRING."
  (car (push cstring (gethash handle *easy-handle-cstrings*))))
@end lisp

@noindent
Here we have redefined the interface to create and free handles, to
associate a list of allocated C strings with each handle while it
exists.  The strategy of using different function names to wrap around
simple foreign functions is more common than the solution implemented
earlier with @code{curry-curl-option-setter}, which was to modify the
function name's function slot.@footnote{There are advantages and
disadvantages to each approach; I chose to @code{(setf
symbol-function)} earlier because it entailed generating fewer magic
function names.}

Incidentally, the next step is to redefine
@code{curry-curl-option-setter} to allocate C strings for the
appropriate length of time, given a Lisp string as the
@code{new-value} argument:

@lisp
(defun curry-curl-option-setter (function-name option-keyword)
  "Wrap the function named by FUNCTION-NAME with a version that
curries the second argument as OPTION-KEYWORD.

This function is intended for use in DEFINE-CURL-OPTION-SETTER."
  (setf (symbol-function function-name)
          (let ((c-function (symbol-function function-name)))
            (lambda (easy-handle new-value)
              (funcall c-function easy-handle option-keyword
                       (if (stringp new-value)
                         (add-curl-handle-cstring
                          easy-handle
                          (foreign-string-alloc new-value))
                         new-value))))))
@end lisp

@noindent
A quick analysis of the code shows that you need only reevaluate the
@code{curl-option} enumeration definition to take advantage of these
new semantics.  Now, for good measure, let's reallocate the handle
with the new functions we just defined, and set its @acronym{URL}:

@example
@sc{cffi-user>} (curl-easy-cleanup *easy-handle*)
@result{} NIL
@sc{cffi-user>} (setf *easy-handle* (make-easy-handle))
@result{} #
@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1)
@result{} 0
@sc{cffi-user>} (set-curl-option-url *easy-handle*
                                "http://www.cliki.net/CFFI")
@result{} 0
@end example

@cindex strings
For fun, let's inspect the Lisp value of the C string that was created
to hold @code{"@clikicffi{}"}.  By virtue of the implementation of
@code{add-curl-handle-cstring}, it should be accessible through the
hash table defined:

@example
@sc{cffi-user>} (foreign-string-to-lisp
            (car (gethash *easy-handle* *easy-handle-cstrings*)))
@result{} "http://www.cliki.net/CFFI"
@end example

@noindent
Looks like that worked, and @code{libcurl} now knows what
@acronym{URL} we want to retrieve.

Finally, we turn back to the @code{:errorbuffer} option mentioned at
the beginning of this section.  Whereas the abstraction added to
support string inputs works fine for cases like @code{CURLOPT_URL}, it
hides the detail of keeping the C string; for @code{:errorbuffer},
however, we need that C string.

In a moment, we'll define something slightly cleaner, but for now,
remember that you can always hack around anything.  We're modifying
handle creation, so make sure you free the old handle before
redefining @code{free-easy-handle}.

@smalllisp
(defvar *easy-handle-errorbuffers* (make-hash-table)
  "Hashtable of easy handles to C strings serving as error
writeback buffers.")

;;; @lispcmt{An extra byte is very little to pay for peace of mind.}
(defparameter *curl-error-size* 257
  "Minimum char[] size used by cURL to report errors.")

(defun make-easy-handle ()
  "Answer a new CURL easy interface handle, to which the lifetime
of C strings may be tied.  See `add-curl-handle-cstring'."
  (let ((easy-handle (curl-easy-init)))
    (setf (gethash easy-handle *easy-handle-cstrings*) '())
    (setf (gethash easy-handle *easy-handle-errorbuffers*)
            (foreign-alloc :char :count *curl-error-size*
                           :initial-element 0))
    easy-handle))

(defun free-easy-handle (handle)
  "Free CURL easy interface HANDLE and any C strings created to
be its options."
  (curl-easy-cleanup handle)
  (foreign-free (gethash handle *easy-handle-errorbuffers*))
  (remhash handle *easy-handle-errorbuffers*)
  (mapc #'foreign-string-free
        (gethash handle *easy-handle-cstrings*))
  (remhash handle *easy-handle-cstrings*))

(defun get-easy-handle-error (handle)
  "Answer a string containing HANDLE's current error message."
  (foreign-string-to-lisp
   (gethash handle *easy-handle-errorbuffers*)))
@end smalllisp

Be sure to once again set the options we've set thus far.  You may
wish to define yet another wrapper function to do this.


@node Tutorial-Callbacks, Tutorial-Completion, Tutorial-Memory, Tutorial
@section Calling Lisp from C

If you have been reading
@uref{http://curl.haxx.se/libcurl/c/curl_easy_setopt.html,,
@code{curl_easy_setopt(3)}}, you should have noticed that some options
accept a function pointer.  In particular, we need one function
pointer to set as @code{CURLOPT_WRITEFUNCTION}, to be called by
@code{libcurl} rather than the reverse, in order to receive data as it
is downloaded.

A binding writer without the aid of @acronym{FFI} usually approaches
this problem by writing a C function that accepts C data, converts to
the language's internal objects, and calls the callback provided by
the user, again in a reverse of usual practices.

The @cffi{} approach to callbacks precisely mirrors its differences
with the non-@acronym{FFI} approach on the ``calling C from Lisp''
side, which we have dealt with exclusively up to now.  That is, you
define a callback function in Lisp using @code{defcallback}, and
@cffi{} effectively creates a C function to be passed as a function
pointer.

@impnote{This is much trickier than calling C functions from Lisp, as
it literally involves somehow generating a new C function that is as
good as any created by the compiler.  Therefore, not all Lisps support
them.  @xref{Implementation Support}, for information about @cffi{}
support issues in this and other areas.  You may want to consider
changing to a Lisp that supports callbacks in order to continue with
this tutorial.}

@cindex callback definition
@cindex defining callbacks
Defining a callback is very similar to defining a callout; the main
difference is that we must provide some Lisp forms to be evaluated as
part of the callback.  Here is the signature for the function the
@code{:writefunction} option takes:

@example
size_t
@var{function}(void *ptr, size_t size, size_t nmemb, void *stream);
@end example

@impnote{size_t is almost always an unsigned int.  You can get this
and many other types using feature tests for your system by using
cffi-grovel.}

The above signature trivially translates into a @cffi{}
@code{defcallback} form, as follows.

@lisp
;;; @lispcmt{Alias in case size_t changes.}
(defctype size :unsigned-int)

;;; @lispcmt{To be set as the CURLOPT_WRITEFUNCTION of every easy handle.}
(defcallback easy-write size ((ptr :pointer) (size size)
                              (nmemb size) (stream :pointer))
  (let ((data-size (* size nmemb)))
    (handler-case
      ;; @lispcmt{We use the dynamically-bound *easy-write-procedure* to}
      ;; @lispcmt{call a closure with useful lexical context.}
      (progn (funcall (symbol-value '*easy-write-procedure*)
                      (foreign-string-to-lisp ptr :count data-size))
             data-size)         ;@lispcmt{indicates success}
      ;; @lispcmt{The WRITEFUNCTION should return something other than the}
      ;; @lispcmt{#bytes available to signal an error.}
      (error () (if (zerop data-size) 1 0)))))
@end lisp

First, note the correlation of the first few forms, used to declare
the C function's signature, with the signature in C syntax.  We
provide a Lisp name for the function, its return type, and a name and
type for each argument.

In the body, we call the dynamically-bound
@code{*easy-write-procedure*} with a ``finished'' translation, of
pulling together the raw data and size into a Lisp string, rather than
deal with the data directly.  As part of calling
@code{curl_easy_perform} later, we'll bind that variable to a closure
with more useful lexical bindings than the top-level
@code{defcallback} form.

Finally, we make a halfhearted effort to prevent non-local exits from
unwinding the C stack, covering the most likely case with an
@code{error} handler, which is usually triggered
unexpectedly.@footnote{Unfortunately, we can't protect against
@emph{all} non-local exits, such as @code{return}s and @code{throw}s,
because @code{unwind-protect} cannot be used to ``short-circuit'' a
non-local exit in Common Lisp, due to proposal @code{minimal} in
@uref{http://www.lisp.org/HyperSpec/Issues/iss152-writeup.html,
@acronym{ANSI} issue @sc{Exit-Extent}}.  Furthermore, binding an
@code{error} handler prevents higher-up code from invoking restarts
that may be provided under the callback's dynamic context.  Such is
the way of compromise.}  The reason is that most C code is written to
understand its own idiosyncratic error condition, implemented above in
the case of @code{curl_easy_perform}, and more ``undefined behavior''
can result if we just wipe C stack frames without allowing them to
execute whatever cleanup actions as they like.

Using the @code{CURLoption} enumeration in @file{curl.h} once more, we
can describe the new option by modifying and reevaluating
@code{define-curl-options}.

@lisp
(define-curl-options curl-option
    (long 0 objectpoint 10000 functionpoint 20000 off-t 30000)
  (:noprogress long 43)
  (:nosignal long 99)
  (:errorbuffer objectpoint 10)
  (:url objectpoint 2)
  (:writefunction functionpoint 11)) ;@lispcmt{new item here}
@end lisp

Finally, we can use the defined callback and the new
@code{set-curl-option-writefunction} to finish configuring the easy
handle, using the @code{callback} macro to retrieve a @cffi{}
@code{:pointer}, which works like a function pointer in C code.

@example
@sc{cffi-user>} (set-curl-option-writefunction
            *easy-handle* (callback easy-write))
@result{} 0
@end example


@node Tutorial-Completion, Tutorial-Types, Tutorial-Callbacks, Tutorial
@section A complete @acronym{FFI}?

@c TeX goes insane on @uref{@clikicffi{}}

With all options finally set and a medium-level interface developed,
we can finish the definition and retrieve
@uref{http://www.cliki.net/CFFI}, as is done in the tutorial.

@lisp
(defcfun "curl_easy_perform" curl-code
  (handle easy-handle))
@end lisp

@example
@sc{cffi-user>} (with-output-to-string (contents)
             (let ((*easy-write-procedure*
                     (lambda (string)
                       (write-string string contents))))
               (declare (special *easy-write-procedure*))
               (curl-easy-perform *easy-handle*)))
@result{} "
"
@end example

Of course, that itself is slightly unwieldy, so you may want to define
a function around it that simply retrieves a @acronym{URL}.  I will
leave synthesis of all the relevant @acronym{REPL} forms presented
thus far into a single function as an exercise for the reader.

The remaining sections of this tutorial explore some advanced features
of @cffi{}; the definition of new types will receive special
attention.  Some of these features are essential for particular
foreign function calls; some are very helpful when trying to develop a
Lispy interface to C.


@node Tutorial-Types, Tutorial-Conclusion, Tutorial-Completion, Tutorial
@section Defining new types

We've occasionally used the @code{defctype} macro in previous sections
as a kind of documentation, much what you'd use @code{typedef} for in
C.  We also tried one special kind of type definition, the
@code{defcenum} type.  @xref{defcstruct}, for a definition macro that
may come in handy if you need to use C @code{struct}s as data.

@cindex type definition
@cindex data in Lisp and C
@cindex translating types
However, all of these are mostly sugar for the powerful underlying
foreign type interface called @dfn{type translators}.  You can easily
define new translators for any simple named foreign type.  Since we've
defined the new type @code{curl-code} to use as the return type for
various @code{libcurl} functions, we can use that to directly convert
c@acronym{URL} errors to Lisp errors.

@code{defctype}'s purpose is to define simple @code{typedef}-like
aliases.  In order to use @dfn{type translators} we must use the
@code{define-foreign-type} macro.  So let's redefine @code{curl-code}
using it.

@lisp
(define-foreign-type curl-code-type ()
  ()
  (:actual-type :int)
  (:simple-parser curl-code))
@end lisp

@code{define-foreign-type} is a thin wrapper around @code{defclass}.
For now, all you need to know in the context of this example is that
it does what @code{(defctype curl-code :int)} would do and,
additionally, defines a new class @code{curl-code-type} which we will
take advantage of shortly.

The @code{CURLcode} enumeration seems to follow the typical error code
convention of @samp{0} meaning all is well, and each non-zero integer
indicating a different kind of error.  We can apply that trivially to
differentiate between normal exits and error exits.

@lisp
(define-condition curl-code-error (error)
  (($code :initarg :curl-code :reader curl-error-code))
  (:report (lambda (c stream)
             (format stream "libcurl function returned error ~A"
                            (curl-error-code c))))
  (:documentation "Signalled when a libcurl function answers
a code other than CURLE_OK."))

(defmethod translate-from-foreign (value (type curl-code-type))
  "Raise a CURL-CODE-ERROR if VALUE, a curl-code, is non-zero."
  (if (zerop value)
      :curle-ok
      (error 'curl-code-error :curl-code value)))
@end lisp

@noindent
The heart of this translator is new method
@code{translate-from-foreign}.  By specializing the @var{type}
parameter on @code{curl-code-type}, we immediately modify the behavior
of every function that returns a @code{curl-code} to pass the result
through this new method.

To see the translator in action, try invoking a function that returns
a @code{curl-code}.  You need to reevaluate the respective
@code{defcfun} form so that it picks up the new @code{curl-code}
definition.

@example
@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1)
@result{} :CURLE-OK
@end example

@noindent
As the result was @samp{0}, the new method returned @code{:curle-ok},
just as specified.@footnote{It might be better to return
@code{(values)} than @code{:curle-ok} in real code, but this is good
for illustration.}  I will leave disjoining the separate
@code{CURLcode}s into condition types and improving the @code{:report}
function as an exercise for you.

The creation of @code{*easy-handle-cstrings*} and
@code{*easy-handle-errorbuffers*} as properties of @code{easy-handle}s
is a kluge.  What we really want is a Lisp structure that stores these
properties along with the C pointer.  Unfortunately,
@code{easy-handle} is currently just a fancy name for the foreign type
@code{:pointer}; the actual pointer object varies from Common Lisp
implementation to implementation, needing only to satisfy
@code{pointerp} and be returned from @code{make-pointer} and friends.

One solution that would allow us to define a new Lisp structure to
represent @code{easy-handle}s would be to write a wrapper around every
function that currently takes an @code{easy-handle}; the wrapper would
extract the pointer and pass it to the foreign function.  However, we
can use type translators to more elegantly integrate this
``translation'' into the foreign function calling framework, using
@code{translate-to-foreign}.

@smalllisp
(defclass easy-handle ()
  ((pointer :initform (curl-easy-init)
            :documentation "Foreign pointer from curl_easy_init")
   (error-buffer
    :initform (foreign-alloc :char :count *curl-error-size*
                             :initial-element 0)
    :documentation "C string describing last error")
   (c-strings :initform '()
              :documentation "C strings set as options"))
  (:documentation "I am a parameterization you may pass to
curl-easy-perform to perform a cURL network protocol request."))

(defmethod initialize-instance :after ((self easy-handle) &key)
  (set-curl-option-errorbuffer self (slot-value self 'error-buffer)))

(defun add-curl-handle-cstring (handle cstring)
  "Add CSTRING to be freed when HANDLE is, answering CSTRING."
  (car (push cstring (slot-value handle 'c-strings))))

(defun get-easy-handle-error (handle)
  "Answer a string containing HANDLE's current error message."
  (foreign-string-to-lisp
   (slot-value handle 'error-buffer)))

(defun free-easy-handle (handle)
  "Free CURL easy interface HANDLE and any C strings created to
be its options."
  (with-slots (pointer error-buffer c-strings) handle
    (curl-easy-cleanup pointer)
    (foreign-free error-buffer)
    (mapc #'foreign-string-free c-strings)))

(define-foreign-type easy-handle-type ()
  ()
  (:actual-type :pointer)
  (:simple-parser easy-handle))

(defmethod translate-to-foreign (handle (type easy-handle-type))
  "Extract the pointer from an easy-HANDLE."
  (slot-value handle 'pointer))
@end smalllisp

While we changed some of the Lisp functions defined earlier to use
@acronym{CLOS} slots rather than hash tables, the foreign functions
work just as well as they did before.

@cindex limitations of type translators
The greatest strength, and the greatest limitation, of the type
translator comes from its generalized interface.  As stated
previously, we could define all foreign function calls in terms of the
primitive foreign types provided by @cffi{}.  The type translator
interface allows us to cleanly specify the relationship between Lisp
and C data, independent of where it appears in a function call.  This
independence comes at a price; for example, it cannot be used to
modify translation semantics based on other arguments to a function
call.  In these cases, you should rely on other features of Lisp,
rather than the powerful, yet domain-specific, type translator
interface.


@node Tutorial-Conclusion,  , Tutorial-Types, Tutorial
@section What's next?

@cffi{} provides a rich and powerful foundation for communicating with
foreign libraries; as we have seen, it is up to you to make that
experience a pleasantly Lispy one.  This tutorial does not cover all
the features of @cffi{}; please see the rest of the manual for
details.  In particular, if something seems obviously missing, it is
likely that either code or a good reason for lack of code is already
present.

@impnote{There are some other things in @cffi{} that might deserve
tutorial sections, such as free-translated-object, or structs.  Let us
know which ones you care about.}


@c ===================================================================
@c CHAPTER: Wrapper generators

@node Wrapper generators, Foreign Types, Tutorial, Top
@chapter Wrapper generators

@cffi{}'s interface is designed for human programmers, being aimed at
aesthetic as well as technical sophistication.  However, there are a
few programs aimed at translating C and C++ header files, or
approximations thereof, into @cffi{} forms constituting a foreign
interface to the symbols in those files.

These wrapper generators are known to support output of @cffi{} forms.

@table @asis
@item @uref{http://www.cliki.net/Verrazano,Verrazano}
Designed specifically for Common Lisp.  Uses @acronym{GCC}'s parser
output in @acronym{XML} format to discover functions, variables, and
other header file data.  This means you need @acronym{GCC} to generate
forms; on the other hand, the parser employed is mostly compliant with
@acronym{ANSI} C.

@item @uref{http://www.cliki.net/SWIG,SWIG}
A foreign interface generator originally designed to generate Python
bindings, it has been ported to many other systems, including @cffi{}
in version 1.3.28.  Includes its own C declaration munger, not
intended to be fully-compliant with @acronym{ANSI} C.
@end table

First, this manual does not describe use of these other programs; they
have documentation of their own.  If you have problems using a
generated interface, please look at the output @cffi{} forms and
verify that they are a correct @cffi{} interface to the library in
question; if they are correct, contact @cffi{} developers with
details, keeping in mind that they communicate in terms of those forms
rather than any particular wrapper generator.  Otherwise, contact the
maintainers of the wrapper generator you are using, provided you can
reasonably expect more accuracy from the generator.

When is more accuracy an unreasonable expectation?  As described in
the tutorial (@pxref{Tutorial-Abstraction,, Breaking the
abstraction}), the information in C declarations is insufficient to
completely describe every interface.  In fact, it is quite common to
run into an interface that cannot be handled automatically, and
generators should be excused from generating a complete interface in
these cases.

As further described in the tutorial, the thinnest Lisp interface to a
C function is not always the most pleasant one.  In many cases, you
will want to manually write a Lispier interface to the C functions
that interest you.

Wrapper generators should be treated as time-savers, not complete
automation of the full foreign interface writing job.  Reports of the
amount of work done by generators vary from 30% to 90%.  The
incremental development style enabled by @cffi{} generally reduces
this proportion below that for languages like Python.

@c Where I got the above 30-90% figures:
@c 30%: lemonodor's post about SWIG
@c 90%: Balooga on #lisp.  He said 99%, but that's probably an
@c      exaggeration (leave it to me to pass judgement :)
@c -stephen


@c ===================================================================
@c CHAPTER: Foreign Types

@node Foreign Types, Pointers, Wrapper generators, Top
@chapter Foreign Types

Foreign types describe how data is translated back and forth between C
and Lisp. @cffi{} provides various built-in types and allows the user to
define new types.

@menu
* Built-In Types::
* Other Types::
* Defining Foreign Types::
* Foreign Type Translators::
* Optimizing Type Translators::
* Foreign Structure Types::
* Allocating Foreign Objects::

Dictionary

* convert-from-foreign::
* convert-to-foreign::
* defbitfield::
* defcstruct::
* defcunion::
* defctype::
* defcenum::
@c * define-type-spec-parser::
* define-foreign-type::
* define-parse-method::
@c * explain-foreign-slot-value:
* foreign-bitfield-symbols::
* foreign-bitfield-value::
* foreign-enum-keyword::
* foreign-enum-value::
* foreign-slot-names::
* foreign-slot-offset::
* foreign-slot-pointer::
* foreign-slot-value::
* foreign-type-alignment::
* foreign-type-size::
* free-converted-object::
* free-translated-object::
* translate-from-foreign::
* translate-to-foreign::
* translate-into-foreign-memory::
* with-foreign-slots::
@end menu

@node Built-In Types, Other Types, Foreign Types, Foreign Types
@section Built-In Types

@ForeignType{:char}
@ForeignType{:unsigned-char}
@ForeignType{:short}
@ForeignType{:unsigned-short}
@ForeignType{:int}
@ForeignType{:unsigned-int}
@ForeignType{:long}
@ForeignType{:unsigned-long}
@ForeignType{:long-long}
@ForeignType{:unsigned-long-long}

These types correspond to the native C integer types according to the
@acronym{ABI} of the Lisp implementation's host system.

@code{:long-long} and @code{:unsigned-long-long} are not supported
natively on all implementations. However, they are emulated by
@code{mem-ref} and @code{mem-set}.

When those types are @strong{not} available, the symbol
@code{cffi-sys::no-long-long} is pushed into @code{*features*}.

@ForeignType{:uchar}
@ForeignType{:ushort}
@ForeignType{:uint}
@ForeignType{:ulong}
@ForeignType{:llong}
@ForeignType{:ullong}

For convenience, the above types are provided as shortcuts for
@code{unsigned-char}, @code{unsigned-short}, @code{unsigned-int},
@code{unsigned-long}, @code{long-long} and @code{unsigned-long-long},
respectively.

@ForeignType{:int8}
@ForeignType{:uint8}
@ForeignType{:int16}
@ForeignType{:uint16}
@ForeignType{:int32}
@ForeignType{:uint32}
@ForeignType{:int64}
@ForeignType{:uint64}

Foreign integer types of specific sizes, corresponding to the C types
defined in @code{stdint.h}.

@c @ForeignType{:size}
@c @ForeignType{:ssize}
@c @ForeignType{:ptrdiff}
@c @ForeignType{:time}

@c Foreign integer types corresponding to the standard C types (without
@c the @code{_t} suffix).

@c @impnote{These are not implemented yet. --luis}

@c @impnote{I'm sure there are more of these that could be useful, let's
@c add any types that can't be defined portably to this list as
@c necessary. --james}

@ForeignType{:float}
@ForeignType{:double}

On all systems, the @code{:float} and @code{:double} types represent a
C @code{float} and @code{double}, respectively. On most but not all
systems, @code{:float} and @code{:double} represent a Lisp
@code{single-float} and @code{double-float}, respectively. It is not
so useful to consider the relationship between Lisp types and C types
as isomorphic, as simply to recognize the relationship, and relative
precision, among each respective category.

@ForeignType{:long-double}

This type is only supported on SCL.

@ForeignType{:pointer &optional type}

A foreign pointer to an object of any type, corresponding to
@code{void *}.  You can optionally specify type of pointer
(e.g. @code{(:pointer :char)}).  Although @cffi{} won't do anything
with that information yet, it is useful for documentation purposes.

@ForeignType{:void}

No type at all. Only valid as the return type of a function.

@node Other Types, Defining Foreign Types, Built-In Types, Foreign Types
@section Other Types

@cffi{} also provides a few useful types that aren't built-in C
types.

@ForeignType{:string}

The @code{:string} type performs automatic conversion between Lisp and
C strings. Note that, in the case of functions the converted C string
will have dynamic extent (i.e.@: it will be automatically freed after
the foreign function returns).

In addition to Lisp strings, this type will accept foreign pointers
and pass them unmodified.

A method for @ref{free-translated-object} is specialized for this
type. So, for example, foreign strings allocated by this type and
passed to a foreign function will be freed after the function
returns.

@lisp
CFFI> (foreign-funcall "getenv" :string "SHELL" :string)
@result{} "/bin/bash"

CFFI> (with-foreign-string (str "abcdef")
        (foreign-funcall "strlen" :string str :int))
@result{} 6
@end lisp

@ForeignType{:string+ptr}

Like @code{:string} but returns a list with two values when convert
from C to Lisp: a Lisp string and the C string's foreign pointer.

@lisp
CFFI> (foreign-funcall "getenv" :string "SHELL" :string+ptr)
@result{} ("/bin/bash" #.(SB-SYS:INT-SAP #XBFFFFC6F))
@end lisp

@ForeignType{:boolean &optional (base-type :int)}

The @code{:boolean} type converts between a Lisp boolean and a C
boolean. It canonicalizes to @var{base-type} which is @code{:int} by
default.

@lisp
(convert-to-foreign nil :boolean) @result{} 0
(convert-to-foreign t :boolean) @result{} 1
(convert-from-foreign 0 :boolean) @result{} nil
(convert-from-foreign 1 :boolean) @result{} t
@end lisp

@ForeignType{:bool}

The @code{:bool} type represents the C99 @code{_Bool} or C++
@code{bool}. Its size is usually 1 byte except on OSX where it's an
@code{int}.

@ForeignType{:wrapper base-type &key to-c from-c}

The @code{:wrapper} type stores two symbols passed to the @var{to-c}
and @var{from-c} arguments. When a value is being translated to or
from C, this type @code{funcall}s the respective symbol.

@code{:wrapper} types will be typedefs for @var{base-type} and will
inherit its translators, if any.

Here's an example of how the @code{:boolean} type could be defined in
terms of @code{:wrapper}.

@lisp
(defun bool-c-to-lisp (value)
  (not (zerop value)))

(defun bool-lisp-to-c (value)
  (if value 1 0))

(defctype my-bool (:wrapper :int :from-c bool-c-to-lisp
                                 :to-c bool-lisp-to-c))

(convert-to-foreign nil 'my-bool) @result{} 0
(convert-from-foreign 1 'my-bool) @result{} t
@end lisp

@node Defining Foreign Types, Foreign Type Translators, Other Types, Foreign Types
@section Defining Foreign Types

You can define simple C-like @code{typedef}s through the
@code{defctype} macro. Defining a typedef is as simple as giving
@code{defctype} a new name and the name of the type to be wrapped.

@lisp
;;; @lispcmt{Define MY-INT as an alias for the built-in type :INT.}
(defctype my-int :int)
@end lisp

With this type definition, one can, for instance, declare arguments to
foreign functions as having the type @code{my-int}, and they will be
passed as integers.

@subheading More complex types

@cffi{} offers another way to define types through
@code{define-foreign-type}, a thin wrapper macro around
@code{defclass}. As an example, let's go through the steps needed to
define a @code{(my-string &key encoding)} type. First, we need to
define our type class:

@lisp
(define-foreign-type my-string-type ()
  ((encoding :reader string-type-encoding :initarg :encoding))
  (:actual-type :pointer))
@end lisp

The @code{:actual-type} class option tells CFFI that this type will
ultimately be passed to and received from foreign code as a
@code{:pointer}. Now you need to tell CFFI how to parse a type
specification such as @code{(my-string :encoding :utf8)} into an
instance of @code{my-string-type}.  We do that with
@code{define-parse-method}:

@lisp
(define-parse-method my-string (&key (encoding :utf-8))
  (make-instance 'my-string-type :encoding encoding))
@end lisp

The next section describes how make this type actually translate
between C and Lisp strings.

@node Foreign Type Translators, Optimizing Type Translators, Defining Foreign Types, Foreign Types
@section Foreign Type Translators

Type translators are used to automatically convert Lisp values to or
from foreign values.  For example, using type translators, one can
take the @code{my-string} type defined in the previous section and
specify that it should:

@itemize
@item
convert C strings to Lisp strings;
@item
convert Lisp strings to newly allocated C strings;
@item
free said C strings when they are no longer needed.
@end itemize

In order to tell @cffi{} how to automatically convert Lisp values to
foreign values, define a specialized method for the
@code{translate-to-foreign} generic function:

@lisp
;;; @lispcmt{Define a method that converts Lisp strings to C strings.}
(defmethod translate-to-foreign (string (type my-string-type))
  (foreign-string-alloc string :encoding (string-type-encoding type)))
@end lisp

@noindent
From now on, whenever an object is passed as a @code{my-string} to a
foreign function, this method will be invoked to convert the Lisp
value. To perform the inverse operation, which is needed for functions
that return a @code{my-string}, specialize the
@code{translate-from-foreign} generic function in the same manner:

@lisp
;;; @lispcmt{Define a method that converts C strings to Lisp strings.}
(defmethod translate-from-foreign (pointer (type my-string-type))
  (foreign-string-to-lisp pointer :encoding (string-type-encoding type)))
@end lisp

@noindent
When a @code{translate-to-foreign} method requires allocation of
foreign memory, you must also define a @code{free-translated-object}
method to free the memory once the foreign object is no longer needed,
otherwise you'll be faced with memory leaks.  This generic function is
called automatically by @cffi{} when passing objects to foreign
functions. Let's do that:

@lisp
;;; @lispcmt{Free strings allocated by translate-to-foreign.}
(defmethod free-translated-object (pointer (type my-string-type) param)
  (declare (ignore param))
  (foreign-string-free pointer))
@end lisp

@noindent
In this specific example, we don't need the @var{param} argument, so
we ignore it. See @ref{free-translated-object}, for an explanation of
its purpose and how you can use it.

A type translator does not necessarily need to convert the value.  For
example, one could define a typedef for @code{:pointer} that ensures,
in the @code{translate-to-foreign} method, that the value is not a
null pointer, signalling an error if a null pointer is passed.  This
would prevent some pointer errors when calling foreign functions that
cannot handle null pointers.

@strong{Please note:} these methods are meant as extensible hooks
only, and you should not call them directly.  Use
@code{convert-to-foreign}, @code{convert-from-foreign} and
@code{free-converted-object} instead.

@xref{Tutorial-Types,, Defining new types}, for another example of
type translators.

@node Optimizing Type Translators, Foreign Structure Types, Foreign Type Translators, Foreign Types
@section Optimizing Type Translators

@cindex type translators, optimizing
@cindex compiler macros for type translation
@cindex defining type-translation compiler macros
Being based on generic functions, the type translation mechanism
described above can add a bit of overhead.  This is usually not
significant, but we nevertheless provide a way of getting rid of the
overhead for the cases where it matters.

A good way to understand this issue is to look at the code generated
by @code{defcfun}. Consider the following example using the previously
defined @code{my-string} type:

@lisp
CFFI> (macroexpand-1 '(defcfun foo my-string (x my-string)))
;; @lispcmt{(simplified, downcased, etc...)}
(defun foo (x)
  (multiple-value-bind (#:G2019 #:PARAM3149)
      (translate-to-foreign x #)
    (unwind-protect
        (translate-from-foreign
         (foreign-funcall "foo" :pointer #:G2019 :pointer)
         #)
      (free-translated-object #:G2019 #
                              #:PARAM3149))))
@end lisp

@noindent
In order to get rid of those generic function calls, @cffi{} has
another set of extensible generic functions that provide functionality
similar to @acronym{CL}'s compiler macros:
@code{expand-to-foreign-dyn}, @code{expand-to-foreign} and
@code{expand-from-foreign}. Here's how one could define a
@code{my-boolean} with them:

@lisp
(define-foreign-type my-boolean-type ()
  ()
  (:actual-type :int)
  (:simple-parser my-boolean))

(defmethod expand-to-foreign (value (type my-boolean-type))
  `(if ,value 1 0))

(defmethod expand-from-foreign (value (type my-boolean-type))
  `(not (zerop ,value)))
@end lisp

@noindent
And here's what the macroexpansion of a function using this type would
look like:

@lisp
CFFI> (macroexpand-1 '(defcfun bar my-boolean (x my-boolean)))
;; @lispcmt{(simplified, downcased, etc...)}
(defun bar (x)
  (let ((#:g3182 (if x 1 0)))
    (not (zerop (foreign-funcall "bar" :int #:g3182 :int)))))
@end lisp

@noindent
No generic function overhead.

Let's go back to our @code{my-string} type.  The expansion interface
has no equivalent of @code{free-translated-object}; you must instead
define a method on @code{expand-to-foreign-dyn}, the third generic
function in this interface.  This is especially useful when you can
allocate something much more efficiently if you know the object has
dynamic extent, as is the case with function calls that don't save the
relevant allocated arguments.

This exactly what we need for the @code{my-string} type:

@lisp
(defmethod expand-from-foreign (form (type my-string-type))
  `(foreign-string-to-lisp ,form))

(defmethod expand-to-foreign-dyn (value var body (type my-string-type))
  (let ((encoding (string-type-encoding type)))
    `(with-foreign-string (,var ,value :encoding ',encoding)
       ,@@body)))
@end lisp

@noindent
So let's look at the macro expansion:

@lisp
CFFI> (macroexpand-1 '(defcfun foo my-string (x my-string)))
;; @lispcmt{(simplified, downcased, etc...)}
(defun foo (x)
  (with-foreign-string (#:G2021 X :encoding ':utf-8)
    (foreign-string-to-lisp
     (foreign-funcall "foo" :pointer #:g2021 :pointer))))
@end lisp

@noindent
Again, no generic function overhead.

@subheading Other details

To short-circuit expansion and use the @code{translate-*} functions
instead, simply call the next method.  Return its result in cases
where your method cannot generate an appropriate replacement for it.
This analogous to the @code{&whole form} mechanism compiler macros
provide.

The @code{expand-*} methods have precedence over their
@code{translate-*} counterparts and are guaranteed to be used in
@code{defcfun}, @code{foreign-funcall}, @code{defcvar} and
@code{defcallback}.  If you define a method on each of the
@code{expand-*} generic functions, you are guaranteed to have full
control over the expressions generated for type translation in these
macros.

They may or may not be used in other @cffi{} operators that need to
translate between Lisp and C data; you may only assume that
@code{expand-*} methods will probably only be called during Lisp
compilation.

@code{expand-to-foreign-dyn} has precedence over
@code{expand-to-foreign} and is only used in @code{defcfun} and
@code{foreign-funcall}, only making sense in those contexts.

@strong{Important note:} this set of generic functions is called at
macroexpansion time.  Methods are defined when loaded or evaluated,
not compiled.  You are responsible for ensuring that your
@code{expand-*} methods are defined when the @code{foreign-funcall} or
other forms that use them are compiled.  One way to do this is to put
the method definitions earlier in the file and inside an appropriate
@code{eval-when} form; another way is to always load a separate Lisp
or @acronym{FASL} file containing your @code{expand-*} definitions
before compiling files with forms that ought to use them.  Otherwise,
they will not be found and the runtime translators will be used
instead.

@node Foreign Structure Types, Allocating Foreign Objects, Optimizing Type Translators, Foreign Types
@section Foreign Structure Types

For more involved C types than simple aliases to built-in types, such
as you can make with @code{defctype}, @cffi{} allows declaration of
structures and unions with @code{defcstruct} and @code{defcunion}.

For example, consider this fictional C structure declaration holding
some personal information:

@example
struct person @{
  int number;
  char* reason;
@};
@end example

@noindent
The equivalent @code{defcstruct} form follows:

@lisp
(defcstruct person
  (number :int)
  (reason :string))
@end lisp

@c LMH structure translation
By default, @ref{convert-from-foreign} (and also @ref{mem-ref}) will
make a plist with slot names as keys, and @ref{convert-to-foreign} will
translate such a plist to a foreign structure.  A user wishing to define
other translations should use the @code{:class} argument to
@ref{defcstruct}, and then define methods for
@ref{translate-from-foreign} and
@ref{translate-into-foreign-memory} that specialize on this class,
possibly calling @code{call-next-method} to translate from and to the
plists rather than provide a direct interface to the foreign object.
The macro @code{translation-forms-for-class} will generate the forms
necessary to translate a Lisp class into a foreign structure and vice
versa.
@c Write separate function doc section for translation-forms-for-class?
@c Examples, perhaps taken from the tests?

Please note that this interface is only for those that must know about
the values contained in a relevant struct.  If the library you are
interfacing returns an opaque pointer that needs only be passed to
other C library functions, by all means just use @code{:pointer} or a
type-safe definition munged together with @code{defctype} and type
translation.  To pass or return a structure by value to a function, load
the cffi-libffi system and specify the structure as @code{(:struct
@var{structure-name})}.  To pass or return the pointer, you can use
either @code{:pointer} or @code{(:pointer (:struct
@var{structure-name}))}.

@subheading Optimizing translate-into-foreign-memory

Just like how @ref{translate-from-foreign} had
@code{expand-from-foreign} to optimize away the generic function call
and @ref{translate-to-foreign} had the same in
@code{expand-to-foreign}, @ref{translate-into-foreign-memory} has
@code{expand-into-foreign-memory}.

Let's use our @code{person} struct in an example. However, we are
going to spice it up by using a lisp struct rather than a plist to
represent the person in lisp.

First we redefine @code{person} very slightly.

@lisp
(defcstruct (person :class c-person)
  (number :int)
  (reason :string))
@end lisp

By adding @code{:class} we can specialize the @code{translate-*}
methods on the type @code{c-person}.

Next we define a lisp struct to use instead of the plists.

@lisp
(defstruct lisp-person
  (number 0 :type integer)
  (reason "" :type string))
@end lisp

And now let's define the type translators we know already:

@lisp
(defmethod translate-from-foreign (ptr (type c-person))
  (with-foreign-slots ((number reason) ptr (:struct person))
    (make-lisp-person :number number :reason reason)))

(defmethod expand-from-foreign (ptr (type c-person))
  `(with-foreign-slots ((number reason) ,ptr (:struct person))
     (make-lisp-person :number number :reason reason)))

(defmethod translate-into-foreign-memory (value (type c-person) ptr)
  (with-foreign-slots ((number reason) ptr (:struct person))
    (setf number (lisp-person-number value)
          reason (lisp-person-reason value))))
@end lisp

At this point everything works, we can convert to and from our
@code{lisp-person} and foreign @code{person}. If we macroexpand

@lisp
(setf (mem-aref ptr '(:struct person)) x)
@end lisp

we get something like:

@lisp
(let ((#:store879 x))
  (translate-into-foreign-memory #:store879 #
                                 (inc-pointer ptr 0))
  #:store879)
@end lisp

Which is good, but now we can do better and get rid of that generic
function call to @code{translate-into-foreign-memory}.

@lisp
(defmethod expand-into-foreign-memory (value (type c-person) ptr)
  `(with-foreign-slots ((number reason) ,ptr (:struct person))
     (setf number (lisp-person-number ,value)
           reason (lisp-person-reason ,value))))
@end lisp

Now we can expand again so see the changes:

@lisp
;; this:
(setf (mem-aref ptr '(:struct person)) x)

;; expands to this
;; (simplified, downcased, etc..)
(let ((#:store887 x))
  (with-foreign-slots ((number reason) (inc-pointer ptr 0) (:struct person))
    (setf number (lisp-person-number #:store887)
          reason (lisp-person-reason #:store887))) #:store887)
@end lisp

And there we are, no generic function overhead.

@subheading Compatibility note

Previous versions of CFFI accepted the
``bare'' @var{structure-name} as a type specification, which was
interpreted as a pointer to the structure.  This is deprecated and
produces a style warning.  Using this deprecated form means that
@ref{mem-aref} retains its prior meaning and returns a pointer.  Using
the @code{(:struct @var{structure-name})} form for the type,
@ref{mem-aref} provides a Lisp object translated from the
structure (by default a plist).  Thus the semantics are consistent with all
types in returning the object as represented in Lisp, and not a pointer,
with the exception of the ``bare'' structure compatibility retained.
In order to obtain the pointer, you should use the function @ref{mem-aptr}.

See @ref{defcstruct} for more details.

@node Allocating Foreign Objects, convert-from-foreign, Foreign Structure Types, Foreign Types
@section Allocating Foreign Objects

@c I moved this because I moved with-foreign-object to the Pointers
@c chapter, where foreign-alloc is.

@xref{Allocating Foreign Memory}.


@c ===================================================================
@c CONVERT-FROM-FOREIGN

@page
@node convert-from-foreign, convert-to-foreign, Allocating Foreign Objects, Foreign Types
@heading convert-from-foreign
@subheading Syntax
@Function{convert-from-foreign foreign-value type @res{} value}

@subheading Arguments and Values

@table @var
@item foreign-value
The primitive C value as returned from a primitive foreign function or
from @code{convert-to-foreign}.

@item type
A @cffi{} type specifier.

@item value
The Lisp value translated from @var{foreign-value}.
@end table

@subheading Description

This is an external interface to the type translation facility.  In
the implementation, all foreign functions are ultimately defined as
type translation wrappers around primitive foreign function
invocations.

This function is available mostly for inspection of the type
translation process, and possibly optimization of special cases of
your foreign function calls.

Its behavior is better described under @code{translate-from-foreign}'s
documentation.

@subheading Examples

@lisp
CFFI-USER> (convert-to-foreign "a boat" :string)
@result{} #
@result{} T
CFFI-USER> (convert-from-foreign * :string)
@result{} "a boat"
@end lisp

@subheading See Also
@seealso{convert-to-foreign} @*
@seealso{free-converted-object} @*
@seealso{translate-from-foreign}


@c ===================================================================
@c CONVERT-TO-FOREIGN

@page
@node convert-to-foreign, defbitfield, convert-from-foreign, Foreign Types
@heading convert-to-foreign
@subheading Syntax
@Function{convert-to-foreign value type @res{} foreign-value, alloc-params}

@subheading Arguments and Values

@table @var
@item value
The Lisp object to be translated to a foreign object.

@item type
A @cffi{} type specifier.

@item foreign-value
The primitive C value, ready to be passed to a primitive foreign
function.

@item alloc-params
Something of a translation state; you must pass it to
@code{free-converted-object} along with the foreign value for that to
work.
@end table

@subheading Description

This is an external interface to the type translation facility.  In
the implementation, all foreign functions are ultimately defined as
type translation wrappers around primitive foreign function
invocations.

This function is available mostly for inspection of the type
translation process, and possibly optimization of special cases of
your foreign function calls.

Its behavior is better described under @code{translate-to-foreign}'s
documentation.

@subheading Examples

@lisp
CFFI-USER> (convert-to-foreign t :boolean)
@result{} 1
@result{} NIL
CFFI-USER> (convert-to-foreign "hello, world" :string)
@result{} #
@result{} T
CFFI-USER> (code-char (mem-aref * :char 5))
@result{} #\,
@end lisp

@subheading See Also
@seealso{convert-from-foreign} @*
@seealso{free-converted-object} @*
@seealso{translate-to-foreign}


@c ===================================================================
@c DEFBITFIELD

@page
@node defbitfield, defcstruct, convert-to-foreign, Foreign Types
@heading defbitfield
@subheading Syntax
@Macro{defbitfield name-and-options &body masks}

masks ::= [docstring] @{ (symbol value) @}* @*
name-and-options ::= name | (name &optional (base-type :int))

@subheading Arguments and Values

@table @var
@item name
The name of the new bitfield type.

@item docstring
A documentation string, ignored.

@item base-type
A symbol denoting a foreign type.

@item symbol
A Lisp symbol.

@item value
An integer representing a bitmask.
@end table

@subheading Description
The @code{defbitfield} macro is used to define foreign types that map
lists of symbols to integer values.

If @var{value} is omitted, it will be computed as follows: find the
greatest @var{value} previously used, including those so computed,
with only a single 1-bit in its binary representation (that is, powers
of two), and left-shift it by one.  This rule guarantees that a
computed @var{value} cannot clash with previous values, but may clash
with future explicitly specified values.

Symbol lists will be automatically converted to values and vice versa
when being passed as arguments to or returned from foreign functions,
respectively. The same applies to any other situations where an object
of a bitfield type is expected.

Types defined with @code{defbitfield} canonicalize to @var{base-type}
which is @code{:int} by default.

@subheading Examples
@lisp
(defbitfield open-flags
  (:rdonly #x0000)
  :wronly               ;@lispcmt{#x0001}
  :rdwr                 ;@lispcmt{@dots{}}
  :nonblock
  :append
  (:creat  #x0200))
  ;; @lispcmt{etc@dots{}}

CFFI> (foreign-bitfield-symbols 'open-flags #b1101)
@result{} (:RDONLY :WRONLY :NONBLOCK :APPEND)

CFFI> (foreign-bitfield-value 'open-flags '(:rdwr :creat))
@result{} 514   ; #x0202

(defcfun ("open" unix-open) :int
  (path :string)
  (flags open-flags)
  (mode :uint16)) ; unportable

CFFI> (unix-open "/tmp/foo" '(:wronly :creat) #o644)
@result{} #

;;; @lispcmt{Consider also the following lispier wrapper around open()}
(defun lispier-open (path mode &rest flags)
  (unix-open path flags mode))
@end lisp

@subheading See Also
@seealso{foreign-bitfield-value} @*
@seealso{foreign-bitfield-symbols}


@c ===================================================================
@c DEFCSTRUCT

@page
@node defcstruct, defcunion, defbitfield, Foreign Types
@heading defcstruct
@subheading Syntax
@Macro{defcstruct name-and-options &body doc-and-slots @res{} name}

name-and-options ::= structure-name | (structure-name &key size)

doc-and-slots ::= [docstring] @{ (slot-name slot-type &key count offset) @}*

@subheading Arguments and Values

@table @var
@item structure-name
The name of new structure type.

@item docstring
A documentation string, ignored.

@item slot-name
A symbol naming the slot.  It must be unique among slot names in this
structure.

@item size
Use this option to override the size (in bytes) of the struct.

@item slot-type
The type specifier for the slot.

@item count
Used to declare an array of size @var{count} inside the
structure.  Defaults to @code{1} as such an array and a single element
are semantically equivalent.

@item offset
Overrides the slot's offset. The next slot's offset is calculated
based on this one.
@end table

@subheading Description
This defines a new @cffi{} aggregate type akin to C @code{struct}s.
In other words, it specifies that foreign objects of the type
@var{structure-name} are groups of different pieces of data, or
``slots'', of the @var{slot-type}s, distinguished from each other by
the @var{slot-name}s.  Each structure is located in memory at a
position, and the slots are allocated sequentially beginning at that
point in memory (with some padding allowances as defined by the C
@acronym{ABI}, unless otherwise requested by specifying an
@var{offset} from the beginning of the structure (offset 0).

In other words, it is isomorphic to the C @code{struct}, giving
several extra features.

There are two kinds of slots, for the two kinds of @cffi{} types:

@table @dfn
@item Simple
Contain a single instance of a type that canonicalizes to a built-in
type, such as @code{:long} or @code{:pointer}.  Used for simple
@cffi{} types.

@item Aggregate
Contain an embedded structure or union, or an array of objects.  Used
for aggregate @cffi{} types.
@end table

The use of @acronym{CLOS} terminology for the structure-related
features is intentional; structure definitions are very much like
classes with (far) fewer features.

@subheading Examples
@lisp
(defcstruct point
  "Point structure."
  (x :int)
  (y :int))

CFFI> (with-foreign-object (ptr 'point)
        ;; @lispcmt{Initialize the slots}
        (setf (foreign-slot-value ptr 'point 'x) 42
              (foreign-slot-value ptr 'point 'y) 42)
        ;; @lispcmt{Return a list with the coordinates}
        (with-foreign-slots ((x y) ptr point)
          (list x y)))
@result{} (42 42)
@end lisp

@lisp
;; @lispcmt{Using the :size and :offset options to define a partial structure.}
;; @lispcmt{(this is useful when you are interested in only a few slots}
;; @lispcmt{of a big foreign structure)}

(defcstruct (foo :size 32)
  "Some struct with 32 bytes."
                        ; @lispcmt{<16 bytes we don't care about>}
  (x :int :offset 16)   ; @lispcmt{an int at offset 16}
  (y :int)              ; @lispcmt{another int at offset 16+sizeof(int)}
                        ; @lispcmt{}
  (z :char :offset 24)) ; @lispcmt{a char at offset 24}
                        ; @lispcmt{<7 more bytes ignored (since size is 32)>}

CFFI> (foreign-type-size 'foo)
@result{} 32
@end lisp

@lisp
;;; @lispcmt{Using :count to define arrays inside of a struct.}
(defcstruct video_tuner
  (name :char :count 32))
@end lisp

@subheading See Also
@seealso{foreign-slot-pointer} @*
@seealso{foreign-slot-value} @*
@seealso{with-foreign-slots}


@c ===================================================================
@c DEFCUNION

@page
@node defcunion, defctype, defcstruct, Foreign Types
@heading defcunion
@subheading Syntax
@Macro{defcunion name &body doc-and-slots @res{} name}

doc-and-slots ::= [docstring] @{ (slot-name slot-type &key count) @}*

@subheading Arguments and Values

@table @var
@item name
The name of new union type.

@item docstring
A documentation string, ignored.

@item slot-name
A symbol naming the slot.

@item slot-type
The type specifier for the slot.

@item count
Used to declare an array of size @var{count} inside the
structure.
@end table

@subheading Description
A union is a structure in which all slots have an offset of zero.  It
is isomorphic to the C @code{union}.  Therefore, you should use the
usual foreign structure operations for accessing a union's slots.

@subheading Examples
@lisp
(defcunion uint32-bytes
  (int-value :unsigned-int)
  (bytes :unsigned-char :count 4))
@end lisp

@subheading See Also
@seealso{foreign-slot-pointer} @*
@seealso{foreign-slot-value}


@c ===================================================================
@c DEFCTYPE

@page
@node defctype, defcenum, defcunion, Foreign Types
@heading defctype
@subheading Syntax
@Macro{defctype name base-type &optional documentation}

@subheading Arguments and Values

@table @var
@item name
The name of the new foreign type.

@item base-type
A symbol or a list defining the new type.

@item documentation
A documentation string, currently ignored.
@end table

@subheading Description
The @code{defctype} macro provides a mechanism similar to C's
@code{typedef} to define new types. The new type inherits
@var{base-type}'s translators, if any. There is no way to define
translations for types defined with @code{defctype}.  For that,
you should use @ref{define-foreign-type}.

@subheading Examples
@lisp
(defctype my-string :string
  "My own string type.")

(defctype long-bools (:boolean :long)
  "Booleans that map to C longs.")
@end lisp

@subheading See Also
@seealso{define-foreign-type}


@c ===================================================================
@c DEFCENUM

@page
@node defcenum, define-foreign-type, defctype, Foreign Types
@heading defcenum
@subheading Syntax
@Macro{defcenum name-and-options &body enum-list}

enum-list ::= [docstring] @{ keyword | (keyword value) @}*
name-and-options ::= name | (name &optional (base-type :int))

@subheading Arguments and Values

@table @var
@item name
The name of the new enum type.

@item docstring
A documentation string, ignored.

@item base-type
A symbol denoting a foreign type.

@item keyword
A keyword symbol.

@item value
An index value for a keyword.
@end table

@subheading Description
The @code{defcenum} macro is used to define foreign types that map
keyword symbols to integer values, similar to the C @code{enum} type.

If @var{value} is omitted its value will either be 0, if it's the
first entry, or it it will continue the progression from the last
specified value.

Keywords will be automatically converted to values and vice-versa when
being passed as arguments to or returned from foreign functions,
respectively. The same applies to any other situations where an object
of an @code{enum} type is expected.

Types defined with @code{defcenum} canonicalize to @var{base-type}
which is @code{:int} by default.

@subheading Examples
@lisp
(defcenum boolean
  :no
  :yes)

CFFI> (foreign-enum-value 'boolean :no)
@result{} 0
@end lisp

@lisp
(defcenum numbers
  (:one 1)
  :two
  (:four 4))

CFFI> (foreign-enum-keyword 'numbers 2)
@result{} :TWO
@end lisp

@subheading See Also
@seealso{foreign-enum-value} @*
@seealso{foreign-enum-keyword}


@c ===================================================================
@c DEFINE-FOREIGN-TYPE

@page
@node define-foreign-type, define-parse-method, defcenum, Foreign Types
@heading define-foreign-type
@subheading Syntax
@Macro{define-foreign-type class-name supers slots &rest options @res{} class-name}

options ::= (@code{:actual-type} @var{type}) | @
    (@code{:simple-parser} @var{symbol}) | @
    @emph{regular defclass option}

@subheading Arguments and Values

@table @var
@item class-name
A symbol naming the new foreign type class.

@item supers
A list of symbols naming the super classes.

@item slots
A list of slot definitions, passed to @code{defclass}.
@end table

@subheading Description

@c TODO rewrite

The macro @code{define-foreign-type} defines a new class
@var{class-name}. It is a thin wrapper around @code{defclass}. Among
other things, it ensures that @var{class-name} becomes a subclass of
@var{foreign-type}, what you need to know about that is that there's
an initarg @code{:actual-type} which serves the same purpose as
@code{defctype}'s @var{base-type} argument.

@c TODO mention the type translators here
@c FIX FIX

@subheading Examples
Taken from @cffi{}'s @code{:boolean} type definition:

@lisp
(define-foreign-type :boolean (&optional (base-type :int))
  "Boolean type. Maps to an :int by default. Only accepts integer types."
  (ecase base-type
    ((:char
      :unsigned-char
      :int
      :unsigned-int
      :long
      :unsigned-long) base-type)))

CFFI> (canonicalize-foreign-type :boolean)
@result{} :INT
CFFI> (canonicalize-foreign-type '(:boolean :long))
@result{} :LONG
CFFI> (canonicalize-foreign-type '(:boolean :float))
;; @lispcmt{@error{} signalled by ECASE.}
@end lisp

@subheading See Also
@seealso{defctype} @*
@seealso{define-parse-method}


@c ===================================================================
@c DEFINE-PARSE-METHOD

@page
@node define-parse-method, foreign-bitfield-symbols, define-foreign-type, Foreign Types
@heading define-parse-method
@subheading Syntax
@Macro{define-parse-method name lambda-list &body body @res{} name}

@subheading Arguments and Values

@table @var
@item type-name
A symbol naming the new foreign type.

@item lambda-list
A lambda list which is the argument list of the new foreign type.

@item body
One or more forms that provide a definition of the new foreign type.
@end table

@subheading Description


@c TODO: update example. The boolean type is probably a good choice.

@subheading Examples
Taken from @cffi{}'s @code{:boolean} type definition:

@lisp
(define-foreign-type :boolean (&optional (base-type :int))
  "Boolean type. Maps to an :int by default. Only accepts integer types."
  (ecase base-type
    ((:char
      :unsigned-char
      :int
      :unsigned-int
      :long
      :unsigned-long) base-type)))

CFFI> (canonicalize-foreign-type :boolean)
@result{} :INT
CFFI> (canonicalize-foreign-type '(:boolean :long))
@result{} :LONG
CFFI> (canonicalize-foreign-type '(:boolean :float))
;; @lispcmt{@error{} signalled by ECASE.}
@end lisp

@subheading See Also
@seealso{define-foreign-type}


@c ===================================================================
@c EXPLAIN-FOREIGN-SLOT-VALUE

@c @node explain-foreign-slot-value
@c @heading explain-foreign-slot-value
@c @subheading Syntax
@c @Macro{explain-foreign-slot-value ptr type &rest slot-names}

@c @subheading Arguments and Values

@c @table @var
@c @item ptr
@c ...

@c @item type
@c ...

@c @item slot-names
@c ...
@c @end table

@c @subheading Description
@c This macro translates the slot access that would occur by calling
@c @code{foreign-slot-value} with the same arguments into an equivalent
@c expression in C and prints it to @code{*standard-output*}.

@c @emph{Note: this is not implemented yet.}

@c @subheading Examples
@c @lisp
@c CFFI> (explain-foreign-slot-value ptr 'timeval 'tv-secs)
@c @result{} ptr->tv_secs

@c CFFI> (explain-foreign-slot-value emp 'employee 'hire-date 'tv-usecs)
@c @result{} emp->hire_date.tv_usecs
@c @end lisp

@c @subheading See Also


@c ===================================================================
@c FOREIGN-BITFIELD-SYMBOLS

@page
@node foreign-bitfield-symbols, foreign-bitfield-value, define-parse-method, Foreign Types
@heading foreign-bitfield-symbols
@subheading Syntax
@Function{foreign-bitfield-symbols type value @res{} symbols}

@subheading Arguments and Values

@table @var
@item type
A bitfield type.

@item value
An integer.

@item symbols
A potentially shared list of symbols.
@code{nil}.
@end table

@subheading Description
The function @code{foreign-bitfield-symbols} returns a possibly shared
list of symbols that correspond to @var{value} in @var{type}.

@subheading Examples
@lisp
(defbitfield flags
  (flag-a 1)
  (flag-b 2)
  (flag-c 4))

CFFI> (foreign-bitfield-symbols 'boolean #b101)
@result{} (FLAG-A FLAG-C)
@end lisp

@subheading See Also
@seealso{defbitfield} @*
@seealso{foreign-bitfield-value}


@c ===================================================================
@c FOREIGN-BITFIELD-VALUE

@page
@node foreign-bitfield-value, foreign-enum-keyword, foreign-bitfield-symbols, Foreign Types
@heading foreign-bitfield-value
@subheading Syntax
@Function{foreign-bitfield-value type symbols @res{} value}

@subheading Arguments and Values

@table @var
@item type
A @code{bitfield} type.

@item symbol
A Lisp symbol.

@item value
An integer.
@end table

@subheading Description
The function @code{foreign-bitfield-value} returns the @var{value} that
corresponds to the symbols in the @var{symbols} list.

@subheading Examples
@lisp
(defbitfield flags
  (flag-a 1)
  (flag-b 2)
  (flag-c 4))

CFFI> (foreign-bitfield-value 'flags '(flag-a flag-c))
@result{} 5  ; #b101
@end lisp

@subheading See Also
@seealso{defbitfield} @*
@seealso{foreign-bitfield-symbols}


@c ===================================================================
@c FOREIGN-ENUM-KEYWORD

@page
@node foreign-enum-keyword, foreign-enum-value, foreign-bitfield-value, Foreign Types
@heading foreign-enum-keyword
@subheading Syntax
@Function{foreign-enum-keyword type value &key errorp @res{} keyword}

@subheading Arguments and Values

@table @var
@item type
An @code{enum} type.

@item value
An integer.

@item errorp
If true (the default), signal an error if @var{value} is not defined
in @var{type}.  If false, @code{foreign-enum-keyword} returns
@code{nil}.

@item keyword
A keyword symbol.
@end table

@subheading Description
The function @code{foreign-enum-keyword} returns the keyword symbol
that corresponds to @var{value} in @var{type}.

An error is signaled if @var{type} doesn't contain such @var{value}
and @var{errorp} is true.

@subheading Examples
@lisp
(defcenum boolean
  :no
  :yes)

CFFI> (foreign-enum-keyword 'boolean 1)
@result{} :YES
@end lisp

@subheading See Also
@seealso{defcenum} @*
@seealso{foreign-enum-value}


@c ===================================================================
@c FOREIGN-ENUM-VALUE

@page
@node foreign-enum-value, foreign-slot-names, foreign-enum-keyword, Foreign Types
@heading foreign-enum-value
@subheading Syntax
@Function{foreign-enum-value type keyword &key errorp @res{} value}

@subheading Arguments and Values

@table @var
@item type
An @code{enum} type.

@item keyword
A keyword symbol.

@item errorp
If true (the default), signal an error if @var{keyword} is not
defined in @var{type}.  If false, @code{foreign-enum-value} returns
@code{nil}.

@item value
An integer.
@end table

@subheading Description
The function @code{foreign-enum-value} returns the @var{value} that
corresponds to @var{keyword} in @var{type}.

An error is signaled if @var{type} doesn't contain such
@var{keyword}, and @var{errorp} is true.

@subheading Examples
@lisp
(defcenum boolean
  :no
  :yes)

CFFI> (foreign-enum-value 'boolean :yes)
@result{} 1
@end lisp

@subheading See Also
@seealso{defcenum} @*
@seealso{foreign-enum-keyword}


@c ===================================================================
@c FOREIGN-SLOT-NAMES

@page
@node foreign-slot-names, foreign-slot-offset, foreign-enum-value, Foreign Types
@heading foreign-slot-names
@subheading Syntax
@Function{foreign-slot-names type @res{} names}

@subheading Arguments and Values

@table @var
@item type
A foreign struct type.

@item names
A list.
@end table

@subheading Description
The function @code{foreign-slot-names} returns a potentially shared
list of slot @var{names} for the given structure @var{type}. This list
has no particular order.

@subheading Examples
@lisp
(defcstruct timeval
  (tv-secs :long)
  (tv-usecs :long))

CFFI> (foreign-slot-names '(:struct timeval))
@result{} (TV-SECS TV-USECS)
@end lisp

@subheading See Also
@seealso{defcstruct} @*
@seealso{foreign-slot-offset} @*
@seealso{foreign-slot-value} @*
@seealso{foreign-slot-pointer}


@c ===================================================================
@c FOREIGN-SLOT-OFFSET

@page
@node foreign-slot-offset, foreign-slot-pointer, foreign-slot-names, Foreign Types
@heading foreign-slot-offset
@subheading Syntax
@Function{foreign-slot-offset type slot-name @res{} offset}

@subheading Arguments and Values

@table @var
@item type
A foreign struct type.

@item slot-name
A symbol.

@item offset
An integer.
@end table

@subheading Description
The function @code{foreign-slot-offset} returns the @var{offset} in
bytes of a slot in a foreign struct type.

@subheading Examples
@lisp
(defcstruct timeval
  (tv-secs :long)
  (tv-usecs :long))

CFFI> (foreign-slot-offset '(:struct timeval) 'tv-secs)
@result{} 0
CFFI> (foreign-slot-offset '(:struct timeval) 'tv-usecs)
@result{} 4
@end lisp

@subheading See Also
@seealso{defcstruct} @*
@seealso{foreign-slot-names} @*
@seealso{foreign-slot-pointer} @*
@seealso{foreign-slot-value}


@c ===================================================================
@c FOREIGN-SLOT-POINTER

@page
@node foreign-slot-pointer, foreign-slot-value, foreign-slot-offset, Foreign Types
@heading foreign-slot-pointer
@subheading Syntax
@Function{foreign-slot-pointer ptr type slot-name @res{} pointer}

@subheading Arguments and Values

@table @var
@item ptr
A pointer to a structure.

@item type
A foreign structure type.

@item slot-names
A slot name in the @var{type}.

@item pointer
A pointer to the slot @var{slot-name}.
@end table

@subheading Description
Returns a pointer to the location of the slot @var{slot-name} in a
foreign object of type @var{type} at @var{ptr}. The returned pointer
points inside the structure. Both the pointer and the memory it points
to have the same extent as @var{ptr}.

For aggregate slots, this is the same value returned by
@code{foreign-slot-value}.

@subheading Examples
@lisp
(defcstruct point
  "Pointer structure."
  (x :int)
  (y :int))

CFFI> (with-foreign-object (ptr '(:struct point))
        (foreign-slot-pointer ptr '(:struct point) 'x))
@result{} #
;; @lispcmt{Note: the exact pointer representation varies from lisp to lisp.}
@end lisp

@subheading See Also
@seealso{defcstruct} @*
@seealso{foreign-slot-value} @*
@seealso{foreign-slot-names} @*
@seealso{foreign-slot-offset}


@c ===================================================================
@c FOREIGN-SLOT-VALUE

@page
@node foreign-slot-value, foreign-type-alignment, foreign-slot-pointer, Foreign Types
@heading foreign-slot-value
@subheading Syntax
@Accessor{foreign-slot-value ptr type slot-name @res{} object}

@subheading Arguments and Values

@table @var
@item ptr
A pointer to a structure.

@item type
A foreign structure type.

@item slot-name
A symbol naming a slot in the structure type.

@item object
The object contained in the slot specified by @var{slot-name}.
@end table

@subheading Description
For simple slots, @code{foreign-slot-value} returns the value of the
object, such as a Lisp integer or pointer. In C, this would be
expressed as @code{ptr->slot}.

For aggregate slots, a pointer inside the structure to the beginning
of the slot's data is returned. In C, this would be expressed as
@code{&ptr->slot}. This pointer and the memory it points to have the
same extent as @var{ptr}.

There are compiler macros for @code{foreign-slot-value} and its
@code{setf} expansion that open code the memory access when
@var{type} and @var{slot-names} are constant at compile-time.

@subheading Examples
@lisp
(defcstruct point
  "Pointer structure."
  (x :int)
  (y :int))

CFFI> (with-foreign-object (ptr '(:struct point))
        ;; @lispcmt{Initialize the slots}
        (setf (foreign-slot-value ptr '(:struct point) 'x) 42
              (foreign-slot-value ptr '(:struct point) 'y) 42)
        ;; @lispcmt{Return a list with the coordinates}
        (with-foreign-slots ((x y) ptr (:struct point))
          (list x y)))
@result{} (42 42)
@end lisp

@subheading See Also
@seealso{defcstruct} @*
@seealso{foreign-slot-names} @*
@seealso{foreign-slot-offset} @*
@seealso{foreign-slot-pointer} @*
@seealso{with-foreign-slots}


@c ===================================================================
@c FOREIGN-TYPE-ALIGNMENT

@page
@node foreign-type-alignment, foreign-type-size, foreign-slot-value, Foreign Types
@heading foreign-type-alignment
@subheading Syntax
@c XXX: This is actually a generic function.
@Function{foreign-type-alignment type @res{} alignment}

@subheading Arguments and Values

@table @var
@item type
A foreign type.

@item alignment
An integer.
@end table

@subheading Description
The function @code{foreign-type-alignment} returns the
@var{alignment} of @var{type} in bytes.

@subheading Examples
@lisp
CFFI> (foreign-type-alignment :char)
@result{} 1
CFFI> (foreign-type-alignment :short)
@result{} 2
CFFI> (foreign-type-alignment :int)
@result{} 4
@end lisp

@lisp
(defcstruct foo
  (a :char))

CFFI> (foreign-type-alignment '(:struct foo))
@result{} 1
@end lisp

@subheading See Also
@seealso{foreign-type-size}


@c ===================================================================
@c FOREIGN-TYPE-SIZE

@page
@node foreign-type-size, free-converted-object, foreign-type-alignment, Foreign Types
@heading foreign-type-size
@subheading Syntax
@c XXX: this is actually a generic function.
@Function{foreign-type-size type @res{} size}

@subheading Arguments and Values

@table @var
@item type
A foreign type.

@item size
An integer.
@end table

@subheading Description
The function @code{foreign-type-size} return the @var{size} of
@var{type} in bytes.  This includes any padding within and following
the in-memory representation as needed to create an array of
@var{type} objects.

@subheading Examples
@lisp
(defcstruct foo
  (a :double)
  (c :char))

CFFI> (foreign-type-size :double)
@result{} 8
CFFI> (foreign-type-size :char)
@result{} 1
CFFI> (foreign-type-size '(:struct foo))
@result{} 16
@end lisp

@subheading See Also
@seealso{foreign-type-alignment}


@c ===================================================================
@c FREE-CONVERTED-OBJECT

@page
@node free-converted-object, free-translated-object, foreign-type-size, Foreign Types
@heading free-converted-object
@subheading Syntax
@Function{free-converted-object foreign-value type params}

@subheading Arguments and Values

@table @var
@item foreign-value
The C object to be freed.

@item type
A @cffi{} type specifier.

@item params
The state returned as the second value from @code{convert-to-foreign};
used to implement the third argument to @code{free-translated-object}.
@end table

@subheading Description

The return value is unspecified.

This is an external interface to the type translation facility.  In
the implementation, all foreign functions are ultimately defined as
type translation wrappers around primitive foreign function
invocations.

This function is available mostly for inspection of the type
translation process, and possibly optimization of special cases of
your foreign function calls.

Its behavior is better described under @code{free-translated-object}'s
documentation.

@subheading Examples

@lisp
CFFI-USER> (convert-to-foreign "a boat" :string)
@result{} #
@result{} T
CFFI-USER> (free-converted-object * :string t)
@result{} NIL
@end lisp

@subheading See Also
@seealso{convert-from-foreign} @*
@seealso{convert-to-foreign} @*
@seealso{free-translated-object}


@c ===================================================================
@c FREE-TRANSLATED-OBJECT

@c TODO: update

@page
@node free-translated-object, translate-from-foreign, free-converted-object, Foreign Types
@heading free-translated-object
@subheading Syntax
@GenericFunction{free-translated-object value type-name param}

@subheading Arguments and Values

@table @var
@item pointer
The foreign value returned by @code{translate-to-foreign}.

@item type-name
A symbol naming a foreign type defined by @code{defctype}.

@item param
The second value, if any, returned by @code{translate-to-foreign}.
@end table

@subheading Description
This generic function may be specialized by user code to perform
automatic deallocation of foreign objects as they are passed to C
functions.

Any methods defined on this generic function must EQL-specialize the
@var{type-name} parameter on a symbol defined as a foreign type by
the @code{defctype} macro.

@subheading See Also
@seealso{Foreign Type Translators} @*
@seealso{translate-to-foreign}


@c ===================================================================
@c TRANSLATE-FROM-FOREIGN

@c TODO: update

@page
@node translate-from-foreign, translate-to-foreign, free-translated-object, Foreign Types
@heading translate-from-foreign
@subheading Syntax
@GenericFunction{translate-from-foreign foreign-value type-name @
                                        @res{} lisp-value}

@subheading Arguments and Values

@table @var
@item foreign-value
The foreign value to convert to a Lisp object.

@item type-name
A symbol naming a foreign type defined by @code{defctype}.

@item lisp-value
The lisp value to pass in place of @code{foreign-value} to Lisp code.
@end table

@subheading Description
This generic function is invoked by @cffi{} to convert a foreign value to
a Lisp value, such as when returning from a foreign function, passing
arguments to a callback function, or accessing a foreign variable.

To extend the @cffi{} type system by performing custom translations, this
method may be specialized by @sc{eql}-specializing @code{type-name} on a
symbol naming a foreign type defined with @code{defctype}.  This
method should return the appropriate Lisp value to use in place of the
foreign value.

The results are undefined if the @code{type-name} parameter is
specialized in any way except an @sc{eql} specializer on a foreign type
defined with @code{defctype}.  Specifically, translations may not be
defined for built-in types.

@subheading See Also
@seealso{Foreign Type Translators} @*
@seealso{translate-to-foreign} @*
@seealso{free-translated-object}


@c ===================================================================
@c TRANSLATE-TO-FOREIGN

@c TODO: update

@page
@node translate-to-foreign, translate-into-foreign-memory, translate-from-foreign, Foreign Types
@heading translate-to-foreign
@subheading Syntax
@GenericFunction{translate-to-foreign lisp-value type-name @
                                      @res{} foreign-value, alloc-param}

@subheading Arguments and Values

@table @var
@item lisp-value
The Lisp value to convert to foreign representation.

@item type-name
A symbol naming a foreign type defined by @code{defctype}.

@item foreign-value
The foreign value to pass in place of @code{lisp-value} to foreign code.

@item alloc-param
If present, this value will be passed to
@code{free-translated-object}.
@end table

@subheading Description
This generic function is invoked by @cffi{} to convert a Lisp value to a
foreign value, such as when passing arguments to a foreign function,
returning a value from a callback, or setting a foreign variable.  A
``foreign value'' is one appropriate for passing to the next-lowest
translator, including the low-level translators that are ultimately
invoked invisibly with @cffi{}.

To extend the @cffi{} type system by performing custom translations, this
method may be specialized by @sc{eql}-specializing @code{type-name} on a
symbol naming a foreign type defined with @code{defctype}.  This
method should return the appropriate foreign value to use in place of
the Lisp value.

In cases where @cffi{} can determine the lifetime of the foreign object
returned by this method, it will invoke @code{free-translated-object}
on the foreign object at the appropriate time.  If
@code{translate-to-foreign} returns a second value, it will be passed
as the @code{param} argument to @code{free-translated-object}.  This
can be used to establish communication between the allocation and
deallocation methods.

The results are undefined if the @code{type-name} parameter is
specialized in any way except an @sc{eql} specializer on a foreign type
defined with @code{defctype}.  Specifically, translations may not be
defined for built-in types.

@subheading See Also
@seealso{Foreign Type Translators} @*
@seealso{translate-from-foreign} @*
@seealso{free-translated-object}


@c ===================================================================
@c TRANSLATE-INTO-FOREIGN-MEMORY

@page
@node translate-into-foreign-memory, with-foreign-slots, translate-to-foreign, Foreign Types
@heading translate-into-foreign-memory
@subheading Syntax
@GenericFunction{translate-into-foreign-memory lisp-value type-name pointer}

@subheading Arguments and Values

@table @var
@item lisp-value
The Lisp value to convert to foreign representation.

@item type-name
A symbol or list @code{(:struct @var{structure-name})} naming a foreign type defined by @code{defctype}.

@item pointer
The foreign pointer where the translated object should be stored.
@end table

@subheading Description
Translate the Lisp value into the foreign memory location given by
pointer.  The return value is not used.

@c ===================================================================
@c WITH-FOREIGN-SLOTS

@page
@node with-foreign-slots,  , translate-into-foreign-memory, Foreign Types
@heading with-foreign-slots
@subheading Syntax
@Macro{with-foreign-slots (vars ptr type) &body body}

@subheading Arguments and Values

@table @var
@item vars
A list with each element a symbol, or list of length two with the
first element @code{:pointer} and the second a symbol.

@item ptr
A foreign pointer to a structure.

@item type
A structure type.

@item body
A list of forms to be executed.
@end table

@subheading Description
The @code{with-foreign-slots} macro creates local symbol macros for each
var in @var{vars} to reference foreign slots in @var{ptr} of @var{type}.
If the var is a list starting with @code{:pointer}, it will bind the
pointer to the slot (rather than the value). It is similar to Common
Lisp's @code{with-slots} macro.

@subheading Examples
@lisp
(defcstruct tm
  (sec :int)
  (min :int)
  (hour :int)
  (mday :int)
  (mon  :int)
  (year :int)
  (wday :int)
  (yday :int)
  (isdst  :boolean)
  (zone   :string)
  (gmtoff :long))

CFFI> (with-foreign-object (time :int)
        (setf (mem-ref time :int)
              (foreign-funcall "time" :pointer (null-pointer) :int))
        (foreign-funcall "gmtime" :pointer time (:pointer (:struct tm))))
@result{} #
CFFI> (with-foreign-slots ((sec min hour mday mon year) * (:struct tm))
        (format nil "~A:~A:~A, ~A/~A/~A"
                hour min sec (+ 1900 year) mon mday))
@result{} "7:22:47, 2005/8/2"
@end lisp

@subheading See Also
@seealso{defcstruct} @*
@seealso{defcunion} @*
@seealso{foreign-slot-value}


@c ===================================================================
@c CHAPTER: Pointers

@node Pointers, Strings, Foreign Types, Top
@chapter Pointers

All C data in @cffi{} is referenced through pointers.  This includes
defined C variables that hold immediate values, and integers.

To see why this is, consider the case of the C integer.  It is not
only an arbitrary representation for an integer, congruent to Lisp's
fixnums; the C integer has a specific bit pattern in memory defined by
the C @acronym{ABI}.  Lisp has no such constraint on its fixnums;
therefore, it only makes sense to think of fixnums as C integers if
you assume that @cffi{} converts them when necessary, such as when
storing one for use in a C function call, or as the value of a C
variable.  This requires defining an area of memory@footnote{The
definition of @dfn{memory} includes the @acronym{CPU} registers.},
represented through an effective address, and storing it there.

Due to this compartmentalization, it only makes sense to manipulate
raw C data in Lisp through pointers to it.  For example, while there
may be a Lisp representation of a @code{struct} that is converted to C
at store time, you may only manipulate its raw data through a pointer.
The C compiler does this also, albeit informally.

@menu
* Basic Pointer Operations::
* Allocating Foreign Memory::
* Accessing Foreign Memory::

Dictionary

* foreign-free::
* foreign-alloc::
* foreign-symbol-pointer::
* inc-pointer::
* incf-pointer::
* make-pointer::
* mem-aptr::
* mem-aref::
* mem-ref::
* null-pointer::
* null-pointer-p::
* pointerp::
* pointer-address::
* pointer-eq::
* with-foreign-object::
* with-foreign-objects::
* with-foreign-pointer::
@end menu

@node Basic Pointer Operations, Allocating Foreign Memory, Pointers, Pointers
@section Basic Pointer Operations

Manipulating pointers proper can be accomplished through most of the
other operations defined in the Pointers dictionary, such as
@code{make-pointer}, @code{pointer-address}, and @code{pointer-eq}.
When using them, keep in mind that they merely manipulate the Lisp
representation of pointers, not the values they point to.

@deftp {Lisp Type} foreign-pointer
The pointers' representations differ from implementation to
implementation and have different types.  @code{foreign-pointer}
provides a portable type alias to each of these types.
@end deftp


@node Allocating Foreign Memory, Accessing Foreign Memory, Basic Pointer Operations, Pointers
@section Allocating Foreign Memory

@cffi{} provides support for stack and heap C memory allocation.
Stack allocation, done with @code{with-foreign-object}, is sometimes
called ``dynamic'' allocation in Lisp, because memory allocated as
such has dynamic extent, much as with @code{let} bindings of special
variables.

This should not be confused with what C calls ``dynamic'' allocation,
or that done with @code{malloc} and friends.  This sort of heap
allocation is done with @code{foreign-alloc}, creating objects that
exist until freed with @code{foreign-free}.


@node Accessing Foreign Memory, foreign-free, Allocating Foreign Memory, Pointers
@section Accessing Foreign Memory

When manipulating raw C data, consider that all pointers are pointing
to an array.  When you only want one C value, such as a single
@code{struct}, this array only has one such value.  It is worthwhile
to remember that everything is an array, though, because this is also
the semantic that C imposes natively.

C values are accessed as the @code{setf}-able places defined by
@code{mem-aref} and @code{mem-ref}.  Given a pointer and a @cffi{}
type (@pxref{Foreign Types}), either of these will dereference the
pointer, translate the C data there back to Lisp, and return the
result of said translation, performing the reverse operation when
@code{setf}-ing.  To decide which one to use, consider whether you
would use the array index operator @code{[@var{n}]} or the pointer
dereference @code{*} in C; use @code{mem-aref} for array indexing and
@code{mem-ref} for pointer dereferencing.


@c ===================================================================
@c FOREIGN-FREE

@page
@node foreign-free, foreign-alloc, Accessing Foreign Memory, Pointers
@heading foreign-free
@subheading Syntax
@Function{foreign-free ptr @res{} undefined}

@subheading Arguments and Values

@table @var
@item ptr
A foreign pointer.
@end table

@subheading Description
The @code{foreign-free} function frees a @code{ptr} previously
allocated by @code{foreign-alloc}. The consequences of freeing a given
pointer twice are undefined.

@subheading Examples

@lisp
CFFI> (foreign-alloc :int)
@result{} #
CFFI> (foreign-free *)
@result{} NIL
@end lisp

@subheading See Also
@seealso{foreign-alloc} @*
@seealso{with-foreign-pointer}


@c ===================================================================
@c FOREIGN-ALLOC

@page
@node foreign-alloc, foreign-symbol-pointer, foreign-free, Pointers
@heading foreign-alloc
@subheading Syntax
@Function{foreign-alloc type &key initial-element initial-contents (count 1) @
                        null-terminated-p @res{} pointer}

@subheading Arguments and Values

@table @var
@item type
A foreign type.

@item initial-element
A Lisp object.

@item initial-contents
A sequence.

@item count
An integer. Defaults to 1 or the length of @var{initial-contents} if
supplied.

@item null-terminated-p
A boolean, false by default.

@item pointer
A foreign pointer to the newly allocated memory.
@end table

@subheading Description
The @code{foreign-alloc} function allocates enough memory to hold
@var{count} objects of type @var{type} and returns a
@var{pointer}. This memory must be explicitly freed using
@code{foreign-free} once it is no longer needed.

If @var{initial-element} is supplied, it is used to initialize the
@var{count} objects the newly allocated memory holds.

If an @var{initial-contents} sequence is supplied, it must have a
length less than or equal to @var{count} and each of its elements
will be used to initialize the contents of the newly allocated
memory.

If @var{count} is omitted and @var{initial-contents} is specified, it
will default to @code{(length @var{initial-contents})}.

@var{initial-element} and @var{initial-contents} are mutually
exclusive.

When @var{null-terminated-p} is true,
@code{(1+ (max @var{count} (length @var{initial-contents})))} elements
are allocated and the last one is set to @code{NULL}. Note that in
this case @var{type} must be a pointer type (ie. a type that
canonicalizes to @code{:pointer}), otherwise an error is signaled.

@subheading Examples
@lisp
CFFI> (foreign-alloc :char)
@result{} #     ; @lispcmt{A pointer to 1 byte of memory.}

CFFI> (foreign-alloc :char :count 20)
@result{} #     ; @lispcmt{A pointer to 20 bytes of memory.}

CFFI> (foreign-alloc :int :initial-element 12)
@result{} #
CFFI> (mem-ref * :int)
@result{} 12

CFFI> (foreign-alloc :int :initial-contents '(1 2 3))
@result{} #
CFFI> (loop for i from 0 below 3
            collect (mem-aref * :int i))
@result{} (1 2 3)

CFFI> (foreign-alloc :int :initial-contents #(1 2 3))
@result{} #
CFFI> (loop for i from 0 below 3
            collect (mem-aref * :int i))
@result{} (1 2 3)

;;; @lispcmt{Allocate a char** pointer that points to newly allocated memory}
;;; @lispcmt{by the :string type translator for the string "foo".}
CFFI> (foreign-alloc :string :initial-element "foo")
@result{} #
@end lisp

@lisp
;;; @lispcmt{Allocate a null-terminated array of strings.}
;;; @lispcmt{(Note: FOREIGN-STRING-TO-LISP returns NIL when passed a null pointer)}
CFFI> (foreign-alloc :string
                     :initial-contents '("foo" "bar" "baz")
                     :null-terminated-p t)
@result{} #
CFFI> (loop for i from 0 below 4
            collect (mem-aref * :string i))
@result{} ("foo" "bar" "baz" NIL)
CFFI> (progn
        (dotimes (i 3)
          (foreign-free (mem-aref ** :pointer i)))
        (foreign-free **))
@result{} nil
@end lisp

@subheading See Also
@seealso{foreign-free} @*
@seealso{with-foreign-object} @*
@seealso{with-foreign-pointer}


@c ===================================================================
@c FOREIGN-SYMBOL-POINTER

@page
@node foreign-symbol-pointer, inc-pointer, foreign-alloc, Pointers
@heading foreign-symbol-pointer
@subheading Syntax
@Function{foreign-symbol-pointer foreign-name &key library @res{} pointer}

@subheading Arguments and Values

@table @var
@item foreign-name
A string.

@item pointer
A foreign pointer, or @code{nil}.

@item library
A Lisp symbol or an instance of @code{foreign-library}.
@end table

@subheading Description
The function @code{foreign-symbol-pointer} will return a foreign
pointer corresponding to the foreign symbol denoted by the string
@var{foreign-name}.  If a foreign symbol named @var{foreign-name}
doesn't exist, @code{nil} is returned.

ABI name manglings will be performed on @var{foreign-name} by
@code{foreign-symbol-pointer} if necessary. (eg: adding a leading
underscore on darwin/ppc)

@var{library} should name a foreign library as defined by
@code{define-foreign-library}, @code{:default} (which is the default)
or an instance of @code{foreign-library} as returned by
@code{load-foreign-library}.

@strong{Important note:} do not keep these pointers across saved Lisp
cores as the foreign-library may move across sessions.

@subheading Examples

@lisp
CFFI> (foreign-symbol-pointer "errno")
@result{} #
CFFI> (foreign-symbol-pointer "strerror")
@result{} #
CFFI> (foreign-funcall-pointer * () :int (mem-ref ** :int) :string)
@result{} "No such file or directory"

CFFI> (foreign-symbol-pointer "inexistent symbol")
@result{} NIL
@end lisp

@subheading See Also
@seealso{defcvar}


@c ===================================================================
@c INC-POINTER

@page
@node inc-pointer, incf-pointer, foreign-symbol-pointer, Pointers
@heading inc-pointer
@subheading Syntax
@Function{inc-pointer pointer offset @res{} new-pointer}

@subheading Arguments and Values

@table @var
@item pointer
@itemx new-pointer
A foreign pointer.

@item offset
An integer.
@end table

@subheading Description
The function @code{inc-pointer} will return a @var{new-pointer} pointing
@var{offset} bytes past @var{pointer}.

@subheading Examples

@lisp
CFFI> (foreign-string-alloc "Common Lisp")
@result{} #
CFFI> (inc-pointer * 7)
@result{} #
CFFI> (foreign-string-to-lisp *)
@result{} "Lisp"
@end lisp

@subheading See Also
@seealso{incf-pointer} @*
@seealso{make-pointer} @*
@seealso{pointerp} @*
@seealso{null-pointer} @*
@seealso{null-pointer-p}


@c ===================================================================
@c INCF-POINTER

@page
@node incf-pointer, make-pointer, inc-pointer, Pointers
@heading incf-pointer
@subheading Syntax
@Macro{incf-pointer place &optional (offset 1) @res{} new-pointer}

@subheading Arguments and Values

@table @var
@item place
A @code{setf} place.

@item new-pointer
A foreign pointer.

@item offset
An integer.
@end table

@subheading Description
The @code{incf-pointer} macro takes the foreign pointer from
@var{place} and creates a @var{new-pointer} incremented by
@var{offset} bytes and which is stored in @var{place}.

@subheading Examples

@lisp
CFFI> (defparameter *two-words* (foreign-string-alloc "Common Lisp"))
@result{} *TWO-WORDS*
CFFI> (defparameter *one-word* *two-words*)
@result{} *ONE-WORD*
CFFI> (incf-pointer *one-word* 7)
@result{} #.(SB-SYS:INT-SAP #X00600457)
CFFI> (foreign-string-to-lisp *one-word*)
@result{} "Lisp"
CFFI> (foreign-string-to-lisp *two-words*)
@result{} "Common Lisp"
@end lisp

@subheading See Also
@seealso{inc-pointer} @*
@seealso{make-pointer} @*
@seealso{pointerp} @*
@seealso{null-pointer} @*
@seealso{null-pointer-p}


@c ===================================================================
@c MAKE-POINTER

@page
@node make-pointer, mem-aptr, incf-pointer, Pointers
@heading make-pointer
@subheading Syntax
@Function{make-pointer address @res{} ptr}

@subheading Arguments and Values

@table @var
@item address
An integer.

@item ptr
A foreign pointer.
@end table

@subheading Description
The function @code{make-pointer} will return a foreign pointer
pointing to @var{address}.

@subheading Examples

@lisp
CFFI> (make-pointer 42)
@result{} #
CFFI> (pointerp *)
@result{} T
CFFI> (pointer-address **)
@result{} 42
CFFI> (inc-pointer *** -42)
@result{} #
CFFI> (null-pointer-p *)
@result{} T
CFFI> (typep ** 'foreign-pointer)
@result{} T
@end lisp

@subheading See Also
@seealso{inc-pointer} @*
@seealso{null-pointer} @*
@seealso{null-pointer-p} @*
@seealso{pointerp} @*
@seealso{pointer-address} @*
@seealso{pointer-eq} @*
@seealso{mem-ref}


@c ===================================================================
@c MEM-APTR

@page
@node mem-aptr, mem-aref, make-pointer, Pointers
@heading mem-aptr
@subheading Syntax
@Accessor{mem-aptr ptr type &optional (index 0)}

@subheading Arguments and Values

@table @var
@item ptr
A foreign pointer.

@item type
A foreign type.

@item index
An integer.

@item new-value
A Lisp value compatible with @var{type}.
@end table

@subheading Description
The @code{mem-aptr} function finds the pointer to an element of the array.

@lisp
(mem-aptr ptr type n)

;; @lispcmt{is identical to:}

(inc-pointer ptr (* n (foreign-type-size type)))
@end lisp

@subheading Examples

@lisp
CFFI> (with-foreign-string (str "Hello, foreign world!")
        (mem-aptr str :char 6))
@result{} #.(SB-SYS:INT-SAP #X0063D4B6)
@end lisp

@c ===================================================================
@c MEM-AREF

@page
@node mem-aref, mem-ref, mem-aptr, Pointers
@heading mem-aref
@subheading Syntax
@Accessor{mem-aref ptr type &optional (index 0)}

(setf (@strong{mem-aref} @emph{ptr type &optional (index 0)) new-value})

@subheading Arguments and Values

@table @var
@item ptr
A foreign pointer.

@item type
A foreign type.

@item index
An integer.

@item new-value
A Lisp value compatible with @var{type}.
@end table

@subheading Description
The @code{mem-aref} function is similar to @code{mem-ref} but will
automatically calculate the offset from an @var{index}.

@lisp
(mem-aref ptr type n)

;; @lispcmt{is identical to:}

(mem-ref ptr type (* n (foreign-type-size type)))
@end lisp

@subheading Examples

@lisp
CFFI> (with-foreign-string (str "Hello, foreign world!")
        (mem-aref str :char 6))
@result{} 32
CFFI> (code-char *)
@result{} #\Space

CFFI> (with-foreign-object (array :int 10)
        (loop for i below 10
              do (setf (mem-aref array :int i) (random 100)))
        (loop for i below 10 collect (mem-aref array :int i)))
@result{} (22 7 22 52 69 1 46 93 90 65)
@end lisp

@subheading Compatibility Note

For compatibility with older versions of CFFI, @ref{mem-aref} will
produce a pointer for the deprecated bare structure specification, but
it is consistent with other types for the current specification form
@code{(:struct @var{structure-name})} and provides a Lisp object
translated from the structure (by default a plist).  In order to obtain
the pointer, you should use the new function @ref{mem-aptr}.

@subheading See Also
@seealso{mem-ref} @*
@seealso{mem-aptr}

@c ===================================================================
@c MEM-REF

@page
@node mem-ref, null-pointer, mem-aref, Pointers
@heading mem-ref
@subheading Syntax
@Accessor{mem-ref ptr type &optional offset @res{} object}

@subheading Arguments and Values

@table @var
@item ptr
A pointer.

@item type
A foreign type.

@item offset
An integer (in byte units).

@item object
The value @var{ptr} points to.
@end table

@subheading Description
@subheading Examples

@lisp
CFFI> (with-foreign-string (ptr "Saluton")
        (setf (mem-ref ptr :char 3) (char-code #\a))
        (loop for i from 0 below 8
              collect (code-char (mem-ref ptr :char i))))
@result{} (#\S #\a #\l #\a #\t #\o #\n #\Null)
CFFI> (setq ptr-to-int (foreign-alloc :int))
@result{} #
CFFI> (mem-ref ptr-to-int :int)
@result{} 1054619
CFFI> (setf (mem-ref ptr-to-int :int) 1984)
@result{} 1984
CFFI> (mem-ref ptr-to-int :int)
@result{} 1984
@end lisp

@subheading See Also
@seealso{mem-aref}


@c ===================================================================
@c NULL-POINTER

@page
@node null-pointer, null-pointer-p, mem-ref, Pointers
@heading null-pointer
@subheading Syntax
@Function{null-pointer @res{} pointer}

@subheading Arguments and Values

@table @var
@item pointer
A @code{NULL} pointer.
@end table

@subheading Description
The function @code{null-pointer} returns a null pointer.

@subheading Examples

@lisp
CFFI> (null-pointer)
@result{} #
CFFI> (pointerp *)
@result{} T
@end lisp

@subheading See Also
@seealso{null-pointer-p} @*
@seealso{make-pointer}


@c ===================================================================
@c NULL-POINTER-P

@page
@node null-pointer-p, pointerp, null-pointer, Pointers
@heading null-pointer-p
@subheading Syntax
@Function{null-pointer-p ptr @res{} boolean}

@subheading Arguments and Values

@table @var
@item ptr
A foreign pointer that may be a null pointer.

@item boolean
@code{T} or @code{NIL}.
@end table

@subheading Description
The function @code{null-pointer-p} returns true if @var{ptr} is a null
pointer and false otherwise.

@subheading Examples

@lisp
CFFI> (null-pointer-p (null-pointer))
@result{} T
@end lisp

@lisp
(defun contains-str-p (big little)
  (not (null-pointer-p
        (foreign-funcall "strstr" :string big :string little :pointer))))

CFFI> (contains-str-p "Popcorns" "corn")
@result{} T
CFFI> (contains-str-p "Popcorns" "salt")
@result{} NIL
@end lisp

@subheading See Also
@seealso{null-pointer} @*
@seealso{pointerp}


@c ===================================================================
@c POINTERP

@page
@node pointerp, pointer-address, null-pointer-p, Pointers
@heading pointerp
@subheading Syntax
@Function{pointerp ptr @res{} boolean}

@subheading Arguments and Values

@table @var
@item ptr
An object that may be a foreign pointer.

@item boolean
@code{T} or @code{NIL}.
@end table

@subheading Description
The function @code{pointerp} returns true if @var{ptr} is a foreign
pointer and false otherwise.

@subheading Implementation-specific Notes
In Allegro CL, foreign pointers are integers thus in this
implementation @code{pointerp} will return true for any ordinary integer.

@subheading Examples

@lisp
CFFI> (foreign-alloc 32)
@result{} #
CFFI> (pointerp *)
@result{} T
CFFI> (pointerp "this is not a pointer")
@result{} NIL
@end lisp

@subheading See Also
@seealso{make-pointer}
@seealso{null-pointer-p}


@c ===================================================================
@c POINTER-ADDRESS

@page
@node pointer-address, pointer-eq, pointerp, Pointers
@heading pointer-address
@subheading Syntax
@Function{pointer-address ptr @res{} address}

@subheading Arguments and Values

@table @var
@item ptr
A foreign pointer.

@item address
An integer.
@end table

@subheading Description
The function @code{pointer-address} will return the @var{address} of
a foreign pointer @var{ptr}.

@subheading Examples

@lisp
CFFI> (pointer-address (null-pointer))
@result{} 0
CFFI> (pointer-address (make-pointer 123))
@result{} 123
@end lisp

@subheading See Also
@seealso{make-pointer} @*
@seealso{inc-pointer} @*
@seealso{null-pointer} @*
@seealso{null-pointer-p} @*
@seealso{pointerp} @*
@seealso{pointer-eq} @*
@seealso{mem-ref}


@c ===================================================================
@c POINTER-EQ

@page
@node pointer-eq, with-foreign-object, pointer-address, Pointers
@heading pointer-eq
@subheading Syntax
@Function{pointer-eq ptr1 ptr2 @res{} boolean}

@subheading Arguments and Values

@table @var
@item ptr1
@itemx ptr2
A foreign pointer.

@item boolean
@code{T} or @code{NIL}.
@end table

@subheading Description
The function @code{pointer-eq} returns true if @var{ptr1} and
@var{ptr2} point to the same memory address and false otherwise.

@subheading Implementation-specific Notes
The representation of foreign pointers varies across the various Lisp
implementations as does the behaviour of the built-in Common Lisp
equality predicates. Comparing two pointers that point to the same
address with @code{EQ} Lisps will return true on some Lisps, others require
more general predicates like @code{EQL} or @code{EQUALP} and finally
some will return false using any of these predicates. Therefore, for
portability, you should use @code{POINTER-EQ}.

@subheading Examples
This is an example using @acronym{SBCL}, see the
implementation-specific notes above.

@lisp
CFFI> (eql (null-pointer) (null-pointer))
@result{} NIL
CFFI> (pointer-eq (null-pointer) (null-pointer))
@result{} T
@end lisp

@subheading See Also
@seealso{inc-pointer}


@c ===================================================================
@c WITH-FOREIGN-OBJECT

@page
@node with-foreign-object, with-foreign-pointer, pointer-eq, Pointers
@heading with-foreign-object, with-foreign-objects
@subheading Syntax
@Macro{with-foreign-object (var type &optional count) &body body}

@anchor{with-foreign-objects}
@Macro{with-foreign-objects (bindings) &body body}

bindings ::= @{(var type &optional count)@}*

@subheading Arguments and Values

@table @var
@item var
A symbol.

@item type
A foreign type, evaluated.

@item count
An integer.
@end table

@subheading Description
The macros @code{with-foreign-object} and @code{with-foreign-objects}
bind @var{var} to a pointer to @var{count} newly allocated objects
of type @var{type} during @var{body}. The buffer has dynamic extent
and may be stack allocated if supported by the host Lisp.

@subheading Examples

@lisp
CFFI> (with-foreign-object (array :int 10)
        (dotimes (i 10)
          (setf (mem-aref array :int i) (random 100)))
        (loop for i below 10
              collect (mem-aref array :int i)))
@result{} (22 7 22 52 69 1 46 93 90 65)
@end lisp

@subheading See Also
@seealso{foreign-alloc}


@c ===================================================================
@c WITH-FOREIGN-POINTER

@page
@node with-foreign-pointer,  , with-foreign-object, Pointers
@heading with-foreign-pointer
@subheading Syntax
@Macro{with-foreign-pointer (var size &optional size-var) &body body}

@subheading Arguments and Values

@table @var
@item var
@itemx size-var
A symbol.

@item size
An integer.

@item body
A list of forms to be executed.
@end table

@subheading Description
The @code{with-foreign-pointer} macro, binds @var{var} to @var{size}
bytes of foreign memory during @var{body}. The pointer in @var{var}
is invalid beyond the dynamic extend of @var{body} and may be
stack-allocated if supported by the implementation.

If @var{size-var} is supplied, it will be bound to @var{size} during
@var{body}.

@subheading Examples

@lisp
CFFI> (with-foreign-pointer (string 4 size)
        (setf (mem-ref string :char (1- size)) 0)
        (lisp-string-to-foreign "Popcorns" string size)
        (loop for i from 0 below size
              collect (code-char (mem-ref string :char i))))
@result{} (#\P #\o #\p #\Null)
@end lisp

@subheading See Also
@seealso{foreign-alloc} @*
@seealso{foreign-free}


@c ===================================================================
@c CHAPTER: Strings

@node Strings, Variables, Pointers, Top
@chapter Strings

As with many languages, Lisp and C have special support for logical
arrays of characters, going so far as to give them a special name,
``strings''.  In that spirit, @cffi{} provides special support for
translating between Lisp and C strings.

The @code{:string} type and the symbols related below also serve as an
example of what you can do portably with @cffi{}; were it not
included, you could write an equally functional @file{strings.lisp}
without referring to any implementation-specific symbols.

@menu
Dictionary

* *default-foreign-encoding*::
* foreign-string-alloc::
* foreign-string-free::
* foreign-string-to-lisp::
* lisp-string-to-foreign::
* with-foreign-string::
* with-foreign-strings::
* with-foreign-pointer-as-string::
@end menu


@c ===================================================================
@c *DEFAULT-FOREIGN-ENCODING*

@page
@node *default-foreign-encoding*, foreign-string-alloc, Strings, Strings
@heading *default-foreign-encoding*
@subheading Syntax

@Variable{*default-foreign-encoding*}

@subheading Value type

A keyword.

@subheading Initial value

@code{:utf-8}

@subheading Description

This special variable holds the default foreign encoding.

@subheading Examples

@lisp
CFFI> *default-foreign-encoding*
:utf-8
CFFI> (foreign-funcall "strdup" (:string :encoding :utf-16) "foo" :string)
"f"
CFFI> (let ((*default-foreign-encoding* :utf-16))
        (foreign-funcall "strdup" (:string :encoding :utf-16) "foo" :string))
"foo"
@end lisp

@subheading See also

@seealso{Other Types} (@code{:string} type) @*
@seealso{foreign-string-alloc} @*
@seealso{foreign-string-to-lisp} @*
@seealso{lisp-string-to-foreign} @*
@seealso{with-foreign-string} @*
@seealso{with-foreign-pointer-as-string}


@c ===================================================================
@c FOREIGN-STRING-ALLOC

@page
@node foreign-string-alloc, foreign-string-free, *default-foreign-encoding*, Strings
@heading foreign-string-alloc
@subheading Syntax
@Function{foreign-string-alloc string &key encoding null-terminated-p @
                               start end @res{} pointer}

@subheading Arguments and Values

@table @emph
@item @var{string}
A Lisp string.

@item @var{encoding}
Foreign encoding. Defaults to @code{*default-foreign-encoding*}.

@item @var{null-terminated-p}
Boolean, defaults to true.

@item @var{start}, @var{end}
Bounding index designators of @var{string}. 0 and @code{nil}, by
default.

@item @var{pointer}
A pointer to the newly allocated foreign string.
@end table

@subheading Description
The @code{foreign-string-alloc} function allocates foreign memory
holding a copy of @var{string} converted using the specified
@var{encoding}. @var{Start} specifies an offset into @var{string} and
@var{end} marks the position following the last element of the foreign
string.

This string must be freed with @code{foreign-string-free}.

If @var{null-terminated-p} is false, the string will not be
null-terminated.

@subheading Examples

@lisp
CFFI> (defparameter *str* (foreign-string-alloc "Hello, foreign world!"))
@result{} #
CFFI> (foreign-funcall "strlen" :pointer *str* :int)
@result{} 21
@end lisp

@subheading See Also
@seealso{foreign-string-free} @*
@seealso{with-foreign-string}
@c @seealso{:string}


@c ===================================================================
@c FOREIGN-STRING-FREE

@page
@node foreign-string-free, foreign-string-to-lisp, foreign-string-alloc, Strings
@heading foreign-string-free
@subheading Syntax
@Function{foreign-string-free pointer}

@subheading Arguments and Values

@table @var
@item pointer
A pointer to a string allocated by @code{foreign-string-alloc}.
@end table

@subheading Description
The @code{foreign-string-free} function frees a foreign string
allocated by @code{foreign-string-alloc}.

@subheading Examples

@subheading See Also
@seealso{foreign-string-alloc}


@c ===================================================================
@c FOREIGN-STRING-TO-LISP

@page
@node foreign-string-to-lisp, lisp-string-to-foreign, foreign-string-free, Strings
@heading foreign-string-to-lisp
@subheading Syntax
@Function{foreign-string-to-lisp ptr &key offset count max-chars @
                                 encoding @res{} string}

@subheading Arguments and Values

@table @var
@item ptr
A pointer.

@item offset
An integer greater than or equal to 0. Defauls to 0.

@item count
Either @code{nil} (the default), or an integer greater than or equal to 0.

@item max-chars
An integer greater than or equal to 0.
@code{(1- array-total-size-limit)}, by default.

@item encoding
Foreign encoding. Defaults to @code{*default-foreign-encoding*}.

@item string
A Lisp string.
@end table

@subheading Description
The @code{foreign-string-to-lisp} function converts at most
@var{count} octets from @var{ptr} into a Lisp string, using the
defined @var{encoding}.

If @var{count} is @code{nil} (the default), characters are copied
until @var{max-chars} is reached or a @code{NULL} character is found.

If @var{ptr} is a null pointer, returns @code{nil}.

Note that the @code{:string} type will automatically convert between
Lisp strings and foreign strings.

@subheading Examples

@lisp
CFFI> (foreign-funcall "getenv" :string "HOME" :pointer)
@result{} #
CFFI> (foreign-string-to-lisp *)
@result{} "/Users/luis"
@end lisp

@subheading See Also
@seealso{lisp-string-to-foreign} @*
@seealso{foreign-string-alloc}
@c @seealso{:string}


@c ===================================================================
@c LISP-STRING-TO-FOREIGN

@page
@node lisp-string-to-foreign, with-foreign-string, foreign-string-to-lisp, Strings
@heading lisp-string-to-foreign
@subheading Syntax
@Function{lisp-string-to-foreign string buffer bufsize &key start @
                                 end offset encoding @res{} buffer}

@subheading Arguments and Values

@table @emph
@item @var{string}
A Lisp string.

@item @var{buffer}
A foreign pointer.

@item @var{bufsize}
An integer.

@item @var{start}, @var{end}
Bounding index designators of @var{string}. 0 and @code{nil}, by
default.

@item @var{offset}
An integer greater than or equal to 0. Defauls to 0.

@item @var{encoding}
Foreign encoding. Defaults to @code{*default-foreign-encoding*}.
@end table

@subheading Description
The @code{lisp-string-to-foreign} function copies at most
@var{bufsize}-1 octets from a Lisp @var{string} using the specified
@var{encoding} into @var{buffer}+@var{offset}. The foreign string will
be null-terminated.

@var{Start} specifies an offset into @var{string} and
@var{end} marks the position following the last element of the foreign
string.

@subheading Examples

@lisp
CFFI> (with-foreign-pointer-as-string (str 255)
        (lisp-string-to-foreign "Hello, foreign world!" str 6))
@result{} "Hello"
@end lisp

@subheading See Also
@seealso{foreign-string-alloc} @*
@seealso{foreign-string-to-lisp} @*
@seealso{with-foreign-pointer-as-string}


@c ===================================================================
@c WITH-FOREIGN-STRING

@page
@node with-foreign-string, with-foreign-pointer-as-string, lisp-string-to-foreign, Strings
@heading with-foreign-string, with-foreign-strings
@subheading Syntax
@Macro{with-foreign-string (var-or-vars string &rest args) &body body}

@anchor{with-foreign-strings}
@Macro{with-foreign-strings (bindings) &body body}

var-or-vars ::= var | (var &optional octet-size-var)
bindings ::= @{(var-or-vars string &rest args)@}*

@subheading Arguments and Values

@table @emph
@item @var{var}, @var{byte-size-var}
A symbol.

@item @var{string}
A Lisp string.

@item @var{body}
A list of forms to be executed.
@end table

@subheading Description
The @code{with-foreign-string} macro will bind @var{var} to a newly
allocated foreign string containing @var{string}. @var{Args} is passed
to the underlying @code{foreign-string-alloc} call.

If @var{octet-size-var} is provided, it will be bound the length of
foreign string in octets including the null terminator.

@subheading Examples

@lisp
CFFI> (with-foreign-string (foo "12345")
        (foreign-funcall "strlen" :pointer foo :int))
@result{} 5

CFFI> (let ((array (coerce #(84 117 114 97 110 103 97)
                           '(array (unsigned-byte 8)))))
        (with-foreign-string (foreign-string array)
          (foreign-string-to-lisp foreign-string)))
@result{} "Turanga"
@end lisp

@subheading See Also
@seealso{foreign-string-alloc} @*
@seealso{with-foreign-pointer-as-string}


@c ===================================================================
@c WITH-FOREIGN-POINTER-AS-STRING

@page
@node with-foreign-pointer-as-string,  , with-foreign-string, Strings
@heading with-foreign-pointer-as-string
@subheading Syntax
@Macro{with-foreign-pointer-as-string (var size &optional size-var @
                                      &rest args) &body body @res{} string}

@subheading Arguments and Values

@table @var
@item var
A symbol.

@item string
A Lisp string.

@item body
List of forms to be executed.
@end table

@subheading Description
The @code{with-foreign-pointer-as-string} macro is similar to
@code{with-foreign-pointer} except that @var{var} is used as the
returned value of an implicit @code{progn} around @var{body}, after
being converted to a Lisp string using the provided @var{args}.

@subheading Examples

@lisp
CFFI> (with-foreign-pointer-as-string (str 6 str-size :encoding :ascii)
        (lisp-string-to-foreign "Hello, foreign world!" str str-size))
@result{} "Hello"
@end lisp

@subheading See Also
@seealso{foreign-string-alloc} @*
@seealso{with-foreign-string}


@c ===================================================================
@c CHAPTER: Variables

@node Variables, Functions, Strings, Top
@chapter Variables

@menu
Dictionary

* defcvar::
* get-var-pointer::
@end menu


@c ===================================================================
@c DEFCVAR

@page
@node defcvar, get-var-pointer, Variables, Variables
@heading defcvar
@subheading Syntax
@Macro{defcvar name-and-options type &optional documentation @res{} lisp-name}

@var{name-and-options} ::= name | (name &key read-only (library :default)) @*
@var{name} ::= lisp-name [foreign-name] | foreign-name [lisp-name]

@subheading Arguments and Values

@table @var
@item foreign-name
A string denoting a foreign function.

@item lisp-name
A symbol naming the Lisp function to be created.

@item type
A foreign type.

@item read-only
A boolean.

@item documentation
A Lisp string; not evaluated.
@end table

@subheading Description
The @code{defcvar} macro defines a symbol macro @var{lisp-name} that looks
up @var{foreign-name} and dereferences it acording to @var{type}.  It
can also be @code{setf}ed, unless @var{read-only} is true, in which
case an error will be signaled.

When one of @var{lisp-name} or @var{foreign-name} is omitted, the
other is automatically derived using the following rules:

@itemize
@item
Foreign names are converted to Lisp names by uppercasing, replacing
underscores with hyphens, and wrapping around asterisks.
@item
Lisp names are converted to foreign names by lowercasing, replacing
hyphens with underscores, and removing asterisks, if any.
@end itemize

@subheading Examples

@lisp
CFFI> (defcvar "errno" :int)
@result{} *ERRNO*
CFFI> (foreign-funcall "strerror" :int *errno* :string)
@result{} "Inappropriate ioctl for device"
CFFI> (setf *errno* 1)
@result{} 1
CFFI> (foreign-funcall "strerror" :int *errno* :string)
@result{} "Operation not permitted"
@end lisp

Trying to modify a read-only foreign variable:

@lisp
CFFI> (defcvar ("errno" +error-number+ :read-only t) :int)
@result{} +ERROR-NUMBER+
CFFI> (setf +error-number+ 12)
;; @lispcmt{@error{} Trying to modify read-only foreign var: +ERROR-NUMBER+.}
@end lisp

@emph{Note that accessing @code{errno} this way won't work with every
implementation of the C standard library.}

@subheading See Also
@seealso{get-var-pointer}


@c ===================================================================
@c GET-VAR-POINTER

@page
@node get-var-pointer,  , defcvar, Variables
@heading get-var-pointer
@subheading Syntax
@Function{get-var-pointer symbol @res{} pointer}

@subheading Arguments and Values

@table @var
@item symbol
A symbol denoting a foreign variable defined with @code{defcvar}.

@item pointer
A foreign pointer.
@end table

@subheading Description
The function @code{get-var-pointer} will return a @var{pointer} to the
foreign global variable @var{symbol} previously defined with
@code{defcvar}.

@subheading Examples

@lisp
CFFI> (defcvar "errno" :int :read-only t)
@result{} *ERRNO*
CFFI> *errno*
@result{} 25
CFFI> (get-var-pointer '*errno*)
@result{} #
CFFI> (mem-ref * :int)
@result{} 25
@end lisp

@subheading See Also
@seealso{defcvar}


@c ===================================================================
@c CHAPTER: Functions

@node Functions, Libraries, Variables, Top
@chapter Functions

@menu
@c * Defining Foreign Functions::
@c * Calling Foreign Functions::

Dictionary

* defcfun::
* foreign-funcall::
* foreign-funcall-pointer::
* translate-camelcase-name::
* translate-name-from-foreign::
* translate-name-to-foreign::
* translate-underscore-separated-name::
@end menu

@c @node Calling Foreign Functions
@c @section Calling Foreign Functions

@c @node Defining Foreign Functions
@c @section Defining Foreign Functions


@c ===================================================================
@c DEFCFUN

@page
@node defcfun, foreign-funcall, Functions, Functions
@heading defcfun
@subheading Syntax
@Macro{defcfun name-and-options return-type &body [docstring] arguments [&rest] @
               @res{} lisp-name}

@var{name-and-options} ::= name | (name &key library convention) @*
@var{name} ::= @var{lisp-name} [@var{foreign-name}] | @var{foreign-name} [@var{lisp-name}] @*
@var{arguments} ::= @{ (arg-name arg-type) @}* @*

@subheading Arguments and Values

@table @var
@item foreign-name
A string denoting a foreign function.

@item lisp-name
A symbol naming the Lisp function to be created.

@item arg-name
A symbol.

@item return-type
@itemx arg-type
A foreign type.

@item convention
One of @code{:cdecl} (default) or @code{:stdcall}.

@item library
A symbol designating a foreign library.

@item docstring
A documentation string.
@end table

@subheading Description
The @code{defcfun} macro provides a declarative interface for defining
Lisp functions that call foreign functions.

When one of @var{lisp-name} or @var{foreign-name} is omitted, the
other is automatically derived using the following rules:

@itemize
@item
Foreign names are converted to Lisp names by uppercasing and replacing
underscores with hyphens.
@item
Lisp names are converted to foreign names by lowercasing and replacing
hyphens with underscores.
@end itemize

If you place the symbol @code{&rest} in the end of the argument list
after the fixed arguments, @code{defcfun} will treat the foreign
function as a @strong{variadic function}. The variadic arguments
should be passed in a way similar to what @code{foreign-funcall} would
expect. Unlike @code{foreign-funcall} though, @code{defcfun} will take
care of doing argument promotion. Note that in this case
@code{defcfun} will generate a Lisp @emph{macro} instead of a
function and will only work for Lisps that support
@code{foreign-funcall.}

If a foreign structure is to be passed or returned by value (that is,
the type is of the form @code{(:struct ...)}), then the cffi-libffi system
must be loaded, which in turn depends on
@uref{http://sourceware.org/libffi/,libffi}, including the header files.
Failure to load that system will result in an error.
Variadic functions cannot at present accept or return structures by
value.

@subheading Examples

@lisp
(defcfun "strlen" :int
  "Calculate the length of a string."
  (n :string))

CFFI> (strlen "123")
@result{} 3
@end lisp

@lisp
(defcfun ("abs" c-abs) :int (n :int))

CFFI> (c-abs -42)
@result{} 42
@end lisp

Function without arguments:

@lisp
(defcfun "rand" :int)

CFFI> (rand)
@result{} 1804289383
@end lisp

Variadic function example:

@lisp
(defcfun "sprintf" :int
  (str :pointer)
  (control :string)
  &rest)

CFFI> (with-foreign-pointer-as-string (s 100)
        (sprintf s "%c %d %.2f %s" :char 90 :short 42 :float pi
                 :string "super-locrian"))
@result{} "A 42 3.14 super-locrian"
@end lisp

@subheading See Also
@seealso{foreign-funcall} @*
@seealso{foreign-funcall-pointer}


@c ===================================================================
@c FOREIGN-FUNCALL

@page
@node foreign-funcall, foreign-funcall-pointer, defcfun, Functions
@heading foreign-funcall
@subheading Syntax
@Macro{foreign-funcall name-and-options &rest arguments @res{} return-value}

arguments ::= @{ arg-type arg @}* [return-type]
name-and-options ::= name | ( name &key library convention)

@subheading Arguments and Values

@table @var
@item name
A Lisp string.

@item arg-type
A foreign type.

@item arg
An argument of type @var{arg-type}.

@item return-type
A foreign type, @code{:void} by default.

@item return-value
A lisp object.

@item library
A lisp symbol; not evaluated.

@item convention
One of @code{:cdecl} (default) or @code{:stdcall}.
@end table

@subheading Description
The @code{foreign-funcall} macro is the main primitive for calling
foreign functions.

If a foreign structure is to be passed or returned by value (that is,
the type is of the form @code{(:struct ...)}), then the cffi-libffi system
must be loaded, which in turn depends on
@uref{http://sourceware.org/libffi/,libffi}, including the header files.
Failure to load that system will result in an error.
Variadic functions cannot at present accept or return structures by
value.

@emph{Note: The return value of foreign-funcall on functions with a
:void return type is still undefined.}

@subheading Implementation-specific Notes
@itemize
@item
Corman Lisp does not support @code{foreign-funcall}. On
implementations that @strong{don't} support @code{foreign-funcall}
@code{cffi-sys::no-foreign-funcall} will be present in
@code{*features*}. Note: in these Lisps you can still use the
@code{defcfun} interface.
@end itemize

@subheading Examples

@lisp
CFFI> (foreign-funcall "strlen" :string "foo" :int)
@result{} 3
@end lisp

Given the C code:

@example
void print_number(int n)
@{
    printf("N: %d\n", n);
@}
@end example

@lisp
CFFI> (foreign-funcall "print_number" :int 123456)
@print{} N: 123456
@result{} NIL
@end lisp

@noindent
Or, equivalently:

@lisp
CFFI> (foreign-funcall "print_number" :int 123456 :void)
@print{} N: 123456
@result{} NIL
@end lisp

@lisp
CFFI> (foreign-funcall "printf" :string (format nil "%s: %d.~%")
                       :string "So long and thanks for all the fish"
                       :int 42 :int)
@print{} So long and thanks for all the fish: 42.
@result{} 41
@end lisp

@subheading See Also
@seealso{defcfun} @*
@seealso{foreign-funcall-pointer}


@c ===================================================================
@c FOREIGN-FUNCALL-POINTER

@page
@node foreign-funcall-pointer,  translate-camelcase-name, foreign-funcall, Functions
@heading foreign-funcall-pointer
@subheading Syntax
@Macro{foreign-funcall-pointer pointer options &rest arguments @res{} return-value}

arguments ::= @{ arg-type arg @}* [return-type]
options ::= ( &key convention )

@subheading Arguments and Values

@table @var
@item pointer
A foreign pointer.

@item arg-type
A foreign type.

@item arg
An argument of type @var{arg-type}.

@item return-type
A foreign type, @code{:void} by default.

@item return-value
A lisp object.

@item convention
One of @code{:cdecl} (default) or @code{:stdcall}.
@end table

@subheading Description
The @code{foreign-funcall} macro is the main primitive for calling
foreign functions.

@emph{Note: The return value of foreign-funcall on functions with a
:void return type is still undefined.}

@subheading Implementation-specific Notes
@itemize
@item
Corman Lisp does not support @code{foreign-funcall}. On
implementations that @strong{don't} support @code{foreign-funcall}
@code{cffi-sys::no-foreign-funcall} will be present in
@code{*features*}. Note: in these Lisps you can still use the
@code{defcfun} interface.
@end itemize

@subheading Examples

@lisp
CFFI> (foreign-funcall-pointer (foreign-symbol-pointer "abs") ()
                               :int -42 :int)
@result{} 42
@end lisp

@subheading See Also
@seealso{defcfun} @*
@seealso{foreign-funcall}


@c ===================================================================
@c TRANSLATE-CAMELCASE-NAME

@page
@node translate-camelcase-name, translate-name-from-foreign, foreign-funcall-pointer, Functions
@heading translate-camelcase-name
@subheading Syntax
@Function{translate-camelcase-name name &key upper-initial-p special-words @res{} return-value}

@subheading Arguments and Values

@table @var
@item name
Either a symbol or a string.

@item upper-initial-p
A generalized boolean.

@item special words
A list of strings.

@item return-value
If @var{name} is a symbol, this is a string, and vice versa.
@end table

@subheading Description
@code{translate-camelcase-name} is a helper function for
specializations of @code{translate-name-from-foreign} and
@code{translate-name-to-foreign}. It handles the common case of
converting between foreign camelCase names and lisp
names. @var{upper-initial-p} indicates whether the first letter of the
foreign name should be uppercase. @var{special-words} is a list of
strings that should be treated atomically in translation. This list is
case-sensitive.

@subheading Examples

@lisp
CFFI> (translate-camelcase-name some-xml-function)
@result{} "someXmlFunction"
CFFI> (translate-camelcase-name some-xml-function :upper-initial-p t)
@result{} "SomeXmlFunction"
CFFI> (translate-camelcase-name some-xml-function :special-words '("XML"))
@result{} "someXMLFunction"
CFFI> (translate-camelcase-name "someXMLFunction")
@result{} SOME-X-M-L-FUNCTION
CFFI> (translate-camelcase-name "someXMLFunction" :special-words '("XML"))
@result{} SOME-XML-FUNCTION
@end lisp

@subheading See Also
@seealso{translate-name-from-foreign} @*
@seealso{translate-name-to-foreign} @*
@seealso{translate-underscore-separated-name}


@c ===================================================================
@c TRANSLATE-NAME-FROM-FOREIGN

@page
@node translate-name-from-foreign, translate-name-to-foreign, translate-camelcase-name, Functions
@heading translate-name-from-foreign
@subheading Syntax
@Function{translate-name-from-foreign foreign-name package &optional varp @res{} symbol}

@subheading Arguments and Values

@table @var
@item foreign-name
A string denoting a foreign function.

@item package
A Lisp package

@item varp
A generalized boolean.

@item symbol
The Lisp symbol to be used a function name.
@end table

@subheading Description
@code{translate-name-from-foreign} is used by @ref{defcfun} to handle
the conversion of foreign names to lisp names. By default, it
translates using @ref{translate-underscore-separated-name}. However,
you can create specialized methods on this function to make
translating more closely match the foreign library's naming
conventions.

Specialize @var{package} on some package. This allows other packages
to load libraries with different naming conventions.

@subheading Examples

@lisp
CFFI> (defcfun "someXmlFunction" ...)
@result{} SOMEXMLFUNCTION
CFFI> (defmethod translate-name-from-foreign ((spec string)
                                              (package (eql *package*))
                                              &optional varp)
        (let ((name (translate-camelcase-name spec)))
          (if varp (intern (format nil "*~a*" name)) name)))
@result{} #))>
CFFI> (defcfun "someXmlFunction" ...)
@result{} SOME-XML-FUNCTION
@end lisp

@subheading See Also
@seealso{defcfun} @*
@seealso{translate-camelcase-name} @*
@seealso{translate-name-to-foreign} @*
@seealso{translate-underscore-separated-name}


@c ===================================================================
@c TRANSLATE-NAME-TO-FOREIGN

@page
@node translate-name-to-foreign, translate-underscore-separated-name, translate-name-from-foreign, Functions
@heading translate-name-to-foreign
@subheading Syntax
@Function{translate-name-to-foreign lisp-name package &optional varp @res{} string}

@subheading Arguments and Values

@table @var
@item lisp-name
A symbol naming the Lisp function to be created.

@item package
A Lisp package

@item varp
A generalized boolean.

@item string
The string representing the foreign function name.
@end table

@subheading Description
@code{translate-name-to-foreign} is used by @ref{defcfun} to handle
the conversion of lisp names to foreign names. By default, it
translates using @ref{translate-underscore-separated-name}. However,
you can create specialized methods on this function to make
translating more closely match the foreign library's naming
conventions.

Specialize @var{package} on some package. This allows other packages
to load libraries with different naming conventions.

@subheading Examples

@lisp
CFFI> (defcfun some-xml-function ...)
@result{} "some_xml_function"
CFFI> (defmethod translate-name-to-foreign ((spec symbol)
                                            (package (eql *package*))
                                            &optional varp)
        (let ((name (translate-camelcase-name spec)))
          (if varp (subseq name 1 (1- (length name))) name)))
@result{} #))>
CFFI> (defcfun some-xml-function ...)
@result{} "someXmlFunction"
@end lisp

@subheading See Also
@seealso{defcfun} @*
@seealso{translate-camelcase-name} @*
@seealso{translate-name-from-foreign} @*
@seealso{translate-underscore-separated-name}


@c ===================================================================
@c TRANSLATE-UNDERSCORE-SEPARATED-NAME

@page
@node translate-underscore-separated-name,  , translate-name-to-foreign, Functions
@heading translate-underscore-separated-name
@subheading Syntax
@Function{translate-underscore-separated-name name @res{} return-value}

@subheading Arguments and Values

@table @var
@item name
Either a symbol or a string.

@item return-value
If @var{name} is a symbol, this is a string, and vice versa.
@end table

@subheading Description
@code{translate-underscore-separated-name} is a helper function for
specializations of @ref{translate-name-from-foreign} and
@ref{translate-name-to-foreign}. It handles the common case of
converting between foreign underscore_separated names and lisp names.

@subheading Examples

@lisp
CFFI> (translate-underscore-separated-name some-xml-function)
@result{} "some_xml_function"
CFFI> (translate-camelcase-name "some_xml_function")
@result{} SOME-XML-FUNCTION
@end lisp

@subheading See Also
@seealso{translate-name-from-foreign} @*
@seealso{translate-name-to-foreign} @*
@seealso{translate-camelcase-name}


@c ===================================================================
@c CHAPTER: Libraries

@node Libraries, Callbacks, Functions, Top
@chapter Libraries

@menu
* Defining a library::
* Library definition style::

Dictionary

* close-foreign-library::       Close a foreign library.
* *darwin-framework-directories*::  Search path for Darwin frameworks.
* define-foreign-library::      Explain how to load a foreign library.
* *foreign-library-directories*::  Search path for shared libraries.
* load-foreign-library::        Load a foreign library.
* load-foreign-library-error::  Signalled on failure of its namesake.
* use-foreign-library::         Load a foreign library when needed.
@end menu


@node Defining a library, Library definition style, Libraries, Libraries
@section Defining a library

Almost all foreign code you might want to access exists in some kind
of shared library.  The meaning of @dfn{shared library} varies among
platforms, but for our purposes, we will consider it to include
@file{.so} files on @sc{unix}, frameworks on Darwin (and derivatives
like Mac @acronym{OS X}), and @file{.dll} files on Windows.

Bringing one of these libraries into the Lisp image is normally a
two-step process.

@enumerate
@item
Describe to @cffi{} how to load the library at some future point,
depending on platform and other factors, with a
@code{define-foreign-library} top-level form.

@item
Load the library so defined with either a top-level
@code{use-foreign-library} form or by calling the function
@code{load-foreign-library}.
@end enumerate

@xref{Tutorial-Loading,, Loading foreign libraries}, for a working
example of the above two steps.


@node Library definition style, close-foreign-library, Defining a library, Libraries
@section Library definition style

Looking at the @code{libcurl} library definition presented earlier,
you may ask why we did not simply do this:

@lisp
(define-foreign-library libcurl
  (t (:default "libcurl")))
@end lisp

@noindent
Indeed, this would work just as well on the computer on which I tested
the tutorial.  There are a couple of good reasons to provide the
@file{.so}'s current version number, however.  Namely, the versionless
@file{.so} is not packaged on most @sc{unix} systems along with the
actual, fully-versioned library; instead, it is included in the
``development'' package along with C headers and static @file{.a}
libraries.

The reason @cffi{} does not try to account for this lies in the
meaning of the version numbers.  A full treatment of shared library
versions is beyond this manual's scope; see @ref{Versioning,, Library
interface versions, libtool, @acronym{GNU} Libtool}, for helpful
information for the unfamiliar.  For our purposes, consider that a
mismatch between the library version with which you tested and the
installed library version may cause undefined
behavior.@footnote{Windows programmers may chafe at adding a
@sc{unix}-specific clause to @code{define-foreign-library}.  Instead,
ask why the Windows solution to library incompatibility is ``include
your own version of every library you use with every program''.}

@impnote{Maybe some notes should go here about OS X, which I know
little about.  --stephen}


@c ===================================================================
@c CLOSE-FOREIGN-LIBRARY

@page
@node close-foreign-library, *darwin-framework-directories*, Library definition style, Libraries
@heading close-foreign-library
@subheading Syntax
@Function{close-foreign-library library @res{} success}

@subheading Arguments and Values

@table @var
@item library
A symbol or an instance of @code{foreign-library}.

@item success
A Lisp boolean.
@end table

@subheading Description

Closes @var{library} which can be a symbol designating a library
define through @code{define-foreign-library} or an instance of
@code{foreign-library} as returned by @code{load-foreign-library}.

@c @subheading Examples
@c @xref{Tutorial-Loading,, Loading foreign libraries}.

@subheading See Also

@seealso{define-foreign-library} @*
@seealso{load-foreign-library} @*
@seealso{use-foreign-library}


@c ===================================================================
@c *DARWIN-FRAMEWORK-DIRECTORIES*

@page
@node *darwin-framework-directories*, define-foreign-library, close-foreign-library, Libraries
@heading *darwin-framework-directories*
@subheading Syntax

@Variable{*darwin-framework-directories*}

@subheading Value type

A list, in which each element is a string, a pathname, or a simple
Lisp expression.

@subheading Initial value

A list containing the following, in order: an expression corresponding
to Darwin path @file{~/Library/Frameworks/},
@code{#P"/Library/Frameworks/"}, and
@code{#P"/System/Library/Frameworks/"}.

@subheading Description

The meaning of ``simple Lisp expression'' is explained in
@ref{*foreign-library-directories*}.  In contrast to that variable,
this is not a fallback search path; the default value described above
is intended to be a reasonably complete search path on Darwin systems.

@subheading Examples

@lisp
CFFI> (let ((lib (load-foreign-library '(:framework "OpenGL"))))
        (foreign-library-pathname lib))
@result{} #P"/System/Library/Frameworks/OpenGL.framework/OpenGL"
@end lisp

@subheading See also

@seealso{*foreign-library-directories*} @*
@seealso{define-foreign-library}


@c ===================================================================
@c DEFINE-FOREIGN-LIBRARY

@page
@node define-foreign-library, *foreign-library-directories*, *darwin-framework-directories*, Libraries
@heading define-foreign-library

@subheading Syntax

@Macro{define-foreign-library name-and-options @{ load-clause @}* @res{} name}

name-and-options ::= name | (name &key convention search-path)
load-clause ::= (feature library &key convention search-path)

@subheading Arguments and Values

@table @var
@item name
A symbol.

@item feature
A feature expression.

@item library
A library designator.

@item convention
One of @code{:cdecl} (default) or @code{:stdcall}

@item search-path
A path or list of paths where the library will be searched if not found in
system-global directories. Paths specified in a load clause take priority over
paths specified as library option, with *foreign-library-directories* having
lowest priority.
@end table

@subheading Description

Creates a new library designator called @var{name}.  The
@var{load-clause}s describe how to load that designator when passed to
@code{load-foreign-library} or @code{use-foreign-library}.

When trying to load the library @var{name}, the relevant function
searches the @var{load-clause}s in order for the first one where
@var{feature} evaluates to true.  That happens for any of the
following situations:

@enumerate 1
@item
If @var{feature} is a symbol present in @code{common-lisp:*features*}.

@item
If @var{feature} is a list, depending on @code{(first @var{feature})},
a keyword:

@table @code
@item :and
All of the feature expressions in @code{(rest @var{feature})} are
true.

@item :or
At least one of the feature expressions in @code{(rest @var{feature})}
is true.

@item :not
The feature expression @code{(second @var{feature})} is not true.
@end table

@item
Finally, if @var{feature} is @code{t}, this @var{load-clause} is
picked unconditionally.
@end enumerate

Upon finding the first true @var{feature}, the library loader then
loads the @var{library}.  The meaning of ``library designator'' is
described in @ref{load-foreign-library}.

Functions associated to a library defined by
@code{define-foreign-library} (e.g. through @code{defcfun}'s
@code{:library} option, will inherit the library's options.  The
precedence is as follows:

@enumerate 1
@item
@code{defcfun}/@code{foreign-funcall} specific options;

@item
@var{load-clause} options;

@item
global library options (the @var{name-and-options} argument)
@end enumerate


@subheading Examples

@xref{Tutorial-Loading,, Loading foreign libraries}.


@subheading See Also

@seealso{close-foreign-library} @*
@seealso{load-foreign-library}


@c ===================================================================
@c *FOREIGN-LIBRARY-DIRECTORIES*

@page
@node *foreign-library-directories*, load-foreign-library, define-foreign-library, Libraries
@heading *foreign-library-directories*
@subheading Syntax

@Variable{*foreign-library-directories*}

@subheading Value type

A list, in which each element is a string, a pathname, or a simple
Lisp expression.

@subheading Initial value

The empty list.

@subheading Description

You should not have to use this variable.

Most, if not all, Lisps supported by @cffi{} have a reasonable default
search algorithm for foreign libraries.  For example, Lisps for
@sc{unix} usually call
@uref{http://www.opengroup.org/onlinepubs/009695399/functions/dlopen.html,,
@code{dlopen(3)}}, which in turn looks in the system library
directories.  Only if that fails does @cffi{} look for the named
library file in these directories, and load it from there if found.

Thus, this is intended to be a @cffi{}-only fallback to the library
search configuration provided by your operating system.  For example,
if you distribute a foreign library with your Lisp package, you can
add the library's containing directory to this list and portably
expect @cffi{} to find it.

A @dfn{simple Lisp expression} is intended to provide functionality
commonly used in search paths such as
@acronym{ASDF}'s@footnote{@xref{Using asdf to load systems,,, asdf,
asdf: another system definition facility}, for information on
@code{asdf:*central-registry*}.}, and is defined recursively as
follows:@footnote{See @code{mini-eval} in @file{libraries.lisp} for
the source of this definition.  As is always the case with a Lisp
@code{eval}, it's easier to understand the Lisp definition than the
english.}

@enumerate
@item
A list, whose @samp{first} is a function designator, and whose
@samp{rest} is a list of simple Lisp expressions to be evaluated and
passed to the so-designated function.  The result is the result of the
function call.

@item
A symbol, whose result is its symbol value.

@item
Anything else evaluates to itself.
@end enumerate

The result of evaluating the @dfn{simple Lisp expression} should yield
a @emph{designator} for a @emph{list} of @emph{pathname designators}.

@strong{Note}: in Common Lisp, @code{#p"/foo/bar"} designates the
@emph{bar} file within the @emph{/foo} directory whereas
@code{#p"/foo/bar/"} designates the @emph{/foo/bar} directory. Keep
that in mind when customising the value of
@code{*foreign-library-directories*}.


@subheading Examples

@example
$ ls
@print{} liblibli.so    libli.lisp
@end example

@noindent
In @file{libli.lisp}:

@lisp
(pushnew #P"/home/sirian/lisp/libli/" *foreign-library-directories*
         :test #'equal)

(load-foreign-library '(:default "liblibli"))
@end lisp

@noindent
The following example would achieve the same effect:

@lisp
(pushnew '(merge-pathnames #p"lisp/libli/" (user-homedir-pathname))
          *foreign-library-directories*
          :test #'equal)
@result{} ((MERGE-PATHNAMES #P"lisp/libli/" (USER-HOMEDIR-PATHNAME)))

(load-foreign-library '(:default "liblibli"))
@end lisp

@subheading See also

@seealso{*darwin-framework-directories*} @*
@seealso{define-foreign-library}


@c ===================================================================
@c LOAD-FOREIGN-LIBRARY

@page
@node load-foreign-library, load-foreign-library-error, *foreign-library-directories*, Libraries
@heading load-foreign-library
@subheading Syntax
@Function{load-foreign-library library-designator @res{} library}

@subheading Arguments and Values

@table @var
@item library-designator
A library designator.

@item library-designator
An instance of @code{foreign-library}.
@end table

@subheading Description

Load the library indicated by @var{library-designator}. A @dfn{library
designator} is defined as follows:

@enumerate
@item
If a symbol, is considered a name previously defined with
@code{define-foreign-library}.

@item
If a string or pathname, passed as a namestring directly to the
implementation's foreign library loader.  If that fails, search the
directories in @code{*foreign-library-directories*} with
@code{cl:probe-file}; if found, the absolute path is passed to the
implementation's loader.

@item
If a list, the meaning depends on @code{(first @var{library})}:

@table @code
@item :framework
The second list element is taken to be a Darwin framework name, which
is then searched in @code{*darwin-framework-directories*}, and loaded
when found.

@item :or
Each remaining list element, itself a library designator, is loaded in
order, until one succeeds.

@item :default
The name is transformed according to the platform's naming convention
to shared libraries, and the resultant string is loaded as a library
designator.  For example, on @sc{unix}, the name is suffixed with
@file{.so}.
@end table
@end enumerate

If the load fails, signal a @code{load-foreign-library-error}.

@strong{Please note:} For system libraries, you should not need to
specify the directory containing the library.  Each operating system
has its own idea of a default search path, and you should rely on it
when it is reasonable.

@subheading Implementation-specific Notes
On ECL platforms where its dynamic FFI is not supported (ie. when
@code{:dffi} is not present in @code{*features*}),
@code{cffi:load-foreign-library} does not work and you must use ECL's
own @code{ffi:load-foreign-library} with a constant string argument.

@subheading Examples

@xref{Tutorial-Loading,, Loading foreign libraries}.

@subheading See Also

@seealso{close-foreign-library} @*
@seealso{*darwin-framework-directories*} @*
@seealso{define-foreign-library} @*
@seealso{*foreign-library-directories*} @*
@seealso{load-foreign-library-error} @*
@seealso{use-foreign-library}


@c ===================================================================
@c LOAD-FOREIGN-LIBRARY-ERROR

@page
@node load-foreign-library-error, use-foreign-library, load-foreign-library, Libraries
@heading load-foreign-library-error

@subheading Syntax

@Condition{load-foreign-library-error}

@subheading Class precedence list

@code{load-foreign-library-error}, @code{error},
@code{serious-condition}, @code{condition}, @code{t}

@subheading Description

Signalled when a foreign library load completely fails.  The exact
meaning of this varies depending on the real conditions at work, but
almost universally, the implementation's error message is useless.
However, @cffi{} does provide the useful restarts @code{retry} and
@code{use-value}; invoke the @code{retry} restart to try loading the
foreign library again, or the @code{use-value} restart to try loading
a different foreign library designator.

@subheading See also

@seealso{load-foreign-library}


@c ===================================================================
@c USE-FOREIGN-LIBRARY

@page
@node use-foreign-library,  , load-foreign-library-error, Libraries
@heading use-foreign-library

@subheading Syntax

@Macro{use-foreign-library name}

@subheading Arguments and values

@table @var
@item name
A library designator; unevaluated.
@end table


@subheading Description

@xref{load-foreign-library}, for the meaning of ``library
designator''.  This is intended to be the top-level form used
idiomatically after a @code{define-foreign-library} form to go ahead
and load the library. @c ; it also sets the ``current foreign library''.
Finally, on implementations where the regular evaluation rule is
insufficient for foreign library loading, it loads it at the required
time.@footnote{Namely, @acronym{CMUCL}.  See
@code{use-foreign-library} in @file{libraries.lisp} for details.}

@c current foreign library is a concept created a few hours ago as of
@c this writing.  It is not actually used yet, but probably will be.

@subheading Examples

@xref{Tutorial-Loading,, Loading foreign libraries}.


@subheading See also

@seealso{load-foreign-library}


@c ===================================================================
@c CHAPTER: Callbacks

@node Callbacks, The Groveller, Libraries, Top
@chapter Callbacks

@menu
Dictionary

* callback::
* defcallback::
* get-callback::
@end menu


@c ===================================================================
@c CALLBACK

@page
@node callback, defcallback, Callbacks, Callbacks
@heading callback
@subheading Syntax
@Macro{callback symbol @res{} pointer}

@subheading Arguments and Values

@table @var
@item symbol
A symbol denoting a callback.

@item pointer
@itemx new-value
A pointer.
@end table

@subheading Description
The @code{callback} macro is analogous to the standard CL special
operator @code{function} and will return a pointer to the callback
denoted by the symbol @var{name}.

@subheading Examples

@lisp
CFFI> (defcallback sum :int ((a :int) (b :int))
        (+ a b))
@result{} SUM
CFFI> (callback sum)
@result{} #
@end lisp

@subheading See Also
@seealso{get-callback} @*
@seealso{defcallback}


@c ===================================================================
@c DEFCALLBACK

@page
@node defcallback, get-callback, callback, Callbacks
@heading defcallback
@subheading Syntax
@Macro{defcallback name-and-options return-type arguments &body body @res{} name}

name-and-options ::= name | (name &key convention)
arguments ::= (@{ (arg-name arg-type) @}*)

@subheading Arguments and Values

@table @var
@item name
A symbol naming the callback created.

@item return-type
The foreign type for the callback's return value.

@item arg-name
A symbol.

@item arg-type
A foreign type.

@item convention
One of @code{:cdecl} (default) or @code{:stdcall}.
@end table

@subheading Description
The @code{defcallback} macro defines a Lisp function that can be called
from C. The arguments passed to this function will be converted to the
appropriate Lisp representation and its return value will be converted
to its C representation.

This Lisp function can be accessed by the @code{callback} macro or the
@code{get-callback} function.

@strong{Portability note:} @code{defcallback} will not work correctly
on some Lisps if it's not a top-level form.

@subheading Examples

@lisp
(defcfun "qsort" :void
  (base :pointer)
  (nmemb :int)
  (size :int)
  (fun-compar :pointer))

(defcallback < :int ((a :pointer) (b :pointer))
  (let ((x (mem-ref a :int))
        (y (mem-ref b :int)))
    (cond ((> x y) 1)
          ((< x y) -1)
          (t 0))))

CFFI> (with-foreign-object (array :int 10)
        ;; @lispcmt{Initialize array.}
        (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
              do (setf (mem-aref array :int i) n))
        ;; @lispcmt{Sort it.}
        (qsort array 10 (foreign-type-size :int) (callback <))
        ;; @lispcmt{Return it as a list.}
        (loop for i from 0 below 10
              collect (mem-aref array :int i)))
@result{} (1 2 3 4 5 6 7 8 9 10)
@end lisp

@subheading See Also
@seealso{callback} @*
@seealso{get-callback}


@c ===================================================================
@c GET-CALLBACK

@page
@node get-callback,  , defcallback, Callbacks
@heading get-callback
@subheading Syntax
@Accessor{get-callback symbol @res{} pointer}

@subheading Arguments and Values

@table @var
@item symbol
A symbol denoting a callback.

@item pointer
A pointer.
@end table

@subheading Description
This is the functional version of the @code{callback} macro. It
returns a pointer to the callback named by @var{symbol} suitable, for
example, to pass as arguments to foreign functions.

@subheading Examples

@lisp
CFFI> (defcallback sum :int ((a :int) (b :int))
        (+ a b))
@result{} SUM
CFFI> (get-callback 'sum)
@result{} #
@end lisp

@subheading See Also
@seealso{callback} @*
@seealso{defcallback}


@c ===================================================================
@c CHAPTER: The Groveller

@node The Groveller, Limitations, Callbacks, Top
@chapter The Groveller

@cffi{}-Grovel is a tool which makes it easier to write @cffi{}
declarations for libraries that are implemented in C.  That is, it
grovels through the system headers, getting information about types
and structures, so you don't have to.  This is especially important
for libraries which are implemented in different ways by different
vendors, such as the @sc{unix}/@sc{posix} functions.  The @cffi{}
declarations are usually quite different from platform to platform,
but the information you give to @cffi{}-Grovel is the same.  Hence,
much less work is required!

If you use @acronym{ASDF}, @cffi{}-Grovel is integrated, so that it
will run automatically when your system is building.  This feature was
inspired by SB-Grovel, a similar @acronym{SBCL}-specific project.
@cffi{}-Grovel can also be used without @acronym{ASDF}.

@section Building FFIs with CFFI-Grovel

@cffi{}-Grovel uses a specification file (*.lisp) describing the
features that need groveling.  The C compiler is used to retrieve this
data and write a Lisp file (*.cffi.lisp) which contains the necessary
@cffi{} definitions to access the variables, structures, constants, and
enums mentioned in the specification.

@c This is most similar to the SB-Grovel package, upon which it is
@c based.  Unlike SB-Grovel, we do not currently support defining
@c regular foreign functions in the specification file; those are best
@c defined in normal Lisp code.

@cffi{}-Grovel provides an @acronym{ASDF} component for handling the
necessary calls to the C compiler and resulting file management.

@c See the included CFFI-Unix package for an example of how to
@c integrate a specification file with ASDF-built packages.

@menu
* Groveller Syntax::            How grovel files should look like.
* Groveller ASDF Integration::  ASDF components for grovel files.
* Groveller Implementation Notes:: Implementation notes.
@end menu

@node Groveller Syntax, Groveller ASDF Integration, The Groveller, The Groveller
@section Specification File Syntax

The specification files are read by the normal Lisp reader, so they
have syntax very similar to normal Lisp code.  In particular,
semicolon-comments and reader-macros will work as expected.

There are several forms recognized by @cffi{}-Grovel:

@deffn {Grovel Form} progn &rest forms

Processes a list of forms. Useful for conditionalizing several
forms. For example:
@end deffn

@lisp
#+freebsd
(progn
  (constant (ev-enable "EV_ENABLE"))
  (constant (ev-disable "EV_DISABLE")))
@end lisp

@deffn {Grovel Form} include &rest files

Include the specified files (specified as strings) in the generated C
source code.
@end deffn

@deffn {Grovel Form} in-package symbol

Set the package to be used for the final Lisp output.
@end deffn

@deffn {Grovel Form} ctype lisp-name size-designator

Define a @cffi{} foreign type for the string in @var{size-designator},
e.g. @code{(ctype :pid "pid_t")}.
@end deffn

@deffn {Grovel Form} constant (lisp-name &rest c-names) &key type documentation optional

Search for the constant named by the first @var{c-name} string found
to be known to the C preprocessor and define it as @var{lisp-name}.

The @var{type} keyword argument specifies how to grovel the constant:
either @code{integer} (the default) or @code{double-float}. If
@var{optional} is true, no error will be raised if all the
@var{c-names} are unknown. If @var{lisp-name} is a keyword, the actual
constant will be a symbol of the same name interned in the current
package.
@end deffn

@deffn {Grovel Form} define name &optional value

Defines an additional C preprocessor symbol, which is useful for
altering the behavior of included system headers.
@end deffn

@deffn {Grovel Form} cc-flags &rest flags

Adds @var{cc-flags} to the command line arguments used for the C compiler
invocation.
@end deffn

@deffn {Grovel Form} pkg-config-cflags pkg &key optional

Adds @var{pkg} to the command line arguments for the external program
@code{pkg-config} and runs it to retrieve the relevant include flags
used for the C compiler invocation. This syntax can be used instead of
hard-coding paths using @code{cc-flags}, and ensures that include
flags are added correctly on the build system. Assumes
@code{pkg-config} is installed and working.  @var{pkg} is a string
that identifies an installed @code{pkg-config} package. See the
pkg-config manual for more information. If @var{optional} is true,
failure to execute @code{pkg-config} does @emph{not} abort
compilation.
@end deffn

@deffn {Grovel Form} cstruct lisp-name c-name slots

Define a @cffi{} foreign struct with the slot data specfied.  Slots
are of the form @code{(lisp-name c-name &key type count (signed t))}.
@end deffn

@deffn {Grovel Form} cunion lisp-name c-name slots

Identical to @code{cstruct}, but defines a @cffi{} foreign union.
@end deffn

@deffn {Grovel Form} cstruct-and-class c-name slots

Defines a @cffi{} foreign struct, as with @code{cstruct} and defines a
@acronym{CLOS} class to be used with it.  This is useful for mapping
foreign structures to application-layer code that shouldn't need to
worry about memory allocation issues.
@end deffn

@deffn {Grovel Form} cvar namespec type &key read-only

Defines a foreign variable of the specified type, even if that
variable is potentially a C preprocessor pseudo-variable.  e.g.
@code{(cvar ("errno" errno) errno-values)}, assuming that errno-values
is an enum or equivalent to type @code{:int}.

The @var{namespec} is similar to the one used in @ref{defcvar}.
@end deffn

@deffn {Grovel Form} cenum name-and-opts &rest elements

Defines a true C enum, with elements specified as @code{((lisp-name
&rest c-names) &key optional documentation)}.
@var{name-and-opts} can be either a symbol as name, or a list
@code{(name &key base-type define-constants)}. If @var{define-constants}
is non-null, a Lisp constant will be defined for each enum member.
@end deffn

@deffn {Grovel Form} constantenum name-and-opts &rest elements

Defines an enumeration of pre-processor constants, with elements
specified as @code{((lisp-name &rest c-names) &key optional
documentation)}.
@var{name-and-opts} can be either a symbol as name, or a list
@code{(name &key base-type define-constants)}. If @var{define-constants}
is non-null, a Lisp constant will be defined for each enum member.

This example defines @code{:af-inet} to represent the value held by
@code{AF_INET} or @code{PF_INET}, whichever the pre-processor finds
first.  Similarly for @code{:af-packet}, but no error will be
signalled if the platform supports neither @code{AF_PACKET} nor
@code{PF_PACKET}.
@end deffn

@lisp
(constantenum address-family
  ((:af-inet "AF_INET" "PF_INET")
   :documentation "IPv4 Protocol family")
  ((:af-local "AF_UNIX" "AF_LOCAL" "PF_UNIX" "PF_LOCAL")
   :documentation "File domain sockets")
  ((:af-inet6 "AF_INET6" "PF_INET6")
   :documentation "IPv6 Protocol family")
  ((:af-packet "AF_PACKET" "PF_PACKET")
   :documentation "Raw packet access"
   :optional t))
@end lisp

@deffn {Grovel Form} bitfield name-and-opts &rest elements

Defines a bitfield, with elements specified as @code{((lisp-name &rest
c-names) &key optional documentation)}.  @var{name-and-opts} can be either a
symbol as name, or a list @code{(name &key base-type)}.  For example:
@end deffn

@lisp
(bitfield flags-ctype
  ((:flag-a "FLAG_A")
    :documentation "DOCU_A")
  ((:flag-b "FLAG_B" "FLAG_B_ALT")
    :documentation "DOCU_B")
  ((:flag-c "FLAG_C")
    :documentation "DOCU_C"
    :optional t))
@end lisp


@c ===================================================================
@c SECTION: Groveller ASDF Integration

@node Groveller ASDF Integration, Groveller Implementation Notes, Groveller Syntax, The Groveller
@section ASDF Integration

An example software project might contain four files; an
@acronym{ASDF} file, a package definition file, an implementation
file, and a @cffi{}-Grovel specification file.

The @acronym{ASDF} file defines the system and its dependencies.
Notice the use of @code{eval-when} to ensure @cffi{}-Grovel is present
and the use of @code{(cffi-grovel:grovel-file name &key cc-flags)}
instead of @code{(:file name)}.

The @file{example-software.asd} file would look like that:

@lisp
;;; @lispcmt{CFFI-Grovel is needed for processing grovel-file components}
(defsystem "example-software"
  :defsystem-depends-on ("cffi-grovel")
  :depends-on ("cffi")
  :serial t
  :components
  ((:file "package")
   (:cffi-grovel-file "example-grovelling")
   (:cffi-wrapper-file "example-wrappers")
   (:file "example")))
@end lisp

The @file{package.lisp} file would contain one or several
@code{defpackage} forms, to remove circular dependencies and make
building the project easier.  Note that you may or may not want to
@code{:use} your internal package.

@impnote{Note that it's a not a good idea to @code{:use} when names may
clash with, say, CL symbols.
Or you could use @code{uiop:define-package} and its @code{:mix} option.}

@lisp
(defpackage #:example-internal
  (:use)
  (:nicknames #:exampleint))

(defpackage #:example-software
  (:export ...)
  (:use #:cl #:cffi #:exampleint))
@end lisp

The internal package is created by Lisp code output from the C program
written by @cffi{}-Grovel; if your specification file is
@file{exampleint.lisp}, the @file{exampleint.cffi.lisp} file will contain the
@cffi{} definitions needed by the rest of your project.
@xref{Groveller Syntax}.

@node Groveller Implementation Notes,  , Groveller ASDF Integration, The Groveller
@section Implementation Notes

@cffi{}-Grovel will generate many files that not only architecture-specific,
but also implementation-specific, and should not be distributed.
ASDF will generate these files in its output cache;
if you build with multiple architectures (e.g. with NFS/AFS home
directories) or implementations, it is critical for avoiding clashes
to keep this cache in an implementation-dependent directory (as is the
default).

For @code{foo-internal.lisp}, the resulting @code{foo-internal.c},
@code{foo-internal}, and @code{foo-internal.cffi.lisp} are all
platform-specific, either because of possible reader-macros in
foo-internal.lisp, or because of varying C environments on the host
system.  For this reason, it is not helpful to distribute any of those
files; end users building @cffi{}-Grovel based software will need
@code{cffi}-Grovel anyway.

@impnote{For now, after some experimentation with @sc{clisp} having no
long-long, it seems appropriate to assert that the generated @code{.c}
files are architecture and operating-system dependent, but
lisp-implementation independent.  This way the same @code{.c} file
(and so the same @code{.grovel-tmp.lisp} file) will be shareable
between the implementations running on a given system.}

@c TODO: document the new wrapper stuff.


@c ===================================================================
@c CHAPTER: Static Linking

@node Static Linking, Limitations, The Groveller, Top
@chapter Static Linking

On recent enough versions of supported implementations (currently,
GNU CLISP 2.49, CMUCL 2015-11, and SBCL 1.2.17), and with a recent
enough ASDF (3.1.2 or later), you can create a statically linked
Lisp executable image that includes all the C extensions
(wrappers and any other objects output by @code{compile-op})
as well as your Lisp code --- or a standalone application executable.
This makes it easier to deliver your code as a single file.

To dump a statically linked executable image, use:

@lisp
(asdf:load-system :cffi-grovel)
(asdf:operate :static-image-op :example-software)
@end lisp

To dump a statically linked executable standalone application, use:

@lisp
(asdf:load-system :cffi-grovel)
(asdf:operate :static-program-op :example-software)
@end lisp

See @uref{https://common-lisp.net/project/asdf/,,the ASDF
manual} for documentation about @code{image-op} and @code{program-op}
which are the parent operation classes that behave similarly except
they don't statically link C code.

@impnote{There is also an operation @code{:static-runtime-op} to create the
statically linked runtime alone, but it's admittedly not very useful
except as an intermediate step dependency towards building
@code{:static-image-op} or @code{:static-program-op}.}



@c ===================================================================
@c CHAPTER: Limitations

@node Limitations, Platform-specific features, The Groveller, Top
@chapter Limitations

These are @cffi{}'s limitations across all platforms; for information
on the warts on particular Lisp implementations, see
@ref{Implementation Support}.

@itemize @bullet
@item
The tutorial includes a treatment of the primary, intractable
limitation of @cffi{}, or any @acronym{FFI}: that the abstractions
commonly used by C are insufficiently expressive.
@xref{Tutorial-Abstraction,, Breaking the abstraction}, for more
details.

@end itemize


@node Platform-specific features, Glossary, Limitations, Top
@appendix Platform-specific features

Whenever a backend doesn't support one of @cffi{}'s features, a
specific symbol is pushed onto @code{common-lisp:*features*}.  The
meanings of these symbols follow.

@table @var
@item cffi-sys::flat-namespace
This Lisp has a flat namespace for foreign symbols meaning that you
won't be able to load two different libraries with homograph functions
and successfully differentiate them through the @code{:library}
option to @code{defcfun}, @code{defcvar}, etc@dots{}

@item cffi-sys::no-foreign-funcall
The macro @code{foreign-funcall} is @strong{not} available.  On such
platforms, the only way to call a foreign function is through
@code{defcfun}.  @xref{foreign-funcall}, and @ref{defcfun}.

@item cffi-sys::no-long-long
The C @code{long long} type is @strong{not} available as a foreign
type.

However, on such platforms @cffi{} provides its own implementation of
the @code{long long} type for all of operations in chapters
@ref{Foreign Types}, @ref{Pointers} and @ref{Variables}. The
functionality described in @ref{Functions} and @ref{Callbacks} will
not be available.

32-bit Lispworks 5.0+ is an exception. In addition to the @cffi{}
implementation described above, Lispworks itself implements the
@code{long long} type for @ref{Functions}. @ref{Callbacks} are still
missing @code{long long} support, though.

@item cffi-sys::no-stdcall
This Lisp doesn't support the @code{stdcall} calling convention.  Note
that it only makes sense to support @code{stdcall} on (32-bit) x86
platforms.

@end table


@node Glossary, Comprehensive Index, Platform-specific features, Top
@appendix Glossary

@table @dfn
@item aggregate type
A @cffi{} type for C data defined as an organization of data of simple
type; in structures and unions, which are themselves aggregate types,
they are represented by value.

@item foreign value
This has two meanings; in any context, only one makes sense.

When using type translators, the foreign value is the lower-level Lisp
value derived from the object passed to @code{translate-to-foreign}
(@pxref{translate-to-foreign}).  This value should be a Lisp number or
a pointer (satisfies @code{pointerp}), and it can be treated like any
general Lisp object; it only completes the transformation to a true
foreign value when passed through low-level code in the Lisp
implementation, such as the foreign function caller or indirect memory
addressing combined with a data move.

In other contexts, this refers to a value accessible by C, but which
may only be accessed through @cffi{} functions.  The closest you can
get to such a foreign value is through a pointer Lisp object, which
itself counts as a foreign value in only the previous sense.

@item simple type
A @cffi{} type that is ultimately represented as a builtin type;
@cffi{} only provides extra semantics for Lisp that are invisible to C
code or data.
@end table

@node Comprehensive Index,  , Glossary, Top
@unnumbered Index
@printindex cp

@bye
cffi_0.19.0/doc/Makefile0000644000175000017500000000401013103031266013477 0ustar  luisluis# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
#
# Makefile --- Make targets for generating the documentation.
#
# Copyright (C) 2005-2007, Luis Oliveira  
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use, copy,
# modify, merge, publish, distribute, sublicense, and/or sell copies
# of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
#

export LC_ALL=C

all: manual spec

manual: cffi-manual.texinfo style.css
	sh gendocs.sh -o manual --html "--css-include=style.css" cffi-manual "CFFI User Manual"

spec: cffi-sys-spec.texinfo style.css
	sh gendocs.sh -o spec --html "--css-include=style.css" cffi-sys-spec "CFFI-SYS Interface Specification"

clean:
	find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \;
	rm -rf manual spec dir

upload-docs: manual spec
	rsync -av --delete -e ssh manual spec common-lisp.net:/project/cffi/public_html/
#	scp -r manual spec common-lisp.net:/project/cffi/public_html/

# vim: ft=make ts=3 noet
cffi_0.19.0/doc/style.css0000644000175000017500000000515513103031266013724 0ustar  luisluisbody {font-family: Georgia, serif;
      line-height: 1.3;
      padding-left: 5em; padding-right: 1em;
      padding-bottom: 1em; max-width: 60em;}
table {border-collapse: collapse}
span.roman { font-family: century schoolbook, serif; font-weight: normal; }
h1, h2, h3, h4, h5, h6 {font-family:  Helvetica, sans-serif}
h4 { margin-top: 2.5em; }
dfn {font-family: inherit; font-variant: italic; font-weight: bolder }
kbd {font-family: monospace; text-decoration: underline}
/*var {font-family: Helvetica, sans-serif; font-variant: slanted}*/
var {font-variant: slanted;}
td  {padding-right: 1em; padding-left: 1em}
sub {font-size: smaller}
.node {padding: 0; margin: 0}

pre.lisp { font-family: monospace;
           background-color: #F4F4F4; border: 1px solid #AAA;
           padding-top: 0.5em; padding-bottom: 0.5em; }

/* coloring */

.lisp-bg { background-color: #F4F4F4 ; color: black; }
.lisp-bg:hover { background-color: #F4F4F4 ; color: black; }

.symbol { font-weight: bold; color: #770055; background-color : transparent; border: 0px; margin: 0px;}
a.symbol:link { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:active { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:visited { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:hover { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
.special { font-weight: bold; color: #FF5000; background-color: inherit; }
.keyword { font-weight: bold; color: #770000; background-color: inherit; }
.comment { font-weight: normal; color: #007777; background-color: inherit; }
.string  { font-weight: bold; color: #777777; background-color: inherit; }
.character   { font-weight: bold; color: #0055AA; background-color: inherit; }
.syntaxerror { font-weight: bold; color: #FF0000; background-color: inherit; }
span.paren1 { font-weight: bold; color: #777777; }
span.paren1:hover { color: #777777; background-color: #BAFFFF; }
span.paren2 { color: #777777; }
span.paren2:hover { color: #777777; background-color: #FFCACA; }
span.paren3 { color: #777777; }
span.paren3:hover { color: #777777; background-color: #FFFFBA; }
span.paren4 { color: #777777; }
span.paren4:hover { color: #777777; background-color: #CACAFF; }
span.paren5 { color: #777777; }
span.paren5:hover { color: #777777; background-color: #CAFFCA; }
span.paren6 { color: #777777; }
span.paren6:hover { color: #777777; background-color: #FFBAFF; }
cffi_0.19.0/cffi-toolchain.asd0000644000175000017500000000410513103031266014655 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-toolchain.asd --- ASDF system definition for cffi-toolchain.
;;;
;;; Copyright (C) 2007, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

;; Make sure to upgrade ASDF before the #.(if ...) below may be read.
(load-system "asdf")
#-asdf3.1 (error "CFFI-toolchain requires ASDF 3.1!")

(defsystem "cffi-toolchain"
  :description "The CFFI toolchain"
  :long-description "Portable abstractions for using the C compiler, linker, etc."
  :author "Francois-Rene Rideau "
  :depends-on ((:version "asdf" "3.1.2") "cffi")
  :licence "MIT"
  :components
  ((:module "toolchain"
    :components
    (;; This is a plain copy of bundle.lisp from ASDF 3.2.0
     ;; in case your asdf isn't up to snuff.
     (:file "bundle" :if-feature (#.(if (version< "3.2.0" (asdf-version)) :or :and)))
     (:file "package")
     (:file "c-toolchain" :depends-on ("package"))
     (:file "static-link" :depends-on ("bundle" "c-toolchain"))))))

;; vim: ft=lisp et
cffi_0.19.0/COPYRIGHT0000644000175000017500000000207713103031266012600 0ustar  luisluisCopyright (C) 2005-2007, James Bielman  

Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the "Software"), to deal in the Software without
restriction, including without limitation the rights to use, copy,
modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
cffi_0.19.0/README.md0000644000175000017500000000171713103031266012564 0ustar  luisluis[![Build Status](https://travis-ci.org/cffi/cffi.svg?branch=master)](https://travis-ci.org/cffi/cffi)

CFFI, the Common Foreign Function Interface, purports to be a portable
foreign function interface for Common Lisp. The CFFI library is
composed of a Lisp-implementation-specific backend in the CFFI-SYS
package, and a portable frontend in the CFFI package.

The CFFI-SYS backend package defines a low-level interface to the
native FFI support in the Lisp implementation. It offers operators for
allocating and dereferencing foreign memory, calling foreign
functions, and loading shared libraries. The CFFI frontend provides a
declarative interface for defining foreign functions, structures,
typedefs, enumerated types, etc. It is implemented in portable ANSI CL
making use of the low-level operators exported by CFFI-SYS.

Please consult [the manual][1] for further details, including
installation instructions.

[1]: http://common-lisp.net/project/cffi/manual/html_node/
cffi_0.19.0/Makefile0000644000175000017500000000452013103031266012740 0ustar  luisluis# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
#
# Makefile --- Make targets for various tasks.
#
# Copyright (C) 2005-2006, James Bielman  
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use, copy,
# modify, merge, publish, distribute, sublicense, and/or sell copies
# of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
#

# This way you can easily run the tests for different versions
# of each lisp with, e.g. ALLEGRO=/path/to/some/lisp make test-allegro
CMUCL    ?= lisp
OPENMCL  ?= openmcl
SBCL     ?= sbcl
CLISP    ?= clisp
ALLEGRO  ?= alisp
SCL      ?= scl

shlibs:
	@$(MAKE) -wC tests shlibs

clean:
	@$(MAKE) -wC tests clean
	find . -name ".fasls" | xargs rm -rf
	find . \( -name "*.dfsl" -o -name "*.fasl" -o -name "*.fas" -o -name "*.lib" -o -name "*.x86f" -o -name "*.amd64f" -o -name "*.sparcf" -o -name "*.sparc64f" -o -name "*.hpf" -o -name "*.hp64f" -o -name "*.ppcf" -o -name "*.nfasl" -o -name "*.ufsl" -o -name "*.fsl" -o -name "*.lx64fsl" \) -exec rm {} \;

test-openmcl:
	@-$(OPENMCL) --load tests/run-tests.lisp

test-sbcl:
	@-$(SBCL) --noinform --load tests/run-tests.lisp

test-cmucl:
	@-$(CMUCL) -load tests/run-tests.lisp

test-scl:
	@-$(SCL) -load tests/run-tests.lisp

test-clisp:
	@-$(CLISP) -q -x '(load "tests/run-tests.lisp")'

test-clisp-modern:
	@-$(CLISP) -modern -q -x '(load "tests/run-tests.lisp")'

test-allegro:
	@-$(ALLEGRO) -L tests/run-tests.lisp

test: test-openmcl test-sbcl test-cmucl test-clisp

# vim: ft=make ts=3 noet
cffi_0.19.0/tests/0000755000175000017500000000000013103031266012441 5ustar  luisluiscffi_0.19.0/tests/union.lisp0000644000175000017500000000371213103031266014465 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; union.lisp --- Tests on C unions.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(defcunion uint32-bytes
  (int-value :unsigned-int)
  (bytes :unsigned-char :count 4))

(defctype uint32-bytes (:union uint32-bytes))

(defun int-to-bytes (n)
  "Convert N to a list of bytes using a union."
  (with-foreign-object (obj 'uint32-bytes)
    (setf (foreign-slot-value obj 'uint32-bytes 'int-value) n)
    (loop for i from 0 below 4
          collect (mem-aref
                   (foreign-slot-value obj 'uint32-bytes 'bytes)
                   :unsigned-char i))))

(deftest union.1
    (let ((bytes (int-to-bytes #x12345678)))
      (cond ((equal bytes '(#x12 #x34 #x56 #x78))
             t)
            ((equal bytes '(#x78 #x56 #x34 #x12))
             t)
            (t bytes)))
  t)
cffi_0.19.0/tests/libtest.c0000644000175000017500000007435213103031266014266 0ustar  luisluis/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
 *
 * libtest.c --- auxiliary C lib for testing purposes
 *
 * Copyright (C) 2005-2007, Luis Oliveira  
 *
 * Permission is hereby granted, free of charge, to any person
 * obtaining a copy of this software and associated documentation
 * files (the "Software"), to deal in the Software without
 * restriction, including without limitation the rights to use, copy,
 * modify, merge, publish, distribute, sublicense, and/or sell copies
 * of the Software, and to permit persons to whom the Software is
 * furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be
 * included in all copies or substantial portions of the Software.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 * NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
 * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
 * DEALINGS IN THE SOFTWARE.
 */

#ifdef WIN32
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT
#endif

#include 
#include 
#include 
#include 
#include 
#include 
#include 

/* MSVC doesn't have stdint.h and uses a different syntax for stdcall */
#ifndef _MSC_VER
#include 
#endif

#ifdef WIN32
#ifdef _MSC_VER
#define STDCALL __stdcall
#else
#define STDCALL __attribute__((stdcall))
#endif
#else
#define STDCALL
#endif

/*
 * Some functions that aren't available on WIN32
 */

DLLEXPORT
float my_sqrtf(float n)
{
    return (float) sqrt((double) n);
}

DLLEXPORT
char *my_strdup(const char *str)
{
    char *p = malloc(strlen(str) + 1);
    strcpy(p, str);
    return p;
}

DLLEXPORT
void my_strfree(char *str)
{
    free(str);
}

DLLEXPORT
long long my_llabs(long long n)
{
    return n < 0 ? -n : n;
}


DLLEXPORT
unsigned long long ullong(unsigned long long n)
{
    return n == ULLONG_MAX ? n : 42;
}

/*
 * Foreign Globals
 *
 * (var_int is used in MISC-TYPES.EXPAND.3 as well)
 */

DLLEXPORT char *         dll_version        = "20120107";

/* TODO: look into signed char vs. unsigned char issue */
DLLEXPORT char           var_char           = -127;
DLLEXPORT unsigned char  var_unsigned_char  = 255;
DLLEXPORT short          var_short          = -32767;
DLLEXPORT unsigned short var_unsigned_short = 65535;
DLLEXPORT int            var_int            = -32767;
DLLEXPORT unsigned int   var_unsigned_int   = 65535;
DLLEXPORT long           var_long           = -2147483647L;
DLLEXPORT unsigned long  var_unsigned_long  = 4294967295UL;
DLLEXPORT float          var_float          = 42.0f;
DLLEXPORT double         var_double         = 42.0;
DLLEXPORT void *         var_pointer        = NULL;
DLLEXPORT char *         var_string         = "Hello, foreign world!";

DLLEXPORT long long          var_long_long          = -9223372036854775807LL;
DLLEXPORT unsigned long long var_unsigned_long_long = 18446744073709551615ULL;

DLLEXPORT float float_max = FLT_MAX;
DLLEXPORT float float_min = FLT_MIN;
DLLEXPORT double double_max = DBL_MAX;
DLLEXPORT double double_min = DBL_MIN;

/*
 * Callbacks
 */

DLLEXPORT
int expect_char_sum(char (*f)(char, char))
{
    return f('a', 3) == 'd';
}

DLLEXPORT
int expect_unsigned_char_sum(unsigned char (*f)(unsigned char, unsigned char))
{
    return f(UCHAR_MAX-1, 1) == UCHAR_MAX;
}

DLLEXPORT
int expect_short_sum(short (*f)(short a, short b))
{
    return f(SHRT_MIN+1, -1) == SHRT_MIN;
}

DLLEXPORT
int expect_unsigned_short_sum(unsigned short (*f)(unsigned short,
                                                  unsigned short))
{
    return f(USHRT_MAX-1, 1) == USHRT_MAX;
}

/* used in MISC-TYPES.EXPAND.4 as well */
DLLEXPORT
int expect_int_sum(int (*f)(int, int))
{
    return f(INT_MIN+1, -1) == INT_MIN;
}

DLLEXPORT
int expect_unsigned_int_sum(unsigned int (*f)(unsigned int, unsigned int))
{
    return f(UINT_MAX-1, 1) == UINT_MAX;
}

DLLEXPORT
int expect_long_sum(long (*f)(long, long))
{
    return f(LONG_MIN+1, -1) == LONG_MIN;
}

DLLEXPORT
int expect_unsigned_long_sum(unsigned long (*f)(unsigned long, unsigned long))
{
    return f(ULONG_MAX-1, 1) == ULONG_MAX;
}

DLLEXPORT
int expect_long_long_sum(long long (*f)(long long, long long))
{
    return f(LLONG_MIN+1, -1) == LLONG_MIN;
}

DLLEXPORT
int expect_unsigned_long_long_sum (unsigned long long
                                   (*f)(unsigned long long, unsigned long long))
{
    return f(ULLONG_MAX-1, 1) == ULLONG_MAX;
}

DLLEXPORT
int expect_float_sum(float (*f)(float, float))
{
    /*printf("\n>>> FLOAT: %f <<<\n", f(20.0f, 22.0f));*/
    return f(20.0f, 22.0f) == 42.0f;
}

DLLEXPORT
int expect_double_sum(double (*f)(double, double))
{
    /*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
    return f(-20.0, -22.0) == -42.0;
}

DLLEXPORT
int expect_long_double_sum(long double (*f)(long double, long double))
{
    /*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
    return f(-20.0, -22.0) == -42.0;
}

DLLEXPORT
int expect_pointer_sum(void* (*f)(void*, int))
{
    return f(NULL, 0xDEAD) == (void *) 0xDEAD;
}

DLLEXPORT
int expect_strcat(char* (*f)(char*, char*))
{
    char *ret = f("Hello, ", "C world!");
    int res = strcmp(ret, "Hello, C world!") == 0;
    /* commented out as a quick fix on platforms that don't
       foreign allocate in C malloc space. */
    /*free(ret);*/ /* is this allowed? */
    return res;
}

DLLEXPORT
void pass_int_ref(void (*f)(int*))
{
    int x = 1984;
    f(&x);
}

/*
 * Enums
 */

typedef enum {
    ONE = 1,
    TWO,
    THREE,
    FOUR,
    FORTY_ONE = 41,
    FORTY_TWO
} numeros;

DLLEXPORT
int check_enums(numeros one, numeros two, numeros three, numeros four,
                numeros forty_one, numeros forty_two)
{
    if (one == ONE && two == TWO && three == THREE && four == FOUR &&
        forty_one == FORTY_ONE && forty_two == FORTY_TWO)
        return 1;

    return 0;
}

typedef enum { FALSE, TRUE } another_boolean;

DLLEXPORT
another_boolean return_enum(int x)
{
    if (x == 0)
        return FALSE;
    else
        return TRUE;
}

/*
 * Booleans
 */

DLLEXPORT
int equalequal(int a, unsigned int b)
{
    return ((unsigned int) a) == b;
}

DLLEXPORT
char bool_and(unsigned char a, char b)
{
    return a && b;
}

DLLEXPORT
unsigned long bool_xor(long a, unsigned long b)
{
    return (a && !b) || (!a && b);
}

DLLEXPORT
unsigned sizeof_bool(void)
{
    return (unsigned) sizeof(_Bool);
}

DLLEXPORT
unsigned bool_to_unsigned(_Bool b)
{
    return (unsigned) b;
}

DLLEXPORT
_Bool unsigned_to_bool(unsigned u)
{
    return (_Bool) u;
}

/*
 * Test struct alignment issues. These comments assume the x86 gABI.
 * Hopefully these tests will spot alignment issues in others archs
 * too.
 */

/*
 * STRUCT.ALIGNMENT.1
 */

struct s_ch {
    char a_char;
};

/* This struct's size should be 2 bytes */
struct s_s_ch {
    char another_char;
    struct s_ch a_s_ch;
};

DLLEXPORT
struct s_s_ch the_s_s_ch = { 2, { 1 } };

/*
 * STRUCT.ALIGNMENT.2
 */

/* This one should be alignment should be the same as short's alignment. */
struct s_short {
    char a_char;
    char another_char;
    short a_short;
};

struct s_s_short {
    char yet_another_char;
    struct s_short a_s_short; /* so this should be 2-byte aligned */
};  /* size: 6 bytes */

DLLEXPORT
struct s_s_short the_s_s_short = { 4, { 1, 2, 3 } };

/*
 * STRUCT.ALIGNMENT.3
 */

/* This test will, among other things, check for the existence tail padding. */

struct s_double {
    char a_char;       /* 1 byte */
                       /* padding: 3 bytes */
    double a_double;   /* 8 bytes */
    char another_char; /* 1 byte */
                       /* padding: 3 bytes */
};                     /* total size: 16 bytes */

struct s_s_double {
    char yet_another_char;      /* 1 byte */
                                /* 3 bytes padding */
    struct s_double a_s_double; /* 16 bytes */
    short a_short;              /* 2 byte */
                                /* 2 bytes padding */
};                              /* total size: 24 bytes */

DLLEXPORT
struct s_s_double the_s_s_double = { 4, { 1, 2.0, 3 }, 5 };

/*
 * STRUCT.ALIGNMENT.4
 */
struct s_s_s_double {
    short another_short;            /* 2 bytes */
                                    /* 2 bytes padding */
    struct s_s_double a_s_s_double; /* 24 bytes */
    char last_char;                 /* 1 byte */
                                    /* 3 bytes padding */
};                                  /* total size: 32 */

DLLEXPORT
struct s_s_s_double the_s_s_s_double = { 6, { 4, { 1, 2.0, 3 }, 5 }, 7 };

/*
 * STRUCT.ALIGNMENT.5
 */

/* MacOSX ABI says: "The embedding alignment of the first element in a data
   structure is equal to the element's natural alignment." and "For subsequent
   elements that have a natural alignment greater than 4 bytes, the embedding
   alignment is 4, unless the element is a vector." */

/* note: these rules will apply to the structure itself. So, unless it is
   the first element of another structure, its alignment will be 4. */

/* the following offsets and sizes are specific to darwin/ppc32 */

struct s_double2 {
    double a_double;            /* 8 bytes (alignment 8) */
    short a_short;              /* 2 bytes */
                                /* 6 bytes padding */
};                              /* total size: 16 */

struct s_s_double2 {
    char a_char;                  /* 1 byte */
                                  /* 3 bytes padding */
    struct s_double2 a_s_double2; /* 16 bytes, alignment 4 */
    short another_short;          /* 2 bytes */
                                  /* 2 bytes padding */
};                                /* total size: 24 bytes */
                                  /* alignment: 4 */

DLLEXPORT
struct s_s_double2 the_s_s_double2 = { 3, { 1.0, 2 }, 4 };

/*
 * STRUCT.ALIGNMENT.6
 */

/* Same as STRUCT.ALIGNMENT.5 but with long long. */

struct s_long_long {
    long long a_long_long;      /* 8 bytes (alignment 8) */
    short a_short;              /* 2 bytes */
                                /* 6 bytes padding */
};                              /* total size: 16 */

struct s_s_long_long {
    char a_char;                      /* 1 byte */
                                      /* 3 bytes padding */
    struct s_long_long a_s_long_long; /* 16 bytes, alignment 4 */
    short a_short;                    /* 2 bytes */
                                      /* 2 bytes padding */
};                                    /* total size: 24 bytes */
                                      /* alignment: 4 */

DLLEXPORT
struct s_s_long_long the_s_s_long_long = { 3, { 1, 2 }, 4 };

/*
 * STRUCT.ALIGNMENT.7
 */

/* Another test for Darwin's PPC32 ABI. */

struct s_s_double3 {
    struct s_double2 a_s_double2; /* 16 bytes, alignment 8*/
    short another_short;          /* 2 bytes */
                                  /* 6 bytes padding */
};                                /* total size: 24 */

struct s_s_s_double3 {
    struct s_s_double3 a_s_s_double3; /* 24 bytes */
    char a_char;                      /* 1 byte */
                                      /* 7 bytes padding */
};                                    /* total size: 32 */

DLLEXPORT
struct s_s_s_double3 the_s_s_s_double3 = { { { 1.0, 2 }, 3 }, 4 };

/*
 * STRUCT.ALIGNMENT.8
 */

/* Same as STRUCT.ALIGNMENT.[56] but with unsigned long long. */

struct s_unsigned_long_long {
    unsigned long long an_unsigned_long_long; /* 8 bytes (alignment 8) */
    short a_short;                            /* 2 bytes */
                                              /* 6 bytes padding */
};                                            /* total size: 16 */

struct s_s_unsigned_long_long {
    char a_char;                                         /* 1 byte */
                                                         /* 3 bytes padding */
    struct s_unsigned_long_long a_s_unsigned_long_long;  /* 16 bytes, align 4 */
    short a_short;                                       /* 2 bytes */
                                                         /* 2 bytes padding */
};                                           /* total size: 24 bytes */
                                             /*  alignment: 4 */

DLLEXPORT
struct s_s_unsigned_long_long the_s_s_unsigned_long_long = { 3, { 1, 2 }, 4 };

/* STRUCT.ALIGNMENT.x */

/* commented this test out because this is not standard C
   and MSVC++ (or some versions of it at least) won't compile it. */

/*
struct empty_struct {};

struct with_empty_struct {
    struct empty_struct foo;
    int an_int;
};

DLLEXPORT
struct with_empty_struct the_with_empty_struct = { {}, 42 };
*/

/*
 * STRUCT-VALUES.*
 */

struct pair { int a, b; };

DLLEXPORT
int pair_sum(struct pair p)
{
    return p.a + p.b;
}

DLLEXPORT
int pair_pointer_sum(struct pair *p)
{
    return p->a + p->b;
}

DLLEXPORT
struct pair make_pair(int a, int b)
{
    return (struct pair) { a, b };
}

DLLEXPORT
struct pair *alloc_pair(int a, int b)
{
    struct pair *p = malloc(sizeof(struct pair));
    p->a = a;
    p->b = b;
    return p;
}

struct pair_plus_one {
    struct pair p;
    int c;
};

DLLEXPORT
int pair_plus_one_sum(struct pair_plus_one p)
{
    return p.p.a + p.p.b + p.c;
}

DLLEXPORT
int pair_plus_one_pointer_sum(struct pair_plus_one *p)
{
    return p->p.a + p->p.b + p->c;
}

DLLEXPORT
struct pair_plus_one make_pair_plus_one(int a, int b, int c)
{
    return (struct pair_plus_one) { { a, b }, c };
}

DLLEXPORT
struct pair_plus_one *alloc_pair_plus_one(int a, int b, int c)
{
    struct pair_plus_one *p = malloc(sizeof(struct pair_plus_one));
    p->p.a = a;
    p->p.b = b;
    p->c = c;
    return p;
}

/*
 * DEFCFUN.NOARGS and DEFCFUN.NOOP
 */

DLLEXPORT
int noargs()
{
    return 42;
}

DLLEXPORT
void noop()
{
    return;
}

/*
 * DEFCFUN.BFF.1
 *
 * (let ((rettype (find-type :long))
 *       (arg-types (n-random-types-no-ll 127)))
 *   (c-function rettype arg-types)
 *   (gen-function-test rettype arg-types))
 */

DLLEXPORT long sum_127_no_ll
  (long a1, unsigned long a2, short a3, unsigned short a4, float a5,
   double a6, unsigned long a7, float a8, unsigned char a9, unsigned
   short a10, short a11, unsigned long a12, double a13, long a14,
   unsigned int a15, void* a16, unsigned int a17, unsigned short a18,
   long a19, float a20, void* a21, float a22, int a23, int a24, unsigned
   short a25, long a26, long a27, double a28, unsigned char a29, unsigned
   int a30, unsigned int a31, int a32, unsigned short a33, unsigned int
   a34, void* a35, double a36, double a37, long a38, short a39, unsigned
   short a40, long a41, char a42, long a43, unsigned short a44, void*
   a45, int a46, unsigned int a47, double a48, unsigned char a49,
   unsigned char a50, float a51, int a52, unsigned short a53, double a54,
   short a55, unsigned char a56, unsigned long a57, float a58, float a59,
   float a60, void* a61, void* a62, unsigned int a63, unsigned long a64,
   char a65, short a66, unsigned short a67, unsigned long a68, void* a69,
   float a70, double a71, long a72, unsigned long a73, short a74,
   unsigned int a75, unsigned short a76, int a77, unsigned short a78,
   char a79, double a80, short a81, unsigned char a82, float a83, char
   a84, int a85, double a86, unsigned char a87, int a88, unsigned long
   a89, double a90, short a91, short a92, unsigned int a93, unsigned char
   a94, float a95, long a96, float a97, long a98, long a99, int a100, int
   a101, unsigned int a102, char a103, char a104, unsigned short a105,
   unsigned int a106, unsigned short a107, unsigned short a108, int a109,
   long a110, char a111, double a112, unsigned int a113, char a114, short
   a115, unsigned long a116, unsigned int a117, short a118, unsigned char
   a119, float a120, void* a121, double a122, int a123, long a124, char
   a125, unsigned short a126, float a127)
{
    return (long) a1 + a2 + a3 + a4 + ((long) a5) + ((long) a6) + a7 +
        ((long) a8) + a9 + a10 + a11 + a12 + ((long) a13) + a14 + a15 +
        ((intptr_t) a16) + a17 + a18 + a19 + ((long) a20) +
        ((intptr_t) a21) + ((long) a22) + a23 + a24 + a25 + a26 + a27 +
        ((long) a28) + a29 + a30 + a31 + a32 + a33 + a34 + ((intptr_t) a35) +
        ((long) a36) + ((long) a37) + a38 + a39 + a40 + a41 + a42 + a43 + a44 +
        ((intptr_t) a45) + a46 + a47 + ((long) a48) + a49 + a50 +
        ((long) a51) + a52 + a53 + ((long) a54) + a55 + a56 + a57 + ((long) a58) +
        ((long) a59) + ((long) a60) + ((intptr_t) a61) +
        ((intptr_t) a62) + a63 + a64 + a65 + a66 + a67 + a68 +
        ((intptr_t) a69) + ((long) a70) + ((long) a71) + a72 + a73 + a74 +
        a75 + a76 + a77 + a78 + a79 + ((long) a80) + a81 + a82 + ((long) a83) +
        a84 + a85 + ((long) a86) + a87 + a88 + a89 + ((long) a90) + a91 + a92 +
        a93 + a94 + ((long) a95) + a96 + ((long) a97) + a98 + a99 + a100 + a101 +
        a102 + a103 + a104 + a105 + a106 + a107 + a108 + a109 + a110 + a111 +
        ((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 +
        ((long) a120) + ((intptr_t) a121) + ((long) a122) + a123 + a124 +
        a125 + a126 + ((long) a127);
}

/*
 * DEFCFUN.BFF.2
 *
 * (let ((rettype (find-type :long-long))
 *       (arg-types (n-random-types 127)))
 *   (c-function rettype arg-types)
 *   (gen-function-test rettype arg-types))
 */

DLLEXPORT long long sum_127
  (void* a1, void* a2, float a3, unsigned long a4, void* a5, long long
  a6, double a7, double a8, unsigned short a9, int a10, long long a11,
  long a12, short a13, unsigned int a14, long a15, unsigned char a16,
  int a17, double a18, short a19, short a20, long long a21, unsigned
  int a22, unsigned short a23, short a24, void* a25, short a26,
  unsigned short a27, unsigned short a28, int a29, long long a30,
  void* a31, int a32, unsigned long a33, unsigned long a34, void* a35,
  unsigned long long a36, float a37, int a38, short a39, void* a40,
  unsigned long long a41, long long a42, unsigned long a43, unsigned
  long a44, unsigned long long a45, unsigned long a46, char a47,
  double a48, long a49, unsigned int a50, int a51, short a52, void*
  a53, long a54, unsigned long long a55, int a56, unsigned short a57,
  unsigned long long a58, float a59, void* a60, float a61, unsigned
  short a62, unsigned long a63, float a64, unsigned int a65, unsigned
  long long a66, void* a67, double a68, unsigned long long a69, double
  a70, double a71, long long a72, void* a73, unsigned short a74, long
  a75, void* a76, short a77, double a78, long a79, unsigned char a80,
  void* a81, unsigned char a82, long a83, double a84, void* a85, int
  a86, double a87, unsigned char a88, double a89, short a90, long a91,
  int a92, long a93, double a94, unsigned short a95, unsigned int a96,
  int a97, char a98, long long a99, double a100, float a101, unsigned
  long a102, short a103, void* a104, float a105, long long a106, int
  a107, long long a108, long long a109, double a110, unsigned long
  long a111, double a112, unsigned long a113, char a114, char a115,
  unsigned long a116, short a117, unsigned char a118, unsigned char
  a119, int a120, int a121, float a122, unsigned char a123, unsigned
  char a124, double a125, unsigned long long a126, char a127)
{
    return (long long) ((intptr_t) a1) + ((intptr_t) a2) + ((long) a3) +
        a4 + ((intptr_t) a5) + a6 + ((long) a7) + ((long) a8) + a9 + a10 +
        a11 + a12 + a13 + a14 + a15 + a16 + a17 + ((long) a18) + a19 + a20 +
        a21 + a22 + a23 + a24 + ((intptr_t) a25) + a26 + a27 + a28 + a29 +
        a30 + ((intptr_t) a31) + a32 + a33 + a34 + ((intptr_t) a35) +
        a36 + ((long) a37) + a38 + a39 + ((intptr_t) a40) + a41 + a42 + a43 +
        a44 + a45 + a46 + a47 + ((long) a48) + a49 + a50 + a51 + a52 +
        ((intptr_t) a53) + a54 + a55 + a56 + a57 + a58 + ((long) a59) +
        ((intptr_t) a60) + ((long) a61) + a62 + a63 + ((long) a64) + a65 + a66
        + ((intptr_t) a67) + ((long) a68) + a69 + ((long) a70) + ((long) a71) +
        a72 + ((intptr_t) a73) + a74 + a75 + ((intptr_t) a76) + a77 +
        ((long) a78) + a79 + a80 + ((intptr_t) a81) + a82 + a83 + ((long) a84)
        + ((intptr_t) a85) + a86 + ((long) a87) + a88 + ((long) a89) + a90 +
        a91 + a92 + a93 + ((long) a94) + a95 + a96 + a97 + a98 + a99 +
        ((long) a100) + ((long) a101) + a102 + a103 + ((intptr_t) a104) +
        ((long) a105) + a106 + a107 + a108 + a109 + ((long) a110) + a111 +
        ((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 + a120 +
        a121 + ((long) a122) + a123 + a124 + ((long) a125) + a126 + a127;
}

/*
 * CALLBACKS.BFF.1  (cb-test :no-long-long t)
 */

DLLEXPORT long call_sum_127_no_ll
  (long (*func)
   (unsigned long, void*, long, double, unsigned long, float, float,
    int, unsigned int, double, double, double, void*, unsigned short,
    unsigned short, void*, long, long, int, short, unsigned short,
    unsigned short, char, long, void*, void*, char, unsigned char,
    unsigned long, short, int, int, unsigned char, short, long, long,
    void*, unsigned short, char, double, unsigned short, void*, short,
    unsigned long, unsigned short, float, unsigned char, short, float,
    short, char, unsigned long, unsigned long, char, float, long, void*,
    short, float, unsigned int, float, unsigned int, double, unsigned int,
    unsigned char, int, long, char, short, double, int, void*, char,
    unsigned short, void*, unsigned short, void*, unsigned long, double,
    void*, long, float, unsigned short, unsigned short, void*, float, int,
    unsigned int, double, float, long, void*, unsigned short, float,
    unsigned char, unsigned char, float, unsigned int, float, unsigned
    short, double, unsigned short, unsigned long, unsigned int, unsigned
    long, void*, unsigned char, char, char, unsigned short, unsigned long,
    float, short, void*, long, unsigned short, short, double, short, int,
    char, unsigned long, long, int, void*, double, unsigned char))
{
    return
        func(948223085, (void *) 803308438, -465723152, 20385,
             219679466, -10035, 13915, -1193455756, 1265303699, 27935, -18478,
             -10508, (void *) 215389089, 55561, 55472, (void *) 146070433,
             -1040819989, -17851453, -1622662247, -19473, 20837, 30216, 79,
             986800400, (void *) 390281604, (void *) 1178532858, 19, 117,
             78337699, -5718, -991300738, 872160910, 184, 926, -1487245383,
             1633973783, (void *) 33738609, 53985, -116, 31645, 27196, (void *)
             145569903, -6960, 17252220, 47404, -10491, 88, -30438, -21212,
             -1982, -16, 1175270, 7949380, -121, 8559, -432968526, (void *)
             293455312, 11894, -8394, 142421516, -25758, 3422998, 4004,
             15758212, 198, -1071899743, -1284904617, -11, -17219, -30039,
             311589092, (void *) 541468577, 123, 63517, (void *) 1252504506,
             39368, (void *) 10057868, 134781408, -7143, (void *) 72825877,
             -1190798667, -30862, 63757, 14965, (void *) 802391252, 22008,
             -517289619, 806091099, 1125, 451, -498145176, (void *) 55960931,
             15379, 4629, 184, 254, 22532, 465856451, -1669, 49416, -16546,
             2983, 4337541, 65292495, 39253529, (void *) 669025, 211, 85, -19,
             24298, 65358, 16776, -29957, (void *) 124311, -163231228, 2610,
             -7806, 26434, -21913, -753615541, 120, 358697932, -1198889034,
             -2131350926, (void *) 3749492036, -13413, 17);
}

/*
 * CALLBACKS.BFF.2  (cb-test)
 */

DLLEXPORT long long call_sum_127
  (long long (*func)
   (short, char, void*, float, long, double, unsigned long long,
    unsigned short, unsigned char, char, char, unsigned short, unsigned
    long long, unsigned short, long long, unsigned short, unsigned long
    long, unsigned char, unsigned char, unsigned long long, long long,
    char, float, unsigned int, float, float, unsigned int, float, char,
    unsigned char, long, long long, unsigned char, double, long,
    double, unsigned int, unsigned short, long long, unsigned int, int,
    unsigned long long, long, short, unsigned int, unsigned int,
    unsigned long long, unsigned int, long, void*, unsigned char, char,
    long long, unsigned short, unsigned int, float, unsigned char,
    unsigned long, long long, float, long, float, int, float, unsigned
    short, unsigned long long, short, unsigned long, long, char,
    unsigned short, long long, short, double, void*, unsigned int,
    char, unsigned int, void*, void*, unsigned char, void*, unsigned
    short, unsigned char, long, void*, char, long, unsigned short,
    unsigned char, double, unsigned long long, unsigned short, unsigned
    short, unsigned int, long, char, long, char, short, unsigned short,
    unsigned long, unsigned long, short, long long, long long, long
    long, double, unsigned short, unsigned char, short, unsigned char,
    long, long long, unsigned long long, unsigned int, unsigned long,
    unsigned char, long long, unsigned char, unsigned long long,
    double, unsigned char, long long, unsigned char, char, long long))
{
    return
        func(-8573, 14, (void *) 832601021, -32334, -1532040888,
             -18478, 2793023182591311826, 2740, 230, 103, 97, 13121,
             5112369026351511084, 7763, -8134147951003417418, 34348,
             5776613699556468853, 19, 122, 1431603726926527625,
             439503521880490337, -112, -21557, 1578969190, -22008, -4953,
             2127745975, -7262, -6, 180, 226352974, -3928775366167459219, 134,
             -17730, -1175042526, 23868, 3494181009, 57364,
             3134876875147518682, 104531655, -1286882727, 803577887579693487,
             1349268803, 24912, 3313099419, 3907347884, 1738833249233805034,
             2794230885, 1008818752, (void *) 1820044575, 189, 61,
             -931654560961745071, 57531, 3096859985, 10405, 220, 3631311224,
             -8531370353478907668, 31258, 678896693, -32150, -1869057813,
             -19877, 62841, 4161660185772906873, -23869, 4016251006, 610353435,
             105, 47315, -1051054492535331660, 6846, -15163, (void *)
             736672359, 2123928476, -122, 3859258652, (void *) 3923394833,
             (void *) 1265031970, 161, (void *) 1993867800, 55056, 122,
             1562112760, (void *) 866615125, -79, -1261399547, 31737, 254,
             -31279, 5462649659172897980, 5202, 7644, 174224940, -337854382,
             -45, -583502442, -37, -13266, 24520, 2198606699, 2890453969,
             -8282, -2295716637858246075, -1905178488651598878,
             -6384652209316714643, 14841, 35443, 132, 15524, 187, 2138878229,
             -5153032566879951000, 9056545530140684207, 4124632010, 276167701,
             56, -2307310370663738730, 66, 9113015627153789746, -9618, 167,
             755753399701306200, 119, -28, -990561962725435433);
}

/*
 * CALLBACKS.DOUBLE26
 */

DLLEXPORT double call_double26
  (double (*f)(double, double, double, double, double, double, double, double,
               double, double, double, double, double, double, double, double,
               double, double, double, double, double, double, double, double,
               double, double))
{
    return f(3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
             3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
             3.14, 3.14, 3.14, 3.14);
}

/*
 * DEFCFUN.DOUBLE26 and FUNCALL.DOUBLE26
 */

DLLEXPORT
double sum_double26(double a1, double a2, double a3, double a4, double a5,
                    double a6, double a7, double a8, double a9, double a10,
                    double a11, double a12, double a13, double a14, double a15,
                    double a16, double a17, double a18, double a19, double a20,
                    double a21, double a22, double a23, double a24, double a25,
                    double a26)
{
    return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
        a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
        a26;
}

/*
 * CALLBACKS.FLOAT26
 */

DLLEXPORT float call_float26
  (float (*f)(float, float, float, float, float, float, float, float,
              float, float, float, float, float, float, float, float,
              float, float, float, float, float, float, float, float,
              float, float))
{
    return f(5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
             5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
             5.0, 5.0, 5.0, 5.0);
}

/*
 * DEFCFUN.FLOAT26 and FUNCALL.FLOAT26
 */

DLLEXPORT
float sum_float26(float a1, float a2, float a3, float a4, float a5,
                  float a6, float a7, float a8, float a9, float a10,
                  float a11, float a12, float a13, float a14, float a15,
                  float a16, float a17, float a18, float a19, float a20,
                  float a21, float a22, float a23, float a24, float a25,
                  float a26)
{
    return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
        a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
        a26;
}

/*
 * Symbol case.
 */

DLLEXPORT int UPPERCASEINT1    = 12345;
DLLEXPORT int UPPER_CASE_INT1  = 23456;
DLLEXPORT int MiXeDCaSeInT1    = 34567;
DLLEXPORT int MiXeD_CaSe_InT1  = 45678;

DLLEXPORT int UPPERCASEINT2    = 12345;
DLLEXPORT int UPPER_CASE_INT2  = 23456;
DLLEXPORT int MiXeDCaSeInT2    = 34567;
DLLEXPORT int MiXeD_CaSe_InT2  = 45678;

DLLEXPORT int UPPERCASEINT3    = 12345;
DLLEXPORT int UPPER_CASE_INT3  = 23456;
DLLEXPORT int MiXeDCaSeInT3    = 34567;
DLLEXPORT int MiXeD_CaSe_InT3  = 45678;

/*
 * FOREIGN-SYMBOL-POINTER.1
 */

DLLEXPORT int compare_against_abs(intptr_t p)
{
    return p == (intptr_t) abs;
}

/*
 * FOREIGN-SYMBOL-POINTER.2
 */

DLLEXPORT void xpto_fun() {}

DLLEXPORT
int compare_against_xpto_fun(intptr_t p)
{
    return p == (intptr_t) xpto_fun;
}

/*
 * [DEFCFUN|FUNCALL].NAMESPACE.1
 */

DLLEXPORT
int ns_function()
{
    return 1;
}

/*
 * FOREIGN-GLOBALS.NAMESPACE.*
 */

DLLEXPORT int ns_var = 1;

/*
 * DEFCFUN.STDCALL.1
 */

DLLEXPORT
int STDCALL stdcall_fun(int a, int b, int c)
{
    return a + b + c;
}

/*
 * CALLBACKS.STDCALL.1
 */

DLLEXPORT
int call_stdcall_fun(int (STDCALL *f)(int, int, int))
{
    int a = 42;
    f(1, 2, 3);
    return a;
}

/* Unlike the one above, this commented test below actually
 * works. But, alas, it doesn't compile with -std=c99. */

/*
DLLEXPORT
int call_stdcall_fun(int __attribute__((stdcall)) (*f)(int, int, int))
{
    asm("pushl $42");
    register int ebx asm("%ebx");
    f(1, 2, 3);
    asm("popl %ebx");
    return ebx;
}
*/

/* vim: ts=4 et
*/
cffi_0.19.0/tests/libtest2.c0000644000175000017500000000277213103031266014345 0ustar  luisluis/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
 *
 * libtest2.c --- auxiliary C lib for testing purposes
 *
 * Copyright (C) 2007, Luis Oliveira  
 *
 * Permission is hereby granted, free of charge, to any person
 * obtaining a copy of this software and associated documentation
 * files (the "Software"), to deal in the Software without
 * restriction, including without limitation the rights to use, copy,
 * modify, merge, publish, distribute, sublicense, and/or sell copies
 * of the Software, and to permit persons to whom the Software is
 * furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be
 * included in all copies or substantial portions of the Software.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 * NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
 * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
 * DEALINGS IN THE SOFTWARE.
 */

#ifdef WIN32
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT
#endif

/*
 * [DEFCFUN|FOREIGN].NAMESPACE.1
 */

DLLEXPORT int ns_function()
{
    return 0;
}

/*
 * FOREIGN-GLOBALS.NAMESPACE.*
 */

DLLEXPORT int ns_var = 0;

/* vim: ts=4 et
*/
cffi_0.19.0/tests/misc.lisp0000644000175000017500000000764413103031266014300 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; misc.lisp --- Miscellaneous tests.
;;;
;;; Copyright (C) 2006, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

;;;# foreign-symbol-pointer tests

;;; This might be useful for some libraries that compare function
;;; pointers. http://thread.gmane.org/gmane.lisp.cffi.devel/694
(defcfun "compare_against_abs" :boolean (p :pointer))

(deftest foreign-symbol-pointer.1
    (compare-against-abs (foreign-symbol-pointer "abs"))
  t)

(defcfun "compare_against_xpto_fun" :boolean (p :pointer))

(deftest foreign-symbol-pointer.2
    (compare-against-xpto-fun (foreign-symbol-pointer "xpto_fun"))
  t)

;;;# Library tests
;;;
;;; Need to figure out a way to test this.  CLISP, for instance, will
;;; automatically reopen the foreign-library when we call a foreign
;;; function so we can't test CLOSE-FOREIGN-LIBRARY this way.
;;;
;;; IIRC, GCC has some extensions to have code run when a library is
;;; loaded and stuff like that.  That could work.

#||
#-(and ecl (not dffi))
(deftest library.close.2
    (unwind-protect
         (progn
           (close-foreign-library 'libtest)
           (ignore-errors (my-sqrtf 16.0)))
      (load-test-libraries))
  nil)

#-(or (and ecl (not dffi))
      cffi-sys::flat-namespace
      cffi-sys::no-foreign-funcall)
(deftest library.close.2
    (unwind-protect
         (values
          (foreign-funcall ("ns_function" :library libtest) :boolean)
          (close-foreign-library 'libtest)
          (foreign-funcall "ns_function" :boolean)
          (close-foreign-library 'libtest2)
          (close-foreign-library 'libtest2)
          (ignore-errors (foreign-funcall "ns_function" :boolean)))
      (load-test-libraries))
  t t nil t nil nil)
||#

(deftest library.error.1
    (handler-case (load-foreign-library "libdoesnotexistimsure")
      (load-foreign-library-error () 'error))
  error)

(define-foreign-library pseudo-library
  (t pseudo-library-spec))

;;; RT: T clause was being handled as :T by FEATUREP.
;;;
;;; We might want to export (and clean up) the API used in this test
;;; when the need arises.
(deftest library.t-clause
    (eq (cffi::foreign-library-spec
         (cffi::get-foreign-library 'pseudo-library))
        'pseudo-library-spec)
  t)

;;;# Shareable Byte Vector Tests

#+ecl
(mapc (lambda (x) (pushnew x rt::*expected-failures*))
      '(shareable-vector.1 shareable-vector.2))

(deftest shareable-vector.1
    (let ((vector (cffi-sys::make-shareable-byte-vector 5)))
      (cffi::with-pointer-to-vector-data (pointer vector)
        (strcpy pointer "xpto"))
      vector)
  #(120 112 116 111 0))

(deftest shareable-vector.2
    (block nil
      (let ((vector (cffi-sys::make-shareable-byte-vector 5)))
        (cffi::with-pointer-to-vector-data (pointer vector)
          (strcpy pointer "xpto")
          (return vector))))
  #(120 112 116 111 0))
cffi_0.19.0/tests/compile.bat0000644000175000017500000000032013103031266014554 0ustar  luisluisrem
rem script for compiling the test lib with the free MSVC++ toolkit.
rem

cl /LD /DWIN32=1 /Tc libtest.c
del libtest.obj libtest.exp

cl /LD /DWIN32=1 /Tc libtest2.c
del libtest2.obj libtest2.exp
cffi_0.19.0/tests/enum.lisp0000644000175000017500000001421713103031266014303 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enum.lisp --- Tests on C enums.
;;;
;;; Copyright (C) 2005-2006, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(defctype numeros-base-type :int)

(defcenum (numeros numeros-base-type)
  (:one 1)
  :two
  :three
  :four
  (:forty-one 41)
  :forty-two)

(defcfun "check_enums" :int
  (%one numeros)
  (%two numeros)
  (%three numeros)
  (%four numeros)
  (%forty-one numeros)
  (%forty-two numeros))

(deftest enum.1
    (check-enums :one :two :three 4 :forty-one :forty-two)
  1)

(defcenum another-boolean :false :true)
(defcfun "return_enum" another-boolean (x :int))

(deftest enum.2
    (and (eq :false (return-enum 0))
         (eq :true (return-enum 1)))
  t)

(defctype yet-another-boolean another-boolean)
(defcfun ("return_enum" return-enum2) yet-another-boolean
  (x yet-another-boolean))

(deftest enum.3
    (and (eq :false (return-enum2 :false))
         (eq :true (return-enum2 :true)))
  t)

(defctype numeros-typedef numeros)

(deftest enum.typedef.1
    (eq (foreign-enum-keyword 'numeros-typedef 1)
        (foreign-enum-keyword 'numeros 1))
  t)

(deftest enum.typedef.2
    (eql (foreign-enum-value 'numeros-typedef :four)
         (foreign-enum-value 'numeros :four))
  t)

(defcenum enum-size.int
  (:one 1)
  (enum-size-int #.(1- (expt 2 (1- (* (foreign-type-size :unsigned-int) 8)))))
  (enum-size-negative-int #.(- (1- (expt 2 (1- (* (foreign-type-size :unsigned-int) 8))))))
  (:two 2))

(defcenum enum-size.uint
  (:one 1)
  (enum-size-uint #.(1- (expt 2 (* (foreign-type-size :unsigned-int) 8))))
  (:two 2))

(deftest enum.size
    (mapcar (alexandria:compose 'cffi::unparse-type
                                'cffi::actual-type
                                'cffi::parse-type)
            (list 'enum-size.int
                  'enum-size.uint))
  ;; The C standard only has weak constraints on the size of integer types, so
  ;; we cannot really test more than one type in a platform independent way due
  ;; to the possible overlaps.
  (:int
   :unsigned-int))

(deftest enum.size.members
    (mapcar (alexandria:conjoin 'boundp 'constantp)
            '(enum-size-int enum-size-negative-int enum-size-uint))
  (t t t))

(deftest enum.size.error-when-too-large
    (expecting-error
      (eval '(defcenum enum-size-too-large
              (:too-long #.(expt 2 129)))))
  :error)

;; There are some projects that use non-integer base type. It's not in
;; adherence with the C standard, but we also don't lose much by
;; allowing it.
(defcenum (enum.double :double)
  (:one 1)
  (:two 2d0)
  (:three 3.42)
  :four)

(deftest enum.double
    (values-list
     (mapcar (alexandria:curry 'foreign-enum-value 'enum.double)
             '(:one :two :three :four)))
  1
  2.0d0
  3.42
  4.42)

;;;# Bitfield tests

;;; Regression test: defbitfield was misbehaving when the first value
;;; was provided.
(deftest bitfield.1
    (eval '(defbitfield (bf1 :long)
             (:foo 0)))
  bf1)

(defbitfield bf2
  one
  two
  four
  eight
  sixteen
  (bf2.outlier 42)
  thirty-two
  sixty-four)

(deftest bitfield.2
    (mapcar (lambda (symbol)
              (foreign-bitfield-value 'bf2 (list symbol)))
            '(one two four eight sixteen thirty-two sixty-four))
  (1 2 4 8 16 32 64))

(deftest bitfield.2.outlier
    (mapcar (lambda (symbol)
              (foreign-bitfield-value 'bf2 (list symbol)))
            '(one two four eight sixteen thirty-two sixty-four))
  (1 2 4 8 16 32 64))

(defbitfield (bf3 :int)
  (three 3)
  one
  (seven 7)
  two
  (eight 8)
  sixteen)

;;; Non-single-bit numbers must not influence the progression of
;;; implicit values.  Single bits larger than any before *must*
;;; influence said progression.
(deftest bitfield.3
    (mapcar (lambda (symbol)
              (foreign-bitfield-value 'bf3 (list symbol)))
            '(one two sixteen))
  (1 2 16))

(defbitfield bf4
  ;; zero will be a simple enum member because it's not a valid mask
  (zero 0)
  one
  two
  four
  (three 3)
  (sixteen 16))

;;; Yet another edge case with the 0...
(deftest bitfield.4
    ;; These should macroexpand to the literals in Slime
    ;; due to the compiler macros. Same below.
    (values (foreign-bitfield-value 'bf4 ())
            (foreign-bitfield-value 'bf4 'one)
            (foreign-bitfield-value 'bf4 '(one two))
            (foreign-bitfield-value 'bf4 '(three)) ; or should it signal an error?
            (foreign-bitfield-value 'bf4 '(sixteen)))
  0
  1
  3
  3
  16)

(deftest bitfield.4b
    (values (foreign-bitfield-symbols 'bf4 0)
            (foreign-bitfield-symbols 'bf4 1)
            (foreign-bitfield-symbols 'bf4 3)
            (foreign-bitfield-symbols 'bf4 8)
            (foreign-bitfield-symbols 'bf4 16))
  nil
  (one)
  (one two)
  nil
  (sixteen))

(deftest bitfield.translators
    (with-foreign-object (bf 'bf4 2)
      (setf (mem-aref bf 'bf4 0) 1)
      (setf (mem-aref bf 'bf4 1) 3)
      (values (mem-aref bf 'bf4 0)
              (mem-aref bf 'bf4 1)))
  (one)
  (one two))

#+nil
(deftest bitfield.base-type-error
    (expecting-error
      (eval '(defbitfield (bf1 :float)
              (:foo 0))))
  :error)
cffi_0.19.0/tests/random-tester.lisp0000644000175000017500000002401113103031266016114 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; random-tester.lisp --- Random test generator.
;;;
;;; Copyright (C) 2006, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

;;; This code was used to generate the C and Lisp source code for
;;; the CALLBACKS.BFF.[12] and DEFCFUN.BFF.[12] tests.
;;;
;;; The original idea was to test all combinations of argument types
;;; but obviously as soon as you do the maths that it's not quite
;;; feasable for more that 4 or 5 arguments.
;;;
;;; TODO: actually run random tests, ie compile/load/run the tests
;;; this code can generate.

(defpackage #:cffi-random-tester
  (:use #:cl #:cffi #:alexandria #:regression-test))
(in-package #:cffi-random-tester)

(defstruct (c-type (:conc-name type-))
  keyword
  name
  abbrev
  min
  max)

(defparameter +types+
  (mapcar (lambda (type)
            (let ((keyword (first type))
                  (name (second type)))
              (multiple-value-bind (min max)
                  ;; assume we can represent an integer in the range
                  ;; [-2^16 2^16-1] in a float/double without causing
                  ;; rounding errors (probably a lame assumption)
                  (let ((type-size (if (or (eq keyword :float)
                                           (eq keyword :double))
                                       16
                                       (* 8 (foreign-type-size keyword)))))
                    (if (or (eql (char name 0) #\u) (eq keyword :pointer))
                        (values 0 (1- (expt 2 type-size)))
                        (values (- (expt 2 (1- type-size)))
                                (1- (expt 2 (1- type-size))))))
                (make-c-type :keyword keyword :name name :abbrev (third type)
                             :min min :max max))))
          '((:char "char" "c")
            (:unsigned-char "unsigned char" "uc")
            (:short "short" "s")
            (:unsigned-short "unsigned short" "us")
            (:int "int" "i")
            (:unsigned-int "unsigned int" "ui")
            (:long "long" "l")
            (:unsigned-long "unsigned long" "ul")
            (:float "float" "f")
            (:double "double" "d")
            (:pointer "void*" "p")
            (:long-long "long long" "ll")
            (:unsigned-long-long "unsigned long long" "ull"))))

(defun find-type (keyword)
  (find keyword +types+ :key #'type-keyword))

(defun n-random-types (n)
  (loop repeat n collect (nth (random (length +types+)) +types+)))

;;; same as above, without the long long types
(defun n-random-types-no-ll (n)
  (loop repeat n collect (nth (random (- (length +types+) 2)) +types+)))

(defun random-range (x y)
  (+ x (random (+ (- y x) 2))))

(defun random-sum (rettype arg-types)
  "Returns a list of integers that fit in the respective types in the
ARG-TYPES list and whose sum fits in RETTYPE."
  (loop with sum = 0
        for type in arg-types
        for x = (random-range (max (- (type-min rettype) sum) (type-min type))
                              (min (- (type-max rettype) sum) (type-max type)))
        do (incf sum x)
        collect x))

(defun combinations (n items)
  (let ((combs '()))
    (labels ((rec (n accum)
               (if (= n 0)
                   (push accum combs)
                   (loop for item in items
                         do (rec (1- n) (cons item accum))))))
      (rec n '())
      combs)))

(defun function-name (rettype arg-types)
  (format nil "sum_~A_~{_~A~}"
          (type-abbrev rettype)
          (mapcar #'type-abbrev arg-types)))

(defun c-function (rettype arg-types)
  (let ((args (loop for type in arg-types and i from 1
                    collect (list (type-name type) (format nil "a~A" i)))))
    (format t "DLLEXPORT ~A ~A(~{~{~A ~A~}~^, ~})~%~
               { return ~A(~A) ~{~A~^ + ~}~A; }"
            (type-name rettype) (function-name rettype arg-types) args
            (if (eq (type-keyword rettype) :pointer)
                "(void *)((unsigned int)("
                "")
            (type-name rettype)
            (loop for arg-pair in args collect
                  (format nil "~A~A~A"
                          (cond ((string= (first arg-pair) "void*")
                                 "(unsigned int) ")
                                ((or (string= (first arg-pair) "double")
                                     (string= (first arg-pair) "float"))
                                 "((int) ")
                                (t ""))
                          (second arg-pair)
                          (if (member (first arg-pair)
                                      '("void*" "double" "float")
                                      :test #'string=)
                              ")"
                              "")))
            (if (eq (type-keyword rettype) :pointer) "))" ""))))

(defun c-callback (rettype arg-types args)
  (format t "DLLEXPORT ~A call_~A(~A (*func)(~{~A~^, ~}~^))~%~
             { return func(~{~A~^, ~}); }"
          (type-name rettype) (function-name rettype arg-types)
          (type-name rettype) (mapcar #'type-name arg-types)
          (loop for type in arg-types and value in args collect
                (format nil "~A~A"
                        (if (eq (type-keyword type) :pointer)
                            "(void *) "
                            "")
                        value))))

;;; (output-c-code #p"generated.c" 3 5)
(defun output-c-code (file min max)
  (with-open-file (stream file :direction :output :if-exists :error)
    (let ((*standard-output* stream))
      (format t "/* automatically generated functions and callbacks */~%~%")
      (loop for n from min upto max do
            (format t "/* ~A args */" (1- n))
            (loop for comb in (combinations n +types+) do
                  (terpri) (c-function (car comb) (cdr comb))
                  (terpri) (c-callback (car comb) (cdr comb)))))))

(defmacro with-conversion (type form)
  (case type
    (:double `(float ,form 1.0d0))
    (:float `(float ,form))
    (:pointer `(make-pointer ,form))
    (t form)))

(defun integer-conversion (type form)
  (case type
    ((:double :float) `(values (floor ,form)))
    (:pointer `(pointer-address ,form))
    (t form)))

(defun gen-arg-values (rettype arg-types)
  (let ((numbers (random-sum rettype arg-types)))
    (values
     (reduce #'+ numbers)
     (loop for type in arg-types and n in numbers
           collect (case (type-keyword type)
                     (:double (float n 1.0d0))
                     (:float (float n))
                     (:pointer `(make-pointer ,n))
                     (t n))))))

(defun gen-function-test (rettype arg-types)
  (let* ((fun-name (function-name rettype arg-types))
         (fun-sym (cffi::lisp-function-name fun-name)))
    (multiple-value-bind (sum value-forms)
        (gen-arg-values rettype arg-types)
    `(progn
       (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype)
         ,@(loop for type in arg-types and i from 1 collect
                 (list (symbolicate '#:a (format nil "~A" i))
                       (type-keyword type))))
       (deftest ,(symbolicate '#:defcfun. fun-sym)
           ,(integer-conversion (type-keyword rettype)
                                `(,fun-sym ,@value-forms))
         ,sum)))))

(defun gen-callback-test (rettype arg-types sum)
  (let* ((fname (function-name rettype arg-types))
         (cb-sym (cffi::lisp-function-name fname))
         (fun-name (concatenate 'string "call_" fname))
         (fun-sym (cffi::lisp-function-name fun-name))
         (arg-names (loop for i from 1 upto (length arg-types) collect
                          (symbolicate '#:a (format nil "~A" i)))))
    `(progn
       (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) (cb :pointer))
       (defcallback ,cb-sym ,(type-keyword rettype)
           ,(loop for type in arg-types and name in arg-names
                  collect (list name (type-keyword type)))
         ,(integer-conversion
           (type-keyword rettype)
           `(+ ,@(mapcar (lambda (tp n)
                           (integer-conversion (type-keyword tp) n))
                         arg-types arg-names))))
       (deftest ,(symbolicate '#:callbacks. cb-sym)
           ,(integer-conversion (type-keyword rettype)
                                `(,fun-sym (callback ,cb-sym)))
         ,sum))))

(defun cb-test (&key no-long-long)
  (let* ((rettype (find-type (if no-long-long :long :long-long)))
         (arg-types (if no-long-long
                        (n-random-types-no-ll 127)
                        (n-random-types 127)))
         (args (random-sum rettype arg-types))
         (sum (reduce #'+ args)))
    (c-callback rettype arg-types args)
    (gen-callback-test rettype arg-types sum)))

;; (defmacro define-function-and-callback-tests (min max)
;;   `(progn
;;      ,@(loop for n from min upto max appending
;;              (loop for comb in (combinations n +types+)
;;                    collect (gen-function-test (car comb) (cdr comb))
;;                    collect (gen-callback-test (car comb) (cdr comb))))))

;; (define-function-and-callback-tests 3 5)
cffi_0.19.0/tests/GNUmakefile0000644000175000017500000000532313103031266014516 0ustar  luisluis# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
#
# Makefile --- Make targets for various tasks.
#
# Copyright (C) 2005, James Bielman  
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use, copy,
# modify, merge, publish, distribute, sublicense, and/or sell copies
# of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
#

OSTYPE = $(shell uname)
ARCH   = $(shell uname -m)

CC             := gcc
CFLAGS         := -Wall -std=c99 -pedantic
SHLIB_CFLAGS   := -shared
SHLIB_EXT      := .so

ifneq ($(if $(filter Linux %BSD,$(OSTYPE)),OK), OK)
ifeq ($(OSTYPE), Darwin)
SHLIB_CFLAGS   := -dynamiclib
SHLIB_EXT      := .dylib
ifeq ($(shell sysctl -n hw.optional.x86_64), 1)
ARCH           := x86_64
CFLAGS_64      := -m64
endif
else
ifeq ($(OSTYPE), SunOS)
CFLAGS         := -m64 -fPIC -c -Wall -std=c99 -pedantic
else
# Let's assume this is win32
SHLIB_EXT      := .dll
endif
endif
endif

ifneq ($(ARCH), x86_64)
CFLAGS += -lm
endif

ifeq ($(ARCH), x86_64)
CFLAGS_64 += -fPIC
endif

# Are all G5s ppc970s?
ifeq ($(ARCH), ppc970)
CFLAGS_64 += -m64
endif

SHLIBS = libtest$(SHLIB_EXT) libtest2$(SHLIB_EXT) libfsbv$(SHLIB_EXT)

ifeq ($(ARCH), x86_64)
SHLIBS += libtest32$(SHLIB_EXT) libtest2_32$(SHLIB_EXT) libfsbv_32$(SHLIB_EXT)
endif

shlibs: $(SHLIBS)

libtest$(SHLIB_EXT): libtest.c
	$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<

libtest2$(SHLIB_EXT): libtest2.c
	$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<

libfsbv$(SHLIB_EXT): libfsbv.c
	$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<

ifeq ($(ARCH), x86_64)
libtest32$(SHLIB_EXT): libtest.c
	-$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<

libtest2_32$(SHLIB_EXT): libtest2.c
	-$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<

libfsbv_32$(SHLIB_EXT): libfsbv.c
	-$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
endif

clean:
	rm -f *.so *.dylib *.dll *.bundle

# vim: ft=make ts=3 noet
cffi_0.19.0/tests/foreign-globals.lisp0000644000175000017500000002206713103031266016413 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; foreign-globals.lisp --- Tests on foreign globals.
;;;
;;; Copyright (C) 2005-2007, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(defcvar ("var_char" *char-var*)  :char)
(defcvar "var_unsigned_char"      :unsigned-char)
(defcvar "var_short"              :short)
(defcvar "var_unsigned_short"     :unsigned-short)
(defcvar "var_int"                :int)
(defcvar "var_unsigned_int"       :unsigned-int)
(defcvar "var_long"               :long)
(defcvar "var_unsigned_long"      :unsigned-long)
(defcvar "var_float"              :float)
(defcvar "var_double"             :double)
(defcvar "var_pointer"            :pointer)
(defcvar "var_string"             :string)
(defcvar "var_long_long"          :long-long)
(defcvar "var_unsigned_long_long" :unsigned-long-long)

;;; The expected failures marked below result from this odd behaviour:
;;;
;;;   (foreign-symbol-pointer "var_char") => NIL
;;;
;;;   (foreign-symbol-pointer "var_char" :library 'libtest)
;;;     => #
;;;
;;; Why is this  happening? --luis
#+lispworks
(mapc (lambda (x) (pushnew x rtest::*expected-failures*))
      '(foreign-globals.ref.char foreign-globals.get-var-pointer.1
        foreign-globals.get-var-pointer.2 foreign-globals.symbol-name
        foreign-globals.read-only.1 ))

(deftest foreign-globals.ref.char
    *char-var*
  -127)

(deftest foreign-globals.ref.unsigned-char
    *var-unsigned-char*
  255)

(deftest foreign-globals.ref.short
    *var-short*
  -32767)

(deftest foreign-globals.ref.unsigned-short
    *var-unsigned-short*
  65535)

(deftest foreign-globals.ref.int
    *var-int*
  -32767)

(deftest foreign-globals.ref.unsigned-int
    *var-unsigned-int*
  65535)

(deftest foreign-globals.ref.long
    *var-long*
  -2147483647)

(deftest foreign-globals.ref.unsigned-long
    *var-unsigned-long*
  4294967295)

(deftest foreign-globals.ref.float
    *var-float*
  42.0)

(deftest foreign-globals.ref.double
    *var-double*
  42.0d0)

(deftest foreign-globals.ref.pointer
    (null-pointer-p *var-pointer*)
  t)

(deftest foreign-globals.ref.string
    *var-string*
  "Hello, foreign world!")

#+openmcl (push 'foreign-globals.set.long-long rt::*expected-failures*)

(deftest foreign-globals.ref.long-long
    *var-long-long*
  -9223372036854775807)

(deftest foreign-globals.ref.unsigned-long-long
    *var-unsigned-long-long*
  18446744073709551615)

;; The *.set.* tests restore the old values so that the *.ref.*
;; don't fail when re-run.
(defmacro with-old-value-restored ((place) &body body)
  (let ((old (gensym)))
    `(let ((,old ,place))
       (prog1
           (progn ,@body)
         (setq ,place ,old)))))

(deftest foreign-globals.set.int
    (with-old-value-restored (*var-int*)
      (setq *var-int* 42)
      *var-int*)
  42)

(deftest foreign-globals.set.string
    (with-old-value-restored (*var-string*)
      (setq *var-string* "Ehxosxangxo")
      (prog1
          *var-string*
        ;; free the string we just allocated
        (foreign-free (mem-ref (get-var-pointer '*var-string*) :pointer))))
  "Ehxosxangxo")

(deftest foreign-globals.set.long-long
    (with-old-value-restored (*var-long-long*)
      (setq *var-long-long* -9223000000000005808)
      *var-long-long*)
  -9223000000000005808)

(deftest foreign-globals.get-var-pointer.1
    (pointerp (get-var-pointer '*char-var*))
  t)

(deftest foreign-globals.get-var-pointer.2
    (mem-ref (get-var-pointer '*char-var*) :char)
  -127)

;;; Symbol case.

(defcvar "UPPERCASEINT1"     :int)
(defcvar "UPPER_CASE_INT1"   :int)
(defcvar "MiXeDCaSeInT1"     :int)
(defcvar "MiXeD_CaSe_InT1"   :int)

(deftest foreign-globals.ref.uppercaseint1
    *uppercaseint1*
  12345)

(deftest foreign-globals.ref.upper-case-int1
    *upper-case-int1*
  23456)

(deftest foreign-globals.ref.mixedcaseint1
    *mixedcaseint1*
  34567)

(deftest foreign-globals.ref.mixed-case-int1
    *mixed-case-int1*
  45678)

(when (string= (symbol-name 'nil) "NIL")
  (let ((*readtable* (copy-readtable)))
    (setf (readtable-case *readtable*) :invert)
    (eval (read-from-string "(defcvar \"UPPERCASEINT2\"     :int)"))
    (eval (read-from-string "(defcvar \"UPPER_CASE_INT2\"   :int)"))
    (eval (read-from-string "(defcvar \"MiXeDCaSeInT2\"     :int)"))
    (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT2\"   :int)"))
    (setf (readtable-case *readtable*) :preserve)
    (eval (read-from-string "(DEFCVAR \"UPPERCASEINT3\"     :INT)"))
    (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT3\"   :INT)"))
    (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT3\"     :INT)"))
    (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT3\"   :INT)"))))


;;; EVAL gets rid of SBCL's unreachable code warnings.
(when (string= (symbol-name (eval nil)) "nil")
  (let ((*readtable* (copy-readtable)))
    (setf (readtable-case *readtable*) :invert)
    (eval (read-from-string "(DEFCVAR \"UPPERCASEINT2\"     :INT)"))
    (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT2\"   :INT)"))
    (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT2\"     :INT)"))
    (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT2\"   :INT)"))
    (setf (readtable-case *readtable*) :downcase)
    (eval (read-from-string "(defcvar \"UPPERCASEINT3\"     :int)"))
    (eval (read-from-string "(defcvar \"UPPER_CASE_INT3\"   :int)"))
    (eval (read-from-string "(defcvar \"MiXeDCaSeInT3\"     :int)"))
    (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT3\"   :int)"))))

(deftest foreign-globals.ref.uppercaseint2
    *uppercaseint2*
  12345)

(deftest foreign-globals.ref.upper-case-int2
    *upper-case-int2*
  23456)

(deftest foreign-globals.ref.mixedcaseint2
    *mixedcaseint2*
  34567)

(deftest foreign-globals.ref.mixed-case-int2
    *mixed-case-int2*
  45678)

(deftest foreign-globals.ref.uppercaseint3
    *uppercaseint3*
  12345)

(deftest foreign-globals.ref.upper-case-int3
    *upper-case-int3*
  23456)

(deftest foreign-globals.ref.mixedcaseint3
    *mixedcaseint3*
  34567)

(deftest foreign-globals.ref.mixed-case-int3
    *mixed-case-int3*
  45678)

;;; regression test:
;;; gracefully accept symbols in defcvar

(defcvar *var-char* :char)
(defcvar var-char :char)

(deftest foreign-globals.symbol-name
    (values *var-char* var-char)
  -127 -127)

;;;# Namespace

#-cffi-sys::flat-namespace
(progn
  (deftest foreign-globals.namespace.1
      (values
       (mem-ref (foreign-symbol-pointer "var_char" :library 'libtest) :char)
       (foreign-symbol-pointer "var_char" :library 'libtest2))
    -127 nil)

  (deftest foreign-globals.namespace.2
      (values
       (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest) :boolean)
       (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest2) :boolean))
    t nil)

  ;; For its "default" module, Lispworks seems to cache lookups from
  ;; the newest module tried.  If a lookup happens to have failed
  ;; subsequent lookups will fail even the symbol exists in other
  ;; modules.  So this test fails.
  #+lispworks
  (pushnew 'foreign-globals.namespace.3 regression-test::*expected-failures*)

  (deftest foreign-globals.namespace.3
      (values
       (foreign-symbol-pointer "var_char" :library 'libtest2)
       (mem-ref (foreign-symbol-pointer "var_char") :char))
    nil -127)

  (defcvar ("ns_var" *ns-var1* :library libtest) :boolean)
  (defcvar ("ns_var" *ns-var2* :library libtest2) :boolean)

  (deftest foreign-globals.namespace.4
      (values *ns-var1* *ns-var2*)
    t nil))

;;;# Read-only

(defcvar ("var_char" *var-char-ro* :read-only t) :char
  "docstring")

(deftest foreign-globals.read-only.1
    (values *var-char-ro*
            (ignore-errors (setf *var-char-ro* 12)))
  -127 nil)

(deftest defcvar.docstring
    (documentation '*var-char-ro* 'variable)
  "docstring")

;;;# Other tests

;;; RT: FOREIGN-SYMBOL-POINTER shouldn't signal an error when passed
;;; an undefined variable.
(deftest foreign-globals.undefined.1
    (foreign-symbol-pointer "surely-undefined?")
  nil)

(deftest foreign-globals.error.1
    (handler-case (foreign-symbol-pointer 'not-a-string)
      (type-error () t))
  t)
cffi_0.19.0/tests/grovel.lisp0000644000175000017500000000714313103031266014635 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; grovel.lisp --- CFFI-Grovel tests.
;;;
;;; Copyright (C) 2014, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(deftest %invoke
    (cffi-grovel::invoke "echo" "test")
  nil nil 0)

(defun bug-1395242-helper (enum-type base-type constant-name)
  (check-type enum-type (member constantenum cenum))
  (check-type base-type string)
  (check-type constant-name string)
  (let ((enum-name (intern (symbol-name (gensym))))
        (base-type-name (intern (symbol-name (gensym)))))
    (uiop:with-temporary-file (:stream grovel-stream :pathname grovel-file)
      ;; Write the grovel file
      (with-open-stream (*standard-output* grovel-stream)
        (write `(ctype ,base-type-name ,base-type))
        (write `(,enum-type (,enum-name :base-type ,base-type-name)
                            ((:value ,constant-name)))))
      ;; Get the value of :inaddr-broadcast
      (let ((lisp-file (cffi-grovel:process-grovel-file grovel-file)))
        (unwind-protect
             (progn
               (load lisp-file)
               (cffi:foreign-enum-value enum-name :value))
          (uiop/filesystem:delete-file-if-exists lisp-file))))))

(deftest bug-1395242
    (labels
        ((process-expression (expression)
           (loop for enum-type in '(constantenum cenum)
                 always (destructuring-bind (base-type &rest evaluations) expression
                          (loop for (name expected-value) in evaluations
                                for actual-value = (bug-1395242-helper enum-type base-type name)
                                always (or (= expected-value actual-value)
                                           (progn
                                             (format *error-output*
                                                     "Test failed for case: ~A, ~A, ~A (expected ~A, actual ~A)~%"
                                                     enum-type base-type name expected-value actual-value)
                                             nil)))))))
      (every #'process-expression
             '(("uint8_t" ("UINT8_MAX" 255) ("INT8_MAX" 127) ("INT8_MIN" 128))
               ("int8_t" ("INT8_MIN" -128) ("INT8_MAX" 127) ("UINT8_MAX" -1))
               ("uint16_t" ("UINT16_MAX" 65535) ("INT8_MIN" 65408))
               ("int16_t" ("INT16_MIN" -32768) ("INT16_MAX" 32767) ("UINT16_MAX" -1))
               ("uint32_t" ("UINT32_MAX" 4294967295) ("INT8_MIN" 4294967168))
               ("int32_t" ("INT32_MIN" -2147483648) ("INT32_MAX" 2147483647)))))
  t)
cffi_0.19.0/tests/defcfun.lisp0000644000175000017500000004564213103031266014757 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; defcfun.lisp --- Tests function definition and calling.
;;;
;;; Copyright (C) 2005-2007, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(deftest defcfun.parse-name-and-options.1
    (multiple-value-bind (lisp-name foreign-name)
        (let ((*package* (find-package '#:cffi-tests)))
          (cffi::parse-name-and-options "foo_bar"))
      (list lisp-name foreign-name))
  (foo-bar "foo_bar"))

(deftest defcfun.parse-name-and-options.2
    (multiple-value-bind (lisp-name foreign-name)
        (let ((*package* (find-package '#:cffi-tests)))
          (cffi::parse-name-and-options "foo_bar" t))
      (list lisp-name foreign-name))
  (*foo-bar* "foo_bar"))

(deftest defcfun.parse-name-and-options.3
    (multiple-value-bind (lisp-name foreign-name)
        (cffi::parse-name-and-options 'foo-bar)
      (list lisp-name foreign-name))
  (foo-bar "foo_bar"))

(deftest defcfun.parse-name-and-options.4
    (multiple-value-bind (lisp-name foreign-name)
        (cffi::parse-name-and-options '*foo-bar* t)
      (list lisp-name foreign-name))
  (*foo-bar* "foo_bar"))

(deftest defcfun.parse-name-and-options.5
    (multiple-value-bind (lisp-name foreign-name)
        (cffi::parse-name-and-options '("foo_bar" foo-baz))
      (list lisp-name foreign-name))
  (foo-baz "foo_bar"))

(deftest defcfun.parse-name-and-options.6
    (multiple-value-bind (lisp-name foreign-name)
        (cffi::parse-name-and-options '("foo_bar" *foo-baz*) t)
      (list lisp-name foreign-name))
  (*foo-baz* "foo_bar"))

(deftest defcfun.parse-name-and-options.7
    (multiple-value-bind (lisp-name foreign-name)
        (cffi::parse-name-and-options '(foo-baz "foo_bar"))
      (list lisp-name foreign-name))
  (foo-baz "foo_bar"))

(deftest defcfun.parse-name-and-options.8
    (multiple-value-bind (lisp-name foreign-name)
        (cffi::parse-name-and-options '(*foo-baz* "foo_bar") t)
      (list lisp-name foreign-name))
  (*foo-baz* "foo_bar"))

;;;# Name translation

(deftest translate-underscore-separated-name.to-symbol
    (let ((*package* (find-package '#:cffi-tests)))
      (translate-underscore-separated-name "some_name_with_underscores"))
  some-name-with-underscores)

(deftest translate-underscore-separated-name.to-string
    (translate-underscore-separated-name 'some-name-with-underscores)
  "some_name_with_underscores")

(deftest translate-camelcase-name.to-symbol
    (let ((*package* (find-package '#:cffi-tests)))
      (translate-camelcase-name "someXmlFunction"))
  some-xml-function)

(deftest translate-camelcase-name.to-string
    (translate-camelcase-name 'some-xml-function)
  "someXmlFunction")

(deftest translate-camelcase-name.to-string-upper
    (translate-camelcase-name 'some-xml-function :upper-initial-p t)
  "SomeXmlFunction")

(deftest translate-camelcase-name.to-symbol-special
    (let ((*package* (find-package '#:cffi-tests)))
      (translate-camelcase-name "someXMLFunction" :special-words '("XML")))
  some-xml-function)

(deftest translate-camelcase-name.to-string-special
    (translate-camelcase-name 'some-xml-function :special-words '("XML"))
  "someXMLFunction")

(deftest translate-name-from-foreign.function
    (let ((*package* (find-package '#:cffi-tests)))
      (translate-name-from-foreign "some_xml_name" *package*))
  some-xml-name)

(deftest translate-name-from-foreign.var
    (let ((*package* (find-package '#:cffi-tests)))
      (translate-name-from-foreign "some_xml_name" *package* t))
  *some-xml-name*)

(deftest translate-name-to-foreign.function
    (translate-name-to-foreign 'some-xml-name *package*)
  "some_xml_name")

(deftest translate-name-to-foreign.var
    (translate-name-to-foreign '*some-xml-name* *package* t)
  "some_xml_name")

;;;# Calling with built-in c types
;;;
;;; Tests calling standard C library functions both passing
;;; and returning each built-in type. (adapted from funcall.lisp)

(defcfun "toupper" :char
  "toupper docstring"
  (char :char))

(deftest defcfun.char
    (toupper (char-code #\a))
  #.(char-code #\A))

(deftest defcfun.docstring
    (documentation 'toupper 'function)
  "toupper docstring")


(defcfun ("abs" c-abs) :int
  (n :int))

(deftest defcfun.int
    (c-abs -100)
  100)


(defcfun "labs" :long
  (n :long))

(deftest defcfun.long
    (labs -131072)
  131072)


#-cffi-features:no-long-long
(progn
  (defcfun "my_llabs" :long-long
    (n :long-long))

  (deftest defcfun.long-long
      (my-llabs -9223372036854775807)
    9223372036854775807)

  (defcfun "ullong" :unsigned-long-long
    (n :unsigned-long-long))

  #+allegro ; lp#914500
  (pushnew 'defcfun.unsigned-long-long rt::*expected-failures*)

  (deftest defcfun.unsigned-long-long
      (let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long))))))
        (eql ullong-max (ullong ullong-max)))
    t))


(defcfun "my_sqrtf" :float
  (n :float))

(deftest defcfun.float
    (my-sqrtf 16.0)
  4.0)


(defcfun ("sqrt" c-sqrt) :double
  (n :double))

(deftest defcfun.double
    (c-sqrt 36.0d0)
  6.0d0)


#+(and scl long-float)
(defcfun ("sqrtl" c-sqrtl) :long-double
  (n :long-double))

#+(and scl long-float)
(deftest defcfun.long-double
    (c-sqrtl 36.0l0)
  6.0l0)


(defcfun "strlen" :int
  (n :string))

(deftest defcfun.string.1
    (strlen "Hello")
  5)


(defcfun "strcpy" (:pointer :char)
  (dest (:pointer :char))
  (src :string))

(defcfun "strcat" (:pointer :char)
  (dest (:pointer :char))
  (src :string))

(deftest defcfun.string.2
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (strcpy s "Hello")
      (strcat s ", world!"))
  "Hello, world!")

(defcfun "strerror" :string
  (n :int))

(deftest defcfun.string.3
    (typep (strerror 1) 'string)
  t)


;;; Regression test. Allegro would warn on direct calls to
;;; functions with no arguments.
;;;
;;; Also, let's check if void functions will return NIL.
;;;
;;; Check if a docstring without arguments doesn't cause problems.

(defcfun "noargs" :int
  "docstring")

(deftest defcfun.noargs
    (noargs)
  42)

(defcfun "noop" :void)

#+(or allegro openmcl ecl) (pushnew 'defcfun.noop rt::*expected-failures*)

(deftest defcfun.noop
    (noop)
  #|no values|#)

;;;# Calling varargs functions

(defcfun "sprintf" :int
  "sprintf docstring"
  (str (:pointer :char))
  (control :string)
  &rest)

;;; CLISP and ABCL discard macro docstrings.
#+(or clisp abcl)
(pushnew 'defcfun.varargs.docstrings rt::*expected-failures*)

(deftest defcfun.varargs.docstrings
    (documentation 'sprintf 'function)
  "sprintf docstring")

(deftest defcfun.varargs.char
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%c" :char 65))
  "A")

(deftest defcfun.varargs.short
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%d" :short 42))
  "42")

(deftest defcfun.varargs.int
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%d" :int 1000))
  "1000")

(deftest defcfun.varargs.long
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%ld" :long 131072))
  "131072")

(deftest defcfun.varargs.float
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%.2f" :float (float pi)))
  "3.14")

(deftest defcfun.varargs.double
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%.2f" :double (float pi 1.0d0)))
  "3.14")

#+(and scl long-float)
(deftest defcfun.varargs.long-double
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (sprintf s "%.2Lf" :long-double pi))
  "3.14")

(deftest defcfun.varargs.string
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%s, %s!" :string "Hello" :string "world"))
  "Hello, world!")

;;; (let ((rettype (find-type :long))
;;;       (arg-types (n-random-types-no-ll 127)))
;;;   (c-function rettype arg-types)
;;;   (gen-function-test rettype arg-types))

#+(and (not ecl)
       #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or)))
(progn
  (defcfun "sum_127_no_ll" :long
    (a1 :long) (a2 :unsigned-long) (a3 :short) (a4 :unsigned-short) (a5 :float)
    (a6 :double) (a7 :unsigned-long) (a8 :float) (a9 :unsigned-char)
    (a10 :unsigned-short) (a11 :short) (a12 :unsigned-long) (a13 :double)
    (a14 :long) (a15 :unsigned-int) (a16 :pointer) (a17 :unsigned-int)
    (a18 :unsigned-short) (a19 :long) (a20 :float) (a21 :pointer) (a22 :float)
    (a23 :int) (a24 :int) (a25 :unsigned-short) (a26 :long) (a27 :long)
    (a28 :double) (a29 :unsigned-char) (a30 :unsigned-int) (a31 :unsigned-int)
    (a32 :int) (a33 :unsigned-short) (a34 :unsigned-int) (a35 :pointer)
    (a36 :double) (a37 :double) (a38 :long) (a39 :short) (a40 :unsigned-short)
    (a41 :long) (a42 :char) (a43 :long) (a44 :unsigned-short) (a45 :pointer)
    (a46 :int) (a47 :unsigned-int) (a48 :double) (a49 :unsigned-char)
    (a50 :unsigned-char) (a51 :float) (a52 :int) (a53 :unsigned-short)
    (a54 :double) (a55 :short) (a56 :unsigned-char) (a57 :unsigned-long)
    (a58 :float) (a59 :float) (a60 :float) (a61 :pointer) (a62 :pointer)
    (a63 :unsigned-int) (a64 :unsigned-long) (a65 :char) (a66 :short)
    (a67 :unsigned-short) (a68 :unsigned-long) (a69 :pointer) (a70 :float)
    (a71 :double) (a72 :long) (a73 :unsigned-long) (a74 :short)
    (a75 :unsigned-int) (a76 :unsigned-short) (a77 :int) (a78 :unsigned-short)
    (a79 :char) (a80 :double) (a81 :short) (a82 :unsigned-char) (a83 :float)
    (a84 :char) (a85 :int) (a86 :double) (a87 :unsigned-char) (a88 :int)
    (a89 :unsigned-long) (a90 :double) (a91 :short) (a92 :short)
    (a93 :unsigned-int) (a94 :unsigned-char) (a95 :float) (a96 :long)
    (a97 :float) (a98 :long) (a99 :long) (a100 :int) (a101 :int)
    (a102 :unsigned-int) (a103 :char) (a104 :char) (a105 :unsigned-short)
    (a106 :unsigned-int) (a107 :unsigned-short) (a108 :unsigned-short)
    (a109 :int) (a110 :long) (a111 :char) (a112 :double) (a113 :unsigned-int)
    (a114 :char) (a115 :short) (a116 :unsigned-long) (a117 :unsigned-int)
    (a118 :short) (a119 :unsigned-char) (a120 :float) (a121 :pointer)
    (a122 :double) (a123 :int) (a124 :long) (a125 :char) (a126 :unsigned-short)
    (a127 :float))

  (deftest defcfun.bff.1
      (sum-127-no-ll
       1442906394 520035521 -4715 50335 -13557.0 -30892.0d0 24061483 -23737.0
       22 2348 4986 104895680 8073.0d0 -571698147 102484400
       (make-pointer 507907275) 12733353 7824 -1275845284 13602.0
       (make-pointer 286958390) -8042.0 -773681663 -1289932452 31199 -154985357
       -170994216 16845.0d0 177 218969221 2794350893 6068863 26327 127699339
       (make-pointer 184352771) 18512.0d0 -12345.0d0 -179853040 -19981 37268
       -792845398 116 -1084653028 50494 (make-pointer 2105239646) -1710519651
       1557813312 2839.0d0 90 180 30580.0 -532698978 8623 9537.0d0 -10882 54
       184357206 14929.0 -8190.0 -25615.0 (make-pointer 235310526)
       (make-pointer 220476977) 7476055 1576685 -117 -11781 31479 23282640
       (make-pointer 8627281) -17834.0 10391.0d0 -1904504370 114393659 -17062
       637873619 16078 -891210259 8107 0 760.0d0 -21268 104 14133.0 10
       588598141 310.0d0 20 1351785456 16159552 -10121.0d0 -25866 24821
       68232851 60 -24132.0 -1660411658 13387.0 -786516668 -499825680
       -1128144619 111849719 2746091587 -2 95 14488 326328135 64781 18204
       150716680 -703859275 103 16809.0d0 852235610 -43 21088 242356110
       324325428 -22380 23 24814.0 (make-pointer 40362014) -14322.0d0
       -1864262539 523684371 -21 49995 -29175.0)
    796447501))

;;; (let ((rettype (find-type :long-long))
;;;       (arg-types (n-random-types 127)))
;;;   (c-function rettype arg-types)
;;;   (gen-function-test rettype arg-types))

#-(or ecl cffi-sys::no-long-long
      #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
(progn
  (defcfun "sum_127" :long-long
    (a1 :pointer) (a2 :pointer) (a3 :float) (a4 :unsigned-long) (a5 :pointer)
    (a6 :long-long) (a7 :double) (a8 :double) (a9 :unsigned-short) (a10 :int)
    (a11 :long-long) (a12 :long) (a13 :short) (a14 :unsigned-int) (a15 :long)
    (a16 :unsigned-char) (a17 :int) (a18 :double) (a19 :short) (a20 :short)
    (a21 :long-long) (a22 :unsigned-int) (a23 :unsigned-short) (a24 :short)
    (a25 :pointer) (a26 :short) (a27 :unsigned-short) (a28 :unsigned-short)
    (a29 :int) (a30 :long-long) (a31 :pointer) (a32 :int) (a33 :unsigned-long)
    (a34 :unsigned-long) (a35 :pointer) (a36 :unsigned-long-long) (a37 :float)
    (a38 :int) (a39 :short) (a40 :pointer) (a41 :unsigned-long-long)
    (a42 :long-long) (a43 :unsigned-long) (a44 :unsigned-long)
    (a45 :unsigned-long-long) (a46 :unsigned-long) (a47 :char) (a48 :double)
    (a49 :long) (a50 :unsigned-int) (a51 :int) (a52 :short) (a53 :pointer)
    (a54 :long) (a55 :unsigned-long-long) (a56 :int) (a57 :unsigned-short)
    (a58 :unsigned-long-long) (a59 :float) (a60 :pointer) (a61 :float)
    (a62 :unsigned-short) (a63 :unsigned-long) (a64 :float) (a65 :unsigned-int)
    (a66 :unsigned-long-long) (a67 :pointer) (a68 :double)
    (a69 :unsigned-long-long) (a70 :double) (a71 :double) (a72 :long-long)
    (a73 :pointer) (a74 :unsigned-short) (a75 :long) (a76 :pointer) (a77 :short)
    (a78 :double) (a79 :long) (a80 :unsigned-char) (a81 :pointer)
    (a82 :unsigned-char) (a83 :long) (a84 :double) (a85 :pointer) (a86 :int)
    (a87 :double) (a88 :unsigned-char) (a89 :double) (a90 :short) (a91 :long)
    (a92 :int) (a93 :long) (a94 :double) (a95 :unsigned-short)
    (a96 :unsigned-int) (a97 :int) (a98 :char) (a99 :long-long) (a100 :double)
    (a101 :float) (a102 :unsigned-long) (a103 :short) (a104 :pointer)
    (a105 :float) (a106 :long-long) (a107 :int) (a108 :long-long)
    (a109 :long-long) (a110 :double) (a111 :unsigned-long-long) (a112 :double)
    (a113 :unsigned-long) (a114 :char) (a115 :char) (a116 :unsigned-long)
    (a117 :short) (a118 :unsigned-char) (a119 :unsigned-char) (a120 :int)
    (a121 :int) (a122 :float) (a123 :unsigned-char) (a124 :unsigned-char)
    (a125 :double) (a126 :unsigned-long-long) (a127 :char))

  #+(and sbcl x86) (push 'defcfun.bff.2 rtest::*expected-failures*)

  (deftest defcfun.bff.2
      (sum-127
       (make-pointer 2746181372) (make-pointer 177623060) -32334.0 3158055028
       (make-pointer 242315091) 4288001754991016425 -21047.0d0 287.0d0 18722
       243379286 -8677366518541007140 581399424 -13872 4240394881 1353358999
       226 969197676 -26207.0d0 6484 11150 1241680089902988480 106068320 61865
       2253 (make-pointer 866809333) -31613 35616 11715 1393601698
       8940888681199591845 (make-pointer 1524606024) 805638893 3315410736
       3432596795 (make-pointer 1490355706) 696175657106383698 -25438.0
       1294381547 26724 (make-pointer 3196569545) 2506913373410783697
       -4405955718732597856 4075932032 3224670123 2183829215657835866
       1318320964 -22 -3786.0d0 -2017024146 1579225515 -626617701 -1456
       (make-pointer 3561444187) 395687791 1968033632506257320 -1847773261
       48853 142937735275669133 -17974.0 (make-pointer 2791749948) -14140.0
       2707 3691328585 3306.0 1132012981 303633191773289330
       (make-pointer 981183954) 9114.0d0 8664374572369470 -19013.0d0
       -10288.0d0 -3679345119891954339 (make-pointer 3538786709) 23761
       -154264605 (make-pointer 2694396308) 7023 997.0d0 1009561368 241
       (make-pointer 2612292671) 48 1431872408 -32675.0d0
       (make-pointer 1587599336) 958916472 -9857.0d0 111 -14370.0d0 -7308
       -967514912 488790941 2146978095 -24111.0d0 13711 86681861 717987770
       111 1013402998690933877 17234.0d0 -8772.0 3959216275 -8711
       (make-pointer 3142780851) 9480.0 -3820453146461186120 1616574376
       -3336232268263990050 -1906114671562979758 -27925.0d0 9695970875869913114
       27033.0d0 1096518219 -12 104 3392025403 -27911 60 89 509297051
       -533066551 29158.0 110 54 -9802.0d0 593950442165910888 -79)
    7758614658402721936))

;;; regression test: defining an undefined foreign function should only
;;; throw some sort of warning, not signal an error.

#+(or cmucl (and sbcl (or (not linkage-table) win32)))
(pushnew 'defcfun.undefined rt::*expected-failures*)

(deftest defcfun.undefined
    (progn
      (eval '(defcfun ("undefined_foreign_function" undefined-foreign-function) :void))
      (compile 'undefined-foreign-function)
      t)
  t)

;;; Test whether all doubles are passed correctly. On some platforms, eg.
;;; darwin/ppc, some are passed on registers others on the stack.
(defcfun "sum_double26" :double
  (a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
  (a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
  (a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
  (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
  (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
  (a26 :double))

(deftest defcfun.double26
    (sum-double26 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
                  3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
                  3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
                  3.14d0 3.14d0 3.14d0 3.14d0 3.14d0)
  81.64d0)

;;; Same as above for floats.
(defcfun "sum_float26" :float
  (a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
  (a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
  (a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
  (a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
  (a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
  (a26 :float))

(deftest defcfun.float26
    (sum-float26 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0
                 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0)
  130.0)

;;;# Namespaces

#-cffi-sys::flat-namespace
(progn
  (defcfun ("ns_function" ns-fun1 :library libtest) :boolean)
  (defcfun ("ns_function" ns-fun2 :library libtest2) :boolean)

  (deftest defcfun.namespace.1
      (values (ns-fun1) (ns-fun2))
    t nil))

;;;# stdcall

#+(and x86 windows (not cffi-sys::no-stdcall))
(progn
  (defcfun ("stdcall_fun@12" stdcall-fun :convention :stdcall) :int
    (a :int)
    (b :int)
    (c :int))

  (deftest defcfun.stdcall.1
      (loop repeat 100 do (stdcall-fun 1 2 3)
            finally (return (stdcall-fun 1 2 3)))
    6))
cffi_0.19.0/tests/memory.lisp0000644000175000017500000004510713103031266014651 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; memory.lisp --- Tests for memory referencing.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(deftest deref.char
    (with-foreign-object (p :char)
      (setf (mem-ref p :char) -127)
      (mem-ref p :char))
  -127)

(deftest deref.unsigned-char
    (with-foreign-object (p :unsigned-char)
      (setf (mem-ref p :unsigned-char) 255)
      (mem-ref p :unsigned-char))
  255)

(deftest deref.short
    (with-foreign-object (p :short)
      (setf (mem-ref p :short) -32767)
      (mem-ref p :short))
  -32767)

(deftest deref.unsigned-short
    (with-foreign-object (p :unsigned-short)
      (setf (mem-ref p :unsigned-short) 65535)
      (mem-ref p :unsigned-short))
  65535)

(deftest deref.int
    (with-foreign-object (p :int)
      (setf (mem-ref p :int) -131072)
      (mem-ref p :int))
  -131072)

(deftest deref.unsigned-int
    (with-foreign-object (p :unsigned-int)
      (setf (mem-ref p :unsigned-int) 262144)
      (mem-ref p :unsigned-int))
  262144)

(deftest deref.long
    (with-foreign-object (p :long)
      (setf (mem-ref p :long) -536870911)
      (mem-ref p :long))
  -536870911)

(deftest deref.unsigned-long
    (with-foreign-object (p :unsigned-long)
      (setf (mem-ref p :unsigned-long) 536870912)
      (mem-ref p :unsigned-long))
  536870912)

#+(and darwin openmcl)
(pushnew 'deref.long-long rt::*expected-failures*)

(deftest deref.long-long
    (with-foreign-object (p :long-long)
      (setf (mem-ref p :long-long) -9223372036854775807)
      (mem-ref p :long-long))
  -9223372036854775807)

(deftest deref.unsigned-long-long
    (with-foreign-object (p :unsigned-long-long)
      (setf (mem-ref p :unsigned-long-long) 18446744073709551615)
      (mem-ref p :unsigned-long-long))
  18446744073709551615)

(deftest deref.float.1
    (with-foreign-object (p :float)
      (setf (mem-ref p :float) 0.0)
      (mem-ref p :float))
  0.0)

(deftest deref.float.2
    (with-foreign-object (p :float)
      (setf (mem-ref p :float) *float-max*)
      (mem-ref p :float))
  #.*float-max*)

(deftest deref.float.3
    (with-foreign-object (p :float)
      (setf (mem-ref p :float) *float-min*)
      (mem-ref p :float))
  #.*float-min*)

(deftest deref.double.1
    (with-foreign-object (p :double)
      (setf (mem-ref p :double) 0.0d0)
      (mem-ref p :double))
  0.0d0)

(deftest deref.double.2
    (with-foreign-object (p :double)
      (setf (mem-ref p :double) *double-max*)
      (mem-ref p :double))
  #.*double-max*)

(deftest deref.double.3
    (with-foreign-object (p :double)
      (setf (mem-ref p :double) *double-min*)
      (mem-ref p :double))
  #.*double-min*)

;;; TODO: use something like *DOUBLE-MIN/MAX* above once we actually
;;; have an available lisp that supports long double.
;#-cffi-sys::no-long-float
#+(and scl long-double)
(progn
  (deftest deref.long-double.1
      (with-foreign-object (p :long-double)
        (setf (mem-ref p :long-double) 0.0l0)
        (mem-ref p :long-double))
    0.0l0)

  (deftest deref.long-double.2
      (with-foreign-object (p :long-double)
        (setf (mem-ref p :long-double) most-positive-long-float)
        (mem-ref p :long-double))
    #.most-positive-long-float)

  (deftest deref.long-double.3
      (with-foreign-object (p :long-double)
        (setf (mem-ref p :long-double) least-positive-long-float)
        (mem-ref p :long-double))
    #.least-positive-long-float))

;;; make sure the lisp doesn't convert NULL to NIL
(deftest deref.pointer.null
    (with-foreign-object (p :pointer)
      (setf (mem-ref p :pointer) (null-pointer))
      (null-pointer-p (mem-ref p :pointer)))
  t)

;;; regression test. lisp-string-to-foreign should handle empty strings
(deftest lisp-string-to-foreign.empty
    (with-foreign-pointer (str 2)
      (setf (mem-ref str :unsigned-char) 42)
      (lisp-string-to-foreign "" str 1)
      (mem-ref str :unsigned-char))
  0)

;;; regression test. with-foreign-pointer shouldn't evaluate
;;; the size argument twice.
(deftest with-foreign-pointer.evalx2
    (let ((count 0))
      (with-foreign-pointer (x (incf count) size-var)
        (values count size-var)))
  1 1)

(defconstant +two+ 2)

;;; regression test. cffi-allegro's with-foreign-pointer wasn't
;;; handling constants properly.
(deftest with-foreign-pointer.constant-size
    (with-foreign-pointer (p +two+ size)
      size)
  2)

(deftest mem-ref.left-to-right
    (let ((i 0))
      (with-foreign-object (p :char 3)
        (setf (mem-ref p :char 0) 66 (mem-ref p :char 1) 92)
        (setf (mem-ref p :char (incf i)) (incf i))
        (values (mem-ref p :char 0) (mem-ref p :char 1) i)))
  66 2 2)

;;; This needs to be in a real function for at least Allegro CL or the
;;; compiler macro on %MEM-REF is not expanded and the test doesn't
;;; actually test anything!
(defun %mem-ref-left-to-right ()
  (let ((result nil))
    (with-foreign-object (p :char)
      (%mem-set 42 p :char)
      (%mem-ref (progn (push 1 result) p) :char (progn (push 2 result) 0))
      (nreverse result))))

;;; Test left-to-right evaluation of the arguments to %MEM-REF when
;;; optimized by the compiler macro.
(deftest %mem-ref.left-to-right
    (%mem-ref-left-to-right)
  (1 2))

;;; This needs to be in a top-level function for at least Allegro CL
;;; or the compiler macro on %MEM-SET is not expanded and the test
;;; doesn't actually test anything!
(defun %mem-set-left-to-right ()
  (let ((result nil))
    (with-foreign-object (p :char)
      (%mem-set (progn (push 1 result) 0)
                (progn (push 2 result) p)
                :char
                (progn (push 3 result) 0))
      (nreverse result))))

;;; Test left-to-right evaluation of the arguments to %MEM-SET when
;;; optimized by the compiler macro.
(deftest %mem-set.left-to-right
    (%mem-set-left-to-right)
  (1 2 3))

;; regression test. mem-aref's setf expansion evaluated its type argument twice.
(deftest mem-aref.eval-type-x2
    (let ((count 0))
      (with-foreign-pointer (p 1)
        (setf (mem-aref p (progn (incf count) :char) 0) 127))
      count)
  1)

(deftest mem-aref.left-to-right
    (let ((count -1))
      (with-foreign-pointer (p 2)
        (values
         (setf (mem-aref p (progn (incf count) :char) (incf count)) (incf count))
         (setq count -1)
         (mem-aref (progn (incf count) p) :char (incf count))
         count)))
  2 -1 2 1)

;; regression tests. nested mem-ref's and mem-aref's had bogus getters
(deftest mem-ref.nested
    (with-foreign-object (p :pointer)
      (with-foreign-object (i :int)
        (setf (mem-ref p :pointer) i)
        (setf (mem-ref i :int) 42)
        (setf (mem-ref (mem-ref p :pointer) :int) 1984)
        (mem-ref i :int)))
  1984)

(deftest mem-aref.nested
    (with-foreign-object (p :pointer)
      (with-foreign-object (i :int 2)
        (setf (mem-aref p :pointer 0) i)
        (setf (mem-aref i :int 1) 42)
        (setf (mem-aref (mem-ref p :pointer 0) :int 1) 1984)
        (mem-aref i :int 1)))
  1984)

(cffi:defcstruct mem-aref.bare-struct
  (a :uint8))

;;; regression test: although mem-aref was dealing with bare struct
;;; types as though they were pointers, it wasn't calculating the
;;; proper offsets. The offsets for bare structs types should be
;;; calculated as aggregate types.
(deftest mem-aref.bare-struct
    (with-foreign-object (a 'mem-aref.bare-struct 2)
      (eql (- (pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 1))
              (pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 0)))
           (foreign-type-size '(:struct mem-aref.bare-struct))))
  t)

;;; regression tests. dereferencing an aggregate type. dereferencing a
;;; struct should return a pointer to the struct itself, not return the
;;; first 4 bytes (or whatever the size of :pointer is) as a pointer.
;;;
;;; This important for accessing an array of structs, which is
;;; what the deref.array-of-aggregates test does.
(defcstruct some-struct (x :int))

(deftest deref.aggregate
    (with-foreign-object (s 'some-struct)
      (pointer-eq s (mem-ref s 'some-struct)))
  t)

(deftest deref.array-of-aggregates
    (with-foreign-object (arr 'some-struct 3)
      (loop for i below 3
            do (setf (foreign-slot-value (mem-aref arr 'some-struct i)
                                         'some-struct 'x)
                     112))
      (loop for i below 3
            collect (foreign-slot-value (mem-aref arr 'some-struct i)
                                        'some-struct 'x)))
  (112 112 112))

;;; pointer operations
(deftest pointer.1
    (pointer-address (make-pointer 42))
  42)

;;; I suppose this test is not very good. --luis
(deftest pointer.2
    (pointer-address (null-pointer))
  0)

(deftest pointer.null
    (nth-value 0 (ignore-errors (null-pointer-p nil)))
  nil)

(deftest foreign-pointer-type.nil
    (typep nil 'foreign-pointer)
  nil)

;;; Ensure that a pointer to the highest possible address can be
;;; created using MAKE-POINTER.  Regression test for CLISP/X86-64.
(deftest make-pointer.high
    (let* ((pointer-length (foreign-type-size :pointer))
           (high-address (1- (expt 2 (* pointer-length 8))))
           (pointer (make-pointer high-address)))
      (- high-address (pointer-address pointer)))
  0)

;;; Ensure that incrementing a pointer by zero bytes returns an
;;; equivalent pointer.
(deftest inc-pointer.zero
    (with-foreign-object (x :int)
      (pointer-eq x (inc-pointer x 0)))
  t)

;;; Test the INITIAL-ELEMENT keyword argument to FOREIGN-ALLOC.
(deftest foreign-alloc.1
    (let ((ptr (foreign-alloc :int :initial-element 42)))
      (unwind-protect
           (mem-ref ptr :int)
        (foreign-free ptr)))
  42)

;;; Test the INITIAL-ELEMENT and COUNT arguments to FOREIGN-ALLOC.
(deftest foreign-alloc.2
    (let ((ptr (foreign-alloc :int :count 4 :initial-element 100)))
      (unwind-protect
           (loop for i from 0 below 4
                 collect (mem-aref ptr :int i))
        (foreign-free ptr)))
  (100 100 100 100))

;;; Test the INITIAL-CONTENTS and COUNT arguments to FOREIGN-ALLOC,
;;; passing a list of initial values.
(deftest foreign-alloc.3
    (let ((ptr (foreign-alloc :int :count 4 :initial-contents '(4 3 2 1))))
      (unwind-protect
           (loop for i from 0 below 4
                 collect (mem-aref ptr :int i))
        (foreign-free ptr)))
  (4 3 2 1))

;;; Test INITIAL-CONTENTS and COUNT with FOREIGN-ALLOC passing a
;;; vector of initial values.
(deftest foreign-alloc.4
    (let ((ptr (foreign-alloc :int :count 4 :initial-contents #(10 20 30 40))))
      (unwind-protect
           (loop for i from 0 below 4
                 collect (mem-aref ptr :int i))
        (foreign-free ptr)))
  (10 20 30 40))

;;; Ensure calling FOREIGN-ALLOC with both INITIAL-ELEMENT and
;;; INITIAL-CONTENTS signals an error.
(deftest foreign-alloc.5
    (values
     (ignore-errors
       (let ((ptr (foreign-alloc :int :initial-element 1
                                 :initial-contents '(1))))
         (foreign-free ptr))
       t))
  nil)

;;; Regression test: FOREIGN-ALLOC shouldn't actually perform translation
;;; on initial-element/initial-contents since MEM-AREF will do that already.
(define-foreign-type not-an-int ()
  ()
  (:actual-type :int)
  (:simple-parser not-an-int))

(defmethod translate-to-foreign (value (type not-an-int))
  (assert (not (integerp value)))
  0)

(deftest foreign-alloc.6
    (let ((ptr (foreign-alloc 'not-an-int :initial-element 'foooo)))
      (foreign-free ptr)
      t)
  t)

;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P and a non-pointer
;;; type signals an error.
(deftest foreign-alloc.7
    (values
     (ignore-errors
       (let ((ptr (foreign-alloc :int :null-terminated-p t)))
         (foreign-free ptr))
       t))
  nil)

;;; The opposite of the above test.
(defctype pointer-alias :pointer)

(deftest foreign-alloc.8
    (progn
      (foreign-free (foreign-alloc 'pointer-alias :count 0 :null-terminated-p t))
      t)
  t)

;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P actually places
;;; a null pointer at the end. Not a very reliable test apparently.
(deftest foreign-alloc.9
    (let ((ptr (foreign-alloc :pointer :count 0 :null-terminated-p t)))
      (unwind-protect
           (null-pointer-p (mem-ref ptr :pointer))
        (foreign-free ptr)))
  t)

;;; RT: FOREIGN-ALLOC with :COUNT 0 on CLISP signalled an error.
(deftest foreign-alloc.10
    (foreign-free (foreign-alloc :char :count 0))
  nil)

;;; Tests for mem-ref with a non-constant type. This is a way to test
;;; the functional interface (without compiler macros).

(deftest deref.nonconst.char
    (let ((type :char))
      (with-foreign-object (p type)
        (setf (mem-ref p type) -127)
        (mem-ref p type)))
  -127)

(deftest deref.nonconst.unsigned-char
    (let ((type :unsigned-char))
      (with-foreign-object (p type)
        (setf (mem-ref p type) 255)
        (mem-ref p type)))
  255)

(deftest deref.nonconst.short
    (let ((type :short))
      (with-foreign-object (p type)
        (setf (mem-ref p type) -32767)
        (mem-ref p type)))
  -32767)

(deftest deref.nonconst.unsigned-short
    (let ((type :unsigned-short))
      (with-foreign-object (p type)
        (setf (mem-ref p type) 65535)
        (mem-ref p type)))
  65535)

(deftest deref.nonconst.int
    (let ((type :int))
      (with-foreign-object (p type)
        (setf (mem-ref p type) -131072)
        (mem-ref p type)))
  -131072)

(deftest deref.nonconst.unsigned-int
    (let ((type :unsigned-int))
      (with-foreign-object (p type)
        (setf (mem-ref p type) 262144)
        (mem-ref p type)))
  262144)

(deftest deref.nonconst.long
    (let ((type :long))
      (with-foreign-object (p type)
        (setf (mem-ref p type) -536870911)
        (mem-ref p type)))
  -536870911)

(deftest deref.nonconst.unsigned-long
    (let ((type :unsigned-long))
      (with-foreign-object (p type)
        (setf (mem-ref p type) 536870912)
        (mem-ref p type)))
  536870912)

#+(and darwin openmcl)
(pushnew 'deref.nonconst.long-long rt::*expected-failures*)

(deftest deref.nonconst.long-long
    (let ((type :long-long))
      (with-foreign-object (p type)
        (setf (mem-ref p type) -9223372036854775807)
        (mem-ref p type)))
  -9223372036854775807)

(deftest deref.nonconst.unsigned-long-long
    (let ((type :unsigned-long-long))
      (with-foreign-object (p type)
        (setf (mem-ref p type) 18446744073709551615)
        (mem-ref p type)))
  18446744073709551615)

(deftest deref.nonconst.float.1
    (let ((type :float))
      (with-foreign-object (p type)
        (setf (mem-ref p type) 0.0)
        (mem-ref p type)))
  0.0)

(deftest deref.nonconst.float.2
    (let ((type :float))
      (with-foreign-object (p type)
        (setf (mem-ref p type) *float-max*)
        (mem-ref p type)))
  #.*float-max*)

(deftest deref.nonconst.float.3
    (let ((type :float))
      (with-foreign-object (p type)
        (setf (mem-ref p type) *float-min*)
        (mem-ref p type)))
  #.*float-min*)

(deftest deref.nonconst.double.1
    (let ((type :double))
      (with-foreign-object (p type)
        (setf (mem-ref p type) 0.0d0)
        (mem-ref p type)))
  0.0d0)

(deftest deref.nonconst.double.2
    (let ((type :double))
      (with-foreign-object (p type)
        (setf (mem-ref p type) *double-max*)
        (mem-ref p type)))
  #.*double-max*)

(deftest deref.nonconst.double.3
    (let ((type :double))
      (with-foreign-object (p type)
        (setf (mem-ref p type) *double-min*)
        (mem-ref p type)))
  #.*double-min*)

;;; regression tests: lispworks's %mem-ref and %mem-set compiler
;;; macros were misbehaving.

(defun mem-ref-rt-1 ()
  (with-foreign-object (a :int 2)
    (setf (mem-aref a :int 0) 123
          (mem-aref a :int 1) 456)
    (values (mem-aref a :int 0) (mem-aref a :int 1))))

(deftest mem-ref.rt.1
    (mem-ref-rt-1)
  123 456)

(defun mem-ref-rt-2 ()
  (with-foreign-object (a :double 2)
    (setf (mem-aref a :double 0) 123.0d0
          (mem-aref a :double 1) 456.0d0)
    (values (mem-aref a :double 0) (mem-aref a :double 1))))

(deftest mem-ref.rt.2
    (mem-ref-rt-2)
  123.0d0 456.0d0)

(deftest incf-pointer.1
    (let ((ptr (null-pointer)))
      (incf-pointer ptr)
      (pointer-address ptr))
  1)

(deftest incf-pointer.2
    (let ((ptr (null-pointer)))
      (incf-pointer ptr 42)
      (pointer-address ptr))
  42)

(deftest pointerp.1
    (values
     (pointerp (null-pointer))
     (null-pointer-p (null-pointer))
     (typep (null-pointer) 'foreign-pointer))
  t t t)

(deftest pointerp.2
    (let ((p (make-pointer #xFEFF)))
      (values
       (pointerp p)
       (typep p 'foreign-pointer)))
  t t)

(deftest pointerp.3
    (pointerp 'not-a-pointer)
  nil)

(deftest pointerp.4
    (pointerp 42)
  nil)

(deftest pointerp.5
    (pointerp 0)
  nil)

(deftest pointerp.6
    (pointerp nil)
  nil)

(deftest mem-ref.setf.1
    (with-foreign-object (p :char)
      (setf (mem-ref p :char) 42))
  42)

(define-foreign-type int+1 ()
  ()
  (:actual-type :int)
  (:simple-parser int+1))

(defmethod translate-to-foreign (value (type int+1))
  (1+ value))

(defmethod translate-from-foreign (value (type int+1))
  (1+ value))

(deftest mem-ref.setf.2
    (with-foreign-object (p 'int+1)
      (values (setf (mem-ref p 'int+1) 42)
              (mem-ref p 'int+1)))
  42 ; should this be 43?
  44)

(deftest pointer-eq.non-pointers.1
    (expecting-error (pointer-eq 1 2))
  :error)

(deftest pointer-eq.non-pointers.2
    (expecting-error (pointer-eq 'a 'b))
  :error)

(deftest null-pointer-p.non-pointer.1
    (expecting-error (null-pointer-p 'not-a-pointer))
  :error)

(deftest null-pointer-p.non-pointer.2
    (expecting-error (null-pointer-p 0))
  :error)

(deftest null-pointer-p.non-pointer.3
    (expecting-error (null-pointer-p nil))
  :error)
cffi_0.19.0/tests/fsbv.lisp0000644000175000017500000001235613103031266014301 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; fsbv.lisp --- Tests of foreign structure by value calls.
;;;
;;; Copyright (C) 2011, Liam M. Healy
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

;; Requires struct.lisp

(defcfun "sumpair" :int
  (p (:struct struct-pair)))

(defcfun "makepair" (:struct struct-pair)
  (condition :bool))

(defcfun "doublepair" (:struct struct-pair)
  (p (:struct struct-pair)))

(defcfun "prodsumpair" :double
  (p (:struct struct-pair+double)))

(defcfun "doublepairdouble" (:struct struct-pair+double)
  (p (:struct struct-pair+double)))

;;; Call struct by value
(deftest fsbv.1
    (sumpair '(1 . 2))
  3)

;;; See lp#1528719
(deftest (fsbv.wfo :expected-to-fail t)
    (with-foreign-object (arg '(:struct struct-pair))
      (convert-into-foreign-memory '(40 . 2) '(:struct struct-pair) arg)
      (sumpair arg))
  42)

;;; Call and return struct by value
(deftest fsbv.2
    (doublepair '(1 . 2))
  (2 . 4))

;;; return struct by value
(deftest (fsbv.makepair.1 :expected-to-fail t)
    (makepair nil)
  (-127 . 43))

(deftest (fsbv.makepair.2 :expected-to-fail t)
    (makepair t)
  (-127 . 42))

;;; Call recursive structure by value
(deftest fsbv.3
    (prodsumpair '(pr (a 4 b 5) dbl 2.5d0))
  22.5d0)

;;; Call and return recursive structure by value
(deftest fsbv.4
    (let ((ans (doublepairdouble '(pr (a 4 b 5) dbl 2.5d0))))
      (values (getf (getf ans 'pr) 'a)
	      (getf (getf ans 'pr) 'b)
	      (getf ans 'dbl)))
  8
  10
  5.0d0)

(defcstruct (struct-with-array :size 6)
  (s1 (:array :char 6)))

(defcfun "zork" :void
  (p (:struct struct-with-array)))

;;; Typedef fsbv test

(defcfun ("sumpair" sumpair2) :int
  (p struct-pair-typedef1))

(deftest fsbv.5
    (sumpair2 '(1 . 2))
  3)

(defcfun "returnpairpointer" (:pointer (:struct struct-pair))
  (ignored (:struct struct-pair)))

(deftest fsbv.return-a-pointer
    (let ((ptr (returnpairpointer '(1 . 2))))
      (+ (foreign-slot-value ptr '(:struct struct-pair) 'a)
         (foreign-slot-value ptr '(:struct struct-pair) 'b)))
  42)

;;; Test ulonglong on no-long-long implementations.

(defcfun "ullsum" :unsigned-long-long
  (a :unsigned-long-long) (b :unsigned-long-long))

(deftest fsbv.6
    (ullsum #x10DEADBEEF #x2300000000)
  #x33DEADBEEF)

;;; Combine structures by value with a string argument
(defcfun "stringlenpair" (:struct struct-pair)
  (s :string)
  (p (:struct struct-pair)))

(deftest fsbv.7
  (stringlenpair "abc" '(1 . 2))
  (3 . 6))

;;; Combine structures by value with an enum argument
(defcfun "enumpair" (:int)
  (e numeros)
  (p (:struct struct-pair)))

(deftest fsbv.8
  (enumpair :two '(1 . 2))
  5)

;;; returning struct with bitfield member (bug #1474631)
(defbitfield (struct-bitfield :unsigned-int)
  (:a 1)
  (:b 2))

(defcstruct bitfield-struct
  (b struct-bitfield))

(defcfun "structbitfield" (:struct bitfield-struct)
  (x :unsigned-int))

(defctype struct-bitfield-typedef struct-bitfield)

(defcstruct bitfield-struct.2
  (b struct-bitfield-typedef))

(defcfun ("structbitfield" structbitfield.2) (:struct bitfield-struct.2)
  (x :unsigned-int))

;; these would get stuck in an infinite loop previously
(deftest fsbv.struct-bitfield.0
  (structbitfield 0)
  (b nil))

(deftest fsbv.struct-bitfield.1
  (structbitfield 1)
  (b (:a)))

(deftest fsbv.struct-bitfield.2
  (structbitfield 2)
  (b (:b)))

(deftest fsbv.struct-bitfield.3
  (structbitfield.2 2)
  (b (:b)))

;;; Test for a discrepancy between normal and fsbv return values
(cffi:define-foreign-type int-return-code (cffi::foreign-type-alias)
  ()
  (:default-initargs :actual-type (cffi::parse-type :int))
  (:simple-parser int-return-code))

(defmethod cffi:expand-from-foreign (value (type int-return-code))
  ;; NOTE: strictly speaking it should be
  ;; (cffi:convert-from-foreign ,value :int), but it's irrelevant in this case
  `(let ((return-code ,value))
     (check-type return-code integer)
     return-code))

(defcfun (noargs-with-typedef "noargs") int-return-code)

(deftest fsbv.noargs-with-typedef    ; for reference, not an FSBV call
    (noargs-with-typedef)
  42)

(defcfun (sumpair-with-typedef "sumpair") int-return-code
  (p (:struct struct-pair)))

(deftest (fsbv.return-value-typedef)
    (sumpair-with-typedef '(40 . 2))
  42)
cffi_0.19.0/tests/strings.lisp0000644000175000017500000001437313103031266015033 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; strings.lisp --- Tests for foreign string conversion.
;;;
;;; Copyright (C) 2005, James Bielman  
;;; Copyright (C) 2007, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

;;;# Foreign String Conversion Tests
;;;
;;; With the implementation of encoding support, there are a lot of
;;; things that can go wrong with foreign string conversions.  This is
;;; a start at defining tests for strings and encoding conversion, but
;;; there needs to be a lot more.

(babel:enable-sharp-backslash-syntax)

;;; *ASCII-TEST-STRING* contains the characters in the ASCII character
;;; set that we will convert to a foreign string and check against
;;; *ASCII-TEST-BYTES*.  We don't bother with control characters.
;;;
;;; FIXME: It would probably be good to move these tables into files
;;; in "tests/", especially if we ever want to get fancier and have
;;; tests for more encodings.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *ascii-test-string*
    (concatenate 'string " !\"#$%&'()*+,-./0123456789:;"
                 "<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]"
                 "^_`abcdefghijklmnopqrstuvwxyz{|}~")))

;;; *ASCII-TEST-BYTES* contains the expected ASCII encoded values
;;; for each character in *ASCII-TEST-STRING*.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *ascii-test-bytes*
    (let ((vector (make-array 95 :element-type '(unsigned-byte 8))))
      (loop for i from 0
            for code from 32 below 127
            do (setf (aref vector i) code)
            finally (return vector)))))

;;; Test basic consistency converting a string to and from Lisp using
;;; the default encoding.
(deftest string.conversion.basic
    (with-foreign-string (s *ascii-test-string*)
      (foreign-string-to-lisp s))
  #.*ascii-test-string* 95)

(deftest string.conversion.basic.2
    (with-foreign-string ((ptr size) "123" :null-terminated-p nil)
      (values (foreign-string-to-lisp ptr :count 3) size))
  "123" 3)

;;; Ensure that conversion of *ASCII-TEST-STRING* to a foreign buffer
;;; and back preserves ASCII encoding.
(deftest string.encoding.ascii
    (with-foreign-string (s *ascii-test-string* :encoding :ascii)
      (let ((vector (make-array 95 :element-type '(unsigned-byte 8))))
        (loop for i from 0 below (length vector)
              do (setf (aref vector i) (mem-ref s :unsigned-char i)))
        vector))
  #.*ascii-test-bytes*)

;;; FIXME: bogus test. We need support for BOM or UTF-16{BE,LE}.
(pushnew 'string.encoding.utf-16.basic rtest::*expected-failures*)

;;; Test UTF-16 conversion of a string back and forth.  Tests proper
;;; null terminator handling for wide character strings and ensures no
;;; byte order marks are added.  (Why no BOM? --luis)
;;;
;;; FIXME: an identical test using :UTF-16 wouldn't work because on
;;; little-endian architectures, :UTF-16 defaults to little-endian
;;; when writing and big-endian on reading because the BOM is
;;; suppressed.
#-babel::8-bit-chars
(progn
  (deftest string.encoding.utf-16le.basic
      (with-foreign-string (s *ascii-test-string* :encoding :utf-16le)
        (foreign-string-to-lisp s :encoding :utf-16le))
    #.*ascii-test-string* 190)

  (deftest string.encoding.utf-16be.basic
      (with-foreign-string (s *ascii-test-string* :encoding :utf-16be)
        (foreign-string-to-lisp s :encoding :utf-16be))
    #.*ascii-test-string* 190))

;;; Ensure that writing a long string into a short buffer does not
;;; attempt to write beyond the edge of the buffer, and that the
;;; resulting string is still null terminated.
(deftest string.short-write.1
    (with-foreign-pointer (buf 6)
      (setf (mem-ref buf :unsigned-char 5) 70)
      (lisp-string-to-foreign "ABCDE" buf 5 :encoding :ascii)
      (values (mem-ref buf :unsigned-char 4)
              (mem-ref buf :unsigned-char 5)))
  0 70)

#-babel::8-bit-chars
(deftest string.encoding.utf-8.basic
    (with-foreign-pointer (buf 7 size)
      (let ((string (concatenate 'babel:unicode-string
                                 '(#\u03bb #\u00e3 #\u03bb))))
        (lisp-string-to-foreign string buf size :encoding :utf-8)
        (loop for i from 0 below size
              collect (mem-ref buf :unsigned-char i))))
  (206 187 195 163 206 187 0))

(defparameter *basic-latin-alphabet* "abcdefghijklmnopqrstuvwxyz")

(deftest string.encodings.all.basic
    (let (failed)
      ;;; FIXME: UTF-{32,16} and friends fail due to lack of BOM. See
      ;;; STRING.ENCODING.UTF-16.BASIC for more details.
      (dolist (encoding (remove-if (lambda (x)
                                     (member x '(:utf-32 :utf-16 :ucs-2)))
                                   (babel:list-character-encodings)))
        ;; (format t "Testing ~S~%" encoding)
        (with-foreign-string (ptr *basic-latin-alphabet* :encoding encoding)
          (let ((string (foreign-string-to-lisp ptr :encoding encoding)))
            ;; (format t "  got ~S~%" string)
            (unless (string= *basic-latin-alphabet* string)
              (push encoding failed)))))
      failed)
  nil)

;;; rt: make sure *default-foreign-enconding* binds to a keyword
(deftest string.encodings.default
    (keywordp *default-foreign-encoding*)
  t)
cffi_0.19.0/tests/bindings.lisp0000644000175000017500000001246413103031266015136 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; libtest.lisp --- Setup CFFI bindings for libtest.
;;;
;;; Copyright (C) 2005-2007, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(define-foreign-library (libtest :type :test)
  (:darwin (:or "libtest.dylib" "libtest32.dylib"))
  (:unix (:or "libtest.so" "libtest32.so"))
  (:windows "libtest.dll")
  (t (:default "libtest")))

(define-foreign-library (libtest2 :type :test)
  (:darwin (:or "libtest2.dylib" "libtest2_32.dylib"))
  (:unix (:or "libtest2.so" "libtest2_32.so"))
  (t (:default "libtest2")))

(define-foreign-library (libfsbv :type :test)
  (:darwin (:or "libfsbv.dylib" "libfsbv32.dylib"))
  (:unix (:or "libfsbv.so" "libfsbv_32.so"))
  (:windows "libfsbv.dll")
  (t (:default "libfsbv")))

(define-foreign-library libc
  (:windows "msvcrt.dll"))

(define-foreign-library libm
  #+(and lispworks darwin) ; not sure why the full path is necessary
  (:darwin "/usr/lib/libm.dylib")
  (t (:default "libm")))

(defmacro deftest (name &rest body)
  (destructuring-bind (name &key expected-to-fail)
      (alexandria:ensure-list name)
    (let ((result `(rt:deftest ,name ,@body)))
      (when expected-to-fail
        (setf result `(progn
                        (when ,expected-to-fail
                          (pushnew ',name rt::*expected-failures*))
                        ,result)))
      result)))

(defun call-within-new-thread (fn &rest args)
  (let (result
        error
        (cv (bordeaux-threads:make-condition-variable))
        (lock (bordeaux-threads:make-lock)))
    (bordeaux-threads:with-lock-held (lock)
      (bordeaux-threads:make-thread
       (lambda ()
         (multiple-value-setq (result error)
           (ignore-errors (apply fn args)))
         (bordeaux-threads:with-lock-held (lock)
           (bordeaux-threads:condition-notify cv))))
      (bordeaux-threads:condition-wait cv lock)
      (values result error))))

;;; As of OSX 10.6.6, loading CoreFoundation on something other than
;;; the initial thread results in a crash.
(deftest load-core-foundation
    (progn
      #+bordeaux-threads
      (call-within-new-thread 'load-foreign-library
                              '(:framework "CoreFoundation"))
      t)
  t)

;;; Return the directory containing the source when compiling or
;;; loading this file.  We don't use *LOAD-TRUENAME* because the fasl
;;; file may be in a different directory than the source with certain
;;; ASDF extensions loaded.
(defun load-directory ()
  (let ((here #.(or *compile-file-truename* *load-truename*)))
    (make-pathname :name nil :type nil :version nil
                   :defaults here)))

(defun load-test-libraries ()
  (let ((*foreign-library-directories* (list (load-directory))))
    (load-foreign-library 'libtest)
    (load-foreign-library 'libtest2)
    (load-foreign-library 'libfsbv)
    (load-foreign-library 'libc)
    #+(or abcl lispworks) (load-foreign-library 'libm)))

#-(:and :ecl (:not :dffi))
(load-test-libraries)

#+(:and :ecl (:not :dffi))
(ffi:load-foreign-library
 #.(make-pathname :name "libtest" :type "so"
                  :defaults (or *compile-file-truename* *load-truename*)))

;;; check libtest version
(defparameter *required-dll-version* "20120107")

(defcvar "dll_version" :string)

(unless (string= *dll-version* *required-dll-version*)
  (error "version check failed: expected ~s but libtest reports ~s"
         *required-dll-version*
         *dll-version*))

;;; The maximum and minimum values for single and double precision C
;;; floating point values, which may be quite different from the
;;; corresponding Lisp versions.
(defcvar "float_max" :float)
(defcvar "float_min" :float)
(defcvar "double_max" :double)
(defcvar "double_min" :double)

(defun run-cffi-tests (&key (compiled nil))
  (let ((regression-test::*compile-tests* compiled)
        (*package* (find-package '#:cffi-tests)))
    (format t "~&;;; running tests (~Acompiled)" (if compiled "" "un"))
    (do-tests)
    (set-difference (regression-test:pending-tests)
                    regression-test::*expected-failures*)))

(defun run-all-cffi-tests ()
  (append (run-cffi-tests :compiled nil)
          (run-cffi-tests :compiled t)))

(defmacro expecting-error (&body body)
  `(handler-case (progn ,@body :no-error)
     (error () :error)))
cffi_0.19.0/tests/test-asdf.lisp0000644000175000017500000000345113103031266015227 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; asdf.lisp --- CFFI-Grovel asdf support tests.
;;;
;;; Copyright (C) 2015, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

#.(when (cffi-toolchain::static-ops-enabled-p)
    '(deftest test-static-program
      (progn
        (asdf:operate :static-program-op :cffi-tests/example)
        (let ((program (asdf:output-file :static-program-op :cffi-tests/example)))
          (uiop:run-program `(,(native-namestring program) "1" "2 3") :output :lines)))
      ("Arguments: 1 \"2 3\"" "hello, world!") nil 0))

(deftest test-asdf-load
    (progn
      (asdf:load-system :cffi-tests/example)
      (uiop:symbol-call :cffi-example :check-groveller))
  nil)
cffi_0.19.0/tests/misc-types.lisp0000644000175000017500000002114213103031266015427 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; misc-types.lisp --- Various tests on the type system.
;;;
;;; Copyright (C) 2005-2006, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(defcfun ("my_strdup" strdup) :string+ptr (str :string))

(defcfun ("my_strfree" strfree) :void (str :pointer))

(deftest misc-types.string+ptr
    (destructuring-bind (string pointer)
        (strdup "foo")
      (strfree pointer)
      string)
  "foo")

#-(and)
(deftest misc-types.string+ptr.ub8
    (destructuring-bind (string pointer)
        (strdup (make-array 3 :element-type '(unsigned-byte 8)
                            :initial-contents (map 'list #'char-code "foo")))
      (strfree pointer)
      string)
  "foo")

#-(and)
(deftest misc-types.string.ub8.1
    (let ((array (make-array 7 :element-type '(unsigned-byte 8)
                             :initial-contents '(84 117 114 97 110 103 97))))
      (with-foreign-string (foreign-string array)
        (foreign-string-to-lisp foreign-string)))
  "Turanga")

#-(and)
(deftest misc-types.string.ub8.2
    (let ((str (foreign-string-alloc
                (make-array 7 :element-type '(unsigned-byte 8)
                            :initial-contents '(84 117 114 97 110 103 97)))))
      (prog1 (foreign-string-to-lisp str)
        (foreign-string-free str)))
  "Turanga")

(defcfun "equalequal" :boolean
  (a (:boolean :int))
  (b (:boolean :unsigned-int)))

(defcfun "bool_and" (:boolean :char)
  (a (:boolean :unsigned-char))
  (b (:boolean :char)))

(defcfun "bool_xor" (:boolean :unsigned-long)
  (a (:boolean :long))
  (b (:boolean :unsigned-long)))

(deftest misc-types.boolean.1
    (list (equalequal nil nil)
          (equalequal t t)
          (equalequal t 23)
          (bool-and 'a 'b)
          (bool-and "foo" nil)
          (bool-xor t nil)
          (bool-xor nil nil))
  (t t t t nil t nil))

(defcfun "sizeof_bool" :unsigned-int)

(deftest misc-types.sizeof.bool
    (eql (sizeof-bool) (foreign-type-size :bool))
  t)

(defcfun "bool_to_unsigned" :unsigned-int
  (b :bool))

(defcfun "unsigned_to_bool" :bool
  (u :unsigned-int))

(deftest misc-types.bool.convert-to-foreign.mem
    (loop for v in '(nil t)
          collect
          (with-foreign-object (b :bool)
            (setf (mem-ref b :bool) v)
            (mem-ref b #.(cffi::canonicalize-foreign-type :bool))))
  (0 1))

(deftest misc-types.bool.convert-to-foreign.call
    (mapcar #'bool-to-unsigned '(nil t))
  (0 1))

(deftest misc-types.bool.convert-from-foreign.mem
    (loop for v in '(0 1 42)
          collect
          (with-foreign-object (b :bool)
            (setf (mem-ref b #.(cffi::canonicalize-foreign-type :bool)) v)
            (mem-ref b :bool)))
  (nil t t))

(deftest misc-types.bool.convert-from-foreign.call
    (mapcar #'unsigned-to-bool '(0 1 42))
  (nil t t))

;;; Regression test: boolean type only worked with canonicalized
;;; built-in integer types. Should work for any type that canonicalizes
;;; to a built-in integer type.
(defctype int-for-bool :int)
(defcfun ("equalequal" equalequal2) :boolean
  (a (:boolean int-for-bool))
  (b (:boolean :uint)))

(deftest misc-types.boolean.2
    (equalequal2 nil t)
  nil)

(defctype my-string :string+ptr)

(defun funkify (str)
  (concatenate 'string "MORE " (string-upcase str)))

(defun 3rd-person (value)
  (list (concatenate 'string "Strdup says: " (first value))
        (second value)))

;; (defctype funky-string
;;     (:wrapper my-string
;;               :to-c #'funkify
;;               :from-c (lambda (value)
;;                         (list
;;                          (concatenate 'string "Strdup says: "
;;                                       (first value))
;;                          (second value))))
;;   "A useful type.")

(defctype funky-string (:wrapper my-string :to-c funkify :from-c 3rd-person))

(defcfun ("my_strdup" funky-strdup) funky-string
  (str funky-string))

(deftest misc-types.wrapper
    (destructuring-bind (string ptr)
        (funky-strdup "code")
      (strfree ptr)
      string)
  "Strdup says: MORE CODE")

(deftest misc-types.sized-ints
    (mapcar #'foreign-type-size
            '(:int8 :uint8 :int16 :uint16 :int32 :uint32 :int64 :uint64))
  (1 1 2 2 4 4 8 8))

(define-foreign-type error-error ()
  ()
  (:actual-type :int)
  (:simple-parser error-error))

(defmethod translate-to-foreign (value (type error-error))
  (declare (ignore value))
  (error "translate-to-foreign invoked."))

(defmethod translate-from-foreign (value (type error-error))
  (declare (ignore value))
  (error "translate-from-foreign invoked."))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defmethod expand-to-foreign (value (type error-error))
    value)

  (defmethod expand-from-foreign (value (type error-error))
    value))

(defcfun ("abs" expand-abs) error-error
  (n error-error))

(defcvar ("var_int" *expand-var-int*) error-error)

(defcfun ("expect_int_sum" expand-expect-int-sum) :boolean
  (cb :pointer))

(defcallback expand-int-sum error-error ((x error-error) (y error-error))
  (+ x y))

;;; Ensure that macroexpansion-time translators are called where this
;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback)
(deftest misc-types.expand.1
    (expand-abs -1)
  1)

#-cffi-sys::no-foreign-funcall
(deftest misc-types.expand.2
    (foreign-funcall "abs" error-error -1 error-error)
  1)

(deftest misc-types.expand.3
    (let ((old (mem-ref (get-var-pointer '*expand-var-int*) :int)))
      (unwind-protect
           (progn
             (setf *expand-var-int* 42)
             *expand-var-int*)
        (setf (mem-ref (get-var-pointer '*expand-var-int*) :int) old)))
  42)

(deftest misc-types.expand.4
    (expand-expect-int-sum (callback expand-int-sum))
  t)

(define-foreign-type translate-tracker ()
  ()
  (:actual-type :int)
  (:simple-parser translate-tracker))

(declaim (special .fto-called.))

(defmethod free-translated-object (value (type translate-tracker) param)
  (declare (ignore value param))
  (setf .fto-called. t))

(define-foreign-type expand-tracker ()
  ()
  (:actual-type :int)
  (:simple-parser expand-tracker))

(defmethod free-translated-object (value (type expand-tracker) param)
  (declare (ignore value param))
  (setf .fto-called. t))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmethod expand-to-foreign (value (type expand-tracker))
    (declare (ignore value))
    (call-next-method)))

(defcfun ("abs" ttracker-abs) :int
  (n translate-tracker))

(defcfun ("abs" etracker-abs) :int
  (n expand-tracker))

;; free-translated-object must be called when there is no etf
(deftest misc-types.expand.5
    (let ((.fto-called. nil))
      (ttracker-abs -1)
      .fto-called.)
  t)

;; free-translated-object must be called when there is an etf, but
;; they answer *runtime-translator-form*
(deftest misc-types.expand.6
    (let ((.fto-called. nil))
      (etracker-abs -1)
      .fto-called.)
  t)

(define-foreign-type misc-type.expand.7 ()
  ()
  (:actual-type :int)
  (:simple-parser misc-type.expand.7))

(defmethod translate-to-foreign (value (type misc-type.expand.7))
  (values value 'second-value))

;; Auxiliary function to test CONVERT-TO-FOREIGN's compiler macro.
(defun misc-type.expand.7-aux ()
  (convert-to-foreign "foo" 'misc-type.expand.7))

;; Checking that expand-to-foreign doesn't ignore the second value of
;; translate-to-foreign.
(deftest misc-type.expand.7
    (misc-type.expand.7-aux)
  "foo" second-value)

;; Like MISC-TYPE.EXPAND.7 but doesn't depend on compiler macros
;; kicking in.
(deftest misc-type.expand.8
    (eval (expand-to-foreign "foo" (cffi::parse-type 'misc-type.expand.7)))
  "foo" second-value)
cffi_0.19.0/tests/package.lisp0000644000175000017500000000266713103031266014740 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; package.lisp --- CFFI-TESTS package definition.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cl-user)

(defpackage #:cffi-tests
  (:use #:cl #:cffi #:cffi-sys #:regression-test)
  (:export #:do-tests #:run-cffi-tests #:run-all-cffi-tests)
  (:shadow #:deftest))
cffi_0.19.0/tests/struct.lisp0000644000175000017500000005205613103031266014666 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; struct.lisp --- Foreign structure type tests.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;; Copyright (C) 2005-2011, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(defcstruct timeval
  (tv-secs :long)
  (tv-usecs :long))

(defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
                                       (foreign-type-alignment :long))))

;;;# Basic Structure Tests

(deftest struct.1
    (- (foreign-type-size 'timeval) *timeval-size*)
  0)

(deftest struct.2
    (with-foreign-object (tv 'timeval)
      (setf (foreign-slot-value tv 'timeval 'tv-secs) 0)
      (setf (foreign-slot-value tv 'timeval 'tv-usecs) 1)
      (values (foreign-slot-value tv 'timeval 'tv-secs)
              (foreign-slot-value tv 'timeval 'tv-usecs)))
  0 1)

(deftest struct.3
    (with-foreign-object (tv 'timeval)
      (with-foreign-slots ((tv-secs tv-usecs) tv timeval)
        (setf tv-secs 100 tv-usecs 200)
        (values tv-secs tv-usecs)))
  100 200)

;; regression test: accessing a struct through a typedef

(defctype xpto (:struct timeval))

(deftest struct.4
    (with-foreign-object (tv 'xpto)
      (setf (foreign-slot-value tv 'xpto 'tv-usecs) 1)
      (values (foreign-slot-value tv 'xpto 'tv-usecs)
              (foreign-slot-value tv 'timeval 'tv-usecs)))
  1 1)

(deftest struct.names
    (sort (foreign-slot-names 'xpto) #'<
          :key (lambda (x) (foreign-slot-offset 'xpto x)))
  (tv-secs tv-usecs))

;; regression test: compiler macro not quoting the type in the
;; resulting mem-ref form. The compiler macro on foreign-slot-value
;; is not guaranteed to be expanded though.

(defctype my-int :int)
(defcstruct s5 (a my-int))

(deftest struct.5
    (with-foreign-object (s 's5)
      (setf (foreign-slot-value s 's5 'a) 42)
      (foreign-slot-value s 's5 'a))
  42)

;;;# Structs with type translators

(defcstruct struct-string
  (s :string))

(deftest struct.string.1
    (with-foreign-object (ptr 'struct-string)
      (with-foreign-slots ((s) ptr struct-string)
        (setf s "So long and thanks for all the fish!")
        s))
  "So long and thanks for all the fish!")

(deftest struct.string.2
    (with-foreign-object (ptr 'struct-string)
      (setf (foreign-slot-value ptr 'struct-string 's) "Cha")
      (foreign-slot-value ptr 'struct-string 's))
  "Cha")

;;;# Structure Alignment Tests
;;;
;;; See libtest.c and types.lisp for some comments about alignments.

(defcstruct s-ch
  (a-char :char))

(defctype s-ch (:struct s-ch))

(defcstruct s-s-ch
  (another-char :char)
  (a-s-ch s-ch))

(defctype s-s-ch (:struct s-s-ch))

(defcvar "the_s_s_ch" s-s-ch)

(deftest struct.alignment.1
    (list 'a-char (foreign-slot-value
                   (foreign-slot-pointer *the-s-s-ch* 's-s-ch 'a-s-ch)
                   's-ch 'a-char)
          'another-char (foreign-slot-value *the-s-s-ch* 's-s-ch 'another-char))
  (a-char 1 another-char 2))


(defcstruct s-short
  (a-char :char)
  (another-char :char)
  (a-short :short))

(defctype s-short (:struct s-short))

(defcstruct s-s-short
  (yet-another-char :char)
  (a-s-short s-short))

(defctype s-s-short (:struct s-s-short))

(defcvar "the_s_s_short" s-s-short)

(deftest struct.alignment.2
    (with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-s-short)
      (with-foreign-slots ((a-char another-char a-short) a-s-short s-short)
        (list 'a-char           a-char
              'another-char     another-char
              'a-short          a-short
              'yet-another-char yet-another-char)))
  (a-char 1 another-char 2 a-short 3 yet-another-char 4))


(defcstruct s-double
  (a-char :char)
  (a-double :double)
  (another-char :char))

(defctype s-double (:struct s-double))

(defcstruct s-s-double
  (yet-another-char :char)
  (a-s-double s-double)
  (a-short :short))

(defctype s-s-double (:struct s-s-double))

(defcvar "the_s_s_double" s-s-double)

(deftest struct.alignment.3
    (with-foreign-slots
        ((yet-another-char a-s-double a-short) *the-s-s-double* s-s-double)
      (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
        (list 'a-char            a-char
              'a-double          a-double
              'another-char      another-char
              'yet-another-char  yet-another-char
              'a-short           a-short)))
  (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5))


(defcstruct s-s-s-double
  (another-short :short)
  (a-s-s-double s-s-double)
  (last-char :char))

(defctype s-s-s-double (:struct s-s-s-double))

(defcvar "the_s_s_s_double" s-s-s-double)

(deftest struct.alignment.4
    (with-foreign-slots
        ((another-short a-s-s-double last-char) *the-s-s-s-double* s-s-s-double)
      (with-foreign-slots
          ((yet-another-char a-s-double a-short) a-s-s-double s-s-double)
        (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
          (list 'a-char            a-char
                'a-double          a-double
                'another-char      another-char
                'yet-another-char  yet-another-char
                'a-short           a-short
                'another-short     another-short
                'last-char         last-char))))
  (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5
   another-short 6 last-char 7))


(defcstruct s-double2
  (a-double :double)
  (a-short  :short))

(defctype s-double2 (:struct s-double2))

(defcstruct s-s-double2
  (a-char        :char)
  (a-s-double2   s-double2)
  (another-short :short))

(defctype s-s-double2 (:struct s-s-double2))

(defcvar "the_s_s_double2" s-s-double2)

(deftest struct.alignment.5
    (with-foreign-slots
        ((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double2)
      (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
        (list 'a-double       a-double
              'a-short        a-short
              'a-char         a-char
              'another-short  another-short)))
  (a-double 1.0d0 a-short 2 a-char 3 another-short 4))

(defcstruct s-long-long
  (a-long-long :long-long)
  (a-short     :short))

(defctype s-long-long (:struct s-long-long))

(defcstruct s-s-long-long
  (a-char        :char)
  (a-s-long-long s-long-long)
  (another-short :short))

(defctype s-s-long-long (:struct s-s-long-long))

(defcvar "the_s_s_long_long" s-s-long-long)

(deftest struct.alignment.6
    (with-foreign-slots
        ((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
      (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
        (list 'a-long-long    a-long-long
              'a-short        a-short
              'a-char         a-char
              'another-short  another-short)))
  (a-long-long 1 a-short 2 a-char 3 another-short 4))

(defcstruct s-s-double3
  (a-s-double2   s-double2)
  (another-short :short))

(defctype s-s-double3 (:struct s-s-double3))

(defcstruct s-s-s-double3
  (a-s-s-double3  s-s-double3)
  (a-char         :char))

(defctype s-s-s-double3 (:struct s-s-s-double3))

(defcvar "the_s_s_s_double3" s-s-s-double3)

(deftest struct.alignment.7
    (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
      (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
        (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
          (list 'a-double      a-double
                'a-short       a-short
                'another-short another-short
                'a-char        a-char))))
  (a-double 1.0d0 a-short 2 another-short 3 a-char 4))


(defcstruct empty-struct)

(defctype empty-struct (:struct empty-struct))

(defcstruct with-empty-struct
  (foo empty-struct)
  (an-int :int))

;; commented out this test because an empty struct is not valid/standard C
;; left the struct declarations anyway because they should be handled
;; gracefuly anyway.

; (defcvar "the_with_empty_struct" with-empty-struct)
;
; (deftest struct.alignment.5
;     (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
;       an-int)
;   42)


;; regression test, setf-ing nested foreign-slot-value forms
;; the setf expander used to return a bogus getter

(defcstruct s1
  (an-int :int))

(defctype s1 (:struct s1))

(defcstruct s2
  (an-s1 s1))

(defctype s2 (:struct s2))

(deftest struct.nested-setf
    (with-foreign-object (an-s2 's2)
      (setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
                                's1 'an-int)
            1984)
      (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
                          's1 'an-int))
  1984)

;; regression test, some Lisps were returning 4 instead of 8 for
;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32

(defcstruct s-unsigned-long-long
  (an-unsigned-long-long :unsigned-long-long)
  (a-short               :short))

(defctype s-unsigned-long-long (:struct s-unsigned-long-long))

(defcstruct s-s-unsigned-long-long
  (a-char                 :char)
  (a-s-unsigned-long-long s-unsigned-long-long)
  (another-short          :short))

(defctype s-s-unsigned-long-long (:struct s-s-unsigned-long-long))

(defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)

(deftest struct.alignment.8
    (with-foreign-slots
        ((a-char a-s-unsigned-long-long another-short)
         *the-s-s-unsigned-long-long* s-s-unsigned-long-long)
      (with-foreign-slots ((an-unsigned-long-long a-short)
                           a-s-unsigned-long-long s-unsigned-long-long)
        (list 'an-unsigned-long-long  an-unsigned-long-long
              'a-short                a-short
              'a-char                 a-char
              'another-short          another-short)))
  (an-unsigned-long-long 1 a-short 2 a-char 3 another-short 4))

;;;# C Struct Wrappers

(define-c-struct-wrapper timeval ())

(define-c-struct-wrapper (timeval2 (:struct timeval)) ()
  (tv-secs))

(defmacro with-example-timeval (var &body body)
  `(with-foreign-object (,var 'timeval)
     (with-foreign-slots ((tv-secs tv-usecs) ,var timeval)
       (setf tv-secs 42 tv-usecs 1984)
       ,@body)))

(deftest struct-wrapper.1
    (with-example-timeval ptr
      (let ((obj (make-instance 'timeval :pointer ptr)))
        (values (timeval-tv-secs obj)
                (timeval-tv-usecs obj))))
  42 1984)

(deftest struct-wrapper.2
    (with-example-timeval ptr
      (let ((obj (make-instance 'timeval2 :pointer ptr)))
        (timeval2-tv-secs obj)))
  42)

;;;# Structures as Values

(defcstruct (struct-pair :class pair)
  (a :int)
  (b :int))

(defctype struct-pair-typedef1 (:struct struct-pair))
(defctype struct-pair-typedef2 (:pointer (:struct struct-pair)))

(deftest struct.unparse.1
    (mapcar (alexandria:compose #'cffi::unparse-type #'cffi::parse-type)
            '(struct-pair
              (:struct struct-pair)
              struct-pair-typedef1
              struct-pair-typedef2))
  (struct-pair
   (:struct struct-pair)
   struct-pair-typedef1
   struct-pair-typedef2))

(deftest struct.canonicalize.1
    (mapcar #'cffi::canonicalize-foreign-type
            '(struct-pair
              (:struct struct-pair)
              struct-pair-typedef1
              struct-pair-typedef2))
  (:pointer
   (:struct struct-pair)
   (:struct struct-pair)
   :pointer))

(deftest struct.canonicalize.2
    (mapcar #'cffi::canonicalize-foreign-type
            '(struct-pair
              (:struct struct-pair)
              struct-pair-typedef1
              struct-pair-typedef2))
  (:pointer
   (:struct struct-pair)
   (:struct struct-pair)
   :pointer))

(defmethod translate-from-foreign (pointer (type pair))
  (with-foreign-slots ((a b) pointer (:struct struct-pair))
    (cons a b)))

(defmethod translate-into-foreign-memory (object (type pair) pointer)
  (with-foreign-slots ((a b) pointer (:struct struct-pair))
    (setf a (car object)
          b (cdr object))))

(defmethod translate-to-foreign (object (type pair))
  (let ((p (foreign-alloc '(:struct struct-pair))))
    (translate-into-foreign-memory object type p)
    (values p t)))

(defmethod free-translated-object (pointer (type pair) freep)
  (when freep
    (foreign-free pointer)))

(deftest struct-values.translation.1
    (multiple-value-bind (p freep)
        (convert-to-foreign '(1 . 2) 'struct-pair)
      (assert freep)
      (unwind-protect
           (convert-from-foreign p 'struct-pair)
        (free-converted-object p 'struct-pair freep)))
  (1 . 2))

(defcfun "pair_pointer_sum" :int
  (p (:pointer (:struct struct-pair))))

#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.2
    (pair-pointer-sum '(1 . 2))
  3)

;;; should the return type be something along the lines of
;;; (:pointer (:struct pair) :free t)?
;;; LMH: error on ":free t" option?
(defcfun "alloc_pair" (:pointer (:struct struct-pair))
  (a :int)
  (b :int))

;; bogus: doesn't free() pointer.
#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.3
    (alloc-pair 1 2)
  (1 . 2))

(deftest struct-values.translation.mem-ref.1
    (with-foreign-object (p '(:struct struct-pair))
      (setf (mem-ref p '(:struct struct-pair)) '(1 . 2))
      (with-foreign-slots ((a b) p (:struct struct-pair))
        (values (mem-ref p '(:struct struct-pair))
                a
                b)))
  (1 . 2)
  1
  2)

(deftest struct-values.translation.mem-aref.1
    (with-foreign-object (p '(:struct struct-pair) 2)
      (setf (mem-aref p '(:struct struct-pair) 0) '(1 . 2)
            (mem-aref p '(:struct struct-pair) 1) '(3 . 4))
      (values (mem-aref p '(:struct struct-pair) 0)
              (mem-aref p '(:struct struct-pair) 1)))
  (1 . 2)
  (3 . 4))

(defcstruct (struct-pair-default-translate :class pair-default)
  (a :int)
  (b :int))

(deftest struct-values-default.translation.mem-ref.1
    (with-foreign-object (p '(:struct struct-pair-default-translate))
      (setf (mem-ref p '(:struct struct-pair-default-translate)) '(a 1 b 2))
      (with-foreign-slots ((a b) p (:struct struct-pair-default-translate))
        (let ((plist (mem-ref p '(:struct struct-pair-default-translate))))
          (values (getf plist 'a)
                  (getf plist 'b)
                  a
                  b))))
  1
  2
  1
  2)

(defcstruct (struct-pair+double :class pair+double)
  (pr (:struct struct-pair-default-translate))
  (dbl :double))

(deftest struct-values-default.translation.mem-ref.2
    (with-foreign-object (p '(:struct struct-pair+double))
      (setf (mem-ref p '(:struct struct-pair+double)) '(pr (a 4 b 5) dbl 2.5d0))
      (with-foreign-slots ((pr dbl) p (:struct struct-pair+double))
        (let ((plist (mem-ref p '(:struct struct-pair+double))))
          (values (getf (getf plist 'pr) 'a)
                  (getf (getf plist 'pr) 'b)
                  (getf plist 'dbl)))))
  4
  5
  2.5d0)

(defcstruct (struct-pair+1 :class pair+1)
  (p (:pointer (:struct struct-pair)))
  (c :int))

(defctype struct-pair+1 (:struct struct-pair+1))

(defmethod translate-from-foreign (pointer (type pair+1))
  (with-foreign-slots ((p c) pointer struct-pair+1)
    (cons p c)))

(defmethod translate-into-foreign-memory (object (type pair+1) pointer)
  (with-foreign-slots ((c) pointer struct-pair+1)
    (convert-into-foreign-memory (car object)
                                 'struct-pair
                                 (foreign-slot-pointer pointer
                                                       'struct-pair+1
                                                       'p))
    (setf c (cdr object))))

(defmethod translate-to-foreign (object (type pair+1))
  (let ((p (foreign-alloc 'struct-pair+1)))
    (translate-into-foreign-memory object type p)
    (values p t)))

(defmethod free-translated-object (pointer (type pair+1) freep)
  (when freep
    (foreign-free pointer)))

#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.ppo.1
    (multiple-value-bind (p freep)
        (convert-to-foreign '((1 . 2) . 3) 'struct-pair+1)
      (assert freep)
      (unwind-protect
           (convert-from-foreign p 'struct-pair+1)
        (free-converted-object p 'struct-pair+1 freep)))
  ((1 . 2) . 3))

#+#:unimplemented
(defcfun "pair_plus_one_sum" :int
  (p (:struct pair+1)))

(defcfun "pair_plus_one_pointer_sum" :int
  (p (:pointer (:struct struct-pair+1))))

#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.ppo.2
    (pair-plus-one-pointer-sum '((1 . 2) . 3))
  6)

#+#:unimplemented
(defcfun "make_pair_plus_one" (:struct pair+1)
  (a :int)
  (b :int)
  (c :int))

(defcfun "alloc_pair_plus_one" struct-pair+1
  (a :int)
  (b :int)
  (c :int))

;; bogus: doesn't free() pointer.
#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.ppo.3
    (alloc-pair-plus-one 1 2 3)
  ((1 . 2) . 3))

#+#:unimplemented
(defcfun "pair_sum" :int
  (p (:struct pair)))

#+#:unimplemented
(defcfun "make_pair" (:struct pair)
  (a :int)
  (b :int))

#|| ; TODO: load cffi-libffi for these tests to work.
(deftest struct-values.fn.1
    (with-foreign-object (p '(:struct pair))
      (with-foreign-slots ((a b) p (:struct pair))
        (setf a -1 b 2)
        (pair-sum p)))
  1)

(deftest struct-values.fn.2
    (pair-sum '(3 . 5))
  8)

(deftest struct-values.fn.3
    (with-foreign-object (p '(:struct pair))
      (make-pair 7 11 :result-pointer p)
      (with-foreign-slots ((a b) p (:struct pair))
        (cons a b)))
  (7 . 11))

(deftest struct-values.fn.4
    (make-pair 13 17)
  (13 . 17))
||#

(defcstruct single-byte-struct
  (a :uint8))

(deftest bare-struct-types.1
    (eql (foreign-type-size 'single-byte-struct)
         (foreign-type-size '(:struct single-byte-struct)))
  t)

(defctype single-byte-struct-alias (:struct single-byte-struct))

(deftest bare-struct-types.2
    (eql (foreign-type-size 'single-byte-struct-alias)
         (foreign-type-size '(:struct single-byte-struct)))
  t)

;;; Old-style access to inner structure fields.

(defcstruct inner-struct (x :int))
(defcstruct old-style-outer (inner inner-struct))
(defcstruct new-style-outer (inner (:struct inner-struct)))

(deftest old-style-struct-access
    (with-foreign-object (s '(:struct old-style-outer))
      (let ((inner-ptr (foreign-slot-pointer s 'old-style-outer 'inner)))
        (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
      (assert (pointerp (foreign-slot-value s 'old-style-outer 'inner)))
      (foreign-slot-value (foreign-slot-value s 'old-style-outer 'inner)
                          'inner-struct 'x))
  42)

(deftest new-style-struct-access
    (with-foreign-object (s '(:struct new-style-outer))
      (let ((inner-ptr (foreign-slot-pointer s 'new-style-outer 'inner)))
        (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
      (foreign-slot-value s 'new-style-outer 'inner))
  (x 42))

;;; regression test: setting the value of aggregate slots.

(defcstruct aggregate-struct
  (x :int)
  (pair (:struct struct-pair))
  (y :int))

(deftest set-aggregate-struct-slot
    (with-foreign-objects ((pair-struct '(:struct struct-pair))
                           (aggregate-struct '(:struct aggregate-struct)))
      (with-foreign-slots ((a b) pair-struct (:struct struct-pair))
        (setf a 1 b 2)
        (with-foreign-slots ((x pair y) aggregate-struct (:struct aggregate-struct))
          (setf x 42 y 42)
          (setf pair pair-struct)
          (values x pair y))))
  42
  (1 . 2)
  42)

;; TODO this needs to go through compile-file to exhibit the error
;; ("don't know how to dump #"), but
;; there's no support for that, so let's leave it at toplevel here.
(defcstruct (aggregate-struct.acc :conc-name acc-)
  (x :int)
  (pair (:struct struct-pair))
  (y :int))

(deftest set-aggregate-struct-slot.acc
    (with-foreign-objects ((pair-struct '(:struct struct-pair))
                           (aggregate-struct '(:struct aggregate-struct)))
      (with-foreign-slots ((a b) pair-struct (:struct struct-pair))
        (setf a 1 b 2)
        (setf (acc-x aggregate-struct) 42)
        (setf (acc-y aggregate-struct) 42)
        (setf (acc-pair aggregate-struct) pair-struct)
        (values (acc-x aggregate-struct)
                (acc-pair aggregate-struct)
                (acc-y aggregate-struct))))
  42
  (1 . 2)
  42)
cffi_0.19.0/tests/arrays.lisp0000644000175000017500000000304313103031266014633 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; arrays.lisp --- Tests for foreign arrays.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;; Copyright (C) 2005-2007, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

;;;#Foreign Array Conversion Tests
;;;

(in-package #:cffi-tests)

(deftest array.round-trip
    (with-foreign-array (ptr #(1 2 3 4 5) '(:array :int32 5))
      (foreign-array-to-lisp ptr '(:array :int32 5)))
  #(1 2 3 4 5))
cffi_0.19.0/tests/test-static-link.sh0000755000175000017500000000051113103031266016174 0ustar  luisluis#!/bin/sh -eux

for l in sbcl ; do # mkcl ecl clisp sbcl
    EX="$(cl-launch -l $l -sp cffi-toolchain -ip "(output-file :static-program-op :cffi-tests/example)")"
    rm -f $EX ; :
    cl-launch -l $l -sp cffi-toolchain -i "(operate :static-program-op :cffi-tests/example)"
    [ -f $EX ]
    [ "$($EX)" = "hello, world!" ]
done
cffi_0.19.0/tests/Makefile0000644000175000017500000000003013103031266014072 0ustar  luisluisshlibs clean:
	gmake $@
cffi_0.19.0/tests/funcall.lisp0000644000175000017500000001674713103031266014775 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; funcall.lisp --- Tests function calling.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;; Copyright (C) 2005-2007, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

;;;# Calling with Built-In C Types
;;;
;;; Tests calling standard C library functions both passing and
;;; returning each built-in type.

;;; Don't run these tests if the implementation does not support
;;; foreign-funcall.
#-cffi-sys::no-foreign-funcall
(progn

(deftest funcall.char
    (foreign-funcall "toupper" :char (char-code #\a) :char)
  #.(char-code #\A))

(deftest funcall.int.1
    (foreign-funcall "abs" :int -100 :int)
  100)

(defun funcall-abs (n)
  (foreign-funcall "abs" :int n :int))

;;; regression test: lispworks's %foreign-funcall based on creating
;;; and caching foreign-funcallables at macro-expansion time.
(deftest funcall.int.2
    (funcall-abs -42)
  42)

(deftest funcall.long
    (foreign-funcall "labs" :long -131072 :long)
  131072)

#-cffi-sys::no-long-long
(deftest funcall.long-long
    (foreign-funcall "my_llabs" :long-long -9223372036854775807 :long-long)
  9223372036854775807)

#-cffi-sys::no-long-long
(deftest funcall.unsigned-long-long
    (let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long))))))
      (eql ullong-max
           (foreign-funcall "ullong" :unsigned-long-long ullong-max
                                     :unsigned-long-long)))
  t)

(deftest funcall.float
    (foreign-funcall "my_sqrtf" :float 16.0 :float)
  4.0)

(deftest funcall.double
    (foreign-funcall "sqrt" :double 36.0d0 :double)
  6.0d0)

#+(and scl long-float)
(deftest funcall.long-double
    (foreign-funcall "sqrtl" :long-double 36.0l0 :long-double)
  6.0l0)

(deftest funcall.string.1
    (foreign-funcall "strlen" :string "Hello" :int)
  5)

(deftest funcall.string.2
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (foreign-funcall "strcpy" :pointer s :string "Hello" :pointer)
      (foreign-funcall "strcat" :pointer s :string ", world!" :pointer))
  "Hello, world!")

(deftest funcall.string.3
    (with-foreign-pointer (ptr 100)
      (lisp-string-to-foreign "Hello, " ptr 8)
      (foreign-funcall "strcat" :pointer ptr :string "world!" :string))
  "Hello, world!")

;;;# Calling Varargs Functions

;; The CHAR argument must be passed as :INT because chars are promoted
;; to ints when passed as variable arguments.
(deftest funcall.varargs.char
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (foreign-funcall "sprintf" :pointer s :string "%c" :int 65 :int))
  "A")

(deftest funcall.varargs.int
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (foreign-funcall "sprintf" :pointer s :string "%d" :int 1000 :int))
  "1000")

(deftest funcall.varargs.long
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (foreign-funcall "sprintf" :pointer s :string "%ld" :long 131072 :int))
  "131072")

;;; There is no FUNCALL.VARARGS.FLOAT as floats are promoted to double
;;; when passed as variable arguments.  Currently this fails in SBCL
;;; and CMU CL on Darwin/ppc.
(deftest funcall.varargs.double
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (foreign-funcall "sprintf" :pointer s :string "%.2f"
                       :double (coerce pi 'double-float) :int))
  "3.14")

#+(and scl long-float)
(deftest funcall.varargs.long-double
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (foreign-funcall "sprintf" :pointer s :string "%.2Lf"
                       :long-double pi :int))
  "3.14")

(deftest funcall.varargs.string
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (foreign-funcall "sprintf" :pointer s :string "%s, %s!"
                       :string "Hello" :string "world" :int))
  "Hello, world!")

;;; See DEFCFUN.DOUBLE26.
(deftest funcall.double26
    (foreign-funcall "sum_double26"
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double 3.14d0
                     :double 3.14d0 :double 3.14d0 :double)
  81.64d0)

;;; See DEFCFUN.FLOAT26.
(deftest funcall.float26
    (foreign-funcall "sum_float26"
                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
                     :float 5.0 :float)
  130.0)

;;; Funcalling a pointer.
(deftest funcall.f-s-p.1
    (foreign-funcall-pointer (foreign-symbol-pointer "abs") nil :int -42 :int)
  42)

;;;# Namespaces

#-cffi-sys::flat-namespace
(deftest funcall.namespace.1
    (values (foreign-funcall ("ns_function" :library libtest) :boolean)
            (foreign-funcall ("ns_function" :library libtest2) :boolean))
  t nil)

;;;# stdcall

#+(and x86 windows (not cffi-sys::no-stdcall))
(deftest funcall.stdcall.1
    (flet ((fun ()
             (foreign-funcall ("stdcall_fun@12" :convention :stdcall)
                              :int 1 :int 2 :int 3 :int)))
      (loop repeat 100 do (fun)
            finally (return (fun))))
  6)

;;; RT: NIL arguments are skipped

(defvar *nil-skipped*)

(define-foreign-type check-nil-skip-type ()
  ()
  (:actual-type :pointer)
  (:simple-parser check-nil-skip-type))

(defmethod expand-to-foreign (val (type check-nil-skip-type))
  (declare (ignore val))
  (setf *nil-skipped* nil)
  (null-pointer))

(deftest funcall.nil-skip
    (let ((*nil-skipped* t))
      (compile nil '(lambda ()
                     (foreign-funcall "abs" check-nil-skip-type nil)))
      *nil-skipped*)
  nil)

;;; RT: CLISP returns NIL instead of a null-pointer

(deftest funcall.pointer-not-nil
    (not (null (foreign-funcall "strchr" :string "" :int 1 :pointer)))
  t)

) ;; #-cffi-sys::no-foreign-funcall
cffi_0.19.0/tests/run-tests.lisp0000644000175000017500000000316313103031266015301 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; run-tests.lisp --- Simple script to run the unit tests.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cl-user)

(setf *load-verbose* nil *compile-verbose* nil *compile-print* nil)
#+cmucl (setf ext:*gc-verbose* nil)

(require "asdf")

(format t "~&;;; -------- Running tests in ~A --------~%"
        (uiop:implementation-identifier))

(asdf:load-system "cffi-tests" :verbose nil)
(asdf:test-system "cffi-tests")

(terpri)
(force-output)

(uiop:quit)
cffi_0.19.0/tests/libfsbv.c0000644000175000017500000000747413103031266014250 0ustar  luisluis/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
 *
 * libfsbv.c --- auxiliary C lib for testing foreign structure by value calls
 *
 * Copyright (C) 2011, 2015 Liam M. Healy
 *
 * Permission is hereby granted, free of charge, to any person
 * obtaining a copy of this software and associated documentation
 * files (the "Software"), to deal in the Software without
 * restriction, including without limitation the rights to use, copy,
 * modify, merge, publish, distribute, sublicense, and/or sell copies
 * of the Software, and to permit persons to whom the Software is
 * furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be
 * included in all copies or substantial portions of the Software.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 * NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
 * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
 * DEALINGS IN THE SOFTWARE.
 */

#ifdef WIN32
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT
#endif

#include 
#include 
#include 
#include 
#include 
#include 
#include 

/* MSVC doesn't have stdint.h and uses a different syntax for stdcall */
#ifndef _MSC_VER
#include 
#endif

#ifdef WIN32
#ifdef _MSC_VER
#define STDCALL __stdcall
#else
#define STDCALL __attribute__((stdcall))
#endif
#else
#define STDCALL
#endif

struct struct_pair {
    int a;
    int b;
};

struct struct_pair_double {
    struct struct_pair pr;
    double dbl;
};

typedef enum {
    ONE = 1,
    TWO,
    THREE,
    FOUR,
    FORTY_ONE = 41,
    FORTY_TWO
} numeros;

int sumpair (struct struct_pair sp);
int enumpair (numeros mynum, struct struct_pair sp);
struct struct_pair doublepair (struct struct_pair dp);
double prodsumpair (struct struct_pair_double spd);
struct struct_pair_double doublepairdouble (struct struct_pair_double pd);

DLLEXPORT
int sumpair (struct struct_pair sp)
{
  return sp.a + sp.b;
}

DLLEXPORT
int enumpair (numeros mynum, struct struct_pair sp)
{
  if ( mynum == ONE )
    {
      return sp.a + sp.b;
    }
  else if ( mynum == TWO )
    {
      return sp.a + 2*sp.b;
    }
  else if ( mynum == THREE )
    {
      return 2*sp.a + sp.b;
    }
  else if ( mynum == FOUR )
    {
      return 2*sp.a + 2*sp.b;
    }
  else 
    {
      return 41*sp.a + 42*sp.b;
    }
}

DLLEXPORT
struct struct_pair makepair (bool cond)
{
  struct struct_pair ret;
  ret.a = -127;
  ret.b = cond ? 42 : 43;
  return ret;
}

const struct struct_pair static_pair = { 40, 2};

DLLEXPORT
struct struct_pair * returnpairpointer (struct struct_pair ignored)
{
  return &static_pair;
}

DLLEXPORT
struct struct_pair doublepair (struct struct_pair dp)
{
  struct struct_pair ret;
  ret.a = 2*dp.a;
  ret.b = 2*dp.b;
  return ret;
}

DLLEXPORT
double prodsumpair (struct struct_pair_double pd)
{
  return pd.dbl * sumpair(pd.pr);
}

DLLEXPORT
struct struct_pair_double doublepairdouble (struct struct_pair_double pd)
{
  struct struct_pair_double ret;
  ret.pr = doublepair(pd.pr);
  ret.dbl = 2*pd.dbl;
  return ret;
}

DLLEXPORT
unsigned long long ullsum (unsigned long long a, unsigned long long b)
{
  return a + b;
}

DLLEXPORT
struct struct_pair stringlenpair (char *string, struct struct_pair dp)
{
  struct struct_pair ret;
  int len = strlen(string);
  ret.a = len*dp.a;
  ret.b = len*dp.b;
  return ret;
}

struct bitfield_struct {
  unsigned int b;
};

DLLEXPORT
struct bitfield_struct structbitfield (unsigned int x) {
  struct bitfield_struct ret;
  ret.b = x;
  return ret;
}
cffi_0.19.0/tests/callbacks.lisp0000644000175000017500000004752113103031266015262 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; callbacks.lisp --- Tests on callbacks.
;;;
;;; Copyright (C) 2005-2006, Luis Oliveira  
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(defcfun "expect_char_sum"           :int (f :pointer))
(defcfun "expect_unsigned_char_sum"  :int (f :pointer))
(defcfun "expect_short_sum"          :int (f :pointer))
(defcfun "expect_unsigned_short_sum" :int (f :pointer))
(defcfun "expect_int_sum"            :int (f :pointer))
(defcfun "expect_unsigned_int_sum"   :int (f :pointer))
(defcfun "expect_long_sum"           :int (f :pointer))
(defcfun "expect_unsigned_long_sum"  :int (f :pointer))
(defcfun "expect_float_sum"          :int (f :pointer))
(defcfun "expect_double_sum"         :int (f :pointer))
(defcfun "expect_pointer_sum"        :int (f :pointer))
(defcfun "expect_strcat"             :int (f :pointer))

#-cffi-sys::no-long-long
(progn
  (defcfun "expect_long_long_sum"          :int (f :pointer))
  (defcfun "expect_unsigned_long_long_sum" :int (f :pointer)))

#+(and scl long-float)
(defcfun "expect_long_double_sum"    :int (f :pointer))

(defcallback sum-char :char ((a :char) (b :char))
  "Test if the named block is present and the docstring too."
  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
  (return-from sum-char (+ a b)))

(defcallback sum-unsigned-char :unsigned-char
    ((a :unsigned-char) (b :unsigned-char))
  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
  (+ a b))

(defcallback sum-short :short ((a :short) (b :short))
  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
  (+ a b))

(defcallback sum-unsigned-short :unsigned-short
    ((a :unsigned-short) (b :unsigned-short))
  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
  (+ a b))

(defcallback sum-int :int ((a :int) (b :int))
  (+ a b))

(defcallback sum-unsigned-int :unsigned-int
    ((a :unsigned-int) (b :unsigned-int))
  (+ a b))

(defcallback sum-long :long ((a :long) (b :long))
  (+ a b))

(defcallback sum-unsigned-long :unsigned-long
    ((a :unsigned-long) (b :unsigned-long))
  (+ a b))

#-cffi-sys::no-long-long
(progn
  (defcallback sum-long-long :long-long
      ((a :long-long) (b :long-long))
    (+ a b))

  (defcallback sum-unsigned-long-long :unsigned-long-long
      ((a :unsigned-long-long) (b :unsigned-long-long))
    (+ a b)))

(defcallback sum-float :float ((a :float) (b :float))
  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
  (+ a b))

(defcallback sum-double :double ((a :double) (b :double))
  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
  (+ a b))

#+(and scl long-float)
(defcallback sum-long-double :long-double ((a :long-double) (b :long-double))
  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
  (+ a b))

(defcallback sum-pointer :pointer ((ptr :pointer) (offset :int))
  (inc-pointer ptr offset))

(defcallback lisp-strcat :string ((a :string) (b :string))
  (concatenate 'string a b))

(deftest callbacks.char
    (expect-char-sum (get-callback 'sum-char))
  1)

(deftest callbacks.unsigned-char
    (expect-unsigned-char-sum (get-callback 'sum-unsigned-char))
  1)

(deftest callbacks.short
    (expect-short-sum (callback sum-short))
  1)

(deftest callbacks.unsigned-short
    (expect-unsigned-short-sum (callback sum-unsigned-short))
  1)

(deftest callbacks.int
    (expect-int-sum (callback sum-int))
  1)

(deftest callbacks.unsigned-int
    (expect-unsigned-int-sum (callback sum-unsigned-int))
  1)

(deftest callbacks.long
    (expect-long-sum (callback sum-long))
  1)

(deftest callbacks.unsigned-long
    (expect-unsigned-long-sum (callback sum-unsigned-long))
  1)

#-cffi-sys::no-long-long
(progn
  (deftest (callbacks.long-long :expected-to-fail (alexandria:featurep :openmcl))
      (expect-long-long-sum (callback sum-long-long))
    1)

  (deftest callbacks.unsigned-long-long
      (expect-unsigned-long-long-sum (callback sum-unsigned-long-long))
    1))

(deftest callbacks.float
    (expect-float-sum (callback sum-float))
  1)

(deftest callbacks.double
    (expect-double-sum (callback sum-double))
  1)

#+(and scl long-float)
(deftest callbacks.long-double
    (expect-long-double-sum (callback sum-long-double))
  1)

(deftest callbacks.pointer
    (expect-pointer-sum (callback sum-pointer))
  1)

(deftest callbacks.string
    (expect-strcat (callback lisp-strcat))
  1)

#-cffi-sys::no-foreign-funcall
(defcallback return-a-string-not-nil :string ()
  "abc")

#-cffi-sys::no-foreign-funcall
(deftest callbacks.string-not-docstring
    (foreign-funcall-pointer (callback return-a-string-not-nil) () :string)
  "abc")

(defcallback check-for-nil :boolean ((pointer :pointer))
  (null pointer))

#-cffi-sys::no-foreign-funcall
(deftest callbacks.nil-for-null
    (foreign-funcall-pointer (callback check-for-nil) nil
                             :pointer (null-pointer) :boolean)
  nil)

;;; This one tests mem-aref too.
(defcfun "qsort" :void
  (base :pointer)
  (nmemb :int)
  (size :int)
  (fun-compar :pointer))

(defcallback < :int ((a :pointer) (b :pointer))
  (let ((x (mem-ref a :int))
        (y (mem-ref b :int)))
    (cond ((> x y) 1)
          ((< x y) -1)
          (t 0))))

(deftest callbacks.qsort
    (with-foreign-object (array :int 10)
      ;; Initialize array.
      (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
            do (setf (mem-aref array :int i) n))
      ;; Sort it.
      (qsort array 10 (foreign-type-size :int) (callback <))
      ;; Return it as a list.
      (loop for i from 0 below 10
            collect (mem-aref array :int i)))
  (1 2 3 4 5 6 7 8 9 10))

;;; void callback
(defparameter *int* -1)

(defcfun "pass_int_ref" :void (f :pointer))

;;; CMUCL chokes on this one for some reason.
#-(and darwin cmucl)
(defcallback read-int-from-pointer :void ((a :pointer))
  (setq *int* (mem-ref a :int)))

#+(and darwin cmucl)
(pushnew 'callbacks.void rt::*expected-failures*)

(deftest callbacks.void
    (progn
      (pass-int-ref (callback read-int-from-pointer))
      *int*)
  1984)

;;; test funcalling of a callback and also declarations inside
;;; callbacks.

#-cffi-sys::no-foreign-funcall
(progn
  (defcallback sum-2 :int ((a :int) (b :int) (c :int))
    (declare (ignore c))
    (+ a b))

  (deftest callbacks.funcall.1
      (foreign-funcall-pointer (callback sum-2) () :int 2 :int 3 :int 1 :int)
    5)

  (defctype foo-float :float)

  (defcallback sum-2f foo-float
      ((a foo-float) (b foo-float) (c foo-float) (d foo-float) (e foo-float))
    "This one ignores the middle 3 arguments."
    (declare (ignore b c))
    (declare (ignore d))
    (+ a e))

  (deftest callbacks.funcall.2
      (foreign-funcall-pointer (callback sum-2f) () foo-float 1.0 foo-float 2.0
                               foo-float 3.0 foo-float 4.0 foo-float 5.0
                               foo-float)
    6.0))

;;; (cb-test :no-long-long t)

(defcfun "call_sum_127_no_ll" :long (cb :pointer))

;;; CMUCL, ECL and CCL choke on this one.
#-(or ecl cmucl clozure
      #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
(defcallback sum-127-no-ll :long
    ((a1 :unsigned-long) (a2 :pointer) (a3 :long) (a4 :double)
     (a5 :unsigned-long) (a6 :float) (a7 :float) (a8 :int) (a9 :unsigned-int)
     (a10 :double) (a11 :double) (a12 :double) (a13 :pointer)
     (a14 :unsigned-short) (a15 :unsigned-short) (a16 :pointer) (a17 :long)
     (a18 :long) (a19 :int) (a20 :short) (a21 :unsigned-short)
     (a22 :unsigned-short) (a23 :char) (a24 :long) (a25 :pointer) (a26 :pointer)
     (a27 :char) (a28 :unsigned-char) (a29 :unsigned-long) (a30 :short)
     (a31 :int) (a32 :int) (a33 :unsigned-char) (a34 :short) (a35 :long)
     (a36 :long) (a37 :pointer) (a38 :unsigned-short) (a39 :char) (a40 :double)
     (a41 :unsigned-short) (a42 :pointer) (a43 :short) (a44 :unsigned-long)
     (a45 :unsigned-short) (a46 :float) (a47 :unsigned-char) (a48 :short)
     (a49 :float) (a50 :short) (a51 :char) (a52 :unsigned-long)
     (a53 :unsigned-long) (a54 :char) (a55 :float) (a56 :long) (a57 :pointer)
     (a58 :short) (a59 :float) (a60 :unsigned-int) (a61 :float)
     (a62 :unsigned-int) (a63 :double) (a64 :unsigned-int) (a65 :unsigned-char)
     (a66 :int) (a67 :long) (a68 :char) (a69 :short) (a70 :double) (a71 :int)
     (a72 :pointer) (a73 :char) (a74 :unsigned-short) (a75 :pointer)
     (a76 :unsigned-short) (a77 :pointer) (a78 :unsigned-long) (a79 :double)
     (a80 :pointer) (a81 :long) (a82 :float) (a83 :unsigned-short)
     (a84 :unsigned-short) (a85 :pointer) (a86 :float) (a87 :int)
     (a88 :unsigned-int) (a89 :double) (a90 :float) (a91 :long) (a92 :pointer)
     (a93 :unsigned-short) (a94 :float) (a95 :unsigned-char) (a96 :unsigned-char)
     (a97 :float) (a98 :unsigned-int) (a99 :float) (a100 :unsigned-short)
     (a101 :double) (a102 :unsigned-short) (a103 :unsigned-long)
     (a104 :unsigned-int) (a105 :unsigned-long) (a106 :pointer)
     (a107 :unsigned-char) (a108 :char) (a109 :char) (a110 :unsigned-short)
     (a111 :unsigned-long) (a112 :float) (a113 :short) (a114 :pointer)
     (a115 :long) (a116 :unsigned-short) (a117 :short) (a118 :double)
     (a119 :short) (a120 :int) (a121 :char) (a122 :unsigned-long) (a123 :long)
     (a124 :int) (a125 :pointer) (a126 :double) (a127 :unsigned-char))
  (let ((args (list a1 (pointer-address a2) a3 (floor a4) a5 (floor a6)
                    (floor a7) a8 a9 (floor a10) (floor a11) (floor a12)
                    (pointer-address a13) a14 a15 (pointer-address a16) a17 a18
                    a19 a20 a21 a22 a23 a24 (pointer-address a25)
                    (pointer-address a26) a27 a28 a29 a30 a31 a32 a33 a34 a35
                    a36 (pointer-address a37) a38 a39 (floor a40) a41
                    (pointer-address a42) a43 a44 a45 (floor a46) a47 a48
                    (floor a49) a50 a51 a52 a53 a54 (floor a55) a56
                    (pointer-address a57) a58 (floor a59) a60 (floor a61) a62
                    (floor a63) a64 a65 a66 a67 a68 a69 (floor a70) a71
                    (pointer-address a72) a73 a74 (pointer-address a75) a76
                    (pointer-address a77) a78 (floor a79) (pointer-address a80)
                    a81 (floor a82) a83 a84 (pointer-address a85) (floor a86)
                    a87 a88 (floor a89) (floor a90) a91 (pointer-address a92)
                    a93 (floor a94) a95 a96 (floor a97) a98 (floor a99) a100
                    (floor a101) a102 a103 a104 a105 (pointer-address a106) a107
                    a108 a109 a110 a111 (floor a112) a113 (pointer-address a114)
                    a115 a116 a117 (floor a118) a119 a120 a121 a122 a123 a124
                    (pointer-address a125) (floor a126) a127)))
    #-(and)
    (loop for i from 1 and arg in args do
          (format t "a~A: ~A~%" i arg))
    (reduce #'+ args)))

#+(or openmcl cmucl ecl (and darwin (or allegro lispworks)))
(push 'callbacks.bff.1 regression-test::*expected-failures*)

#+#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or))
(deftest callbacks.bff.1
    (call-sum-127-no-ll (callback sum-127-no-ll))
  2008547941)

;;; (cb-test)

#-(or cffi-sys::no-long-long
      #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(or) '(and)))
(progn
  (defcfun "call_sum_127" :long-long (cb :pointer))

  ;;; CMUCL, ECL and CCL choke on this one.
  #-(or cmucl ecl clozure)
  (defcallback sum-127 :long-long
      ((a1 :short) (a2 :char) (a3 :pointer) (a4 :float) (a5 :long) (a6 :double)
       (a7 :unsigned-long-long) (a8 :unsigned-short) (a9 :unsigned-char)
       (a10 :char) (a11 :char) (a12 :unsigned-short) (a13 :unsigned-long-long)
       (a14 :unsigned-short) (a15 :long-long) (a16 :unsigned-short)
       (a17 :unsigned-long-long) (a18 :unsigned-char) (a19 :unsigned-char)
       (a20 :unsigned-long-long) (a21 :long-long) (a22 :char) (a23 :float)
       (a24 :unsigned-int) (a25 :float) (a26 :float) (a27 :unsigned-int)
       (a28 :float) (a29 :char) (a30 :unsigned-char) (a31 :long) (a32 :long-long)
       (a33 :unsigned-char) (a34 :double) (a35 :long) (a36 :double)
       (a37 :unsigned-int) (a38 :unsigned-short) (a39 :long-long)
       (a40 :unsigned-int) (a41 :int) (a42 :unsigned-long-long) (a43 :long)
       (a44 :short) (a45 :unsigned-int) (a46 :unsigned-int)
       (a47 :unsigned-long-long) (a48 :unsigned-int) (a49 :long) (a50 :pointer)
       (a51 :unsigned-char) (a52 :char) (a53 :long-long) (a54 :unsigned-short)
       (a55 :unsigned-int) (a56 :float) (a57 :unsigned-char) (a58 :unsigned-long)
       (a59 :long-long) (a60 :float) (a61 :long) (a62 :float) (a63 :int)
       (a64 :float) (a65 :unsigned-short) (a66 :unsigned-long-long) (a67 :short)
       (a68 :unsigned-long) (a69 :long) (a70 :char) (a71 :unsigned-short)
       (a72 :long-long) (a73 :short) (a74 :double) (a75 :pointer)
       (a76 :unsigned-int) (a77 :char) (a78 :unsigned-int) (a79 :pointer)
       (a80 :pointer) (a81 :unsigned-char) (a82 :pointer) (a83 :unsigned-short)
       (a84 :unsigned-char) (a85 :long) (a86 :pointer) (a87 :char) (a88 :long)
       (a89 :unsigned-short) (a90 :unsigned-char) (a91 :double)
       (a92 :unsigned-long-long) (a93 :unsigned-short) (a94 :unsigned-short)
       (a95 :unsigned-int) (a96 :long) (a97 :char) (a98 :long) (a99 :char)
       (a100 :short) (a101 :unsigned-short) (a102 :unsigned-long)
       (a103 :unsigned-long) (a104 :short) (a105 :long-long) (a106 :long-long)
       (a107 :long-long) (a108 :double) (a109 :unsigned-short)
       (a110 :unsigned-char) (a111 :short) (a112 :unsigned-char) (a113 :long)
       (a114 :long-long) (a115 :unsigned-long-long) (a116 :unsigned-int)
       (a117 :unsigned-long) (a118 :unsigned-char) (a119 :long-long)
       (a120 :unsigned-char) (a121 :unsigned-long-long) (a122 :double)
       (a123 :unsigned-char) (a124 :long-long) (a125 :unsigned-char)
       (a126 :char) (a127 :long-long))
    (+ a1 a2 (pointer-address a3) (values (floor a4)) a5 (values (floor a6))
       a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22
       (values (floor a23)) a24 (values (floor a25)) (values (floor a26))
       a27 (values (floor a28)) a29 a30 a31 a32 a33 (values (floor a34))
       a35 (values (floor a36)) a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47
       a48 a49 (pointer-address a50) a51 a52 a53 a54 a55 (values (floor a56))
       a57 a58 a59 (values (floor a60)) a61 (values (floor a62)) a63
       (values (floor a64)) a65 a66 a67 a68 a69 a70 a71 a72 a73
       (values (floor a74)) (pointer-address a75) a76 a77 a78
       (pointer-address a79) (pointer-address a80) a81 (pointer-address a82)
       a83 a84 a85 (pointer-address a86) a87 a88 a89 a90 (values (floor a91))
       a92 a93 a94 a95 a96 a97 a98 a99 a100 a101 a102 a103 a104 a105 a106 a107
       (values (floor a108)) a109 a110 a111 a112 a113 a114 a115 a116 a117 a118
       a119 a120 a121 (values (floor a122)) a123 a124 a125 a126 a127))

  #+(or openmcl cmucl ecl)
  (push 'callbacks.bff.2 rt::*expected-failures*)

  (deftest callbacks.bff.2
      (call-sum-127 (callback sum-127))
    8166570665645582011))

;;; regression test: (callback non-existant-callback) should throw an error
(deftest callbacks.non-existant
    (not (null (nth-value 1 (ignore-errors (callback doesnt-exist)))))
  t)

;;; Handling many arguments of type double. Many lisps (used to) fail
;;; this one on darwin/ppc. This test might be bogus due to floating
;;; point arithmetic rounding errors.
;;;
;;; CMUCL chokes on this one.
#-(and darwin cmucl)
(defcallback double26 :double
    ((a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
     (a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
     (a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
     (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
     (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
     (a26 :double))
  (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
                    a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
    #-(and)
    (loop for i from 1 and arg in args do
          (format t "a~A: ~A~%" i arg))
    (reduce #'+ args)))

(defcfun "call_double26" :double (f :pointer))

#+(and darwin (or allegro cmucl))
(pushnew 'callbacks.double26 rt::*expected-failures*)

(deftest callbacks.double26
    (call-double26 (callback double26))
  81.64d0)

#+(and darwin cmucl)
(pushnew 'callbacks.double26.funcall rt::*expected-failures*)

#-cffi-sys::no-foreign-funcall
(deftest callbacks.double26.funcall
    (foreign-funcall-pointer
     (callback double26) () :double 3.14d0 :double 3.14d0
     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
     :double)
  81.64d0)

;;; Same as above, for floats.
#-(and darwin cmucl)
(defcallback float26 :float
    ((a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
     (a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
     (a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
     (a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
     (a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
     (a26 :float))
  (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
                    a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
    #-(and)
    (loop for i from 1 and arg in args do
          (format t "a~A: ~A~%" i arg))
    (reduce #'+ args)))

(defcfun "call_float26" :float (f :pointer))

#+(and darwin (or lispworks openmcl cmucl))
(pushnew 'callbacks.float26 regression-test::*expected-failures*)

(deftest callbacks.float26
    (call-float26 (callback float26))
  130.0)

#+(and darwin (or lispworks openmcl cmucl))
(pushnew 'callbacks.float26.funcall regression-test::*expected-failures*)

#-cffi-sys::no-foreign-funcall
(deftest callbacks.float26.funcall
    (foreign-funcall-pointer
     (callback float26) () :float 5.0 :float 5.0
     :float 5.0 :float 5.0 :float 5.0 :float 5.0
     :float 5.0 :float 5.0 :float 5.0 :float 5.0
     :float 5.0 :float 5.0 :float 5.0 :float 5.0
     :float 5.0 :float 5.0 :float 5.0 :float 5.0
     :float 5.0 :float 5.0 :float 5.0 :float 5.0
     :float 5.0 :float 5.0 :float 5.0 :float 5.0
     :float)
  130.0)

;;; Defining a callback as a non-toplevel form. Not portable. Doesn't
;;; work for CMUCL or Allegro.
#-(and)
(let ((n 42))
  (defcallback non-toplevel-cb :int ()
    n))

#-(and)
(deftest callbacks.non-toplevel
    (foreign-funcall (callback non-toplevel-cb) :int)
  42)

;;;# Stdcall

#+(and x86 (not cffi-sys::no-stdcall))
(progn
  (defcallback (stdcall-cb :convention :stdcall) :int
      ((a :int) (b :int) (c :int))
    (+ a b c))

  (defcfun "call_stdcall_fun" :int
    (f :pointer))

  (deftest callbacks.stdcall.1
      (call-stdcall-fun (callback stdcall-cb))
    42))

;;; RT: many of the %DEFCALLBACK implementations wouldn't handle
;;;     uninterned symbols.
(deftest callbacks.uninterned
    (values (defcallback #1=#:foo :void ())
            (pointerp (callback #1#)))
  #1# t)
cffi_0.19.0/grovel/0000755000175000017500000000000013103031266012575 5ustar  luisluiscffi_0.19.0/grovel/asdf.lisp0000644000175000017500000001430113103031266014402 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; asdf.lisp --- ASDF components for cffi-grovel.
;;;
;;; Copyright (C) 2005-2006, Dan Knap 
;;; Copyright (C) 2005-2006, Emily Backes 
;;; Copyright (C) 2007, Stelian Ionescu 
;;; Copyright (C) 2007, Luis Oliveira 
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-grovel)

(defclass cc-flags-mixin ()
  ((cc-flags :initform nil :accessor cc-flags-of :initarg :cc-flags)))

(defmethod perform :around ((op compile-op) (file cc-flags-mixin))
  (let ((*cc-flags* (append (ensure-list (cc-flags-of file))
                            *cc-flags*)))
    (call-next-method)))

(defclass process-op (downward-operation)
  ()
  (:documentation "This ASDF operation performs the steps necessary
  to generate a compilable and loadable lisp file from a
  PROCESS-OP-INPUT component."))

(defclass process-op-input (cl-source-file)
  ((generated-lisp-file-type
    :initarg :generated-lisp-file-type
    :accessor generated-lisp-file-type
    :documentation "The :TYPE argument to use for the generated lisp file."))
  (:default-initargs
   :generated-lisp-file-type "generated-lisp-file")
  (:documentation "This ASDF component represents a file that is
    used as input to a function that generates lisp source file. This
    component acts as if it is a CL-SOURCE-FILE by applying the
    COMPILE-OP and LOAD-SOURCE-OP operations to the file generated by
    PROCESS-OP."))

(defmethod input-files ((op process-op) (c process-op-input))
  (list (component-pathname c)))

(defmethod input-files ((op compile-op) (c process-op-input))
  (list (first (output-files 'process-op c))))

(defmethod component-depends-on ((op process-op) (c process-op-input))
  `((prepare-op ,c) ,@(call-next-method)))

(defmethod component-depends-on ((op compile-op) (c process-op-input))
  `((process-op ,c) ,@(call-next-method)))

(defmethod component-depends-on ((op load-source-op) (c process-op-input))
  `((process-op ,c) ,@(call-next-method)))

;;;# ASDF component: GROVEL-FILE

(defclass grovel-file (process-op-input cc-flags-mixin)
  ()
  (:default-initargs
   :generated-lisp-file-type "processed-grovel-file")
  (:documentation
   "This ASDF component represents an input file that is processed
    by PROCESS-GROVEL-FILE."))

(defmethod output-files ((op process-op) (c grovel-file))
  (let* ((input-file (first (input-files op c)))
         (output-file (make-pathname :type (generated-lisp-file-type c)
                                     :defaults input-file))
         (c-file (make-c-file-name output-file "__grovel")))
    (list output-file
          c-file
          (make-exe-file-name c-file))))

(defmethod perform ((op process-op) (c grovel-file))
  (let* ((output-file (first (output-files op c)))
         (input-file (first (input-files op c)))
         (tmp-file (process-grovel-file input-file output-file)))
    (rename-file-overwriting-target tmp-file output-file)))


;;;# ASDF component: WRAPPER-FILE

(defclass wrapper-file (process-op-input cc-flags-mixin)
  ((soname :initform nil :initarg :soname :accessor soname-of))
  (:default-initargs
   :generated-lisp-file-type "processed-wrapper-file")
  (:documentation
   "This ASDF component represents an input file that is processed
    by PROCESS-WRAPPER-FILE. This generates a foreign library and
    matching CFFI bindings that are subsequently compiled and
    loaded."))

(defun wrapper-soname (c)
  (or (soname-of c)
      (component-name c)))

(defmethod output-files ((op process-op) (c wrapper-file))
  (let* ((input-file (first (input-files op c)))
         (output-file (make-pathname :type (generated-lisp-file-type c)
                                     :defaults input-file))
         (c-file (make-c-file-name output-file "__wrapper"))
         (o-file (make-o-file-name output-file "__wrapper"))
         (lib-soname (wrapper-soname c)))
    (list output-file
          (make-so-file-name (make-soname lib-soname output-file))
          c-file
          o-file)))

;;; Declare the .o and .so files as compilation outputs,
;;; so they get picked up by bundle operations.
#.(when (version<= "3.1.6" (asdf-version))
    '(defmethod output-files ((op compile-op) (c wrapper-file))
      (destructuring-bind (generated-lisp lib-file c-file o-file) (output-files 'process-op c)
        (declare (ignore generated-lisp c-file))
        (multiple-value-bind (files translatedp) (call-next-method)
          (values (append files (list lib-file o-file)) translatedp)))))

(defmethod perform ((op process-op) (c wrapper-file))
  (let* ((output-file (first (output-files op c)))
         (input-file (first (input-files op c)))
         (tmp-file (process-wrapper-file
                    input-file
                    :output-defaults output-file
                    :lib-soname (wrapper-soname c))))
      (unwind-protect
           (alexandria:copy-file tmp-file output-file :if-to-exists :supersede)
        (delete-file tmp-file))))

;; Allow for naked :cffi-grovel-file and :cffi-wrapper-file in asdf definitions.
(setf (find-class 'asdf::cffi-grovel-file) (find-class 'grovel-file))
(setf (find-class 'asdf::cffi-wrapper-file) (find-class 'wrapper-file))

cffi_0.19.0/grovel/grovel.lisp0000644000175000017500000010651613103031266014775 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; grovel.lisp --- The CFFI Groveller.
;;;
;;; Copyright (C) 2005-2006, Dan Knap 
;;; Copyright (C) 2005-2006, Emily Backes 
;;; Copyright (C) 2007, Stelian Ionescu 
;;; Copyright (C) 2007, Luis Oliveira 
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-grovel)

;;;# Error Conditions

(define-condition grovel-error (simple-error) ())

(defun grovel-error (format-control &rest format-arguments)
  (error 'grovel-error
         :format-control format-control
         :format-arguments format-arguments))

;;; This warning is signalled when cffi-grovel can't find some macro.
;;; Signalled by CONSTANT or CONSTANTENUM.
(define-condition missing-definition (warning)
  ((%name :initarg :name :reader name-of))
  (:report (lambda (condition stream)
             (format stream "No definition for ~A"
                     (name-of condition)))))

;;;# Grovelling

;;; The header of the intermediate C file.
(defparameter *header*
  "/*
 * This file has been automatically generated by cffi-grovel.
 * Do not edit it by hand.
 */

")

;;; C code generated by cffi-grovel is inserted between the contents
;;; of *PROLOGUE* and *POSTSCRIPT*, inside the main function's body.

(defparameter *prologue*
  "
#include 

int main(int argc, char**argv) {
  int autotype_tmp;
  FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout;
  fprintf(output, \";;;; This file has been automatically generated by \"
                  \"cffi-grovel.\\n;;;; Do not edit it by hand.\\n\\n\");
")

(defparameter *postscript*
  "
  if  (output != stdout)
    fclose(output);
  return 0;
}
")

(defun unescape-for-c (text)
  (with-output-to-string (result)
    (loop for i below (length text)
          for char = (char text i) do
          (cond ((eql char #\") (princ "\\\"" result))
                ((eql char #\newline) (princ "\\n" result))
                (t (princ char result))))))

(defun c-format (out fmt &rest args)
  (let ((text (unescape-for-c (format nil "~?" fmt args))))
    (format out "~&  fputs(\"~A\", output);~%" text)))

(defun c-printf (out fmt &rest args)
  (flet ((item (item)
           (format out "~A" (unescape-for-c (format nil item)))))
    (format out "~&  fprintf(output, \"")
    (item fmt)
    (format out "\"")
    (loop for arg in args do
          (format out ", ")
          (item arg))
    (format out ");~%")))

(defun c-print-integer-constant (out arg &optional foreign-type)
  (let ((foreign-type (or foreign-type :int)))
    (c-format out "#.(cffi-grovel::convert-intmax-constant ")
    (format out "~&  fprintf(output, \"%\"PRIiMAX, (intmax_t)~A);~%"
            arg)
    (c-format out " ")
    (c-write out `(quote ,foreign-type))
    (c-format out ")")))

;;; TODO: handle packages in a better way. One way is to process each
;;; grovel form as it is read (like we already do for wrapper
;;; forms). This way in can expect *PACKAGE* to have sane values.
;;; This would require that "header forms" come before any other
;;; forms.
(defun c-print-symbol (out symbol &optional no-package)
  (c-format out
            (let ((package (symbol-package symbol)))
              (cond
                ((eq (find-package '#:keyword) package) ":~(~A~)")
                (no-package "~(~A~)")
                ((eq (find-package '#:cl) package) "cl:~(~A~)")
                (t "~(~A~)")))
            symbol))

(defun c-write (out form &optional no-package)
  (cond
    ((and (listp form)
          (eq 'quote (car form)))
     (c-format out "'")
     (c-write out (cadr form) no-package))
    ((listp form)
     (c-format out "(")
     (loop for subform in form
           for first-p = t then nil
           unless first-p do (c-format out " ")
        do (c-write out subform no-package))
     (c-format out ")"))
    ((symbolp form)
     (c-print-symbol out form no-package))))

;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms
;;; later, if necessary.
(defvar *auto-export* nil)

(defun c-export (out symbol)
  (when (and *auto-export* (not (keywordp symbol)))
    (c-format out "(cl:export '")
    (c-print-symbol out symbol t)
    (c-format out ")~%")))

(defun c-section-header (out section-type section-symbol)
  (format out "~%  /* ~A section for ~S */~%"
          section-type
          section-symbol))

(defun remove-suffix (string suffix)
  (let ((suffix-start (- (length string) (length suffix))))
    (if (and (> suffix-start 0)
             (string= string suffix :start1 suffix-start))
        (subseq string 0 suffix-start)
        string)))

(defgeneric %process-grovel-form (name out arguments)
  (:method (name out arguments)
    (declare (ignore out arguments))
    (grovel-error "Unknown Grovel syntax: ~S" name)))

(defun process-grovel-form (out form)
  (%process-grovel-form (form-kind form) out (cdr form)))

(defun form-kind (form)
  ;; Using INTERN here instead of FIND-SYMBOL will result in less
  ;; cryptic error messages when an undefined grovel/wrapper form is
  ;; found.
  (intern (symbol-name (car form)) '#:cffi-grovel))

(defvar *header-forms* '(c include define flag typedef))

(defun header-form-p (form)
  (member (form-kind form) *header-forms*))

(defun generate-c-file (input-file output-defaults)
  (nest
   (with-standard-io-syntax)
   (let ((c-file (make-c-file-name output-defaults "__grovel"))
         (*print-readably* nil)
         (*print-escape* t)))
   (with-open-file (out c-file :direction :output :if-exists :supersede))
   (with-open-file (in input-file :direction :input))
   (flet ((read-forms (s)
            (do ((forms ())
                 (form (read s nil nil) (read s nil nil)))
                ((null form) (nreverse forms))
              (labels
                  ((process-form (f)
                     (case (form-kind f)
                       (flag (warn "Groveler clause FLAG is deprecated, use CC-FLAGS instead.")))
                     (case (form-kind f)
                       (in-package
                        (setf *package* (find-package (second f)))
                        (push f forms))
                       (progn
                         ;; flatten progn forms
                         (mapc #'process-form (rest f)))
                       (t (push f forms)))))
                (process-form form))))))
   (let* ((forms (read-forms in))
          (header-forms (remove-if-not #'header-form-p forms))
          (body-forms (remove-if #'header-form-p forms)))
     (write-string *header* out)
     (dolist (form header-forms)
       (process-grovel-form out form))
     (write-string *prologue* out)
     (dolist (form body-forms)
       (process-grovel-form out form))
     (write-string *postscript* out)
     c-file)))

(defun tmp-lisp-file-name (defaults)
  (make-pathname :name (strcat (pathname-name defaults) ".grovel-tmp")
                 :type "lisp" :defaults defaults))



;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
;;; *the extent of a given grovel file.
(defun process-grovel-file (input-file &optional (output-defaults input-file))
  (with-standard-io-syntax
    (let* ((c-file (generate-c-file input-file output-defaults))
           (o-file (make-o-file-name c-file))
           (exe-file (make-exe-file-name c-file))
           (lisp-file (tmp-lisp-file-name c-file))
           (inputs (list (cc-include-grovel-argument) c-file)))
      (handler-case
          (progn
            ;; at least MKCL wants to separate compile and link
            (cc-compile o-file inputs)
            (link-executable exe-file (list o-file)))
        (error (e)
          (grovel-error "~a" e)))
      (invoke exe-file lisp-file)
      lisp-file)))

;;; OUT is lexically bound to the output stream within BODY.
(defmacro define-grovel-syntax (name lambda-list &body body)
  (with-unique-names (name-var args)
    `(defmethod %process-grovel-form ((,name-var (eql ',name)) out ,args)
       (declare (ignorable out))
       (destructuring-bind ,lambda-list ,args
         ,@body))))

(define-grovel-syntax c (body)
  (format out "~%~A~%" body))

(define-grovel-syntax include (&rest includes)
  (format out "~{#include <~A>~%~}" includes))

(define-grovel-syntax define (name &optional value)
  (format out "#define ~A~@[ ~A~]~%" name value))

(define-grovel-syntax typedef (base-type new-type)
  (format out "typedef ~A ~A;~%" base-type new-type))

;;; Is this really needed?
(define-grovel-syntax ffi-typedef (new-type base-type)
  (c-format out "(cffi:defctype ~S ~S)~%" new-type base-type))

(define-grovel-syntax flag (&rest flags)
  (appendf *cc-flags* (parse-command-flags-list flags)))

(define-grovel-syntax cc-flags (&rest flags)
  (appendf *cc-flags* (parse-command-flags-list flags)))

(define-grovel-syntax pkg-config-cflags (pkg &key optional)
  (let ((output-stream (make-string-output-stream))
        (program+args (list "pkg-config" pkg "--cflags")))
    (format *debug-io* "~&;~{ ~a~}~%" program+args)
    (handler-case
        (progn
          (run-program program+args
                       :output (make-broadcast-stream output-stream *debug-io*)
                       :error-output output-stream)
          (appendf *cc-flags*
                   (parse-command-flags (get-output-stream-string output-stream))))
      (error (e)
        (let ((message (format nil "~a~&~%~a~&"
                               e (get-output-stream-string output-stream))))
          (cond (optional
                 (format *debug-io* "~&; ERROR: ~a" message)
                 (format *debug-io* "~&~%; Attempting to continue anyway.~%"))
                (t
                 (grovel-error "~a" message))))))))

;;; This form also has some "read time" effects. See GENERATE-C-FILE.
(define-grovel-syntax in-package (name)
  (c-format out "(cl:in-package #:~A)~%~%" name))

(define-grovel-syntax ctype (lisp-name size-designator)
  (c-section-header out "ctype" lisp-name)
  (c-export out lisp-name)
  (c-format out "(cffi:defctype ")
  (c-print-symbol out lisp-name t)
  (c-format out " ")
  (format out "~&  type_name(output, TYPE_SIGNED_P(~A), ~:[sizeof(~A)~;~D~]);~%"
          size-designator
          (etypecase size-designator
            (string nil)
            (integer t))
          size-designator)
  (c-format out ")~%")
  (unless (keywordp lisp-name)
    (c-export out lisp-name))
  (let ((size-of-constant-name (symbolicate '#:size-of- lisp-name)))
    (c-export out size-of-constant-name)
    (c-format out "(cl:defconstant "
              size-of-constant-name lisp-name)
    (c-print-symbol out size-of-constant-name)
    (c-format out " (cffi:foreign-type-size '")
    (c-print-symbol out lisp-name)
    (c-format out "))~%")))

;;; Syntax differs from anything else in CFFI.  Fix?
(define-grovel-syntax constant ((lisp-name &rest c-names)
                                &key (type 'integer) documentation optional)
  (when (keywordp lisp-name)
    (setf lisp-name (format-symbol "~A" lisp-name)))
  (c-section-header out "constant" lisp-name)
  (dolist (c-name c-names)
    (format out "~&#ifdef ~A~%" c-name)
    (c-export out lisp-name)
    (c-format out "(cl:defconstant ")
    (c-print-symbol out lisp-name t)
    (c-format out " ")
    (ecase type
      (integer
       (format out "~&  if(_64_BIT_VALUE_FITS_SIGNED_P(~A))~%" c-name)
       (format out "    fprintf(output, \"%lli\", (long long signed) ~A);" c-name)
       (format out "~&  else~%")
       (format out "    fprintf(output, \"%llu\", (long long unsigned) ~A);" c-name))
      (double-float
       (format out "~&  fprintf(output, \"%s\", print_double_for_lisp((double)~A));~%" c-name)))
    (when documentation
      (c-format out " ~S" documentation))
    (c-format out ")~%")
    (format out "~&#else~%"))
  (unless optional
    (c-format out "(cl:warn 'cffi-grovel:missing-definition :name '~A)~%"
              lisp-name))
  (dotimes (i (length c-names))
    (format out "~&#endif~%")))

(define-grovel-syntax cunion (union-lisp-name union-c-name &rest slots)
  (let ((documentation (when (stringp (car slots)) (pop slots))))
    (c-section-header out "cunion" union-lisp-name)
    (c-export out union-lisp-name)
    (dolist (slot slots)
      (let ((slot-lisp-name (car slot)))
        (c-export out slot-lisp-name)))
    (c-format out "(cffi:defcunion (")
    (c-print-symbol out union-lisp-name t)
    (c-printf out " :size %llu)" (format nil "(long long unsigned) sizeof(~A)" union-c-name))
    (when documentation
      (c-format out "~%  ~S" documentation))
    (dolist (slot slots)
      (destructuring-bind (slot-lisp-name slot-c-name &key type count)
          slot
        (declare (ignore slot-c-name))
        (c-format out "~%  (")
        (c-print-symbol out slot-lisp-name t)
        (c-format out " ")
        (c-write out type)
        (etypecase count
          (integer
           (c-format out " :count ~D" count))
          ((eql :auto)
           ;; nb, works like :count :auto does in cstruct below
           (c-printf out " :count %llu"
                     (format nil "(long long unsigned) sizeof(~A)" union-c-name)))
          (null t))
        (c-format out ")")))
    (c-format out ")~%")))

(defun make-from-pointer-function-name (type-name)
  (symbolicate '#:make- type-name '#:-from-pointer))

;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much
;;; cleaner way to do this.  Unless I can find any advantage in doing
;;; it this way I'll delete this soon.  --luis
(define-grovel-syntax cstruct-and-class-item (&rest arguments)
  (process-grovel-form out (cons 'cstruct arguments))
  (destructuring-bind (struct-lisp-name struct-c-name &rest slots)
      arguments
    (declare (ignore struct-c-name))
    (let* ((slot-names (mapcar #'car slots))
           (reader-names (mapcar
                          (lambda (slot-name)
                            (intern
                             (strcat (symbol-name struct-lisp-name) "-"
                                     (symbol-name slot-name))))
                          slot-names))
           (initarg-names (mapcar
                           (lambda (slot-name)
                             (intern (symbol-name slot-name) "KEYWORD"))
                           slot-names))
           (slot-decoders (mapcar (lambda (slot)
                                    (destructuring-bind
                                          (lisp-name c-name
                                                     &key type count
                                                     &allow-other-keys)
                                        slot
                                      (declare (ignore lisp-name c-name))
                                      (cond ((and (eq type :char) count)
                                             'cffi:foreign-string-to-lisp)
                                            (t nil))))
                                  slots))
           (defclass-form
            `(defclass ,struct-lisp-name ()
               ,(mapcar (lambda (slot-name initarg-name reader-name)
                          `(,slot-name :initarg ,initarg-name
                                       :reader ,reader-name))
                        slot-names
                        initarg-names
                        reader-names)))
           (make-function-name
            (make-from-pointer-function-name struct-lisp-name))
           (make-defun-form
            ;; this function is then used as a constructor for this class.
            `(defun ,make-function-name (pointer)
               (cffi:with-foreign-slots
                   (,slot-names pointer ,struct-lisp-name)
                 (make-instance ',struct-lisp-name
                                ,@(loop for slot-name in slot-names
                                        for initarg-name in initarg-names
                                        for slot-decoder in slot-decoders
                                        collect initarg-name
                                        if slot-decoder
                                        collect `(,slot-decoder ,slot-name)
                                        else collect slot-name))))))
      (c-export out make-function-name)
      (dolist (reader-name reader-names)
        (c-export out reader-name))
      (c-write out defclass-form)
      (c-write out make-defun-form))))

(define-grovel-syntax cstruct (struct-lisp-name struct-c-name &rest slots)
  (let ((documentation (when (stringp (car slots)) (pop slots))))
    (c-section-header out "cstruct" struct-lisp-name)
    (c-export out struct-lisp-name)
    (dolist (slot slots)
      (let ((slot-lisp-name (car slot)))
        (c-export out slot-lisp-name)))
    (c-format out "(cffi:defcstruct (")
    (c-print-symbol out struct-lisp-name t)
    (c-printf out " :size %llu)"
              (format nil "(long long unsigned) sizeof(~A)" struct-c-name))
    (when documentation
      (c-format out "~%  ~S" documentation))
    (dolist (slot slots)
      (destructuring-bind (slot-lisp-name slot-c-name &key type count)
          slot
        (c-format out "~%  (")
        (c-print-symbol out slot-lisp-name t)
        (c-format out " ")
        (etypecase type
          ((eql :auto)
           (format out "~&  SLOT_SIGNED_P(autotype_tmp, ~A, ~A~@[[0]~]);~@*~%~
                        ~&  type_name(output, autotype_tmp, sizeofslot(~A, ~A~@[[0]~]));~%"
                   struct-c-name
                   slot-c-name
                   (not (null count))))
          ((or cons symbol)
           (c-write out type))
          (string
           (c-format out "~A" type)))
        (etypecase count
          (null t)
          (integer
           (c-format out " :count ~D" count))
          ((eql :auto)
           (c-printf out " :count %llu"
                     (format nil "(long long unsigned) countofslot(~A, ~A)"
                             struct-c-name
                             slot-c-name)))
          ((or symbol string)
           (format out "~&#ifdef ~A~%" count)
           (c-printf out " :count %llu"
                     (format nil "(long long unsigned) (~A)" count))
           (format out "~&#endif~%")))
        (c-printf out " :offset %lli)"
                  (format nil "(long long signed) offsetof(~A, ~A)"
                          struct-c-name
                          slot-c-name))))
    (c-format out ")~%")
    (let ((size-of-constant-name
           (symbolicate '#:size-of- struct-lisp-name)))
      (c-export out size-of-constant-name)
      (c-format out "(cl:defconstant "
                size-of-constant-name struct-lisp-name)
      (c-print-symbol out size-of-constant-name)
      (c-format out " (cffi:foreign-type-size '(:struct ")
      (c-print-symbol out struct-lisp-name)
      (c-format out ")))~%"))))

(defmacro define-pseudo-cvar (str name type &key read-only)
  (let ((c-parse (let ((*read-eval* nil)
                       (*readtable* (copy-readtable nil)))
                   (setf (readtable-case *readtable*) :preserve)
                   (read-from-string str))))
    (typecase c-parse
      (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name
                               :read-only ,read-only)
                   ,type))
      (list (unless (and (= (length c-parse) 2)
                         (null (second c-parse))
                         (symbolp (first c-parse))
                         (eql #\* (char (symbol-name (first c-parse)) 0)))
              (grovel-error "Unable to parse c-string ~s." str))
            (let ((func-name (symbolicate "%" name '#:-accessor)))
              `(progn
                 (declaim (inline ,func-name))
                 (cffi:defcfun (,(string-trim "*" (symbol-name (first c-parse)))
                                 ,func-name) :pointer)
                 (define-symbol-macro ,name
                     (cffi:mem-ref (,func-name) ',type)))))
      (t (grovel-error "Unable to parse c-string ~s." str)))))

(defun foreign-name-to-symbol (s)
  (intern (substitute #\- #\_ (string-upcase s))))

(defun choose-lisp-and-foreign-names (string-or-list)
  (etypecase string-or-list
    (string (values string-or-list (foreign-name-to-symbol string-or-list)))
    (list (destructuring-bind (fname lname &rest args) string-or-list
            (declare (ignore args))
            (assert (and (stringp fname) (symbolp lname)))
            (values fname lname)))))

(define-grovel-syntax cvar (name type &key read-only)
  (multiple-value-bind (c-name lisp-name)
      (choose-lisp-and-foreign-names name)
    (c-section-header out "cvar" lisp-name)
    (c-export out lisp-name)
    (c-printf out "(cffi-grovel::define-pseudo-cvar \"%s\" "
              (format nil "indirect_stringify(~A)" c-name))
    (c-print-symbol out lisp-name t)
    (c-format out " ")
    (c-write out type)
    (when read-only
      (c-format out " :read-only t"))
    (c-format out ")~%")))

;;; FIXME: where would docs on enum elements go?
(define-grovel-syntax cenum (name &rest enum-list)
  (destructuring-bind (name &key base-type define-constants)
      (ensure-list name)
    (c-section-header out "cenum" name)
    (c-export out name)
    (c-format out "(cffi:defcenum (")
    (c-print-symbol out name t)
    (when base-type
      (c-printf out " ")
      (c-print-symbol out base-type t))
    (c-format out ")")
    (dolist (enum enum-list)
      (destructuring-bind ((lisp-name &rest c-names) &key documentation)
          enum
        (declare (ignore documentation))
        (check-type lisp-name keyword)
        (loop for c-name in c-names do
          (check-type c-name string)
          (c-format out "  (")
          (c-print-symbol out lisp-name)
          (c-format out " ")
          (c-print-integer-constant out c-name base-type)
          (c-format out ")~%"))))
    (c-format out ")~%")
    (when define-constants
      (define-constants-from-enum out enum-list))))

(define-grovel-syntax constantenum (name &rest enum-list)
  (destructuring-bind (name &key base-type define-constants)
      (ensure-list name)
    (c-section-header out "constantenum" name)
    (c-export out name)
    (c-format out "(cffi:defcenum (")
    (c-print-symbol out name t)
    (when base-type
      (c-printf out " ")
      (c-print-symbol out base-type t))
    (c-format out ")")
    (dolist (enum enum-list)
      (destructuring-bind ((lisp-name &rest c-names)
                           &key optional documentation) enum
        (declare (ignore documentation))
        (check-type lisp-name keyword)
        (c-format out "~%  (")
        (c-print-symbol out lisp-name)
        (loop for c-name in c-names do
          (check-type c-name string)
          (format out "~&#ifdef ~A~%" c-name)
          (c-format out " ")
          (c-print-integer-constant out c-name base-type)
          (format out "~&#else~%"))
        (unless optional
          (c-format out
                    "~%  #.(cl:progn ~
                           (cl:warn 'cffi-grovel:missing-definition :name '~A) ~
                           -1)"
                    lisp-name))
        (dotimes (i (length c-names))
          (format out "~&#endif~%"))
        (c-format out ")")))
    (c-format out ")~%")
    (when define-constants
      (define-constants-from-enum out enum-list))))

(defun define-constants-from-enum (out enum-list)
  (dolist (enum enum-list)
    (destructuring-bind ((lisp-name &rest c-names) &rest options)
        enum
      (%process-grovel-form
       'constant out
       `((,(intern (string lisp-name)) ,(car c-names))
         ,@options)))))

(defun convert-intmax-constant (constant base-type)
  "Convert the C CONSTANT to an integer of BASE-TYPE. The constant is
assumed to be an integer printed using the PRIiMAX printf(3) format
string."
  ;; | C Constant |  Type   | Return Value | Notes                                 |
  ;; |------------+---------+--------------+---------------------------------------|
  ;; |         -1 |  :int32 |           -1 |                                       |
  ;; | 0xffffffff |  :int32 |           -1 | CONSTANT may be a positive integer if |
  ;; |            |         |              | sizeof(intmax_t) > sizeof(int32_t)    |
  ;; | 0xffffffff | :uint32 |   4294967295 |                                       |
  ;; |         -1 | :uint32 |   4294967295 |                                       |
  ;; |------------+---------+--------------+---------------------------------------|
  (let* ((canonical-type (cffi::canonicalize-foreign-type base-type))
         (type-bits (* 8 (cffi:foreign-type-size canonical-type)))
         (2^n (ash 1 type-bits)))
    (ecase canonical-type
      ((:unsigned-char :unsigned-short :unsigned-int
        :unsigned-long :unsigned-long-long)
       (mod constant 2^n))
      ((:char :short :int :long :long-long)
       (let ((v (mod constant 2^n)))
         (if (logbitp (1- type-bits) v)
             (- (mask-field (byte (1- type-bits) 0) v)
                (ash 1 (1- type-bits)))
             v))))))

(defun foreign-type-to-printf-specification (type)
  "Return the printf specification associated with the foreign type TYPE."
  (ecase (cffi::canonicalize-foreign-type type)
    (:char               "\"%hhd\"")
    (:unsigned-char      "\"%hhu\"")
    (:short              "\"%hd\"")
    (:unsigned-short     "\"%hu\"")
    (:int                "\"%d\"")
    (:unsigned-int       "\"%u\"")
    (:long               "\"%ld\"")
    (:unsigned-long      "\"%lu\"")
    (:long-long          "\"%lld\"")
    (:unsigned-long-long "\"%llu\"")))

;; Defines a bitfield, with elements specified as ((LISP-NAME C-NAME)
;; &key DOCUMENTATION).  NAME-AND-OPTS can be either a symbol as name,
;; or a list (NAME &key BASE-TYPE).
(define-grovel-syntax bitfield (name-and-opts &rest masks)
  (destructuring-bind (name &key base-type)
      (ensure-list name-and-opts)
    (c-section-header out "bitfield" name)
    (c-export out name)
    (c-format out "(cffi:defbitfield (")
    (c-print-symbol out name t)
    (when base-type
      (c-printf out " ")
      (c-print-symbol out base-type t))
    (c-format out ")")
    (dolist (mask masks)
      (destructuring-bind ((lisp-name &rest c-names)
                           &key optional documentation) mask
        (declare (ignore documentation))
        (check-type lisp-name symbol)
        (c-format out "~%  (")
        (c-print-symbol out lisp-name)
        (c-format out " ")
        (dolist (c-name c-names)
          (check-type c-name string)
          (format out "~&#ifdef ~A~%" c-name)
          (format out "~&  fprintf(output, ~A, ~A);~%"
                  (foreign-type-to-printf-specification (or base-type :int))
                  c-name)
          (format out "~&#else~%"))
        (unless optional
          (c-format out
                    "~%  #.(cl:progn ~
                           (cl:warn 'cffi-grovel:missing-definition :name '~A) ~
                           -1)"
                    lisp-name))
        (dotimes (i (length c-names))
          (format out "~&#endif~%"))
        (c-format out ")")))
    (c-format out ")~%")))


;;;# Wrapper Generation
;;;
;;; Here we generate a C file from a s-exp specification but instead
;;; of compiling and running it, we compile it as a shared library
;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY.
;;;
;;; Useful to get at macro functionality, errno, system calls,
;;; functions that handle structures by value, etc...
;;;
;;; Matching CFFI bindings are generated along with said C file.

(defun process-wrapper-form (out form)
  (%process-wrapper-form (form-kind form) out (cdr form)))

;;; The various operators push Lisp forms onto this list which will be
;;; written out by PROCESS-WRAPPER-FILE once everything is processed.
(defvar *lisp-forms*)

(defun generate-c-lib-file (input-file output-defaults)
  (let ((*lisp-forms* nil)
        (c-file (make-c-file-name output-defaults "__wrapper")))
    (with-open-file (out c-file :direction :output :if-exists :supersede)
      (with-open-file (in input-file :direction :input)
        (write-string *header* out)
        (loop for form = (read in nil nil) while form
              do (process-wrapper-form out form))))
    (values c-file (nreverse *lisp-forms*))))

(defun make-soname (lib-soname output-defaults)
  (make-pathname :name lib-soname
                 :defaults output-defaults))

(defun generate-bindings-file (lib-file lib-soname lisp-forms output-defaults)
  (with-standard-io-syntax
    (let ((lisp-file (tmp-lisp-file-name output-defaults))
          (*print-readably* nil)
          (*print-escape* t))
      (with-open-file (out lisp-file :direction :output :if-exists :supersede)
        (format out ";;;; This file was automatically generated by cffi-grovel.~%~
                   ;;;; Do not edit by hand.~%")
        (let ((*package* (find-package '#:cl))
              (named-library-name
                (let ((*package* (find-package :keyword))
                      (*read-eval* nil))
                  (read-from-string lib-soname))))
          (pprint `(progn
                     (cffi:define-foreign-library
                         (,named-library-name
                          :type :grovel-wrapper
                          :search-path ,(directory-namestring lib-file))
                       (t ,(namestring (make-so-file-name lib-soname))))
                     (cffi:use-foreign-library ,named-library-name))
                  out)
          (fresh-line out))
        (dolist (form lisp-forms)
          (print form out))
        (terpri out))
      lisp-file)))

(defun cc-include-grovel-argument ()
  (format nil "-I~A" (truename (system-source-directory :cffi-grovel))))

;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
;;; *the extent of a given wrapper file.
(defun process-wrapper-file (input-file
                             &key
                               (output-defaults (make-pathname :defaults input-file :type "processed"))
                               lib-soname)
  (with-standard-io-syntax
    (multiple-value-bind (c-file lisp-forms)
        (generate-c-lib-file input-file output-defaults)
    (let ((lib-file (make-so-file-name (make-soname lib-soname output-defaults)))
          (o-file (make-o-file-name output-defaults "__wrapper")))
        (cc-compile o-file (list (cc-include-grovel-argument) c-file))
        (link-shared-library lib-file (list o-file))
        ;; FIXME: hardcoded library path.
        (values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults)
                lib-file)))))

(defgeneric %process-wrapper-form (name out arguments)
  (:method (name out arguments)
    (declare (ignore out arguments))
    (grovel-error "Unknown Grovel syntax: ~S" name)))

;;; OUT is lexically bound to the output stream within BODY.
(defmacro define-wrapper-syntax (name lambda-list &body body)
  (with-unique-names (name-var args)
    `(defmethod %process-wrapper-form ((,name-var (eql ',name)) out ,args)
       (declare (ignorable out))
       (destructuring-bind ,lambda-list ,args
         ,@body))))

(define-wrapper-syntax progn (&rest forms)
  (dolist (form forms)
    (process-wrapper-form out form)))

(define-wrapper-syntax in-package (name)
  (assert (find-package name) (name)
          "Wrapper file specified (in-package ~s)~%~
           however that does not name a known package."
          name)
  (setq *package* (find-package name))
  (push `(in-package ,name) *lisp-forms*))

(define-wrapper-syntax c (&rest strings)
  (dolist (string strings)
    (write-line string out)))

(define-wrapper-syntax flag (&rest flags)
  (appendf *cc-flags* (parse-command-flags-list flags)))

(define-wrapper-syntax proclaim (&rest proclamations)
  (push `(proclaim ,@proclamations) *lisp-forms*))

(define-wrapper-syntax declaim (&rest declamations)
  (push `(declaim ,@declamations) *lisp-forms*))

(define-wrapper-syntax define (name &optional value)
  (format out "#define ~A~@[ ~A~]~%" name value))

(define-wrapper-syntax include (&rest includes)
  (format out "~{#include <~A>~%~}" includes))

;;; FIXME: this function is not complete.  Should probably follow
;;; typedefs?  Should definitely understand pointer types.
(defun c-type-name (typespec)
  (let ((spec (ensure-list typespec)))
    (if (stringp (car spec))
        (car spec)
        (case (car spec)
          ((:uchar :unsigned-char) "unsigned char")
          ((:unsigned-short :ushort) "unsigned short")
          ((:unsigned-int :uint) "unsigned int")
          ((:unsigned-long :ulong) "unsigned long")
          ((:long-long :llong) "long long")
          ((:unsigned-long-long :ullong) "unsigned long long")
          (:pointer "void*")
          (:string "char*")
          (t (cffi::foreign-name (car spec) nil))))))

(defun cffi-type (typespec)
  (if (and (listp typespec) (stringp (car typespec)))
      (second typespec)
      typespec))

(defun symbol* (s)
  (check-type s (and symbol (not null)))
  s)

(define-wrapper-syntax defwrapper (name-and-options rettype &rest args)
  (multiple-value-bind (lisp-name foreign-name options)
      (cffi::parse-name-and-options name-and-options)
    (let* ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
           (fargs (mapcar (lambda (arg)
                            (list (c-type-name (second arg))
                                  (cffi::foreign-name (first arg) nil)))
                          args))
           (fargnames (mapcar #'second fargs)))
      ;; output C code
      (format out "~A ~A" (c-type-name rettype) foreign-name-wrap)
      (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
      (format out "{~%  return ~A(~{~A~^, ~});~%}~%~%" foreign-name fargnames)
      ;; matching bindings
      (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
                 ,(cffi-type rettype)
               ,@(mapcar (lambda (arg)
                           (list (symbol* (first arg))
                                 (cffi-type (second arg))))
                         args))
            *lisp-forms*))))

(define-wrapper-syntax defwrapper* (name-and-options rettype args &rest c-lines)
  ;; output C code
  (multiple-value-bind (lisp-name foreign-name options)
      (cffi::parse-name-and-options name-and-options)
    (let ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
          (fargs (mapcar (lambda (arg)
                           (list (c-type-name (second arg))
                                 (cffi::foreign-name (first arg) nil)))
                         args)))
      (format out "~A ~A" (c-type-name rettype)
              foreign-name-wrap)
      (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
      (format out "{~%~{  ~A~%~}}~%~%" c-lines)
      ;; matching bindings
      (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
                 ,(cffi-type rettype)
               ,@(mapcar (lambda (arg)
                           (list (symbol* (first arg))
                                 (cffi-type (second arg))))
                         args))
            *lisp-forms*))))
cffi_0.19.0/grovel/common.h0000644000175000017500000000324713103031266014244 0ustar  luisluis#include 
#include 
#include 
#include 
#include 

#ifndef offsetof
#define offsetof(type, slot) ((long) ((char *) &(((type *) 0)->slot)))
#endif
#define getslot(type, slot) (((type *) 0)->slot)
#define sizeofslot(type, slot) (sizeof(getslot(type, slot)))
#define countofslot(type, slot) \
  (sizeof(getslot(type, slot)) / sizeof(getslot(type, slot)[0]))
#define stringify(x) #x
#define indirect_stringify(x) stringify(x)

#define TYPE_SIGNED_P(type) (((type)-1)<0LL)
#define _64_BIT_VALUE_FITS_SIGNED_P(value) ( (value) <= 0x7FFFFFFFFFFFFFFFLL )
#define SLOT_SIGNED_P(result, type, slot)				\
  do { 									\
    type slot_signed_p_struct; 						\
    slot_signed_p_struct.slot = -1; 					\
    (result) = slot_signed_p_struct.slot < 0;				\
  } while (0)

void type_name(FILE *output, int signed_p, int size) {
  if (signed_p) {
    switch (size) {
    case 1: fprintf(output, ":int8"); break;
    case 2: fprintf(output, ":int16"); break;
    case 4: fprintf(output, ":int32"); break;
    case 8: fprintf(output, ":int64"); break;
    default: goto error;
    }
  } else {
    switch(size) {
    case 1: fprintf(output, ":uint8"); break;
    case 2: fprintf(output, ":uint16"); break;
    case 4: fprintf(output, ":uint32"); break;
    case 8: fprintf(output, ":uint64"); break;
    default: goto error;
    }
  }

  return;

error:
  fprintf(output, "(cl:error \"No type of size ~D.\" %i)\n", size);
}

char* print_double_for_lisp(double n)
{
    static char buf[256];
    memset(buf, 0, 256);
    snprintf(buf, 255, "(let ((*read-default-float-format* 'double-float)) (coerce (read-from-string \"%.20E\") 'double-float))", n);
    return buf;
}
cffi_0.19.0/grovel/package.lisp0000644000175000017500000000271313103031266015064 0ustar  luisluis;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; package.lisp --- Groveler DEFPACKAGE.
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(uiop:define-package #:cffi-grovel
  (:mix #:cffi-toolchain #:asdf #:uiop #:alexandria #:common-lisp)
  (:export
   ;; Class name
   #:grovel-file
   #:process-grovel-file
   #:wrapper-file
   #:process-wrapper-file
   ;; Error conditions
   #:grovel-error
   #:missing-definition))
cffi_0.19.0/.travis.yml0000644000175000017500000000154713103031266013417 0ustar  luisluisbranches:
  only:
    - master

language: lisp

env:
  matrix:
    #- LISP=abcl
    #- LISP=allegro
    - LISP=sbcl
    - LISP=sbcl32
    - LISP=ccl
    - LISP=ccl32
    #- LISP=clisp
    #- LISP=clisp32
    #- LISP=cmucl
    #- LISP=ecl

matrix:
  allow_failures:
    - env: LISP=ccl32

install:
  - curl -L https://github.com/luismbo/cl-travis/raw/master/install.sh | sh
  - if [ "${LISP:(-2)}" = "32" ]; then
      sudo apt-get install -y libc6-dev-i386 libffi-dev:i386;
    fi
  - git clone --depth=1 git://github.com/trivial-features/trivial-features.git ~/lisp/trivial-features
  - git clone https://gitlab.common-lisp.net/alexandria/alexandria.git ~/lisp/alexandria
  - git clone --depth=1 git://github.com/cl-babel/babel.git ~/lisp/babel

script:
  - cl -e '(ql:quickload :cffi-tests)
           (when (cffi-tests:run-all-cffi-tests)
             (uiop:quit 1))'