Permalink
Browse files

Add dependency on ALEXANDRIA, remove redundant code from CFFI-UTILS p…

…ackage.
  • Loading branch information...
1 parent b462e46 commit 5b0aa8614359f402a1f963cc908a820aaf051150 @sionescu sionescu committed Dec 30, 2007
View
@@ -28,7 +28,7 @@
(asdf:defsystem cffi-grovel
:description "The CFFI Groveller"
:author "Dan Knapp <dankna@accela.net>"
- :depends-on (cffi)
+ :depends-on (cffi alexandria)
:licence "MIT"
:components
((:module grovel
View
@@ -37,7 +37,7 @@
:author "James Bielman <jamesjb@jamesjb.com>"
:version "0.9.2"
:licence "MIT"
- :depends-on (trivial-features babel)
+ :depends-on (alexandria trivial-features babel)
:components
((:module src
:serial t
View
@@ -29,7 +29,7 @@
;;;
(defpackage #:cffi-grovel
- (:use #:common-lisp #:cffi-utils)
+ (:use #:common-lisp #:cffi-utils #:alexandria)
(:import-from #:cffi-sys #:native-namestring)
(:export
#:grovel-file
View
@@ -28,7 +28,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:cffi-utils)
+ (:use #:common-lisp #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -29,7 +29,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:cffi-utils)
+ (:use #:common-lisp #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -28,7 +28,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:alien #:c-call #:cffi-utils)
+ (:use #:common-lisp #:alien #:c-call #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -32,7 +32,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:c-types #:cffi-utils)
+ (:use #:common-lisp #:c-types #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -28,7 +28,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:cffi-utils)
+ (:use #:common-lisp #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -42,7 +42,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp)
+ (:use #:common-lisp #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:pointerp
View
@@ -28,7 +28,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:cl #:cffi-utils)
+ (:use #:cl #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -28,7 +28,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:ccl #:cffi-utils)
+ (:use #:common-lisp #:ccl #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -28,7 +28,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:sb-alien #:cffi-utils)
+ (:use #:common-lisp #:sb-alien #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
@@ -341,5 +341,5 @@ WITH-POINTER-TO-VECTOR-DATA."
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
- (let-when (address (sb-sys:find-foreign-symbol-address name))
+ (when-let (address (sb-sys:find-foreign-symbol-address name))
(sb-sys:int-sap address)))
View
@@ -29,7 +29,7 @@
;;;# Administrivia
(defpackage #:cffi-sys
- (:use #:common-lisp #:alien #:c-call #:cffi-utils)
+ (:use #:common-lisp #:alien #:c-call #:cffi-utils #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
View
@@ -283,9 +283,8 @@ arguments and does type promotion for the variadic arguments."
(list :calling-convention cconv)))
(defmacro defcallback (name-and-options return-type args &body body)
- (multiple-value-bind (body docstring declarations)
- (parse-body body)
- (declare (ignore docstring))
+ (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)))
View
@@ -193,18 +193,18 @@ ourselves."
(handler-case
(%load-foreign-library name path)
(error (error)
- (bif (file (find-file path *foreign-library-directories*))
- (handler-case
- (%load-foreign-library name (native-namestring file))
- (simple-error (error)
- (report-simple-error name error)))
- (report-simple-error name error)))))
+ (if-let (file (find-file path *foreign-library-directories*))
+ (handler-case
+ (%load-foreign-library name (native-namestring file))
+ (simple-error (error)
+ (report-simple-error name error)))
+ (report-simple-error name error)))))
(defun try-foreign-library-alternatives (name library-list)
"Goes through a list of alternatives and only signals an error when
none of alternatives were successfully loaded."
(dolist (lib library-list)
- (let-when (handle (ignore-errors (load-foreign-library-helper name lib)))
+ (when-let (handle (ignore-errors (load-foreign-library-helper name lib)))
(return-from try-foreign-library-alternatives handle)))
;; Perhaps we should show the error messages we got for each
;; alternative if we can figure out a nice way to do that.
View
@@ -28,7 +28,7 @@
(in-package #:cl-user)
(defpackage #:cffi
- (:use #:common-lisp #:cffi-sys #:cffi-utils #:babel-encodings)
+ (:use #:common-lisp #:cffi-sys #:cffi-utils #:alexandria #:babel-encodings)
(:import-from #:cffi-features #:cffi-feature-p)
(:export
;; Types.
View
@@ -561,7 +561,7 @@ The foreign array must be freed with foreign-array-free."
(discard-docstring fields)
`(eval-when (:compile-toplevel :load-toplevel :execute)
;; n-f-s-d could do with this with mop:ensure-class.
- ,(let-when (class (getf (cdr (ensure-list name-and-options)) :class))
+ ,(when-let (class (getf (cdr (ensure-list name-and-options)) :class))
`(defclass ,class (foreign-struct-type) ()))
(notice-foreign-struct-definition ',name-and-options ',fields)))
View
@@ -30,16 +30,9 @@
;;; This package is for CFFI's internal use. No effort is made to
;;; maintain backwards compatibility. Use at your own risk.
(defpackage #:cffi-utils
- (:use #:common-lisp)
+ (:use #:common-lisp #:alexandria)
(:export #:discard-docstring
- #:parse-body
- #:with-unique-names
- #:once-only
- #:ensure-list
- #:make-gensym-list
#:symbolicate
- #:let-when
- #:bif
#:post-incf
#:single-bit-p
#:warn-if-kw-or-belongs-to-cl))
@@ -58,42 +51,12 @@
(setq ,(car new) (+ ,(car new) ,delta))
,setter))))
-(defun ensure-list (x)
- "Make into list if atom."
- (if (listp x) x (list x)))
-
(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)))
-;;; Parse a body of code, removing an optional documentation string
-;;; and declaration forms. Returns the actual body, docstring, and
-;;; declarations as three multiple values.
-(defun parse-body (body)
- (let ((docstring nil)
- (declarations nil))
- (when (and (stringp (car body)) (cdr body))
- (setf docstring (pop body)))
- (loop while (and (consp (car body)) (eql (caar body) 'cl:declare))
- do (push (pop body) declarations))
- (values body docstring (nreverse declarations))))
-
-;;; LET-IF (renamed to BIF) and LET-WHEN taken from KMRCL
-(defmacro let-when ((var test-form) &body body)
- `(let ((,var ,test-form))
- (when ,var ,@body)))
-
-(defmacro bif ((var test-form) if-true &optional if-false)
- `(let ((,var ,test-form))
- (if ,var ,if-true ,if-false)))
-
-;;; ONCE-ONLY macro taken from PAIP
-(defun starts-with (list x)
- "Is x a list whose first element is x?"
- (and (consp list) (eql (first list) x)))
-
(defun side-effect-free? (exp)
"Is exp a constant, variable, or function,
or of the form (THE type x) where x is side-effect-free?"
@@ -102,49 +65,9 @@ string and the only element (or if FORCE is T)."
(and (starts-with exp 'the)
(side-effect-free? (third exp)))))
-(defmacro once-only (variables &rest body)
- "Returns the code built by BODY. If any of VARIABLES
- might have side effects, they are evaluated once and stored
- in temporary variables that are then passed to BODY."
- (assert (every #'symbolp variables))
- (let ((temps nil))
- (dotimes (i (length variables)) (push (gensym "ONCE") temps))
- `(if (every #'side-effect-free? (list .,variables))
- (progn .,body)
- (list 'let
- ,`(list ,@(mapcar #'(lambda (tmp var)
- `(list ',tmp ,var))
- temps variables))
- (let ,(mapcar #'(lambda (var tmp) `(,var ',tmp))
- variables temps)
- .,body)))))
-
;;;; The following utils were taken from SBCL's
;;;; src/code/*-extensions.lisp
-;;; Automate an idiom often found in macros:
-;;; (LET ((FOO (GENSYM "FOO"))
-;;; (MAX-INDEX (GENSYM "MAX-INDEX-")))
-;;; ...)
-;;;
-;;; "Good notation eliminates thought." -- Eric Siggia
-;;;
-;;; Incidentally, this is essentially the same operator which
-;;; _On Lisp_ calls WITH-GENSYMS.
-(defmacro with-unique-names (symbols &body body)
- `(let ,(mapcar (lambda (symbol)
- (let* ((symbol-name (symbol-name symbol))
- (stem (if (every #'alpha-char-p symbol-name)
- symbol-name
- (concatenate 'string symbol-name "-"))))
- `(,symbol (gensym ,stem))))
- symbols)
- ,@body))
-
-(defun make-gensym-list (n)
- "Return a list of N gensyms."
- (loop repeat n collect (gensym)))
-
(defun symbolicate (&rest things)
"Concatenate together the names of some strings and symbols,
producing a symbol in the current package."
@@ -200,21 +123,3 @@ set twos-complement bit."
; `(if ,test
; (let ((it ,test)) (declare (ignorable it)),@body)
; (acond ,@rest))))))
-
-;;; copied from alexandria
-#-(and)
-(defun remove-from-plist (plist &rest keys)
- "Returns a propery-list with same keys and values as PLIST, except that keys
-in the list designated by KEYS and values corresponding to them are removed.
-The returned property-list may share structure with the PLIST, but PLIST is
-not destructively modified."
- (declare (optimize (speed 3)))
- ;; FIXME: unoptimal: (sans '(:a 1 :b 2) :a) has no need to copy the
- ;; tail.
- (loop for cell = plist :then (cddr cell)
- for key = (car cell)
- while cell
- unless (member key keys :test #'eq)
- collect key
- and do (assert (cdr cell) () "Not a proper plist")
- and collect (cadr cell)))

0 comments on commit 5b0aa86

Please sign in to comment.