(defun stk-int ()
#+allegro
- (ff:with-stack-fobject (ptr :int)
+ (ff:with-stack-fobject (ptr :int)
(setf (ff:fslot-value ptr) 0))
#+lispworks
(fli:with-dynamic-foreign-objects ((ptr :int))
#+cmu
(let ((ptr (alien:make-alien (alien:signed 32))))
(declare ;;(type (alien (* (alien:unsigned 32))) ptr)
- (dynamic-extent ptr))
+ (dynamic-extent ptr))
(setf (alien:deref ptr) 0)
(alien:free-alien ptr))
#+sbcl
#+cmu
(let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
(declare ;;(type (alien (* (alien:unsigned 32))) ptr)
- (dynamic-extent ptr))
+ (dynamic-extent ptr))
(setf (alien:deref ptr 5) 0)
(alien:free-alien ptr))
#+sbcl
(let ((ptr (sb-alien:make-alien (sb-alien:array (sb-alien:signed 32) 10))))
(declare ;;(type (sb-alien (* (sb-alien:unsigned 32))) ptr)
- (dynamic-extent ptr))
+ (dynamic-extent ptr))
(setf (sb-alien:deref ptr 5) 0)
(sb-alien:free-alien ptr))
)
(defun stk-vs-stat ()
(format t "~&Stack allocation, Integer")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stk-int))))
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stk-int))))
(format t "~&Static allocation, Integer")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stat-int))))
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stat-int))))
(format t "~&Stack allocation, Vector")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stk-int))))
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stk-int))))
(format t "~&Static allocation, Vector")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stat-int))))
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stat-int))))
)
(stk-vs-stat)
-
+
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
-;; the GNU Lesser General Public License as published by
+;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the Franz
;; preamble to the LGPL found in
;; http://opensource.franz.com/preamble.html.
#:test-no-error
#:test-warning
#:test-no-warning
-
+
#:with-tests
))
(defmacro if* (&rest args)
(do ((xx (reverse args) (cdr xx))
- (state :init)
- (elseseen nil)
- (totalcol nil)
- (lookat nil nil)
- (col nil))
+ (state :init)
+ (elseseen nil)
+ (totalcol nil)
+ (lookat nil nil)
+ (col nil))
((null xx)
- (cond ((eq state :compl)
- `(cond ,@totalcol))
- (t (error "if*: illegal form ~s" args))))
+ (cond ((eq state :compl)
+ `(cond ,@totalcol))
+ (t (error "if*: illegal form ~s" args))))
(cond ((and (symbolp (car xx))
- (member (symbol-name (car xx))
- if*-keyword-list
- :test #'string-equal))
- (setq lookat (symbol-name (car xx)))))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
(cond ((eq state :init)
- (cond (lookat (cond ((string-equal lookat "thenret")
- (setq col nil
- state :then))
- (t (error
- "if*: bad keyword ~a" lookat))))
- (t (setq state :col
- col nil)
- (push (car xx) col))))
- ((eq state :col)
- (cond (lookat
- (cond ((string-equal lookat "else")
- (cond (elseseen
- (error
- "if*: multiples elses")))
- (setq elseseen t)
- (setq state :init)
- (push `(t ,@col) totalcol))
- ((string-equal lookat "then")
- (setq state :then))
- (t (error "if*: bad keyword ~s"
- lookat))))
- (t (push (car xx) col))))
- ((eq state :then)
- (cond (lookat
- (error
- "if*: keyword ~s at the wrong place " (car xx)))
- (t (setq state :compl)
- (push `(,(car xx) ,@col) totalcol))))
- ((eq state :compl)
- (cond ((not (string-equal lookat "elseif"))
- (error "if*: missing elseif clause ")))
- (setq state :init)))))
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t ,@col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) ,@col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
(defmacro test-values-errorset (form &optional announce catch-breaks)
;; internal macro
(let ((g-announce (gensym))
- (g-catch-breaks (gensym)))
+ (g-catch-breaks (gensym)))
`(let* ((,g-announce ,announce)
- (,g-catch-breaks ,catch-breaks))
+ (,g-catch-breaks ,catch-breaks))
(handler-case (cons t (multiple-value-list ,form))
- (condition (condition)
- (if* (and (null ,g-catch-breaks)
- (typep condition 'simple-break))
- then (break condition)
- elseif ,g-announce
- then (format *error-output* "~&Condition type: ~a~%"
- (class-of condition))
- (format *error-output* "~&Message: ~a~%" condition))
- condition)))))
+ (condition (condition)
+ (if* (and (null ,g-catch-breaks)
+ (typep condition 'simple-break))
+ then (break condition)
+ elseif ,g-announce
+ then (format *error-output* "~&Condition type: ~a~%"
+ (class-of condition))
+ (format *error-output* "~&Message: ~a~%" condition))
+ condition)))))
(defmacro test-values (form &optional announce catch-breaks)
;; internal macro
else `(cons t (multiple-value-list ,form))))
(defmacro test (expected-value test-form
- &key (test #'eql test-given)
- (multiple-values nil multiple-values-given)
- (fail-info nil fail-info-given)
- (known-failure nil known-failure-given)
+ &key (test #'eql test-given)
+ (multiple-values nil multiple-values-given)
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given)
;;;;;;;;;; internal, undocumented keywords:
;;;; Note about these keywords: if they were documented, we'd have a
;;;; Specifically, errorset breaks it, and I don't see any way around
;;;; that. `errorset' is used by the old test.cl module (eg,
;;;; test-equal-errorset).
- errorset
- reported-form
- (wanted-message nil wanted-message-given)
- (got-message nil got-message-given))
+ errorset
+ reported-form
+ (wanted-message nil wanted-message-given)
+ (got-message nil got-message-given))
"Perform a single test. `expected-value' is the reference value for the
test. `test-form' is a form that will produce the value to be compared to
the expected-value. If the values are not the same, then an error is
(defmethod conditionp ((thing t)) nil)
(defmacro test-error (form &key announce
- catch-breaks
- (fail-info nil fail-info-given)
- (known-failure nil known-failure-given)
- (condition-type ''simple-error)
- (include-subtypes nil include-subtypes-given)
- (format-control nil format-control-given)
- (format-arguments nil format-arguments-given))
+ catch-breaks
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given)
+ (condition-type ''simple-error)
+ (include-subtypes nil include-subtypes-given)
+ (format-control nil format-control-given)
+ (format-arguments nil format-arguments-given))
"Test that `form' signals an error. The order of evaluation of the
arguments is keywords first, then test form.
`format-control' and `format-arguments' can be used to check the error
message itself."
(let ((g-announce (gensym))
- (g-catch-breaks (gensym))
- (g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-condition-type (gensym))
- (g-include-subtypes (gensym))
- (g-format-control (gensym))
- (g-format-arguments (gensym))
- (g-c (gensym)))
+ (g-catch-breaks (gensym))
+ (g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-condition-type (gensym))
+ (g-include-subtypes (gensym))
+ (g-format-control (gensym))
+ (g-format-arguments (gensym))
+ (g-c (gensym)))
`(let* ((,g-announce ,announce)
- (,g-catch-breaks ,catch-breaks)
- ,@(when fail-info-given `((,g-fail-info ,fail-info)))
- ,@(when known-failure-given `((,g-known-failure ,known-failure)))
- (,g-condition-type ,condition-type)
- ,@(when include-subtypes-given
- `((,g-include-subtypes ,include-subtypes)))
- ,@(when format-control-given
- `((,g-format-control ,format-control)))
- ,@(when format-arguments-given
- `((,g-format-arguments ,format-arguments)))
- (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+ (,g-catch-breaks ,catch-breaks)
+ ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+ ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+ (,g-condition-type ,condition-type)
+ ,@(when include-subtypes-given
+ `((,g-include-subtypes ,include-subtypes)))
+ ,@(when format-control-given
+ `((,g-format-control ,format-control)))
+ ,@(when format-arguments-given
+ `((,g-format-arguments ,format-arguments)))
+ (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
(test-check
- :predicate #'eq
- :expected-result t
- :test-results
- (test-values (and (conditionp ,g-c)
- ,@(if* include-subtypes-given
- then `((if* ,g-include-subtypes
- then (typep ,g-c ,g-condition-type)
- else (eq (class-of ,g-c)
- (find-class
- ,g-condition-type))))
- else `((eq (class-of ,g-c)
- (find-class ,g-condition-type))))
- ,@(when format-control-given
- `((or
- (null ,g-format-control)
- (string=
- (concatenate 'simple-string
- "~1@<" ,g-format-control "~:@>")
- (simple-condition-format-control ,g-c)))))
- ,@(when format-arguments-given
- `((or
- (null ,g-format-arguments)
- (equal
- ,g-format-arguments
- (simple-condition-format-arguments ,g-c))))))
- t)
- :test-form ',form
- ,@(when fail-info-given `(:fail-info ,g-fail-info))
- ,@(when known-failure-given `(:known-failure ,g-known-failure))
- :condition-type ,g-condition-type
- :condition ,g-c
- ,@(when include-subtypes-given
- `(:include-subtypes ,g-include-subtypes))
- ,@(when format-control-given
- `(:format-control ,g-format-control))
- ,@(when format-arguments-given
- `(:format-arguments ,g-format-arguments))))))
+ :predicate #'eq
+ :expected-result t
+ :test-results
+ (test-values (and (conditionp ,g-c)
+ ,@(if* include-subtypes-given
+ then `((if* ,g-include-subtypes
+ then (typep ,g-c ,g-condition-type)
+ else (eq (class-of ,g-c)
+ (find-class
+ ,g-condition-type))))
+ else `((eq (class-of ,g-c)
+ (find-class ,g-condition-type))))
+ ,@(when format-control-given
+ `((or
+ (null ,g-format-control)
+ (string=
+ (concatenate 'simple-string
+ "~1@<" ,g-format-control "~:@>")
+ (simple-condition-format-control ,g-c)))))
+ ,@(when format-arguments-given
+ `((or
+ (null ,g-format-arguments)
+ (equal
+ ,g-format-arguments
+ (simple-condition-format-arguments ,g-c))))))
+ t)
+ :test-form ',form
+ ,@(when fail-info-given `(:fail-info ,g-fail-info))
+ ,@(when known-failure-given `(:known-failure ,g-known-failure))
+ :condition-type ,g-condition-type
+ :condition ,g-c
+ ,@(when include-subtypes-given
+ `(:include-subtypes ,g-include-subtypes))
+ ,@(when format-control-given
+ `(:format-control ,g-format-control))
+ ,@(when format-arguments-given
+ `(:format-arguments ,g-format-arguments))))))
(defmacro test-no-error (form &key announce
- catch-breaks
- (fail-info nil fail-info-given)
- (known-failure nil known-failure-given))
+ catch-breaks
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given))
"Test that `form' does not signal an error. The order of evaluation of
the arguments is keywords first, then test form.
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
(let ((g-announce (gensym))
- (g-catch-breaks (gensym))
- (g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-c (gensym)))
+ (g-catch-breaks (gensym))
+ (g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-c (gensym)))
`(let* ((,g-announce ,announce)
- (,g-catch-breaks ,catch-breaks)
- ,@(when fail-info-given `((,g-fail-info ,fail-info)))
- ,@(when known-failure-given `((,g-known-failure ,known-failure)))
- (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+ (,g-catch-breaks ,catch-breaks)
+ ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+ ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+ (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
(test-check
- :predicate #'eq
- :expected-result t
- :test-results (test-values (not (conditionp ,g-c)))
- :test-form ',form
- :condition ,g-c
- ,@(when fail-info-given `(:fail-info ,g-fail-info))
- ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
+ :predicate #'eq
+ :expected-result t
+ :test-results (test-values (not (conditionp ,g-c)))
+ :test-form ',form
+ :condition ,g-c
+ ,@(when fail-info-given `(:fail-info ,g-fail-info))
+ ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
(defvar *warn-cookie* (cons nil nil))
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
(let ((g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-value (gensym)))
+ (g-known-failure (gensym))
+ (g-value (gensym)))
`(let* ((,g-fail-info ,fail-info)
- (,g-known-failure ,known-failure)
- (,g-value (test-values-errorset ,form nil t)))
+ (,g-known-failure ,known-failure)
+ (,g-value (test-values-errorset ,form nil t)))
(test
- *warn-cookie*
- (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
- then *warn-cookie*
- else ;; test produced no warning
- nil)
- :test #'eq
- :reported-form ,form ;; quoted by test macro
- :wanted-message "a warning"
- :got-message "no warning"
- :fail-info ,g-fail-info
- :known-failure ,g-known-failure))))
+ *warn-cookie*
+ (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+ then *warn-cookie*
+ else ;; test produced no warning
+ nil)
+ :test #'eq
+ :reported-form ,form ;; quoted by test macro
+ :wanted-message "a warning"
+ :got-message "no warning"
+ :fail-info ,g-fail-info
+ :known-failure ,g-known-failure))))
(defmacro test-no-warning (form &key fail-info known-failure)
"Test that `form' does not signal a warning. The order of evaluation of
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
(let ((g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-value (gensym)))
+ (g-known-failure (gensym))
+ (g-value (gensym)))
`(let* ((,g-fail-info ,fail-info)
- (,g-known-failure ,known-failure)
- (,g-value (test-values-errorset ,form nil t)))
+ (,g-known-failure ,known-failure)
+ (,g-value (test-values-errorset ,form nil t)))
(test
- *warn-cookie*
- (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
- then nil ;; test produced warning
- else *warn-cookie*)
- :test #'eq
- :reported-form ',form
- :wanted-message "no warning"
- :got-message "a warning"
- :fail-info ,g-fail-info
- :known-failure ,g-known-failure))))
+ *warn-cookie*
+ (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+ then nil ;; test produced warning
+ else *warn-cookie*)
+ :test #'eq
+ :reported-form ',form
+ :wanted-message "no warning"
+ :got-message "a warning"
+ :fail-info ,g-fail-info
+ :known-failure ,g-known-failure))))
(defvar *announce-test* nil) ;; if true announce each test that was done
nil))))
(defun test-check (&key (predicate #'eql)
- expected-result test-results test-form
- multiple-values fail-info known-failure
- wanted-message got-message condition-type condition
- include-subtypes format-control format-arguments
- &aux fail predicate-failed got wanted)
+ expected-result test-results test-form
+ multiple-values fail-info known-failure
+ wanted-message got-message condition-type condition
+ include-subtypes format-control format-arguments
+ &aux fail predicate-failed got wanted)
;; for debugging large/complex test sets:
(when *announce-test*
(format t "Just did test ~s~%" test-form)
(force-output))
-
+
;; this is an internal function
(flet ((check (expected-result result)
- (let* ((results
- (multiple-value-list
- (errorset (funcall predicate expected-result result) t)))
- (failed (null (car results))))
- (if* failed
- then (setq predicate-failed t)
- nil
- else (cadr results)))))
+ (let* ((results
+ (multiple-value-list
+ (errorset (funcall predicate expected-result result) t)))
+ (failed (null (car results))))
+ (if* failed
+ then (setq predicate-failed t)
+ nil
+ else (cadr results)))))
(when (conditionp test-results)
(setq condition test-results)
(setq test-results nil))
(setq fail t))
(if* (and (not fail) (not multiple-values))
then ;; should be a single result
- ;; expected-result is the single result wanted
- (when (not (and (cdr test-results)
- (check expected-result (cadr test-results))))
- (setq fail t))
- (when (and (not fail) (cddr test-results))
- (setq fail 'single-got-multiple))
+ ;; expected-result is the single result wanted
+ (when (not (and (cdr test-results)
+ (check expected-result (cadr test-results))))
+ (setq fail t))
+ (when (and (not fail) (cddr test-results))
+ (setq fail 'single-got-multiple))
else ;; multiple results wanted
- ;; expected-result is a list of results, each of which
- ;; should be checked against the corresponding test-results
- ;; using the predicate
- (do ((got (cdr test-results) (cdr got))
- (want expected-result (cdr want)))
- ((or (null got) (null want))
- (when (not (and (null want) (null got)))
- (setq fail t)))
- (when (not (check (car got) (car want)))
- (return (setq fail t)))))
+ ;; expected-result is a list of results, each of which
+ ;; should be checked against the corresponding test-results
+ ;; using the predicate
+ (do ((got (cdr test-results) (cdr got))
+ (want expected-result (cdr want)))
+ ((or (null got) (null want))
+ (when (not (and (null want) (null got)))
+ (setq fail t)))
+ (when (not (check (car got) (car want)))
+ (return (setq fail t)))))
(if* fail
then (when (not known-failure)
- (format *error-output*
- "~& * * * UNEXPECTED TEST FAILURE * * *~%")
- (incf *test-unexpected-failures*))
- (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
- known-failure test-form)
- (if* (eq 'single-got-multiple fail)
- then (format
- *error-output*
- "~
+ (format *error-output*
+ "~& * * * UNEXPECTED TEST FAILURE * * *~%")
+ (incf *test-unexpected-failures*))
+ (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
+ known-failure test-form)
+ (if* (eq 'single-got-multiple fail)
+ then (format
+ *error-output*
+ "~
Reason: additional value were returned from test form.~%")
- elseif predicate-failed
- then (format *error-output* "Reason: predicate error.~%")
- elseif (null (car test-results))
- then (format *error-output* "~
+ elseif predicate-failed
+ then (format *error-output* "Reason: predicate error.~%")
+ elseif (null (car test-results))
+ then (format *error-output* "~
Reason: an error~@[ (of type `~s')~] was detected.~%"
- (when condition (class-of condition)))
- elseif condition
- then (if* (not (conditionp condition))
- then (format *error-output* "~
+ (when condition (class-of condition)))
+ elseif condition
+ then (if* (not (conditionp condition))
+ then (format *error-output* "~
Reason: expected but did not detect an error of type `~s'.~%"
- condition-type)
- elseif (null condition-type)
- then (format *error-output* "~
+ condition-type)
+ elseif (null condition-type)
+ then (format *error-output* "~
Reason: detected an unexpected error of type `~s':
~a.~%"
- (class-of condition)
- condition)
- elseif (not (if* include-subtypes
- then (typep condition condition-type)
- else (eq (class-of condition)
- (find-class condition-type))))
- then (format *error-output* "~
+ (class-of condition)
+ condition)
+ elseif (not (if* include-subtypes
+ then (typep condition condition-type)
+ else (eq (class-of condition)
+ (find-class condition-type))))
+ then (format *error-output* "~
Reason: detected an incorrect condition type.~%")
- (format *error-output*
- " wanted: ~s~%" condition-type)
- (format *error-output*
- " got: ~s~%" (class-of condition))
- elseif (and format-control
- (not (string=
- (setq got
- (concatenate 'simple-string
- "~1@<" format-control "~:@>"))
- (setq wanted
- (simple-condition-format-control
- condition)))))
- then ;; format control doesn't match
- (format *error-output* "~
+ (format *error-output*
+ " wanted: ~s~%" condition-type)
+ (format *error-output*
+ " got: ~s~%" (class-of condition))
+ elseif (and format-control
+ (not (string=
+ (setq got
+ (concatenate 'simple-string
+ "~1@<" format-control "~:@>"))
+ (setq wanted
+ (simple-condition-format-control
+ condition)))))
+ then ;; format control doesn't match
+ (format *error-output* "~
Reason: the format-control was incorrect.~%")
- (format *error-output* " wanted: ~s~%" wanted)
- (format *error-output* " got: ~s~%" got)
- elseif (and format-arguments
- (not (equal
- (setq got format-arguments)
- (setq wanted
- (simple-condition-format-arguments
- condition)))))
- then (format *error-output* "~
+ (format *error-output* " wanted: ~s~%" wanted)
+ (format *error-output* " got: ~s~%" got)
+ elseif (and format-arguments
+ (not (equal
+ (setq got format-arguments)
+ (setq wanted
+ (simple-condition-format-arguments
+ condition)))))
+ then (format *error-output* "~
Reason: the format-arguments were incorrect.~%")
- (format *error-output* " wanted: ~s~%" wanted)
- (format *error-output* " got: ~s~%" got)
- else ;; what else????
- (error "internal-error"))
- else (let ((*print-length* 50)
- (*print-level* 10))
- (if* wanted-message
- then (format *error-output*
- " wanted: ~a~%" wanted-message)
- else (if* (not multiple-values)
- then (format *error-output*
- " wanted: ~s~%"
- expected-result)
- else (format
- *error-output*
- " wanted values: ~{~s~^, ~}~%"
- expected-result)))
- (if* got-message
- then (format *error-output*
- " got: ~a~%" got-message)
- else (if* (not multiple-values)
- then (format *error-output* " got: ~s~%"
- (second test-results))
- else (format
- *error-output*
- " got values: ~{~s~^, ~}~%"
- (cdr test-results))))))
- (when fail-info
- (format *error-output* "Additional info: ~a~%" fail-info))
- (incf *test-errors*)
- (when *break-on-test-failures*
- (break "~a is non-nil." '*break-on-test-failures*))
+ (format *error-output* " wanted: ~s~%" wanted)
+ (format *error-output* " got: ~s~%" got)
+ else ;; what else????
+ (error "internal-error"))
+ else (let ((*print-length* 50)
+ (*print-level* 10))
+ (if* wanted-message
+ then (format *error-output*
+ " wanted: ~a~%" wanted-message)
+ else (if* (not multiple-values)
+ then (format *error-output*
+ " wanted: ~s~%"
+ expected-result)
+ else (format
+ *error-output*
+ " wanted values: ~{~s~^, ~}~%"
+ expected-result)))
+ (if* got-message
+ then (format *error-output*
+ " got: ~a~%" got-message)
+ else (if* (not multiple-values)
+ then (format *error-output* " got: ~s~%"
+ (second test-results))
+ else (format
+ *error-output*
+ " got values: ~{~s~^, ~}~%"
+ (cdr test-results))))))
+ (when fail-info
+ (format *error-output* "Additional info: ~a~%" fail-info))
+ (incf *test-errors*)
+ (when *break-on-test-failures*
+ (break "~a is non-nil." '*break-on-test-failures*))
else (when known-failure
- (format *error-output*
- "~&Expected test failure for ~s did not occur.~%"
- test-form)
- (when fail-info
- (format *error-output* "Additional info: ~a~%" fail-info))
- (setq fail t))
- (incf *test-successes*))
+ (format *error-output*
+ "~&Expected test failure for ~s did not occur.~%"
+ test-form)
+ (when fail-info
+ (format *error-output* "Additional info: ~a~%" fail-info))
+ (setq fail t))
+ (incf *test-successes*))
(not fail)))
(defmacro with-tests ((&key (name "unnamed")) &body body)
(let ((g-name (gensym)))
`(flet ((doit () ,@body))
(let ((,g-name ,name)
- (*test-errors* 0)
- (*test-successes* 0)
- (*test-unexpected-failures* 0))
- (format *error-output* "Begin ~a test~%" ,g-name)
- (if* *break-on-test-failures*
- then (doit)
- else (handler-case (doit)
- (error (c)
- (format
- *error-output*
- "~
+ (*test-errors* 0)
+ (*test-successes* 0)
+ (*test-unexpected-failures* 0))
+ (format *error-output* "Begin ~a test~%" ,g-name)
+ (if* *break-on-test-failures*
+ then (doit)
+ else (handler-case (doit)
+ (error (c)
+ (format
+ *error-output*
+ "~
~&Test ~a aborted by signalling an uncaught error:~%~a~%"
- ,g-name c))))
- #+allegro
- (let ((state (sys:gsgc-switch :print)))
- (setf (sys:gsgc-switch :print) nil)
- (format t "~&**********************************~%" ,g-name)
- (format t "End ~a test~%" ,g-name)
- (format t "Errors detected in this test: ~s " *test-errors*)
- (unless (zerop *test-unexpected-failures*)
- (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
- (format t "~%Successes this test:~s~%" *test-successes*)
- (setf (sys:gsgc-switch :print) state))
- #-allegro
- (progn
- (format t "~&**********************************~%" ,g-name)
- (format t "End ~a test~%" ,g-name)
- (format t "Errors detected in this test: ~s " *test-errors*)
- (unless (zerop *test-unexpected-failures*)
- (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
- (format t "~%Successes this test:~s~%" *test-successes*))
- ))))
+ ,g-name c))))
+ #+allegro
+ (let ((state (sys:gsgc-switch :print)))
+ (setf (sys:gsgc-switch :print) nil)
+ (format t "~&**********************************~%" ,g-name)
+ (format t "End ~a test~%" ,g-name)
+ (format t "Errors detected in this test: ~s " *test-errors*)
+ (unless (zerop *test-unexpected-failures*)
+ (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
+ (format t "~%Successes this test:~s~%" *test-successes*)
+ (setf (sys:gsgc-switch :print) state))
+ #-allegro
+ (progn
+ (format t "~&**********************************~%" ,g-name)
+ (format t "End ~a test~%" ,g-name)
+ (format t "Errors detected in this test: ~s " *test-errors*)
+ (unless (zerop *test-unexpected-failures*)
+ (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
+ (format t "~%Successes this test:~s~%" *test-successes*))
+ ))))
(provide :tester #+module-versions 1.1)
(dotimes (r +row-length+)
(declare (fixnum r))
(setf (uffi:deref-array a '(:array (* :long)) r)
- (uffi:allocate-foreign-object :long +column-length+))
+ (uffi:allocate-foreign-object :long +column-length+))
(let ((col (uffi:deref-array a '(:array (* :long)) r)))
- (dotimes (c +column-length+)
- (declare (fixnum c))
- (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
+ (dotimes (c +column-length+)
+ (declare (fixnum c))
+ (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
(dotimes (r +row-length+)
(declare (fixnum r))
(format t "~&Row ~D: " r)
(let ((col (uffi:deref-array a '(:array (* :long)) r)))
- (dotimes (c +column-length+)
- (declare (fixnum c))
- (let ((result (uffi:deref-array col '(:array :long) c)))
- (format t "~d " result)))))
+ (dotimes (c +column-length+)
+ (declare (fixnum c))
+ (let ((result (uffi:deref-array col '(:array :long) c)))
+ (format t "~d " result)))))
(uffi:free-foreign-object a))
(values))
(in-package :cl-user)
-(uffi:def-function ("atoi" c-atoi)
+(uffi:def-function ("atoi" c-atoi)
((str :cstring))
:returning :int)
-(uffi:def-function ("atol" c-atol)
+(uffi:def-function ("atol" c-atol)
((str :cstring))
:returning :long)
-(uffi:def-function ("atof" c-atof)
+(uffi:def-function ("atof" c-atof)
((str :cstring))
:returning :double)
"Returns a double float from a string."
(uffi:with-cstring (str-cstring str)
(c-atof str-cstring)))
-
+
#+examples-uffi
(progn
(flet ((print-results (str)
- (format t "~&(atoi ~S) => ~S" str (atoi str))))
+ (format t "~&(atoi ~S) => ~S" str (atoi str))))
(print-results "55")))
#+test-uffi
(progn
(util.test:test (atoi "123") 123 :test #'eql
- :fail-info "Error with atoi")
+ :fail-info "Error with atoi")
(util.test:test (atoi "") 0 :test #'eql
- :fail-info "Error with atoi")
+ :fail-info "Error with atoi")
(util.test:test (atof "2.23") 2.23d0 :test #'eql
- :fail-info "Error with atof")
+ :fail-info "Error with atof")
)
-
+
/***************************************************************************
* FILE IDENTIFICATION
- *
+ *
* Name: c-test-fns.c
* Purpose: Test functions in C for UFFI library
* Programer: Kevin M. Rosenberg
{
return 1;
}
-
+
#define DLLEXPORT __declspec(dllexport)
#else
-#define DLLEXPORT
+#define DLLEXPORT
#endif
#include <ctype.h>
if (psz) {
while (*psz) {
if (isupper (*psz))
- ++count;
+ ++count;
++psz;
}
return count;
- } else
+ } else
return -1;
}
buffer[i] = 'A' + (rand() % 26);
}
-
+
/* Test of input/output vector */
DLLEXPORT
void
vec[i] /= 2.;
}
-
+
(in-package :cl-user)
-(unless (uffi:load-foreign-library
- (uffi:find-foreign-library "c-test-fns"
- (list *load-truename* "/home/kevin/debian/src/uffi/examples/"))
- :supporting-libraries '("c"))
+(unless (uffi:load-foreign-library
+ (uffi:find-foreign-library "c-test-fns"
+ (list *load-truename* "/home/kevin/debian/src/uffi/examples/"))
+ :supporting-libraries '("c"))
(warn "Unable to load c-test-fns library"))
(uffi:def-function ("cs_to_upper" cs-to-upper)
(uffi:def-constant +double-vec-length+ 10)
(defun test-half-double-vector ()
(let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
- results)
+ results)
(dotimes (i +double-vec-length+)
- (setf (uffi:deref-array vec '(:array :double) i)
- (coerce i 'double-float)))
+ (setf (uffi:deref-array vec '(:array :double) i)
+ (coerce i 'double-float)))
(half-double-vector +double-vec-length+ vec)
(dotimes (i +double-vec-length+)
(push (uffi:deref-array vec '(:array :double) i) results))
(system:without-gcing
(half-double-vector +double-vec-length+ (system:vector-sap vec)))
vec))
-
+
#+examples-uffi
-(format t "~&(string-to-upper \"this is a test\") => ~A"
- (string-to-upper "this is a test"))
+(format t "~&(string-to-upper \"this is a test\") => ~A"
+ (string-to-upper "this is a test"))
#+examples-uffi
-(format t "~&(string-to-upper nil) => ~A"
- (string-to-upper nil))
+(format t "~&(string-to-upper nil) => ~A"
+ (string-to-upper nil))
#+examples-uffi
-(format t "~&(string-count-upper \"This is a Test\") => ~A"
- (string-count-upper "This is a Test"))
+(format t "~&(string-count-upper \"This is a Test\") => ~A"
+ (string-count-upper "This is a Test"))
#+examples-uffi
-(format t "~&(string-count-upper nil) => ~A"
- (string-count-upper nil))
+(format t "~&(string-count-upper nil) => ~A"
+ (string-count-upper nil))
#+examples-uffi
(format t "~&Half vector: ~S" (test-half-double-vector))
(progn
(util.test:test (string= (string-to-upper "this is a test") "THIS IS A TEST")
t
- :test #'eql
- :fail-info "Error with string-to-upper")
+ :test #'eql
+ :fail-info "Error with string-to-upper")
(util.test:test (string-to-upper nil) nil
- :fail-info "string-to-upper with nil failed")
+ :fail-info "string-to-upper with nil failed")
(util.test:test (string-count-upper "This is a Test")
- 2
- :test #'eql
- :fail-info "Error with string-count-upper")
+ 2
+ :test #'eql
+ :fail-info "Error with string-count-upper")
(util.test:test (string-count-upper nil) -1
- :test #'eql
- :fail-info "string-count-upper with nil failed")
+ :test #'eql
+ :fail-info "string-count-upper with nil failed")
(util.test:test (test-half-double-vector)
- '(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0)
- :test #'equal
- :fail-info "Error comparing half-double-vector")
+ '(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0)
+ :test #'equal
+ :fail-info "Error comparing half-double-vector")
)
(eval-when (:load-toplevel :execute)
(unless (uffi:load-foreign-library
- #-(or macosx darwin)
- (uffi:find-foreign-library
- "libz"
- '("/usr/local/lib/" "/usr/lib/" "/zlib/")
- :types '("so" "a"))
- #+(or macosx darwin)
- (uffi:find-foreign-library "z"
- `(,(pathname-directory *load-pathname*)))
- :module "zlib"
- :supporting-libraries '("c"))
+ #-(or macosx darwin)
+ (uffi:find-foreign-library
+ "libz"
+ '("/usr/local/lib/" "/usr/lib/" "/zlib/")
+ :types '("so" "a"))
+ #+(or macosx darwin)
+ (uffi:find-foreign-library "z"
+ `(,(pathname-directory *load-pathname*)))
+ :module "zlib"
+ :supporting-libraries '("c"))
(warn "Unable to load zlib")))
-
+
(uffi:def-function ("compress" c-compress)
((dest (* :unsigned-char))
(destlen (* :long))
(source-len :long))
:returning :int
:module "zlib")
-
+
(defun compress (source)
"Returns two values: array of bytes containing the compressed data
and the numbe of compressed bytes"
(let* ((sourcelen (length source))
- (destsize (+ 12 (ceiling (* sourcelen 1.01))))
- (dest (uffi:allocate-foreign-string destsize :unsigned t))
- (destlen (uffi:allocate-foreign-object :long)))
+ (destsize (+ 12 (ceiling (* sourcelen 1.01))))
+ (dest (uffi:allocate-foreign-string destsize :unsigned t))
+ (destlen (uffi:allocate-foreign-object :long)))
(setf (uffi:deref-pointer destlen :long) destsize)
(uffi:with-cstring (source-native source)
(let ((result (c-compress dest destlen source-native sourcelen))
- (newdestlen (uffi:deref-pointer destlen :long)))
- (unwind-protect
- (if (zerop result)
- (values (uffi:convert-from-foreign-string
- dest
- :length newdestlen
- :null-terminated-p nil)
- newdestlen)
- (error "zlib error, code ~D" result))
- (progn
- (uffi:free-foreign-object destlen)
- (uffi:free-foreign-object dest)))))))
+ (newdestlen (uffi:deref-pointer destlen :long)))
+ (unwind-protect
+ (if (zerop result)
+ (values (uffi:convert-from-foreign-string
+ dest
+ :length newdestlen
+ :null-terminated-p nil)
+ newdestlen)
+ (error "zlib error, code ~D" result))
+ (progn
+ (uffi:free-foreign-object destlen)
+ (uffi:free-foreign-object dest)))))))
(uffi:def-function ("uncompress" c-uncompress)
((dest (* :unsigned-char))
(defun uncompress (source)
(let* ((sourcelen (length source))
- (destsize 200000) ;adjust as needed
- (dest (uffi:allocate-foreign-string destsize :unsigned t))
- (destlen (uffi:allocate-foreign-object :long)))
+ (destsize 200000) ;adjust as needed
+ (dest (uffi:allocate-foreign-string destsize :unsigned t))
+ (destlen (uffi:allocate-foreign-object :long)))
(setf (uffi:deref-pointer destlen :long) destsize)
(uffi:with-cstring (source-native source)
(let ((result (c-uncompress dest destlen source-native sourcelen))
- (newdestlen (uffi:deref-pointer destlen :long)))
- (unwind-protect
- (if (zerop result)
- (uffi:convert-from-foreign-string
- dest
- :length newdestlen
- :null-terminated-p nil)
- (error "zlib error, code ~D" result))
- (progn
- (uffi:free-foreign-object destlen)
- (uffi:free-foreign-object dest)))))))
+ (newdestlen (uffi:deref-pointer destlen :long)))
+ (unwind-protect
+ (if (zerop result)
+ (uffi:convert-from-foreign-string
+ dest
+ :length newdestlen
+ :null-terminated-p nil)
+ (error "zlib error, code ~D" result))
+ (progn
+ (uffi:free-foreign-object destlen)
+ (uffi:free-foreign-object dest)))))))
#+examples-uffi
(progn
(flet ((print-results (str)
- (multiple-value-bind (compressed len) (compress str)
- (let ((*print-length* nil))
- (format t "~&(compress ~S) => " str)
- (format t "~S~%" (map 'list #'char-code compressed))))))
+ (multiple-value-bind (compressed len) (compress str)
+ (let ((*print-length* nil))
+ (format t "~&(compress ~S) => " str)
+ (format t "~S~%" (map 'list #'char-code compressed))))))
(print-results "")
(print-results "test")
(print-results "test2")))
#+test-uffi
(progn
(flet ((test-compress (str)
- (multiple-value-bind (compressed len) (compress str)
- (multiple-value-bind (uncompressed len2) (uncompress compressed)
- (util.test:test str uncompressed :test #'string=
- :fail-info "Error uncompressing a compressed string")))))
+ (multiple-value-bind (compressed len) (compress str)
+ (multiple-value-bind (uncompressed len2) (uncompress compressed)
+ (util.test:test str uncompressed :test #'string=
+ :fail-info "Error uncompressing a compressed string")))))
(test-compress "")
(test-compress "test")
(test-compress "test2")))
(serv-addr :void-pointer)
(addr-len :int))
:returning :int)
-
+
(defun connect-to-file-socket (filename)
(let ((socket (c-socket PF_UNIX SOCK_STREAM 0)))
(if (plusp socket)
- (let ((stream (c-connect socket filename (length filename))))
- stream)
+ (let ((stream (c-connect socket filename (length filename))))
+ stream)
(error "Unable to create socket"))))
(in-package :cl-user)
-(uffi:def-function ("getenv" c-getenv)
+(uffi:def-function ("getenv" c-getenv)
((name :cstring))
:returning :cstring)
(check-type key string)
(uffi:with-cstring (key-native key)
(uffi:convert-from-cstring (c-getenv key-native))))
-
+
#+examples-uffi
(progn
(flet ((print-results (str)
- (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
+ (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
(print-results "USER")
(print-results "_FOO_")))
(progn
(util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
(util.test:test (and (stringp (my-getenv "USER"))
- (< 0 (length (my-getenv "USER"))))
- t :fail-info "Error retrieving getenv")
+ (< 0 (length (my-getenv "USER"))))
+ t :fail-info "Error retrieving getenv")
)
;;; This example is inspired by the example on the CL-Cookbook web site
-(uffi:def-function ("gethostname" c-gethostname)
+(uffi:def-function ("gethostname" c-gethostname)
((name (* :unsigned-char))
(len :int))
:returning :int)
(defun gethostname ()
"Returns the hostname"
(let* ((name (uffi:allocate-foreign-string 256))
- (result-code (c-gethostname name 256))
- (hostname (when (zerop result-code)
- (uffi:convert-from-foreign-string name))))
+ (result-code (c-gethostname name 256))
+ (hostname (when (zerop result-code)
+ (uffi:convert-from-foreign-string name))))
(uffi:free-foreign-object name)
(unless (zerop result-code)
(error "gethostname() failed."))
"Returns the hostname"
(uffi:with-foreign-object (name '(:array :unsigned-char 256))
(if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
- (uffi:convert-from-foreign-string name)
- (error "gethostname() failed."))))
+ (uffi:convert-from-foreign-string name)
+ (error "gethostname() failed."))))
#+examples-uffi
(progn
#+test-uffi
(progn
(let ((hostname1 (gethostname))
- (hostname2 (gethostname2)))
-
+ (hostname2 (gethostname2)))
+
(util.test:test (and (stringp hostname1) (stringp hostname2)) t
- :fail-info "gethostname not string")
+ :fail-info "gethostname not string")
(util.test:test (and (not (zerop (length hostname1)))
- (not (zerop (length hostname2)))) t
- :fail-info "gethostname length 0")
+ (not (zerop (length hostname2)))) t
+ :fail-info "gethostname length 0")
(util.test:test (string= hostname1 hostname1) t
- :fail-info "gethostname techniques don't match"))
+ :fail-info "gethostname techniques don't match"))
)
(let (shells)
(do ((shell (uffi:convert-from-cstring (getusershell))
(uffi:convert-from-cstring (getusershell))))
- ((null shell))
+ ((null shell))
(push shell shells))
(endusershell)
(nreverse shells)))
(yday :int)
(isdst :int))
-(uffi:def-function ("time" c-time)
+(uffi:def-function ("time" c-time)
((time (* time-t)))
:returning time-t)
(c-time time)
(let ((tm-ptr (the tm-pointer (c-localtime time))))
(declare (type tm-pointer tm-ptr))
- (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d"
- (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
- (uffi:get-slot-value tm-ptr 'tm 'mday)
- (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
- (uffi:get-slot-value tm-ptr 'tm 'hour)
- (uffi:get-slot-value tm-ptr 'tm 'min)
- (uffi:get-slot-value tm-ptr 'tm 'sec)
- )))
- time-string))))
+ (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d"
+ (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
+ (uffi:get-slot-value tm-ptr 'tm 'mday)
+ (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
+ (uffi:get-slot-value tm-ptr 'tm 'hour)
+ (uffi:get-slot-value tm-ptr 'tm 'min)
+ (uffi:get-slot-value tm-ptr 'tm 'sec)
+ )))
+ time-string))))
(let ((time (gettime)))
(util.test:test (stringp time) t :fail-info "Time is not a string")
(util.test:test (plusp (parse-integer time :junk-allowed t))
- t
- :fail-info "time string does not start with a number")))
+ t
+ :fail-info "time string does not start with a number")))
+
-
(pushnew :examples-uffi cl:*features*)
(flet ((load-test (name)
- (load (make-pathname :defaults *load-truename* :name name))))
+ (load (make-pathname :defaults *load-truename* :name name))))
(load-test "c-test-fns")
(load-test "arrays")
(load-test "union")
(setq cl:*features* (remove :examples-uffi cl:*features*))
-
+
(in-package :cl-user)
(uffi:def-foreign-type char-ptr (* :unsigned-char))
-
+
;; This example does not use :cstring to pass the input string since
;; the routine needs to do pointer arithmetic to see how many characters
;; were parsed
-(uffi:def-function ("strtol" c-strtol)
+(uffi:def-function ("strtol" c-strtol)
((nptr char-ptr)
(endptr (* char-ptr))
(base :int))
their was no string at all, or an integer indicating position in string
of first non-valid character"
(let* ((str-native (uffi:convert-to-foreign-string str))
- (endptr (uffi:allocate-foreign-object 'char-ptr))
- (value (c-strtol str-native endptr base))
- (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
+ (endptr (uffi:allocate-foreign-object 'char-ptr))
+ (value (c-strtol str-native endptr base))
+ (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
(unwind-protect
- (if (uffi:null-pointer-p endptr-value)
- (values value t)
- (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
- (chars-parsed (- (uffi:pointer-address endptr-value)
- (uffi:pointer-address str-native))))
- (cond
- ((zerop chars-parsed)
- (values nil nil))
- ((uffi:null-char-p next-char-value)
- (values value t))
- (t
- (values value chars-parsed)))))
+ (if (uffi:null-pointer-p endptr-value)
+ (values value t)
+ (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
+ (chars-parsed (- (uffi:pointer-address endptr-value)
+ (uffi:pointer-address str-native))))
+ (cond
+ ((zerop chars-parsed)
+ (values nil nil))
+ ((uffi:null-char-p next-char-value)
+ (values value t))
+ (t
+ (values value chars-parsed)))))
(progn
- (uffi:free-foreign-object str-native)
- (uffi:free-foreign-object endptr)))))
+ (uffi:free-foreign-object str-native)
+ (uffi:free-foreign-object endptr)))))
+
+
-
-
#+examples-uffi
(progn
(flet ((print-results (str)
- (multiple-value-bind (result flag) (strtol str)
- (format t "~&(strtol ~S) => ~S,~S" str result flag))))
+ (multiple-value-bind (result flag) (strtol str)
+ (format t "~&(strtol ~S) => ~S,~S" str result flag))))
(print-results "55")
(print-results "55.3")
(print-results "a")))
#+test-uffi
(progn
(flet ((test-strtol (str results)
- (util.test:test (multiple-value-list (strtol str)) results
- :test #'equal
- :fail-info "Error testing strtol")))
+ (util.test:test (multiple-value-list (strtol str)) results
+ :test #'equal
+ :fail-info "Error testing strtol")))
(test-strtol "123" '(123 t))
(test-strtol "0" '(0 t))
(test-strtol "55a" '(55 2))
(test-strtol "a" '(nil nil))))
-
+
(util.test:with-tests (:name "UFFI-Tests")
(setq util.test:*break-on-test-failures* nil)
(flet ((load-test (name)
- (load (make-pathname :name name :defaults *load-truename*))))
+ (load (make-pathname :name name :defaults *load-truename*))))
(load-test "c-test-fns")
(load-test "arrays")
(load-test "union")
(in-package :cl-user)
-(uffi:def-union tunion1
+(uffi:def-union tunion1
(char :char)
(int :int)
(uint :unsigned-int)
;; little endian
#-(or sparc sparc-v9 powerpc ppc big-endian)
(+ (* 1 (char-code #\A))
- (* 256 (char-code #\B))
- (* 65536 (char-code #\C))
- (* 16777216 255))
+ (* 256 (char-code #\B))
+ (* 65536 (char-code #\C))
+ (* 16777216 255))
;; big endian
#+(or sparc sparc-v9 powerpc ppc big-endian)
(+ (* 16777216 (char-code #\A))
- (* 65536 (char-code #\B))
- (* 256 (char-code #\C))
- (* 1 255)))
- (format *standard-output* "~&Should be #\A: ~S"
- (uffi:ensure-char-character
- (uffi:get-slot-value u 'tunion1 'char)))
-;; (format *standard-output* "~&Should be negative number: ~D"
-;; (uffi:get-slot-value u 'tunion1 'int))
+ (* 65536 (char-code #\B))
+ (* 256 (char-code #\C))
+ (* 1 255)))
+ (format *standard-output* "~&Should be #\A: ~S"
+ (uffi:ensure-char-character
+ (uffi:get-slot-value u 'tunion1 'char)))
+;; (format *standard-output* "~&Should be negative number: ~D"
+;; (uffi:get-slot-value u 'tunion1 'int))
(format *standard-output* "~&Should be positive number: ~D"
- (uffi:get-slot-value u 'tunion1 'uint))
+ (uffi:get-slot-value u 'tunion1 'uint))
(uffi:free-foreign-object u))
(values))
(defun test-union-1 ()
(let ((u (uffi:allocate-foreign-object 'tunion1)))
(setf (uffi:get-slot-value u 'tunion1 'uint)
- #-(or sparc sparc-v9 powerpc ppc)
- (+ (* 1 (char-code #\A))
- (* 256 (char-code #\B))
- (* 65536 (char-code #\C))
- (* 16777216 128))
- #+(or sparc sparc-v9 powerpc ppc)
- (+ (* 16777216 (char-code #\A))
- (* 65536 (char-code #\B))
- (* 256 (char-code #\C))
- (* 1 128))) ;set signed bit
- (util.test:test (uffi:ensure-char-character
- (uffi:get-slot-value u 'tunion1 'char))
- #\A
- :test #'eql
- :fail-info "Error with union character")
+ #-(or sparc sparc-v9 powerpc ppc)
+ (+ (* 1 (char-code #\A))
+ (* 256 (char-code #\B))
+ (* 65536 (char-code #\C))
+ (* 16777216 128))
+ #+(or sparc sparc-v9 powerpc ppc)
+ (+ (* 16777216 (char-code #\A))
+ (* 65536 (char-code #\B))
+ (* 256 (char-code #\C))
+ (* 1 128))) ;set signed bit
+ (util.test:test (uffi:ensure-char-character
+ (uffi:get-slot-value u 'tunion1 'char))
+ #\A
+ :test #'eql
+ :fail-info "Error with union character")
#-(or sparc sparc-v9 openmcl digitool)
;; (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
-;; t
-;; :fail-info
-;; "Error with negative int in union")
+;; t
+;; :fail-info
+;; "Error with negative int in union")
(util.test:test (plusp (uffi:get-slot-value u 'tunion1 'uint))
- t
- :fail-info
- "Error with unsigned int in union")
+ t
+ :fail-info
+ "Error with unsigned int in union")
(uffi:free-foreign-object u))
(values))
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))
+ (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 `(uffi:def-constant ,name ,value) constants)))
+ (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 `(uffi:def-constant ,name ,value) constants)))
(setf cmds (append '(progn)
- #+allegro `((ff:def-foreign-type ,enum-name :int))
- #+lispworks `((fli:define-c-typedef ,enum-name :int))
- #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
- #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
+ #+allegro `((ff:def-foreign-type ,enum-name :int))
+ #+lispworks `((fli:define-c-typedef ,enum-name :int))
+ #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
+ #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
#+digitool `((def-mcl-type ,enum-name :integer))
#+openmcl `((ccl::def-foreign-type ,enum-name :int))
- (nreverse constants)))
+ (nreverse constants)))
cmds))
(defmacro def-array-pointer (name-array type)
#+allegro
- `(ff:def-foreign-type ,name-array
+ `(ff:def-foreign-type ,name-array
(:array ,(convert-from-uffi-type type :array)))
#+lispworks
`(fli:define-c-typedef ,name-array
(:c-array ,(convert-from-uffi-type type :array)))
#+(or cmu scl)
- `(alien:def-alien-type ,name-array
+ `(alien:def-alien-type ,name-array
(* ,(convert-from-uffi-type type :array)))
#+sbcl
- `(sb-alien:define-alien-type ,name-array
+ `(sb-alien:define-alien-type ,name-array
(* ,(convert-from-uffi-type type :array)))
#+digitool
`(def-mcl-type ,name-array '(:array ,type))
(let (processed)
(dolist (field fields)
(let* ((field-name (car field))
- (type (cadr field))
- (def (append (list field-name)
- (if (eq type :pointer-self)
- #+(or cmu scl) `((* (alien:struct ,name)))
- #+sbcl `((* (sb-alien:struct ,name)))
- #+(or openmcl digitool) `((:* (:struct ,name)))
- #+lispworks `((:pointer ,name))
- #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
- `(,(convert-from-uffi-type type :struct))))))
- (if variant
- (push (list def) processed)
- (push def processed))))
+ (type (cadr field))
+ (def (append (list field-name)
+ (if (eq type :pointer-self)
+ #+(or cmu scl) `((* (alien:struct ,name)))
+ #+sbcl `((* (sb-alien:struct ,name)))
+ #+(or openmcl digitool) `((:* (:struct ,name)))
+ #+lispworks `((:pointer ,name))
+ #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
+ `(,(convert-from-uffi-type type :struct))))))
+ (if variant
+ (push (list def) processed)
+ (push def processed))))
(nreverse processed)))
-
-
+
+
(defmacro def-struct (name &rest fields)
#+(or cmu scl)
`(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
`(ccl:defrecord ,name ,@(process-struct-fields name fields))
#+openmcl
`(ccl::def-foreign-type
- nil
+ nil
(:struct ,name ,@(process-struct-fields name fields)))
)
`(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
#+openmcl
`(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
- (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
+ (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
)
;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8
(defun array-type (type)
(let ((result type))
(when (listp type)
- (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
- (when (and (listp type-list) (eq (car type-list) :array))
- (setf result (cadr type-list)))))
+ (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
+ (when (and (listp type-list) (eq (car type-list) :array))
+ (setf result (cadr type-list)))))
result))
-
-
+
+
(defmacro deref-array (obj type i)
"Returns a field from a row"
#+(or lispworks cmu sbcl scl) (declare (ignore type))
#+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
#+openmcl
(let* ((array-type (array-type type))
- (local-type (convert-from-uffi-type array-type :allocation))
- (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
+ (local-type (convert-from-uffi-type array-type :allocation))
+ (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
(ccl::%foreign-access-form
obj
(ccl::%foreign-type-or-record local-type)
nil))
#+digitool
(let* ((array-type (array-type type))
- (local-type (convert-from-uffi-type array-type :allocation))
- (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
+ (local-type (convert-from-uffi-type array-type :allocation))
+ (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
`(,accessor
- ,obj
- (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
+ ,obj
+ (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
))
-
+
; this expands to the %set-xx functions which has different params than %put-xx
#+digitool
(defmacro deref-array-set (obj type i value)
(local-type (convert-from-uffi-type array-type :allocation))
(accessor (first (macroexpand `(ccl:pref obj ,local-type))))
(settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
- `(,settor
+ `(,settor
,obj
- (* (the fixnum ,i) ,(size-of-foreign-type local-type))
+ (* (the fixnum ,i) ,(size-of-foreign-type local-type))
,value)))
#+digitool
#+digitool
`(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
#+openmcl
- `(ccl::def-foreign-type nil
- (:union ,name ,@(process-struct-fields name fields)))
+ `(ccl::def-foreign-type nil
+ (:union ,name ,@(process-struct-fields name fields)))
)
#-(or sbcl cmu)
(defun convert-from-foreign-usb8 (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
- (fixnum len))
+ (fixnum len))
(let ((a (make-array len :element-type '(unsigned-byte 8))))
(dotimes (i len a)
(declare (fixnum i))
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:without-package-locks
(defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
- (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
- (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
+ (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
+ (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
(defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
- (* sb-vm:vector-data-offset sb-vm:n-word-bits)
- 0))
+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+ 0))
(defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
- sb-vm:n-byte-bits
- 1))))
-
+ sb-vm:n-byte-bits
+ 1))))
+
#+sbcl
(defun convert-from-foreign-usb8 (s len)
(declare (optimize (speed 3) (safety 0)))
(let ((result (make-array len :element-type '(unsigned-byte 8))))
(funcall *system-copy-fn* sap 0 result +system-copy-offset+
- (* len +system-copy-multiplier+))
+ (* len +system-copy-multiplier+))
result))))
#+cmu
(let ((sap (alien:alien-sap s)))
(declare (type system:system-area-pointer sap))
(locally
- (declare (optimize (speed 3) (safety 0)))
+ (declare (optimize (speed 3) (safety 0)))
(let ((result (make-array len :element-type '(unsigned-byte 8))))
- (kernel:copy-from-system-area sap 0
- result (* vm:vector-data-offset
- vm:word-bits)
- (* len vm:byte-bits))
- result))))
+ (kernel:copy-from-system-area sap 0
+ result (* vm:vector-data-offset
+ vm:word-bits)
+ (* len vm:byte-bits))
+ result))))
(in-package :cl-user)
(ct:defun-dll c-getenv ((lpname LPSTR)
- (lpbuffer LPSTR)
- (nsize LPDWORD))
+ (lpbuffer LPSTR)
+ (nsize LPDWORD))
:library-name "kernel32.dll"
:return-type DWORD
:entry-name "GetEnvironmentVariableA"
(let* ((needed-size (c-getenv cname buffer nsizebuf))
(buffer1 (ct:malloc (1+ needed-size))))
(setf (ct:cref lpdword nsizebuf 0) needed-size)
- (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
+ (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
nil
(ct:c-string-to-lisp-string buffer1))
(ct:free buffer1)
(t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
;|
-(uffi:def-function ("getenv" c-getenv)
+(uffi:def-function ("getenv" c-getenv)
((name :cstring))
:returning :cstring)
(check-type key string)
(uffi:with-cstring (key-native key)
(uffi:convert-from-cstring (c-getenv key-native))))
-
+
#examples-uffi
(progn
(flet ((print-results (str)
- (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
+ (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
(print-results "USER")
(print-results "_FOO_")))
(progn
(util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
(util.test:test (and (stringp (my-getenv "USER"))
- (< 0 (length (my-getenv "USER"))))
- t :fail-info "Error retrieving getenv")
+ (< 0 (length (my-getenv "USER"))))
+ t :fail-info "Error retrieving getenv")
)
;; args not null
#+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
(let (processed)
- (dolist (arg args)
- (push (process-one-function-arg arg) processed))
- (nreverse processed))
+ (dolist (arg args)
+ (push (process-one-function-arg arg) processed))
+ (nreverse processed))
#+openmcl
(let ((processed nil)
- (params nil))
- (dolist (arg args)
- (let ((name (car arg))
- (type (convert-from-uffi-type (cadr arg) :routine)))
- ;;(when (and (listp type) (eq (car type) :address))
- ;;(setf type :address))
- (push name params)
- (push type processed)
- (push name processed)))
- (values (nreverse params) (nreverse processed)))
+ (params nil))
+ (dolist (arg args)
+ (let ((name (car arg))
+ (type (convert-from-uffi-type (cadr arg) :routine)))
+ ;;(when (and (listp type) (eq (car type) :address))
+ ;;(setf type :address))
+ (push name params)
+ (push type processed)
+ (push name processed)))
+ (values (nreverse params) (nreverse processed)))
))
(defun process-one-function-arg (arg)
(let ((name (car arg))
- (type (convert-from-uffi-type (cadr arg) :routine)))
+ (type (convert-from-uffi-type (cadr arg) :routine)))
#+(or cmu sbcl scl)
;(list name type :in)
`(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
#+(or allegro lispworks digitool)
(if (and (listp type) (listp (car type)))
- (append (list name) type)
+ (append (list name) type)
(list name type))
#+openmcl
(declare (ignore name type))
- ))
+ ))
(defun allegro-convert-return-type (type)
#|
(defmacro def-funcallable (name args &key returning)
(let ((result-type (convert-from-uffi-type returning :return))
- (function-args (process-function-args args)))
+ (function-args (process-function-args args)))
#+lispworks
`(fli:define-foreign-funcallable ,name ,function-args
:result-type ,result-type
#+(or cmu scl sbcl)
;; requires the type of the function pointer be declared correctly!
(let* ((ptrsym (gensym))
- (ll (funcallable-lambda-list args)))
+ (ll (funcallable-lambda-list args)))
`(defun ,name ,(cons ptrsym ll)
- (alien::alien-funcall ,ptrsym ,@ll)))
+ (alien::alien-funcall ,ptrsym ,@ll)))
#+openmcl
(multiple-value-bind (params args) (process-function-args args)
(let ((ptrsym (gensym)))
- `(defun ,name ,(cons ptrsym params)
- (ccl::ff-call ,ptrsym ,@args ,result-type))))
+ `(defun ,name ,(cons ptrsym params)
+ (ccl::ff-call ,ptrsym ,@args ,result-type))))
#+allegro
;; this is most definitely wrong
(let* ((ptrsym (gensym))
- (ll (funcallable-lambda-list args)))
+ (ll (funcallable-lambda-list args)))
`(defun ,name ,(cons ptrsym ll)
- (system::ff-funcall ,ptrsym ,@ll)))
+ (system::ff-funcall ,ptrsym ,@ll)))
))
-|#
+|#
(defun convert-lispworks-args (args)
(loop for arg in args
- with processed = nil
- do
- (if (and (= (length arg) 3) (eq (third arg) :out))
- (push (list (first arg)
- (list :reference-return (second arg))) processed)
- (push (subseq arg 0 2) processed))
- finally (return (nreverse processed))))
+ with processed = nil
+ do
+ (if (and (= (length arg) 3) (eq (third arg) :out))
+ (push (list (first arg)
+ (list :reference-return (second arg))) processed)
+ (push (subseq arg 0 2) processed))
+ finally (return (nreverse processed))))
(defun preprocess-names (names)
(let ((fname (gensym)))
(if (atom names)
- (values (list names fname) fname (uffi::make-lisp-name names))
- (values (list (first names) fname) fname (second names)))))
+ (values (list names fname) fname (uffi::make-lisp-name names))
+ (values (list (first names) fname) fname (second names)))))
(defun preprocess-args (args)
(loop for arg in args
- with lisp-args = nil and out = nil and processed = nil
- do
- (if (= (length arg) 3)
- (ecase (third arg)
- (:in
- (progn
- (push (first arg) lisp-args)
- (push (list (first arg) (second arg)) processed)))
- (:out
- (progn
- (push (list (first arg) (second arg)) out)
- (push (list (first arg) (list '* (second arg))) processed))))
- (progn
- (push (first arg) lisp-args)
- (push arg processed)))
- finally (return (values (nreverse lisp-args)
- (nreverse out)
- (nreverse processed)))))
+ with lisp-args = nil and out = nil and processed = nil
+ do
+ (if (= (length arg) 3)
+ (ecase (third arg)
+ (:in
+ (progn
+ (push (first arg) lisp-args)
+ (push (list (first arg) (second arg)) processed)))
+ (:out
+ (progn
+ (push (list (first arg) (second arg)) out)
+ (push (list (first arg) (list '* (second arg))) processed))))
+ (progn
+ (push (first arg) lisp-args)
+ (push arg processed)))
+ finally (return (values (nreverse lisp-args)
+ (nreverse out)
+ (nreverse processed)))))
(defmacro def-function (names args &key module returning)
(preprocess-args args)
(declare (ignorable lisp-args processed))
(if (= (length out) 0)
- `(%def-function ,names ,args
- ,@(if module (list :module module) (values))
- ,@(if returning (list :returning returning) (values)))
-
- #+(or cmu scl sbcl)
- `(%def-function ,names ,args
- ,@(if returning (list :returning returning) (values)))
- #+(and lispworks lispworks5)
- (multiple-value-bind (name-pair fname lisp-name)
- (preprocess-names names)
- `(progn
- (%def-function ,name-pair ,(convert-lispworks-args args)
- ,@(if module (list :module module) (values))
- ,@(if returning (list :returning returning) (values)))
- (defun ,lisp-name ,lisp-args
- (,fname ,@(mapcar
- #'(lambda (arg)
- (cond ((member (first arg) lisp-args)
- (first arg))
- ((member (first arg) out :key #'first)
- t)))
- args)))))
- #+(and lispworks (not lispworks5))
- `(%def-function ,names ,(convert-lispworks-args args)
- ,@(if module (list :module module) (values))
- ,@(if returning (list :returning returning) (values)))
- #-(or cmu scl sbcl lispworks)
- (multiple-value-bind (name-pair fname lisp-name)
- (preprocess-names names)
- `(progn
- (%def-function ,name-pair ,processed
- :module ,module :returning ,returning)
- ;(declaim (inline ,fname))
- (defun ,lisp-name ,lisp-args
- (with-foreign-objects ,out
- (values (,fname ,@(mapcar #'first args))
- ,@(mapcar #'(lambda (arg)
- (list 'deref-pointer
- (first arg)
- (second arg))) out))))))
- )))
-
+ `(%def-function ,names ,args
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+
+ #+(or cmu scl sbcl)
+ `(%def-function ,names ,args
+ ,@(if returning (list :returning returning) (values)))
+ #+(and lispworks lispworks5)
+ (multiple-value-bind (name-pair fname lisp-name)
+ (preprocess-names names)
+ `(progn
+ (%def-function ,name-pair ,(convert-lispworks-args args)
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+ (defun ,lisp-name ,lisp-args
+ (,fname ,@(mapcar
+ #'(lambda (arg)
+ (cond ((member (first arg) lisp-args)
+ (first arg))
+ ((member (first arg) out :key #'first)
+ t)))
+ args)))))
+ #+(and lispworks (not lispworks5))
+ `(%def-function ,names ,(convert-lispworks-args args)
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+ #-(or cmu scl sbcl lispworks)
+ (multiple-value-bind (name-pair fname lisp-name)
+ (preprocess-names names)
+ `(progn
+ (%def-function ,name-pair ,processed
+ :module ,module :returning ,returning)
+ ;(declaim (inline ,fname))
+ (defun ,lisp-name ,lisp-args
+ (with-foreign-objects ,out
+ (values (,fname ,@(mapcar #'first args))
+ ,@(mapcar #'(lambda (arg)
+ (list 'deref-pointer
+ (first arg)
+ (second arg))) out))))))
+ )))
+
;; name is either a string representing foreign name, or a list
;; of foreign-name as a string and lisp name as a symbol
(defmacro %def-function (names args &key module returning)
#+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))
-
+
(let* ((result-type (convert-from-uffi-type returning :return))
- (function-args (process-function-args args))
- (foreign-name (if (atom names) names (car names)))
- (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
+ (function-args (process-function-args args))
+ (foreign-name (if (atom names) names (car names)))
+ (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
;; todo: calling-convention :stdcall for cormanlisp
#+allegro
`(ff:def-foreign-call (,lisp-name ,foreign-name)
- ,function-args
+ ,function-args
:returning ,(allegro-convert-return-type result-type)
:call-direct t
:strings-convert nil)
#+(or cmu scl)
`(alien:def-alien-routine (,foreign-name ,lisp-name)
- ,result-type
+ ,result-type
,@function-args)
#+sbcl
`(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
- ,result-type
+ ,result-type
,@function-args)
#+lispworks
`(fli:define-foreign-function (,lisp-name ,foreign-name :source)
- ,function-args
+ ,function-args
,@(if module (list :module module) (values))
:result-type ,result-type
:language :ansi-c
(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)))))))
+ (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 load-foreign-library (filename &key module supporting-libraries
- force-load)
+ force-load)
#+(or allegro openmcl digitool sbcl) (declare (ignore module supporting-libraries))
#+(or cmu scl) (declare (ignore module))
#+lispworks (declare (ignore supporting-libraries))
(find filename *loaded-libraries* :test #'string-equal))
t ;; return T, but don't reload library
(progn
- #+cmu
- (let ((type (pathname-type (parse-namestring filename))))
- (if (string-equal type "so")
- (unless
+ #+cmu
+ (let ((type (pathname-type (parse-namestring filename))))
+ (if (string-equal type "so")
+ (unless
(sys::load-object-file filename)
(load-failure))
- (alien:load-foreign filename
- :libraries
- (convert-supporting-libraries-to-string
- supporting-libraries))))
- #+scl
- (let ((type (pathname-type (parse-namestring filename))))
- (alien:load-foreign filename
- :libraries
- (convert-supporting-libraries-to-string
- supporting-libraries)))
- #+sbcl
- (handler-case (sb-alien::load-1-foreign filename)
- (sb-int:unsupported-operator (c)
- (if (fboundp (intern "LOAD-SHARED-OBJECT" :sb-alien))
- (funcall (intern "LOAD-SHARED-OBJECT" :sb-alien) filename)
- (error c))))
+ (alien:load-foreign filename
+ :libraries
+ (convert-supporting-libraries-to-string
+ supporting-libraries))))
+ #+scl
+ (let ((type (pathname-type (parse-namestring filename))))
+ (alien:load-foreign filename
+ :libraries
+ (convert-supporting-libraries-to-string
+ supporting-libraries)))
+ #+sbcl
+ (handler-case (sb-alien::load-1-foreign filename)
+ (sb-int:unsupported-operator (c)
+ (if (fboundp (intern "LOAD-SHARED-OBJECT" :sb-alien))
+ (funcall (intern "LOAD-SHARED-OBJECT" :sb-alien) filename)
+ (error c))))
- #+lispworks (fli:register-module module :real-name filename
+ #+lispworks (fli:register-module module :real-name filename
:connection-style :immediate)
- #+allegro (load filename)
- #+openmcl (ccl:open-shared-library filename)
- #+digitool (ccl:add-to-shared-library-search-path filename t)
+ #+allegro (load filename)
+ #+openmcl (ccl:open-shared-library filename)
+ #+digitool (ccl:add-to-shared-library-search-path filename t)
- (push filename *loaded-libraries*)
- t)))))
+ (push filename *loaded-libraries*)
+ t)))))
(defun convert-supporting-libraries-to-string (libs)
(let (lib-load-list)
#+digitool
(let ((mcl-type (ccl:find-mactype type nil t)))
(if mcl-type
- (ccl::mactype-record-size mcl-type)
- (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record
+ (ccl::mactype-record-size mcl-type)
+ (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record
#+openmcl (ccl::%foreign-type-or-record-size type :bytes)
))
an array of TYPE with size SIZE. The TYPE parameter is evaluated."
(if (eq size :unspecified)
(progn
- #+(or cmu scl)
- `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
- #+sbcl
- `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
- #+lispworks
- `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
- #+allegro
- `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c)
- #+(or openmcl digitool)
- `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
- )
+ #+(or cmu scl)
+ `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+ #+sbcl
+ `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+ #+lispworks
+ `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
+ #+allegro
+ `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c)
+ #+(or openmcl digitool)
+ `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
+ )
(progn
- #+(or cmu scl)
- `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
- #+sbcl
- `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
- #+lispworks
- `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size)
- #+allegro
- `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c)
- #+(or openmcl digitool)
- `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
- )))
+ #+(or cmu scl)
+ `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
+ #+sbcl
+ `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
+ #+lispworks
+ `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size)
+ #+allegro
+ `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c)
+ #+(or openmcl digitool)
+ `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
+ )))
(defmacro free-foreign-object (obj)
#+(or cmu scl)
#+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
#+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
#+lispworks `(fli:make-pointer :type '(:unsigned :char)
- :address (fli:pointer-address ,obj))
+ :address (fli:pointer-address ,obj))
#+allegro obj
#+(or openmcl digitool) obj
)
#-(or cmu sbcl lispworks scl) ; default version
`(let ((,var (allocate-foreign-object ,type)))
(unwind-protect
- (progn ,@body)
+ (progn ,@body)
(free-foreign-object ,var)))
#+(or cmu scl)
(let ((obj (gensym))
- (ctype (convert-from-uffi-type (eval type) :allocate)))
+ (ctype (convert-from-uffi-type (eval type) :allocate)))
(if (and (consp ctype) (eq 'array (car ctype)))
- `(alien:with-alien ((,obj ,ctype))
- (let* ((,var ,obj))
- ,@body))
- `(alien:with-alien ((,obj ,ctype))
- (let* ((,var (alien:addr ,obj)))
- ,@body))))
+ `(alien:with-alien ((,obj ,ctype))
+ (let* ((,var ,obj))
+ ,@body))
+ `(alien:with-alien ((,obj ,ctype))
+ (let* ((,var (alien:addr ,obj)))
+ ,@body))))
#+sbcl
(let ((obj (gensym))
- (ctype (convert-from-uffi-type (eval type) :allocate)))
+ (ctype (convert-from-uffi-type (eval type) :allocate)))
(if (and (consp ctype) (eq 'array (car ctype)))
- `(sb-alien:with-alien ((,obj ,ctype))
- (let* ((,var ,obj))
- ,@body))
- `(sb-alien:with-alien ((,obj ,ctype))
- (let* ((,var (sb-alien:addr ,obj)))
- ,@body))))
+ `(sb-alien:with-alien ((,obj ,ctype))
+ (let* ((,var ,obj))
+ ,@body))
+ `(sb-alien:with-alien ((,obj ,ctype))
+ (let* ((,var (sb-alien:addr ,obj)))
+ ,@body))))
#+lispworks
`(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
- (eval type) :allocate)))
+ (eval type) :allocate)))
,@body)
)
(defmacro with-foreign-objects (bindings &rest body)
(if bindings
`(with-foreign-object ,(car bindings)
- (with-foreign-objects ,(cdr bindings)
- ,@body))
+ (with-foreign-objects ,(cdr bindings)
+ ,@body))
`(progn ,@body)))
#+(or openmcl digitool)
:shell-type "/bin/sh"
:output-stream output)
- #+clisp ;XXX not exactly *trace-output*, I know
+ #+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)))
+ (ccl:external-process-status
+ (ccl:run-program "/bin/sh" (list "-c" command)
+ :input nil :output output
+ :wait t)))
#-(or openmcl clisp lispworks allegro scl cmu sbcl)
(error "RUN-SHELL-PROGRAM not implemented for this Lisp.")
; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
; So this provides a function to convert any quoted symbols to keywords.
(defun keyword (obj)
- (cond ((keywordp obj)
+ (cond ((keywordp obj)
obj)
((null obj)
nil)
(keyword (cadr obj)))
((stringp obj)
(intern obj *keyword-package*))
- (t
+ (t
obj)))
; Wrapper for unexported function we have to use
(defmacro null-char-p (val)
"Returns T if character is NULL"
`(zerop ,val))
-
+
(defmacro def-foreign-type (name type)
#+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
#+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
#+digitool
`(def-mcl-type ,(keyword name) ,mcl-type)
#+openmcl
- `(ccl::def-foreign-type ,(keyword name) ,mcl-type))
+ `(ccl::def-foreign-type ,(keyword name) ,mcl-type))
)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
#+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
- (make-hash-table :size 20 :test #'eq))
+ (make-hash-table :size 20 :test #'eq))
)
#+(or cmu scl)
#+(or cmu scl)
(setq *type-conversion-list*
- '((* . *) (:void . c-call:void)
+ '((* . *) (:void . c-call:void)
(:pointer-void . (* t))
(:cstring . c-call:c-string)
- (:char . c-call:char)
+ (:char . c-call:char)
(:unsigned-char . (alien:unsigned 8))
(:byte . (alien:signed 8))
(:unsigned-byte . (alien:unsigned 8))
(:short . c-call:short)
(:unsigned-short . c-call:unsigned-short)
- (:int . alien:integer) (:unsigned-int . c-call:unsigned-int)
+ (:int . alien:integer) (:unsigned-int . c-call:unsigned-int)
(:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
(:float . c-call:float) (:double . c-call:double)
(:array . alien:array)))
#+sbcl
(setq *type-conversion-list*
- '((* . *) (:void . sb-alien:void)
+ '((* . *) (:void . sb-alien:void)
(:pointer-void . (* t))
#-sb-unicode(:cstring . sb-alien:c-string)
#+sb-unicode(:cstring . sb-alien:utf8-string)
- (:char . sb-alien:char)
+ (:char . sb-alien:char)
(:unsigned-char . (sb-alien:unsigned 8))
(:byte . (sb-alien:signed 8))
(:unsigned-byte . (sb-alien:unsigned 8))
(:short . sb-alien:short)
(:unsigned-short . sb-alien:unsigned-short)
- (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int)
+ (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int)
(:long . sb-alien:long) (:unsigned-long . sb-alien:unsigned-long)
(:float . sb-alien:float) (:double . sb-alien:double)
(:array . sb-alien:array)))
(:unsigned-byte . :unsigned-char)
(:char . :char)
(:unsigned-char . :unsigned-char)
- (:int . :int) (:unsigned-int . :unsigned-int)
+ (:int . :int) (:unsigned-int . :unsigned-int)
(:long . :long) (:unsigned-long . :unsigned-long)
(:float . :float) (:double . :double)
(:array . :array)))
#+lispworks
(setq *type-conversion-list*
- '((* . :pointer) (:void . :void)
+ '((* . :pointer) (:void . :void)
(:short . :short)
(:pointer-void . (:pointer :void))
(:cstring . (:reference-pass (:ef-mb-string :external-format
- (:latin-1 :eol-style :lf))
- :allow-null t))
+ (:latin-1 :eol-style :lf))
+ :allow-null t))
(:cstring-returning . (:reference (:ef-mb-string :external-format
- (:latin-1 :eol-style :lf))
- :allow-null t))
+ (:latin-1 :eol-style :lf))
+ :allow-null t))
(:byte . :byte)
(:unsigned-byte . (:unsigned :byte))
(:char . :char)
(defun basic-convert-from-uffi-type (type)
(let ((found-type (gethash type +type-conversion-hash+)))
(if found-type
- found-type
+ found-type
#-(or openmcl digitool) type
#+(or openmcl digitool) (keyword type))))
(cond
#+(or allegro cormanlisp)
((and (or (eq context :routine) (eq context :return))
- (eq type :cstring))
- (setq type '((* :char) integer)))
+ (eq type :cstring))
+ (setq type '((* :char) integer)))
#+(or cmu sbcl scl)
((eq context :type)
- (let ((cmu-type (gethash type *cmu-def-type-hash*)))
- (if cmu-type
- cmu-type
- (basic-convert-from-uffi-type type))))
+ (let ((cmu-type (gethash type *cmu-def-type-hash*)))
+ (if cmu-type
+ cmu-type
+ (basic-convert-from-uffi-type type))))
#+lispworks
((and (eq context :return)
- (eq type :cstring))
- (basic-convert-from-uffi-type :cstring-returning))
+ (eq type :cstring))
+ (basic-convert-from-uffi-type :cstring-returning))
#+digitool
((and (eq type :void) (eq context :return)) nil)
(t
- (basic-convert-from-uffi-type type)))
+ (basic-convert-from-uffi-type type)))
(let ((sub-type (car type)))
(case sub-type
- (cl:quote
- (convert-from-uffi-type (cadr type) context))
- (:struct-pointer
- #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
- #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
- )
- (:struct
- #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
- #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)
- )
+ (cl:quote
+ (convert-from-uffi-type (cadr type) context))
+ (:struct-pointer
+ #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+ #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
+ )
+ (:struct
+ #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+ #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)
+ )
(:union
- #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
- #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)
- )
+ #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
+ #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)
+ )
(t
- (cons (%convert-from-uffi-type (first type) context)
- (%convert-from-uffi-type (rest type) context)))))))
+ (cons (%convert-from-uffi-type (first type) context)
+ (%convert-from-uffi-type (rest type) context)))))))
(defun convert-from-uffi-type (type context)
(let ((result (%convert-from-uffi-type type context)))
#+openmcl
((eq (car result) :address)
(if (eq context :struct)
- (append '(:*) (cdr result))
- :address))
+ (append '(:*) (cdr result))
+ :address))
#+digitool
((and (eq (car result) :pointer) (eq context :allocation) :pointer))
(t result))))
(when (char= #\a (schar (symbol-name '#:a) 0))
(pushnew :uffi-lowercase-reader *features*))
(when (not (string= (symbol-name '#:a)
- (symbol-name '#:A)))
+ (symbol-name '#:A)))
(pushnew :uffi-case-sensitive *features*)))
(defun make-lisp-name (name)
(let ((converted (substitute #\- #\_ name)))
- (intern
+ (intern
#+uffi-case-sensitive converted
#+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
#+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (zerop ,stored)
- nil
- (values (excl:native-to-string ,stored)))))
+ nil
+ (values (excl:native-to-string ,stored)))))
#+(or openmcl digitool)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (ccl:%null-ptr-p ,stored)
- nil
- (values (ccl:%get-cstring ,stored)))))
+ nil
+ (values (ccl:%get-cstring ,stored)))))
)
(defmacro convert-to-cstring (obj)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (null ,stored)
- 0
- (values (excl:string-to-native ,stored)))))
+ 0
+ (values (excl:string-to-native ,stored)))))
#+(or openmcl digitool)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (null ,stored)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,stored)))))
- (ccl::%put-cstring ptr ,stored)
- ptr))))
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,stored)))))
+ (ccl::%put-cstring ptr ,stored)
+ ptr))))
)
(defmacro free-cstring (obj)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(unless (zerop ,stored)
- (ff:free-fobject ,stored))))
+ (ff:free-fobject ,stored))))
#+(or openmcl digitool)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(unless (ccl:%null-ptr-p ,stored)
- (dispose-ptr ,stored))))
+ (dispose-ptr ,stored))))
)
(defmacro with-cstring ((cstring lisp-string) &body body)
`(let ((,cstring ,lisp-string)) ,@body)
#+allegro
(let ((acl-native (gensym))
- (stored-lisp-string (gensym)))
+ (stored-lisp-string (gensym)))
`(let ((,stored-lisp-string ,lisp-string))
(excl:with-native-string (,acl-native ,stored-lisp-string)
- (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
- ,@body))))
+ (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
+ ,@body))))
#+(or openmcl digitool)
(let ((stored-lisp-string (gensym)))
`(let ((,stored-lisp-string ,lisp-string))
(if (stringp ,stored-lisp-string)
- (ccl:with-cstrs ((,cstring ,stored-lisp-string))
- ,@body)
- (let ((,cstring +null-cstring-pointer+))
- ,@body))))
+ (ccl:with-cstrs ((,cstring ,stored-lisp-string))
+ ,@body)
+ (let ((,cstring +null-cstring-pointer+))
+ ,@body))))
)
(defmacro with-cstrings (bindings &rest body)
(if bindings
`(with-cstring ,(car bindings)
- (with-cstrings ,(cdr bindings)
- ,@body))
+ (with-cstrings ,(cdr bindings)
+ ,@body))
`(progn ,@body)))
;;; Foreign string functions
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (null ,stored)
- +null-cstring-pointer+
- (fli:convert-to-foreign-string
- ,stored
- :external-format '(:latin-1 :eol-style :lf)))))
+ +null-cstring-pointer+
+ (fli:convert-to-foreign-string
+ ,stored
+ :external-format '(:latin-1 :eol-style :lf)))))
#+allegro
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (null ,stored)
- 0
- (values (excl:string-to-native ,stored)))))
+ 0
+ (values (excl:string-to-native ,stored)))))
#+(or cmu scl)
(let ((size (gensym))
- (storage (gensym))
- (stored-obj (gensym))
- (i (gensym)))
+ (storage (gensym))
+ (stored-obj (gensym))
+ (i (gensym)))
`(let ((,stored-obj ,obj))
(etypecase ,stored-obj
- (null
- (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
- (string
- (let* ((,size (length ,stored-obj))
- (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
- (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (,i ,size)
- (declare (fixnum ,i))
- (setf (alien:deref ,storage ,i)
- (char-code (char ,stored-obj ,i))))
- (setf (alien:deref ,storage ,size) 0))
- ,storage)))))
+ (null
+ (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+ (string
+ (let* ((,size (length ,stored-obj))
+ (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
+ (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (dotimes (,i ,size)
+ (declare (fixnum ,i))
+ (setf (alien:deref ,storage ,i)
+ (char-code (char ,stored-obj ,i))))
+ (setf (alien:deref ,storage ,size) 0))
+ ,storage)))))
#+sbcl
(let ((size (gensym))
- (storage (gensym))
- (stored-obj (gensym))
- (i (gensym)))
+ (storage (gensym))
+ (stored-obj (gensym))
+ (i (gensym)))
`(let ((,stored-obj ,obj))
(etypecase ,stored-obj
- (null
- (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
- (string
- (let* ((,size (length ,stored-obj))
- (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
- (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (,i ,size)
- (declare (fixnum ,i))
- (setf (sb-alien:deref ,storage ,i)
- (char-code (char ,stored-obj ,i))))
- (setf (sb-alien:deref ,storage ,size) 0))
- ,storage)))))
+ (null
+ (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+ (string
+ (let* ((,size (length ,stored-obj))
+ (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
+ (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (dotimes (,i ,size)
+ (declare (fixnum ,i))
+ (setf (sb-alien:deref ,storage ,i)
+ (char-code (char ,stored-obj ,i))))
+ (setf (sb-alien:deref ,storage ,size) 0))
+ ,storage)))))
#+(or openmcl digitool)
(let ((stored-obj (gensym)))
`(let ((,stored-obj ,obj))
(if (null ,stored-obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
- (ccl::%put-cstring ptr ,stored-obj)
- ptr))))
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
+ (ccl::%put-cstring ptr ,stored-obj)
+ ptr))))
)
;; Either length or null-terminated-p must be non-nil
(defmacro convert-from-foreign-string (obj &key
- length
- (locale :default)
- (null-terminated-p t))
+ length
+ (locale :default)
+ (null-terminated-p t))
#+allegro
(let ((stored-obj (gensym)))
`(let ((,stored-obj ,obj))
(if (zerop ,stored-obj)
- nil
- (if (eq ,locale :none)
- (fast-native-to-string ,stored-obj ,length)
- (values
- (excl:native-to-string
- ,stored-obj
- ,@(when length (list :length length))
- :truncate (not ,null-terminated-p)))))))
+ nil
+ (if (eq ,locale :none)
+ (fast-native-to-string ,stored-obj ,length)
+ (values
+ (excl:native-to-string
+ ,stored-obj
+ ,@(when length (list :length length))
+ :truncate (not ,null-terminated-p)))))))
#+lispworks
(let ((stored-obj (gensym)))
`(let ((,stored-obj ,obj))
(if (fli:null-pointer-p ,stored-obj)
- nil
- (if (eq ,locale :none)
- (fast-native-to-string ,stored-obj ,length)
- (fli:convert-from-foreign-string
- ,stored-obj
- ,@(when length (list :length length))
- :null-terminated-p ,null-terminated-p
- :external-format '(:latin-1 :eol-style :lf))))))
+ nil
+ (if (eq ,locale :none)
+ (fast-native-to-string ,stored-obj ,length)
+ (fli:convert-from-foreign-string
+ ,stored-obj
+ ,@(when length (list :length length))
+ :null-terminated-p ,null-terminated-p
+ :external-format '(:latin-1 :eol-style :lf))))))
#+(or cmu scl)
(let ((stored-obj (gensym)))
`(let ((,stored-obj ,obj))
(if (null-pointer-p ,stored-obj)
- nil
- (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
- :length ,length
- :null-terminated-p ,null-terminated-p))))
+ nil
+ (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
+ :length ,length
+ :null-terminated-p ,null-terminated-p))))
#+sbcl
(let ((stored-obj (gensym)))
`(let ((,stored-obj ,obj))
(if (null-pointer-p ,stored-obj)
- nil
- (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
- :length ,length
- :null-terminated-p ,null-terminated-p))))
+ nil
+ (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
+ :length ,length
+ :null-terminated-p ,null-terminated-p))))
#+(or openmcl digitool)
(declare (ignore null-terminated-p))
#+(or openmcl digitool)
(let ((stored-obj (gensym)))
`(let ((,stored-obj ,obj))
(if (ccl:%null-ptr-p ,stored-obj)
- nil
- #+digitool (ccl:%get-cstring
- ,stored-obj 0
- ,@(if length (list length) nil))
- #+openmcl ,@(if length
- `((ccl:%str-from-ptr ,stored-obj ,length))
- `((ccl:%get-cstring ,stored-obj))))))
+ nil
+ #+digitool (ccl:%get-cstring
+ ,stored-obj 0
+ ,@(if length (list length) nil))
+ #+openmcl ,@(if length
+ `((ccl:%str-from-ptr ,stored-obj ,length))
+ `((ccl:%get-cstring ,stored-obj))))))
)
(let ((array-def (gensym)))
`(let ((,array-def (list 'alien:array 'c-call:char ,size)))
(eval `(alien:cast (alien:make-alien ,,array-def)
- ,(if ,unsigned
- '(* (alien:unsigned 8))
- '(* (alien:signed 8)))))))
+ ,(if ,unsigned
+ '(* (alien:unsigned 8))
+ '(* (alien:signed 8)))))))
#+(or cmu scl)
`(alien:make-alien ,(if unsigned
- '(alien:unsigned 8)
- '(alien:signed 8))
+ '(alien:unsigned 8)
+ '(alien:signed 8))
,size)
#+sbcl
`(sb-alien:make-alien ,(if unsigned
- '(sb-alien:unsigned 8)
- '(sb-alien:signed 8))
+ '(sb-alien:unsigned 8)
+ '(sb-alien:signed 8))
,size)
#+lispworks
`(fli:allocate-foreign-object :type
- ,(if unsigned
- ''(:unsigned :char)
- :char)
- :nelems ,size)
+ ,(if unsigned
+ ''(:unsigned :char)
+ :char)
+ :nelems ,size)
#+allegro
(declare (ignore unsigned))
#+allegro
(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
(let ((result (gensym)))
`(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
- (,result (progn ,@body)))
+ (,result (progn ,@body)))
(declare (dynamic-extent ,foreign-string))
(free-foreign-object ,foreign-string)
,result)))
(locally
(declare (optimize (speed 3) (safety 0)))
(let ((null-terminated-length
- (when null-terminated-p
- (loop
- for offset of-type fixnum upfrom 0
- until (zerop (system:sap-ref-8 sap offset))
- finally (return offset)))))
+ (when null-terminated-p
+ (loop
+ for offset of-type fixnum upfrom 0
+ until (zerop (system:sap-ref-8 sap offset))
+ finally (return offset)))))
(if length
- (if (and null-terminated-length
- (> (the fixnum length) (the fixnum null-terminated-length)))
- (setq length null-terminated-length))
- (setq length null-terminated-length)))
+ (if (and null-terminated-length
+ (> (the fixnum length) (the fixnum null-terminated-length)))
+ (setq length null-terminated-length))
+ (setq length null-terminated-length)))
(let ((result (make-string length)))
(kernel:copy-from-system-area sap 0
- result (* vm:vector-data-offset
- vm:word-bits)
- (* length vm:byte-bits))
+ result (* vm:vector-data-offset
+ vm:word-bits)
+ (* length vm:byte-bits))
result)))
#+scl
(locally
(declare (optimize (speed 3) (safety 0)))
(let ((null-terminated-length
- (when null-terminated-p
- (loop
- for offset of-type fixnum upfrom 0
- until (zerop (system:sap-ref-8 sap offset))
- finally (return offset)))))
+ (when null-terminated-p
+ (loop
+ for offset of-type fixnum upfrom 0
+ until (zerop (system:sap-ref-8 sap offset))
+ finally (return offset)))))
(if length
- (if (and null-terminated-length
- (> (the fixnum length) (the fixnum null-terminated-length)))
- (setq length null-terminated-length))
- (setq length null-terminated-length)))
+ (if (and null-terminated-length
+ (> (the fixnum length) (the fixnum null-terminated-length)))
+ (setq length null-terminated-length))
+ (setq length null-terminated-length)))
(let ((result (make-string length)))
(dotimes (i length)
- (declare (type fixnum i))
- (setf (char result i) (code-char (system:sap-ref-8 sap i))))
+ (declare (type fixnum i))
+ (setf (char result i) (code-char (system:sap-ref-8 sap i))))
result)))
#+(and sbcl (not sb-unicode))
(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
(declare (type sb-sys:system-area-pointer sap)
- (type (or null fixnum) length))
+ (type (or null fixnum) length))
(locally
(declare (optimize (speed 3) (safety 0)))
(let ((null-terminated-length
- (when null-terminated-p
- (loop
- for offset of-type fixnum upfrom 0
- until (zerop (sb-sys:sap-ref-8 sap offset))
- finally (return offset)))))
+ (when null-terminated-p
+ (loop
+ for offset of-type fixnum upfrom 0
+ until (zerop (sb-sys:sap-ref-8 sap offset))
+ finally (return offset)))))
(if length
- (if (and null-terminated-length
- (> (the fixnum length) (the fixnum null-terminated-length)))
- (setq length null-terminated-length))
+ (if (and null-terminated-length
+ (> (the fixnum length) (the fixnum null-terminated-length)))
+ (setq length null-terminated-length))
(setq length null-terminated-length)))
(let ((result (make-string length)))
(funcall *system-copy-fn* sap 0 result +system-copy-offset+
- (* length +system-copy-multiplier+))
+ (* length +system-copy-multiplier+))
result)))
#+(and sbcl sb-unicode)
(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
(declare (type sb-sys:system-area-pointer sap)
- (type (or null fixnum) length))
+ (type (or null fixnum) length))
(locally
(declare (optimize (speed 3) (safety 0)))
(cond
(null-terminated-p
(let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
- #+sb-unicode sb-alien:utf8-string
- #-sb-unicode sb-alien:c-string)))
+ #+sb-unicode sb-alien:utf8-string
+ #-sb-unicode sb-alien:c-string)))
(if length
- (copy-seq (subseq casted 0 length))
- (copy-seq casted))))
+ (copy-seq (subseq casted 0 length))
+ (copy-seq casted))))
(t
(let ((result (make-string length)))
;; this will not work in sb-unicode
(funcall *system-copy-fn* sap 0 result +system-copy-offset+
- (* length +system-copy-multiplier+))
+ (* length +system-copy-multiplier+))
result)))))
#+(or (and allegro (not ics)) (and lispworks (not lispworks5)))
(defun fast-native-to-string (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
- (type char-ptr-def s))
+ (type char-ptr-def s))
(let* ((len (or len (strlen s)))
(str (make-string len)))
(declare (fixnum len)
- (type (simple-array #+lispworks base-char
+ (type (simple-array #+lispworks base-char
#-lispworks (signed-byte 8) (*)) str))
(dotimes (i len str)
(setf (aref str i)
- (uffi:deref-array s '(:array :char) i)))))
+ (uffi:deref-array s '(:array :char) i)))))
#+(or (and allegro ics) lispworks5)
(defun fast-native-to-string (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
- (type char-ptr-def s))
+ (type char-ptr-def s))
(let* ((len (or len (strlen s)))
(str (make-string len)))
(dotimes (i len str)
(deftest :array.1
(let ((a (uffi:allocate-foreign-object :long +column-length+))
- (results nil))
+ (results nil))
(dotimes (i +column-length+)
- (setf (uffi:deref-array a '(:array :long) i) (* i i)))
+ (setf (uffi:deref-array a '(:array :long) i) (* i i)))
(dotimes (i +column-length+)
- (push (uffi:deref-array a '(:array :long) i) results))
+ (push (uffi:deref-array a '(:array :long) i) results))
(uffi:free-foreign-object a)
(nreverse results))
(0 1 4 9 16 25 36 49 64 81))
(deftest :array.2
(let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+))
- (results nil))
+ (results nil))
(dotimes (r +row-length+)
- (declare (fixnum r))
- (setf (uffi:deref-array a '(:array (* :long)) r)
- (uffi:allocate-foreign-object :long +column-length+))
- (let ((col (uffi:deref-array a '(:array (* :long)) r)))
- (dotimes (c +column-length+)
- (declare (fixnum c))
- (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
-
+ (declare (fixnum r))
+ (setf (uffi:deref-array a '(:array (* :long)) r)
+ (uffi:allocate-foreign-object :long +column-length+))
+ (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+ (dotimes (c +column-length+)
+ (declare (fixnum c))
+ (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
+
(dotimes (r +row-length+)
- (declare (fixnum r))
- (let ((col (uffi:deref-array a '(:array (* :long)) r)))
- (dotimes (c +column-length+)
- (declare (fixnum c))
- (push (uffi:deref-array col '(:array :long) c) results))))
+ (declare (fixnum r))
+ (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+ (dotimes (c +column-length+)
+ (declare (fixnum c))
+ (push (uffi:deref-array col '(:array :long) c) results))))
(uffi:free-foreign-object a)
(nreverse results))
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99))
(in-package #:uffi-tests)
-(uffi:def-function ("atoi" c-atoi)
+(uffi:def-function ("atoi" c-atoi)
((str :cstring))
:returning :int)
-(uffi:def-function ("atol" c-atol)
+(uffi:def-function ("atol" c-atol)
((str :cstring))
:returning :long)
-(uffi:def-function ("atof" c-atof)
+(uffi:def-function ("atof" c-atof)
((str :cstring))
:returning :double)
"Returns a double float from a string."
(uffi:with-cstring (str-cstring str)
(c-atof str-cstring)))
-
+
(deftest :atoi.1 (atoi "123") 123)
(deftest :atoi.2 (atoi "") 0)
(deftest :atof.3 (atof "2.23") 2.23d0)
(assert (= (uffi:deref-pointer temp :int) 23)))
(let ((result (cast-test-int)))
(uffi:with-cast-pointer (result2 result :int)
- (assert (= (uffi:deref-pointer result2 :int) 23)))
+ (assert (= (uffi:deref-pointer result2 :int) 23)))
(uffi:with-cast-pointer (temp result :int)
- (assert (= (uffi:deref-pointer temp :int) 23))))
+ (assert (= (uffi:deref-pointer temp :int) 23))))
t)
t)
(deftest :cast.2
(progn
(uffi:with-cast-pointer (temp (cast-test-float) :double)
- (assert (= (uffi:deref-pointer temp :double) 3.21d0)))
+ (assert (= (uffi:deref-pointer temp :double) 3.21d0)))
(let ((result (cast-test-float)))
- (uffi:with-cast-pointer (result2 result :double)
- (assert (= (uffi:deref-pointer result2 :double) 3.21d0)))
- (uffi:with-cast-pointer (temp result :double)
- (assert (= (uffi:deref-pointer temp :double) 3.21d0))))
+ (uffi:with-cast-pointer (result2 result :double)
+ (assert (= (uffi:deref-pointer result2 :double) 3.21d0)))
+ (uffi:with-cast-pointer (temp result :double)
+ (assert (= (uffi:deref-pointer temp :double) 3.21d0))))
t)
t)
(source-len :long))
:returning :int
:module "zlib")
-
+
(defun compress (source)
"Returns two values: array of bytes containing the compressed data
and the numbe of compressed bytes"
(let* ((sourcelen (length source))
- (destsize (+ 12 (ceiling (* sourcelen 1.01))))
- (dest (uffi:allocate-foreign-string destsize :unsigned t))
- (destlen (uffi:allocate-foreign-object :long)))
+ (destsize (+ 12 (ceiling (* sourcelen 1.01))))
+ (dest (uffi:allocate-foreign-string destsize :unsigned t))
+ (destlen (uffi:allocate-foreign-object :long)))
(setf (uffi:deref-pointer destlen :long) destsize)
(uffi:with-cstring (source-native source)
(let ((result (c-compress dest destlen source-native sourcelen))
- (newdestlen (uffi:deref-pointer destlen :long)))
- (unwind-protect
- (if (zerop result)
- (values (uffi:convert-from-foreign-usb8
- dest newdestlen)
- newdestlen)
- (error "zlib error, code ~D" result))
- (progn
- (uffi:free-foreign-object destlen)
- (uffi:free-foreign-object dest)))))))
+ (newdestlen (uffi:deref-pointer destlen :long)))
+ (unwind-protect
+ (if (zerop result)
+ (values (uffi:convert-from-foreign-usb8
+ dest newdestlen)
+ newdestlen)
+ (error "zlib error, code ~D" result))
+ (progn
+ (uffi:free-foreign-object destlen)
+ (uffi:free-foreign-object dest)))))))
(uffi:def-function ("uncompress" c-uncompress)
((dest (* :unsigned-char))
(defun uncompress (source)
(let* ((sourcelen (length source))
- (destsize 200000) ;adjust as needed
- (dest (uffi:allocate-foreign-string destsize :unsigned t))
- (destlen (uffi:allocate-foreign-object :long)))
+ (destsize 200000) ;adjust as needed
+ (dest (uffi:allocate-foreign-string destsize :unsigned t))
+ (destlen (uffi:allocate-foreign-object :long)))
(setf (uffi:deref-pointer destlen :long) destsize)
(uffi:with-cstring (source-native source)
(let ((result (c-uncompress dest destlen source-native sourcelen))
- (newdestlen (uffi:deref-pointer destlen :long)))
- (unwind-protect
- (if (zerop result)
- (uffi:convert-from-foreign-string
- dest
- :length newdestlen
- :null-terminated-p nil)
- (error "zlib error, code ~D" result))
- (progn
- (uffi:free-foreign-object destlen)
- (uffi:free-foreign-object dest)))))))
+ (newdestlen (uffi:deref-pointer destlen :long)))
+ (unwind-protect
+ (if (zerop result)
+ (uffi:convert-from-foreign-string
+ dest
+ :length newdestlen
+ :null-terminated-p nil)
+ (error "zlib error, code ~D" result))
+ (progn
+ (uffi:free-foreign-object destlen)
+ (uffi:free-foreign-object dest)))))))
(deftest :compress.1 (compress "")
#(120 156 3 0 0 0 0 1) 8)
#+clisp (uffi:load-foreign-library "/usr/lib/libz.so" :module "z")
#-clisp
(unless (uffi:load-foreign-library
- (uffi:find-foreign-library
- #-(or macosx darwin)
- "libz"
- #+(or macosx darwin)
- "z"
- (list (pathname-directory *load-pathname*)
- "/usr/local/lib/" #+(or 64bit x86-64) "/usr/lib64/"
- "/usr/lib/" "/zlib/"))
- :module "zlib"
- :supporting-libraries '("c"))
+ (uffi:find-foreign-library
+ #-(or macosx darwin)
+ "libz"
+ #+(or macosx darwin)
+ "z"
+ (list (pathname-directory *load-pathname*)
+ "/usr/local/lib/" #+(or 64bit x86-64) "/usr/lib64/"
+ "/usr/lib/" "/zlib/"))
+ :module "zlib"
+ :supporting-libraries '("c"))
(warn "Unable to load zlib"))
#+clisp (uffi:load-foreign-library "/home/kevin/debian/src/uffi/tests/uffi-c-test.so" :module "uffi_tests")
#-clisp
(unless (uffi:load-foreign-library
- (uffi:find-foreign-library
- '(#+(or 64bit x86-64) "uffi-c-test64" "uffi-c-test")
- (list (pathname-directory *load-truename*)
- "/usr/lib/uffi/"
- "/home/kevin/debian/src/uffi/tests/"))
- :supporting-libraries '("c")
- :module "uffi_tests")
+ (uffi:find-foreign-library
+ '(#+(or 64bit x86-64) "uffi-c-test64" "uffi-c-test")
+ (list (pathname-directory *load-truename*)
+ "/usr/lib/uffi/"
+ "/home/kevin/debian/src/uffi/tests/"))
+ :supporting-libraries '("c")
+ :module "uffi_tests")
(warn "Unable to load uffi-c-test library"))
(uffi:def-struct fvar-struct
(i :int)
(d :double))
-
+
(uffi:def-foreign-var ("fvar_struct" *fvar-struct*) fvar-struct
"uffi_tests")
()
:returning :int
:module "uffi_tests")
-
+
(uffi:def-function ("fvar_struct_double" fvar-struct-double)
()
:returning :double
:module "uffi_tests")
-
+
(deftest :fvarst.1 *fvar-addend* 3)
(deftest :fvarst.2 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 42)
(deftest :fvarst.3 (= (+ *fvar-addend*
- (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i))
- (fvar-struct-int))
+ (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i))
+ (fvar-struct-int))
t)
(deftest :fvarst.4 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd) 3.2d0)
(deftest :fvarst.5 (= (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd)
- (fvar-struct-double))
+ (fvar-struct-double))
t)
-(deftest fvarst.6
+(deftest fvarst.6
(let ((orig *fvar-addend*))
(incf *fvar-addend* 3)
(prog1
- *fvar-addend*
- (setf *fvar-addend* orig)))
+ *fvar-addend*
+ (setf *fvar-addend* orig)))
6)
-(deftest fvarst.7
+(deftest fvarst.7
(let ((orig *fvar-addend*))
(incf *fvar-addend* 3)
(prog1
- (fvar-struct-int)
- (setf *fvar-addend* orig)))
+ (fvar-struct-int)
+ (setf *fvar-addend* orig)))
48)
-(deftest fvarst.8
+(deftest fvarst.8
(let ((orig (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i)))
(decf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 10)
(prog1
- (fvar-struct-int)
- (setf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) orig)))
+ (fvar-struct-int)
+ (setf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) orig)))
35)
(in-package #:uffi-tests)
-(uffi:def-function ("getenv" c-getenv)
+(uffi:def-function ("getenv" c-getenv)
((name :cstring))
:returning :cstring)
-(uffi:def-function ("setenv" c-setenv)
+(uffi:def-function ("setenv" c-setenv)
((name :cstring)
(value :cstring)
(overwrite :int))
(check-type name string)
(setq overwrite (if overwrite 1 0))
(uffi:with-cstrings ((key-native key)
- (name-native name))
+ (name-native name))
(c-setenv key-native name-native (if overwrite 1 0))))
(defun my-unsetenv (key)
(c-unsetenv key-native)))
(deftest :getenv.1 (progn
- (my-unsetenv "__UFFI_FOO1__")
- (my-getenv "__UFFI_FOO1__"))
+ (my-unsetenv "__UFFI_FOO1__")
+ (my-getenv "__UFFI_FOO1__"))
nil)
(deftest :getenv.2 (progn
- (my-setenv "__UFFI_FOO1__" "UFFI-TEST")
- (my-getenv "__UFFI_FOO1__"))
+ (my-setenv "__UFFI_FOO1__" "UFFI-TEST")
+ (my-getenv "__UFFI_FOO1__"))
"UFFI-TEST")
;;; This example is inspired by the example on the CL-Cookbook web site
(eval-when (:compile-toplevel :load-toplevel :execute)
- (uffi:def-function ("gethostname" c-gethostname)
+ (uffi:def-function ("gethostname" c-gethostname)
((name (* :unsigned-char))
(len :int))
:returning :int)
-
+
(defun gethostname ()
"Returns the hostname"
(let* ((name (uffi:allocate-foreign-string 256))
- (result-code (c-gethostname name 256))
- (hostname (when (zerop result-code)
- (uffi:convert-from-foreign-string name))))
+ (result-code (c-gethostname name 256))
+ (hostname (when (zerop result-code)
+ (uffi:convert-from-foreign-string name))))
(uffi:free-foreign-object name)
(unless (zerop result-code)
- (error "gethostname() failed."))
+ (error "gethostname() failed."))
hostname))
-
+
(defun gethostname2 ()
"Returns the hostname"
(uffi:with-foreign-object (name '(:array :unsigned-char 256))
(if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
- (uffi:convert-from-foreign-string name)
- (error "gethostname() failed.")))))
+ (uffi:convert-from-foreign-string name)
+ (error "gethostname() failed.")))))
(deftest :gethostname.1 (stringp (gethostname)) t)
(deftest :gethostname.2 (stringp (gethostname2)) t)
(deftest :chptr.1
(let ((native-string "test string"))
(uffi:with-foreign-string (fs native-string)
- (ensure-char-character
- (deref-pointer fs :char))))
+ (ensure-char-character
+ (deref-pointer fs :char))))
#\t)
(deftest :chptr.2
(let ((native-string "test string"))
(uffi:with-foreign-string (fs native-string)
- (ensure-char-character
- (deref-pointer fs :unsigned-char))))
+ (ensure-char-character
+ (deref-pointer fs :unsigned-char))))
#\t)
(deftest :chptr.3
(let ((native-string "test string"))
(uffi:with-foreign-string (fs native-string)
- (ensure-char-integer
- (deref-pointer fs :unsigned-char))))
+ (ensure-char-integer
+ (deref-pointer fs :unsigned-char))))
116)
(deftest :chptr.4
(let ((native-string "test string"))
(uffi:with-foreign-string (fs native-string)
- (integerp
- (ensure-char-integer
- (deref-pointer fs :unsigned-char)))))
+ (integerp
+ (ensure-char-integer
+ (deref-pointer fs :unsigned-char)))))
t)
-
+
(deftest :chptr.5
(let ((fs (uffi:allocate-foreign-object :unsigned-char 128)))
(setf (uffi:deref-array fs '(:array :unsigned-char) 0)
- (uffi:ensure-char-storable #\a))
+ (uffi:ensure-char-storable #\a))
(setf (uffi:deref-array fs '(:array :unsigned-char) 1)
- (uffi:ensure-char-storable (code-char 0)))
+ (uffi:ensure-char-storable (code-char 0)))
(uffi:convert-from-foreign-string fs))
"a")
(deftest :chptr.6
(uffi:with-foreign-object (fs '(:array :unsigned-char 128))
(setf (uffi:deref-array fs '(:array :unsigned-char) 0)
- (uffi:ensure-char-storable #\a))
+ (uffi:ensure-char-storable #\a))
(setf (uffi:deref-array fs '(:array :unsigned-char) 1)
- (uffi:ensure-char-storable (code-char 0)))
+ (uffi:ensure-char-storable (code-char 0)))
(uffi:convert-from-foreign-string fs))
"a")
-
-
+
+
|----------------------------------------------------------------------------|#
(defpackage #:regression-test
- (:nicknames #:rtest #-lispworks #:rt)
+ (:nicknames #:rtest #-lispworks #:rt)
(:use #:cl)
(:export #:*do-tests-when-defined* #:*test* #:continue-testing
- #:deftest #:do-test #:do-tests #:get-test #:pending-tests
- #:rem-all-tests #:rem-test)
+ #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+ #:rem-all-tests #:rem-test)
(:documentation "The MIT regression tester with pfdietz's modifications"))
(in-package :regression-test)
"A list of test names that are expected to fail.")
(defstruct (entry (:conc-name nil)
- (:type list))
+ (:type list))
pend name form)
(defmacro vals (entry) `(cdddr ,entry))
(defun get-entry (name)
(let ((entry (find name (cdr *entries*)
- :key #'name
- :test #'equal)))
+ :key #'name
+ :test #'equal)))
(when (null entry)
(report-error t
"~%No test with name ~:@(~S~)."
- name))
+ name))
entry))
(defmacro deftest (name form &rest values)
(when (null (cdr l))
(setf (cdr l) (list entry))
(return nil))
- (when (equal (name (cadr l))
- (name entry))
+ (when (equal (name (cadr l))
+ (name entry))
(setf (cadr l) entry)
(report-error nil
"Redefining test ~:@(~S~)"
(setq *test* (name entry)))
(defun report-error (error? &rest args)
- (cond (*debug*
- (apply #'format t args)
- (if error? (throw '*debug* nil)))
- (error? (apply #'error args))
- (t (apply #'warn args))))
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args))))
(defun do-test (&optional (name *test*))
(do-entry (get-entry name)))
((eq x y) t)
((consp x)
(and (consp y)
- (equalp-with-case (car x) (car y))
- (equalp-with-case (cdr x) (cdr y))))
+ (equalp-with-case (car x) (car y))
+ (equalp-with-case (cdr x) (cdr y))))
((and (typep x 'array)
- (= (array-rank x) 0))
+ (= (array-rank x) 0))
(equalp-with-case (aref x) (aref y)))
((typep x 'vector)
(and (typep y 'vector)
- (let ((x-len (length x))
- (y-len (length y)))
- (and (eql x-len y-len)
- (loop
- for e1 across x
- for e2 across y
- always (equalp-with-case e1 e2))))))
+ (let ((x-len (length x))
+ (y-len (length y)))
+ (and (eql x-len y-len)
+ (loop
+ for e1 across x
+ for e2 across y
+ always (equalp-with-case e1 e2))))))
((and (typep x 'array)
- (typep y 'array)
- (not (equal (array-dimensions x)
- (array-dimensions y))))
+ (typep y 'array)
+ (not (equal (array-dimensions x)
+ (array-dimensions y))))
nil)
((typep x 'array)
(and (typep y 'array)
- (let ((size (array-total-size x)))
- (loop for i from 0 below size
- always (equalp-with-case (row-major-aref x i)
- (row-major-aref y i))))))
+ (let ((size (array-total-size x)))
+ (loop for i from 0 below size
+ always (equalp-with-case (row-major-aref x i)
+ (row-major-aref y i))))))
(t (eql x y))))
(defun do-entry (entry &optional
- (s *standard-output*))
+ (s *standard-output*))
(catch '*in-test*
(setq *test* (name entry))
(setf (pend entry) t)
(let* ((*in-test* t)
- ;; (*break-on-warnings* t)
- (aborted nil)
- r)
+ ;; (*break-on-warnings* t)
+ (aborted nil)
+ r)
;; (declare (special *break-on-warnings*))
(block aborted
- (setf r
- (flet ((%do
- ()
- (if *compile-tests*
- (multiple-value-list
- (funcall (compile
- nil
- `(lambda ()
- (declare
- (optimize ,@*optimization-settings*))
- ,(form entry)))))
- (multiple-value-list
- (eval (form entry))))))
- (if *catch-errors*
- (handler-bind
- ((style-warning #'muffle-warning)
- (error #'(lambda (c)
- (setf aborted t)
- (setf r (list c))
- (return-from aborted nil))))
- (%do))
- (%do)))))
+ (setf r
+ (flet ((%do
+ ()
+ (if *compile-tests*
+ (multiple-value-list
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare
+ (optimize ,@*optimization-settings*))
+ ,(form entry)))))
+ (multiple-value-list
+ (eval (form entry))))))
+ (if *catch-errors*
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (error #'(lambda (c)
+ (setf aborted t)
+ (setf r (list c))
+ (return-from aborted nil))))
+ (%do))
+ (%do)))))
(setf (pend entry)
- (or aborted
- (not (equalp-with-case r (vals entry)))))
-
+ (or aborted
+ (not (equalp-with-case r (vals entry)))))
+
(when (pend entry)
- (let ((*print-circle* *print-circle-on-failure*))
- (format s "~&Test ~:@(~S~) failed~
+ (let ((*print-circle* *print-circle-on-failure*))
+ (format s "~&Test ~:@(~S~) failed~
~%Form: ~S~
~%Expected value~P: ~
~{~S~^~%~17t~}~%"
- *test* (form entry)
- (length (vals entry))
- (vals entry))
- (format s "Actual value~P: ~
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry))
+ (format s "Actual value~P: ~
~{~S~^~%~15t~}.~%"
- (length r) r)))))
+ (length r) r)))))
(when (not (pend entry)) *test*))
(defun continue-testing ()
(do-entries *standard-output*)))
(defun do-tests (&optional
- (out *standard-output*))
+ (out *standard-output*))
(dolist (entry (cdr *entries*))
(setf (pend entry) t))
(if (streamp out)
(do-entries out)
- (with-open-file
- (stream out :direction :output)
- (do-entries stream))))
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
(defun do-entries (s)
(format s "~&Doing ~A pending test~:P ~
of ~A tests total.~%"
(count t (cdr *entries*)
- :key #'pend)
- (length (cdr *entries*)))
+ :key #'pend)
+ (length (cdr *entries*)))
(dolist (entry (cdr *entries*))
(when (pend entry)
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
- (do-entry entry s))))
+ (do-entry entry s))))
(let ((pending (pending-tests))
- (expected-table (make-hash-table :test #'equal)))
+ (expected-table (make-hash-table :test #'equal)))
(dolist (ex *expected-failures*)
(setf (gethash ex expected-table) t))
(let ((new-failures
- (loop for pend in pending
- unless (gethash pend expected-table)
- collect pend)))
+ (loop for pend in pending
+ unless (gethash pend expected-table)
+ collect pend)))
(if (null pending)
- (format s "~&No tests failed.")
- (progn
- (format s "~&~A out of ~A ~
+ (format s "~&No tests failed.")
+ (progn
+ (format s "~&~A out of ~A ~
total tests failed: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
- (length pending)
- (length (cdr *entries*))
- pending)
- (if (null new-failures)
- (format s "~&No unexpected failures.")
- (when *expected-failures*
- (format s "~&~A unexpected failures: ~
+ (length pending)
+ (length (cdr *entries*))
+ pending)
+ (if (null new-failures)
+ (format s "~&No unexpected failures.")
+ (when *expected-failures*
+ (format s "~&~A unexpected failures: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
- (length new-failures)
- new-failures)))
- ))
+ (length new-failures)
+ new-failures)))
+ ))
(null pending))))
(in-package #:uffi-tests)
(uffi:def-foreign-type char-ptr (* :unsigned-char))
-
+
;; This example does not use :cstring to pass the input string since
;; the routine needs to do pointer arithmetic to see how many characters
;; were parsed
-(uffi:def-function ("strtol" c-strtol)
+(uffi:def-function ("strtol" c-strtol)
((nptr char-ptr)
(endptr (* char-ptr))
(base :int))
their was no string at all, or an integer indicating position in string
of first non-valid character"
(let* ((str-native (uffi:convert-to-foreign-string str))
- (endptr (uffi:allocate-foreign-object 'char-ptr))
- (value (c-strtol str-native endptr base))
- (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
+ (endptr (uffi:allocate-foreign-object 'char-ptr))
+ (value (c-strtol str-native endptr base))
+ (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
(unwind-protect
- (if (uffi:null-pointer-p endptr-value)
- (values value t)
- (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
- (chars-parsed (- (uffi:pointer-address endptr-value)
- (uffi:pointer-address str-native))))
- (cond
- ((zerop chars-parsed)
- (values nil nil))
- ((uffi:null-char-p next-char-value)
- (values value t))
- (t
- (values value chars-parsed)))))
+ (if (uffi:null-pointer-p endptr-value)
+ (values value t)
+ (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
+ (chars-parsed (- (uffi:pointer-address endptr-value)
+ (uffi:pointer-address str-native))))
+ (cond
+ ((zerop chars-parsed)
+ (values nil nil))
+ ((uffi:null-char-p next-char-value)
+ (values value t))
+ (t
+ (values value chars-parsed)))))
(progn
- (uffi:free-foreign-object str-native)
- (uffi:free-foreign-object endptr)))))
+ (uffi:free-foreign-object str-native)
+ (uffi:free-foreign-object endptr)))))
(deftest :strtol.1 (strtol "123") 123 t)
(deftest :strtol.2 (strtol "0") 0 t)
(deftest :strtol.4 (strtol "a") nil nil)
-
+
(uffi:def-foreign-type foo-ptr (* foo))
;; tests that compilation worked
-(deftest :structs.1
+(deftest :structs.1
(with-foreign-object (p 'foo)
t)
t)
;; gmoffset present on SusE SLES9
(gmoffset :long))
-(uffi:def-function ("time" c-time)
+(uffi:def-function ("time" c-time)
((time (* time-t)))
:returning time-t)
(setf (uffi:deref-pointer time :unsigned-long) 7381)
(let ((tm-ptr (the tm-pointer (gmtime time))))
(values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
- (uffi:get-slot-value tm-ptr 'tm 'mday)
- (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
- (uffi:get-slot-value tm-ptr 'tm 'hour)
- (uffi:get-slot-value tm-ptr 'tm 'min)
- (uffi:get-slot-value tm-ptr 'tm 'sec)
- )))
+ (uffi:get-slot-value tm-ptr 'tm 'mday)
+ (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
+ (uffi:get-slot-value tm-ptr 'tm 'hour)
+ (uffi:get-slot-value tm-ptr 'tm 'min)
+ (uffi:get-slot-value tm-ptr 'tm 'sec)
+ )))
1 1 1970 2 3 1)
-(uffi:def-struct timeval
+(uffi:def-struct timeval
(secs :long)
(usecs :long))
(minutes-west :int)
(dsttime :int))
-(uffi:def-function ("gettimeofday" c-gettimeofday)
+(uffi:def-function ("gettimeofday" c-gettimeofday)
((tv (* timeval))
(tz (* timezone)))
:returning :int)
-
+
(defun get-utime ()
(uffi:with-foreign-object (tv 'timeval)
(let ((res (c-gettimeofday tv (uffi:make-null-pointer 'timezone))))
(values
(+ (* 1000000 (uffi:get-slot-value tv 'timeval 'secs))
- (uffi:get-slot-value tv 'timeval 'usecs))
+ (uffi:get-slot-value tv 'timeval 'usecs))
res))))
(deftest :timeofday.1
(multiple-value-bind (t1 res1) (get-utime)
(multiple-value-bind (t2 res2) (get-utime)
- (and (or (= t2 t1) (> t2 t1))
- (> t1 1000000000)
- (> t2 1000000000)
- (zerop res1)
- (zerop res2))))
+ (and (or (= t2 t1) (> t2 t1))
+ (> t1 1000000000)
+ (> t2 1000000000)
+ (zerop res1)
+ (zerop res2))))
t)
-
+
(defun posix-time-to-asctime (secs)
"Converts number of seconds elapsed since 00:00:00 on January 1, 1970, Coordinated Universal Time (UTC)"
(string-right-trim
(defun string-count-upper (str)
(uffi:with-cstring (str-cstring str)
- (cs-count-upper str-cstring)))
+ (cs-count-upper str-cstring)))
(uffi:def-function ("half_double_vector" half-double-vector)
((size :int)
(uffi:def-constant +double-vec-length+ 10)
(defun test-half-double-vector ()
(let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
- results)
+ results)
(dotimes (i +double-vec-length+)
- (setf (uffi:deref-array vec '(:array :double) i)
- (coerce i 'double-float)))
+ (setf (uffi:deref-array vec '(:array :double) i)
+ (coerce i 'double-float)))
(half-double-vector +double-vec-length+ vec)
(dotimes (i +double-vec-length+)
(push (uffi:deref-array vec '(:array :double) i) results))
(system:without-gcing
(half-double-vector +double-vec-length+ (system:vector-sap vec)))
vec))
-
+
(deftest :c-test.1 (string-to-upper "this is a test") "THIS IS A TEST")
(deftest :c-test.2 (string-to-upper nil) nil)
(deftest :c-test.3 (string-count-upper "This is a Test") 2)
/***************************************************************************
* FILE IDENTIFICATION
- *
+ *
* Name: c-test-fns.c
* Purpose: Test functions in C for UFFI library
* Programer: Kevin M. Rosenberg
{
return 1;
}
-
+
#define DLLEXPORT __declspec(dllexport)
#else
-#define DLLEXPORT
+#define DLLEXPORT
#endif
#include <ctype.h>
if (psz) {
while (*psz) {
if (isupper (*psz))
- ++count;
+ ++count;
++psz;
}
return count;
- } else
+ } else
return -1;
}
buffer[i] = 'A' + (rand() % 26);
}
-
+
/* Test of input/output vector */
DLLEXPORT
void
vec[i] /= 2.;
}
-
+
DLLEXPORT
void *
return fvar_struct.d;
}
-
+
(in-package #:uffi-tests)
-(uffi:def-union tunion1
+(uffi:def-union tunion1
(char :char)
(int :int)
(uint :unsigned-int)
(setf (uffi:get-slot-value *u* 'tunion1 'uint)
#-(or sparc sparc-v9 powerpc ppc)
(+ (* 1 (char-code #\A))
- (* 256 (char-code #\B))
- (* 65536 (char-code #\C))
- (* 16777216 128))
+ (* 256 (char-code #\B))
+ (* 65536 (char-code #\C))
+ (* 16777216 128))
#+(or sparc sparc-v9 powerpc ppc)
(+ (* 16777216 (char-code #\A))
- (* 65536 (char-code #\B))
- (* 256 (char-code #\C))
- (* 1 128)))
+ (* 65536 (char-code #\B))
+ (* 256 (char-code #\C))
+ (* 1 128)))
-(deftest :union.1
- (uffi:ensure-char-character
+(deftest :union.1
+ (uffi:ensure-char-character
(uffi:get-slot-value *u* 'tunion1 'char))
#\A)
-(deftest :union.2
- (uffi:ensure-char-integer
+(deftest :union.2
+ (uffi:ensure-char-integer
(uffi:get-slot-value *u* 'tunion1 'char))
65)
(uffi:def-foreign-type foo-u-ptr (* foo-u))
;; tests that compilation worked
-(deftest :unions.4
+(deftest :unions.4
(with-foreign-object (p 'foo-u)
t)
t)
projects / uffi.git / commitdiff