+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: allocation.cl
-;;;; Purpose: Benchmark allocation and slot-access speed
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: allocation.cl,v 1.3 2002/03/21 19:47:20 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-
-(defun stk-int ()
- #+allegro
- (ff:with-stack-fobject (ptr :int)
- (setf (ff:fslot-value ptr) 0))
- #+lispworks
- (fli:with-dynamic-foreign-objects ((ptr :int))
- (setf (fli:dereference ptr) 0))
- #+cmu
- (alien:with-alien ((ptr alien:signed))
- (let ((p (alien:addr ptr)))
- (setf (alien:deref p) 0)))
- )
-
-(defun stk-vector ()
- #+allegro
- (ff:with-stack-fobject (ptr '(:array :int 10) )
- (setf (ff:fslot-value ptr 5) 0))
- #+lispworks
- (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10)))
- (setf (fli:dereference ptr 5) 0))
- #+cmu
- (alien:with-alien ((ptr (alien:array alien:signed 10)))
- (setf (alien:deref ptr 5) 0))
- )
-
-(defun stat-int ()
- #+allegro
- (let ((ptr (ff:allocate-fobject :int :c)))
- (declare (dynamic-extent ptr))
- (setf (ff:fslot-value-typed :int :c ptr) 0)
- (ff:free-fobject ptr))
- #+lispworks
- (let ((ptr (fli:allocate-foreign-object :type :int)))
- (declare (dynamic-extent ptr))
- (setf (fli:dereference ptr) 0)
- (fli:free-foreign-object ptr))
- #+cmu
- (let ((ptr (alien:make-alien (alien:signed 32))))
- (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
- (dynamic-extent ptr))
- (setf (alien:deref ptr) 0)
- (alien:free-alien ptr))
- )
-
-(defun stat-vector ()
- #+allegro
- (let ((ptr (ff:allocate-fobject '(:array :int 10) :c)))
- (declare (dynamic-extent ptr))
- (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0)
- (ff:free-fobject ptr))
- #+lispworks
- (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10))))
- (declare (dynamic-extent ptr))
- (setf (fli:dereference ptr 5) 0)
- (fli:free-foreign-object ptr))
- #+cmu
- (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
- (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
- (dynamic-extent ptr))
- (setf (alien:deref ptr 5) 0)
- (alien:free-alien ptr))
- )
-
-
-(defun stk-vs-stat ()
- (format t "~&Stack allocation, Integer")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stk-int))))
- (format t "~&Static allocation, Integer")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stat-int))))
- (format t "~&Stack allocation, Vector")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stk-int))))
- (format t "~&Static allocation, Vector")
- (time (dotimes (i 1000)
- (dotimes (j 1000)
- (stat-int))))
-)
-
-
-(stk-vs-stat)
-
-
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: allocation.cl
+;;;; Purpose: Benchmark allocation and slot-access speed
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: allocation.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+
+
+(defun stk-int ()
+ #+allegro
+ (ff:with-stack-fobject (ptr :int)
+ (setf (ff:fslot-value ptr) 0))
+ #+lispworks
+ (fli:with-dynamic-foreign-objects ((ptr :int))
+ (setf (fli:dereference ptr) 0))
+ #+cmu
+ (alien:with-alien ((ptr alien:signed))
+ (let ((p (alien:addr ptr)))
+ (setf (alien:deref p) 0)))
+ )
+
+(defun stk-vector ()
+ #+allegro
+ (ff:with-stack-fobject (ptr '(:array :int 10) )
+ (setf (ff:fslot-value ptr 5) 0))
+ #+lispworks
+ (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10)))
+ (setf (fli:dereference ptr 5) 0))
+ #+cmu
+ (alien:with-alien ((ptr (alien:array alien:signed 10)))
+ (setf (alien:deref ptr 5) 0))
+ )
+
+(defun stat-int ()
+ #+allegro
+ (let ((ptr (ff:allocate-fobject :int :c)))
+ (declare (dynamic-extent ptr))
+ (setf (ff:fslot-value-typed :int :c ptr) 0)
+ (ff:free-fobject ptr))
+ #+lispworks
+ (let ((ptr (fli:allocate-foreign-object :type :int)))
+ (declare (dynamic-extent ptr))
+ (setf (fli:dereference ptr) 0)
+ (fli:free-foreign-object ptr))
+ #+cmu
+ (let ((ptr (alien:make-alien (alien:signed 32))))
+ (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+ (dynamic-extent ptr))
+ (setf (alien:deref ptr) 0)
+ (alien:free-alien ptr))
+ )
+
+(defun stat-vector ()
+ #+allegro
+ (let ((ptr (ff:allocate-fobject '(:array :int 10) :c)))
+ (declare (dynamic-extent ptr))
+ (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0)
+ (ff:free-fobject ptr))
+ #+lispworks
+ (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10))))
+ (declare (dynamic-extent ptr))
+ (setf (fli:dereference ptr 5) 0)
+ (fli:free-foreign-object ptr))
+ #+cmu
+ (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
+ (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+ (dynamic-extent ptr))
+ (setf (alien:deref ptr 5) 0)
+ (alien:free-alien ptr))
+ )
+
+
+(defun stk-vs-stat ()
+ (format t "~&Stack allocation, Integer")
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stk-int))))
+ (format t "~&Static allocation, Integer")
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stat-int))))
+ (format t "~&Stack allocation, Vector")
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stk-int))))
+ (format t "~&Static allocation, Vector")
+ (time (dotimes (i 1000)
+ (dotimes (j 1000)
+ (stat-int))))
+)
+
+
+(stk-vs-stat)
+
+
+
+cl-uffi (0.9.1-1) unstable; urgency=low
+
+ * Rename .cl files to .lisp files
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 30 Sep 2002 04:01:58 -0600
+
cl-uffi (0.9.0-1) unstable; urgency=low
* Reorganize directories, merge MCL/OpenMCL into main code
+++ /dev/null
-;; tester.cl
-;; A test harness for Allegro CL.
-;;
-;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
-;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
-;;
-;; 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 Free Software Foundation, as clarified by the Franz
-;; preamble to the LGPL found in
-;; http://opensource.franz.com/preamble.html.
-;;
-;; This code is distributed in the hope that it will be useful,
-;; but without any warranty; without even the implied warranty of
-;; merchantability or fitness for a particular purpose. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; Version 2.1 of the GNU Lesser General Public License can be
-;; found at http://opensource.franz.com/license.html.
-;; If it is not present, you can access it from
-;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
-;; version) or write to the Free Software Foundation, Inc., 59 Temple
-;; Place, Suite 330, Boston, MA 02111-1307 USA
-;;
-;;;; from the original ACL 6.1 sources:
-;; $Id: acl-compat-tester.cl,v 1.3 2002/09/20 05:38:01 kevin Exp $
-
-
-(defpackage :util.test
- (:use :common-lisp)
- (:shadow #:test)
- (:export
-;;;; Control variables:
- #:*break-on-test-failures*
- #:*error-protect-tests*
- #:*test-errors*
- #:*test-successes*
- #:*test-unexpected-failures*
-
-;;;; The test macros:
- #:test
- #:test-error
- #:test-no-error
- #:test-warning
- #:test-no-warning
-
- #:with-tests
- ))
-
-(in-package :util.test)
-
-#+cmu
-(unless (find-class 'break nil)
- (define-condition break (simple-condition) ()))
-
-(define-condition simple-break (error simple-condition) ())
-
-;; the if* macro used in Allegro:
-;;
-;; This is in the public domain... please feel free to put this definition
-;; in your code or distribute it with your version of lisp.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
-
-(defmacro if* (&rest args)
- (do ((xx (reverse args) (cdr xx))
- (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 ((and (symbolp (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)))))
-
-
-
-
-(defvar *break-on-test-failures* nil
- "When a test failure occurs, common-lisp:break is called, allowing
-interactive debugging of the failure.")
-
-(defvar *test-errors* 0
- "The value is the number of test errors which have occurred.")
-(defvar *test-successes* 0
- "The value is the number of test successes which have occurred.")
-(defvar *test-unexpected-failures* 0
- "The value is the number of unexpected test failures which have occurred.")
-
-(defvar *error-protect-tests* nil
- "Protect each test from errors. If an error occurs, then that will be
-taken as a test failure unless test-error is being used.")
-
-(defmacro test-values-errorset (form &optional announce catch-breaks)
- ;; internal macro
- (let ((g-announce (gensym))
- (g-catch-breaks (gensym)))
- `(let* ((,g-announce ,announce)
- (,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)))))
-
-(defmacro test-values (form &optional announce catch-breaks)
- ;; internal macro
- (if* *error-protect-tests*
- then `(test-values-errorset ,form ,announce ,catch-breaks)
- 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)
-
-;;;;;;;;;; internal, undocumented keywords:
-;;;; Note about these keywords: if they were documented, we'd have a
-;;;; problem, since they break the left-to-right order of evaluation.
-;;;; 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))
- "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
-logged, otherwise a success is logged.
-
-Normally the comparison of values is done with `eql'. The `test' keyword
-argument can be used to specify other comparison functions, such as eq,
-equal,equalp, string=, string-equal, etc.
-
-Normally, only the first return value from the test-form is considered,
-however if `multiple-values' is t, then all values returned from test-form
-are considered.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-programs that do regression analysis on the output from a test run to
-discriminate on new versus known failures."
- `(test-check
- :expected-result ,expected-value
- :test-results
- (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
- ,@(when test-given `(:predicate ,test))
- ,@(when multiple-values-given `(:multiple-values ,multiple-values))
- ,@(when fail-info-given `(:fail-info ,fail-info))
- ,@(when known-failure-given `(:known-failure ,known-failure))
- :test-form ',(if reported-form reported-form test-form)
- ,@(when wanted-message-given `(:wanted-message ,wanted-message))
- ,@(when got-message-given `(:got-message ,got-message))))
-
-(defmethod conditionp ((thing condition)) t)
-(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))
- "Test that `form' signals an error. The order of evaluation of the
-arguments is keywords first, then test form.
-
-If `announce' is non-nil, then cause the error message to be printed.
-
-The `catch-breaks' is non-nil then consider a call to common-lisp:break an
-`error'.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-programs that do regression analysis on the output from a test run to
-discriminate on new versus known failures.
-
-If `condition-type' is non-nil, it should be a symbol naming a condition
-type, which is used to check against the signalled condition type. The
-test will fail if they do not match.
-
-`include-subtypes', used with `condition-type', can be used to match a
-condition to an entire subclass of the condition type hierarchy.
-
-`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)))
- `(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)))
- (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))))))
-
-(defmacro test-no-error (form &key announce
- 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.
-
-If `announce' is non-nil, then cause the error message to be printed.
-
-The `catch-breaks' is non-nil then consider a call to common-lisp:break an
-`error'.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-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)))
- `(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)))
- (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))))))
-
-(defvar *warn-cookie* (cons nil nil))
-
-(defmacro test-warning (form &key fail-info known-failure)
- "Test that `form' signals a warning. The order of evaluation of
-the arguments is keywords first, then test form.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-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)))
- `(let* ((,g-fail-info ,fail-info)
- (,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))))
-
-(defmacro test-no-warning (form &key fail-info known-failure)
- "Test that `form' does not signal a warning. The order of evaluation of
-the arguments is keywords first, then test form.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-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)))
- `(let* ((,g-fail-info ,fail-info)
- (,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))))
-
-(defvar *announce-test* nil) ;; if true announce each test that was done
-
-(defmacro errorset (form &optional announce catch-breaks)
- ;; Evaluate FORM, and if there are no errors and FORM returns
- ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an
- ;; error occurs while evaluating FORM, then return nil immediately.
- ;; If ANNOUNCE is t, then the error message will be printed out.
- (if catch-breaks
- `(handler-case (values-list (cons t (multiple-value-list ,form)))
- (error (condition)
- (declare (ignorable condition))
- ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
- nil)
- (simple-break (condition)
- (declare (ignorable condition))
- ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
-)
- nil))
- `(handler-case (values-list (cons t (multiple-value-list ,form)))
- (error (condition)
- (declare (ignorable condition))
- ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
- 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)
- ;; 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)))))
- (when (conditionp test-results)
- (setq condition test-results)
- (setq test-results nil))
- (when (null (car test-results))
- (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))
- 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)))))
- (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*
- "~
-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* "~
-Reason: an error~@[ (of type `~s')~] was detected.~%"
- (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* "~
-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* "~
-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* "~
-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* "~
-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*))
- 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*))
- (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 ~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*))
- ))))
-
-(provide :tester #+module-versions 1.1)
--- /dev/null
+;; tester.cl
+;; A test harness for Allegro CL.
+;;
+;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
+;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
+;;
+;; 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 Free Software Foundation, as clarified by the Franz
+;; preamble to the LGPL found in
+;; http://opensource.franz.com/preamble.html.
+;;
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License can be
+;; found at http://opensource.franz.com/license.html.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple
+;; Place, Suite 330, Boston, MA 02111-1307 USA
+;;
+;;;; from the original ACL 6.1 sources:
+;; $Id: acl-compat-tester.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+
+
+(defpackage :util.test
+ (:use :common-lisp)
+ (:shadow #:test)
+ (:export
+;;;; Control variables:
+ #:*break-on-test-failures*
+ #:*error-protect-tests*
+ #:*test-errors*
+ #:*test-successes*
+ #:*test-unexpected-failures*
+
+;;;; The test macros:
+ #:test
+ #:test-error
+ #:test-no-error
+ #:test-warning
+ #:test-no-warning
+
+ #:with-tests
+ ))
+
+(in-package :util.test)
+
+#+cmu
+(unless (find-class 'break nil)
+ (define-condition break (simple-condition) ()))
+
+(define-condition simple-break (error simple-condition) ())
+
+;; the if* macro used in Allegro:
+;;
+;; This is in the public domain... please feel free to put this definition
+;; in your code or distribute it with your version of lisp.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
+
+(defmacro if* (&rest args)
+ (do ((xx (reverse args) (cdr xx))
+ (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 ((and (symbolp (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)))))
+
+
+
+
+(defvar *break-on-test-failures* nil
+ "When a test failure occurs, common-lisp:break is called, allowing
+interactive debugging of the failure.")
+
+(defvar *test-errors* 0
+ "The value is the number of test errors which have occurred.")
+(defvar *test-successes* 0
+ "The value is the number of test successes which have occurred.")
+(defvar *test-unexpected-failures* 0
+ "The value is the number of unexpected test failures which have occurred.")
+
+(defvar *error-protect-tests* nil
+ "Protect each test from errors. If an error occurs, then that will be
+taken as a test failure unless test-error is being used.")
+
+(defmacro test-values-errorset (form &optional announce catch-breaks)
+ ;; internal macro
+ (let ((g-announce (gensym))
+ (g-catch-breaks (gensym)))
+ `(let* ((,g-announce ,announce)
+ (,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)))))
+
+(defmacro test-values (form &optional announce catch-breaks)
+ ;; internal macro
+ (if* *error-protect-tests*
+ then `(test-values-errorset ,form ,announce ,catch-breaks)
+ 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)
+
+;;;;;;;;;; internal, undocumented keywords:
+;;;; Note about these keywords: if they were documented, we'd have a
+;;;; problem, since they break the left-to-right order of evaluation.
+;;;; 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))
+ "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
+logged, otherwise a success is logged.
+
+Normally the comparison of values is done with `eql'. The `test' keyword
+argument can be used to specify other comparison functions, such as eq,
+equal,equalp, string=, string-equal, etc.
+
+Normally, only the first return value from the test-form is considered,
+however if `multiple-values' is t, then all values returned from test-form
+are considered.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+ `(test-check
+ :expected-result ,expected-value
+ :test-results
+ (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
+ ,@(when test-given `(:predicate ,test))
+ ,@(when multiple-values-given `(:multiple-values ,multiple-values))
+ ,@(when fail-info-given `(:fail-info ,fail-info))
+ ,@(when known-failure-given `(:known-failure ,known-failure))
+ :test-form ',(if reported-form reported-form test-form)
+ ,@(when wanted-message-given `(:wanted-message ,wanted-message))
+ ,@(when got-message-given `(:got-message ,got-message))))
+
+(defmethod conditionp ((thing condition)) t)
+(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))
+ "Test that `form' signals an error. The order of evaluation of the
+arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures.
+
+If `condition-type' is non-nil, it should be a symbol naming a condition
+type, which is used to check against the signalled condition type. The
+test will fail if they do not match.
+
+`include-subtypes', used with `condition-type', can be used to match a
+condition to an entire subclass of the condition type hierarchy.
+
+`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)))
+ `(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)))
+ (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))))))
+
+(defmacro test-no-error (form &key announce
+ 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.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+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)))
+ `(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)))
+ (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))))))
+
+(defvar *warn-cookie* (cons nil nil))
+
+(defmacro test-warning (form &key fail-info known-failure)
+ "Test that `form' signals a warning. The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+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)))
+ `(let* ((,g-fail-info ,fail-info)
+ (,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))))
+
+(defmacro test-no-warning (form &key fail-info known-failure)
+ "Test that `form' does not signal a warning. The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+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)))
+ `(let* ((,g-fail-info ,fail-info)
+ (,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))))
+
+(defvar *announce-test* nil) ;; if true announce each test that was done
+
+(defmacro errorset (form &optional announce catch-breaks)
+ ;; Evaluate FORM, and if there are no errors and FORM returns
+ ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an
+ ;; error occurs while evaluating FORM, then return nil immediately.
+ ;; If ANNOUNCE is t, then the error message will be printed out.
+ (if catch-breaks
+ `(handler-case (values-list (cons t (multiple-value-list ,form)))
+ (error (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+ nil)
+ (simple-break (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
+)
+ nil))
+ `(handler-case (values-list (cons t (multiple-value-list ,form)))
+ (error (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+ 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)
+ ;; 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)))))
+ (when (conditionp test-results)
+ (setq condition test-results)
+ (setq test-results nil))
+ (when (null (car test-results))
+ (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))
+ 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)))))
+ (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*
+ "~
+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* "~
+Reason: an error~@[ (of type `~s')~] was detected.~%"
+ (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* "~
+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* "~
+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* "~
+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* "~
+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*))
+ 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*))
+ (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 ~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*))
+ ))))
+
+(provide :tester #+module-versions 1.1)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: arrays.cl
-;;;; Purpose: UFFI Example file to test arrays
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: arrays.cl,v 1.3 2002/04/02 21:29:45 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-constant +column-length+ 10)
-(uffi:def-constant +row-length+ 10)
-
-(defun test-array-1d ()
- "Tests vector"
- (let ((a (uffi:allocate-foreign-object :long +column-length+)))
- (dotimes (i +column-length+)
- (setf (uffi:deref-array a '(:array :long) i) (* i i)))
- (dotimes (i +column-length+)
- (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i)))
- (uffi:free-foreign-object a))
- (values))
-
-(defun test-array-2d ()
- "Tests 2d array"
- (let ((a (uffi:allocate-foreign-object '(* :long) +row-length+)))
- (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)))))
-
- (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)))))
-
- (uffi:free-foreign-object a))
- (values))
-
-#+examples-uffi
-(test-array-1d)
-
-#+examples-uffi
-(test-array-2d)
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: arrays.cl
+;;;; Purpose: UFFI Example file to test arrays
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: arrays.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-constant +column-length+ 10)
+(uffi:def-constant +row-length+ 10)
+
+(defun test-array-1d ()
+ "Tests vector"
+ (let ((a (uffi:allocate-foreign-object :long +column-length+)))
+ (dotimes (i +column-length+)
+ (setf (uffi:deref-array a '(:array :long) i) (* i i)))
+ (dotimes (i +column-length+)
+ (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i)))
+ (uffi:free-foreign-object a))
+ (values))
+
+(defun test-array-2d ()
+ "Tests 2d array"
+ (let ((a (uffi:allocate-foreign-object '(* :long) +row-length+)))
+ (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)))))
+
+ (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)))))
+
+ (uffi:free-foreign-object a))
+ (values))
+
+#+examples-uffi
+(test-array-1d)
+
+#+examples-uffi
+(test-array-2d)
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: atoifl.cl
-;;;; Purpose: UFFI Example file to atoi/atof/atol
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: atoifl.cl,v 1.5 2002/04/03 00:31:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-function ("atoi" c-atoi)
- ((str :cstring))
- :returning :int)
-
-(uffi:def-function ("atol" c-atol)
- ((str :cstring))
- :returning :long)
-
-(uffi:def-function ("atof" c-atof)
- ((str :cstring))
- :returning :double)
-
-(defun atoi (str)
- "Returns a int from a string."
- (uffi:with-cstring (str-cstring str)
- (c-atoi str-cstring)))
-
-(defun atof (str)
- "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))))
- (print-results "55")))
-
-
-#+test-uffi
-(progn
- (util.test:test (atoi "123") 123 :test #'eql
- :fail-info "Error with atoi")
- (util.test:test (atoi "") 0 :test #'eql
- :fail-info "Error with atoi")
- (util.test:test (atof "2.23") 2.23d0 :test #'eql
- :fail-info "Error with atof")
- )
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: atoifl.cl
+;;;; Purpose: UFFI Example file to atoi/atof/atol
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: atoifl.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-function ("atoi" c-atoi)
+ ((str :cstring))
+ :returning :int)
+
+(uffi:def-function ("atol" c-atol)
+ ((str :cstring))
+ :returning :long)
+
+(uffi:def-function ("atof" c-atof)
+ ((str :cstring))
+ :returning :double)
+
+(defun atoi (str)
+ "Returns a int from a string."
+ (uffi:with-cstring (str-cstring str)
+ (c-atoi str-cstring)))
+
+(defun atof (str)
+ "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))))
+ (print-results "55")))
+
+
+#+test-uffi
+(progn
+ (util.test:test (atoi "123") 123 :test #'eql
+ :fail-info "Error with atoi")
+ (util.test:test (atoi "") 0 :test #'eql
+ :fail-info "Error with atoi")
+ (util.test:test (atof "2.23") 2.23d0 :test #'eql
+ :fail-info "Error with atof")
+ )
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: c-test-fns.cl
-;;;; Purpose: UFFI Example file for zlib compression
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: c-test-fns.cl,v 1.7 2002/04/03 00:31:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(unless (uffi:load-foreign-library
- (uffi:find-foreign-library "c-test-fns" *load-truename*)
- :supporting-libraries '("c")
- :force-load t)
- (warn "Unable to load c-test-fns library"))
-
-(uffi:def-function ("cs_to_upper" cs-to-upper)
- ((input (* :unsigned-char)))
- :returning :void
- )
-
-(defun string-to-upper (str)
- (uffi:with-foreign-string (str-foreign str)
- (cs-to-upper str-foreign)
- (uffi:convert-from-foreign-string str-foreign)))
-
-(uffi:def-function ("cs_count_upper" cs-count-upper)
- ((input :cstring))
- :returning :int
- )
-
-(defun string-count-upper (str)
- (uffi:with-cstring (str-cstring str)
- (cs-count-upper str-cstring)))
-
-(uffi:def-function ("half_double_vector" half-double-vector)
- ((size :int)
- (vec (* :double)))
- :returning :void)
-
-(uffi:def-constant +double-vec-length+ 10)
-(defun test-half-double-vector ()
- (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
- results)
- (dotimes (i +double-vec-length+)
- (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))
- (uffi:free-foreign-object vec)
- (nreverse results)))
-
-(defun t2 ()
- (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
- (dotimes (i +double-vec-length+)
- (setf (aref vec i) (coerce i 'double-float)))
- (half-double-vector +double-vec-length+ vec)
- vec))
-
-#+cmu
-(defun t3 ()
- (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
- (dotimes (i +double-vec-length+)
- (setf (aref vec i) (coerce i 'double-float)))
- (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"))
-
-#+examples-uffi
-(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"))
-
-#+examples-uffi
-(format t "~&(string-count-upper nil) => ~A"
- (string-count-upper nil))
-
-#+examples-uffi
-(format t "~&Half vector: ~S" (test-half-double-vector))
-
-
-
-#+test-uffi
-(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")
- (util.test:test (string-to-upper nil) nil
- :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")
- (util.test:test (string-count-upper nil) -1
- :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")
- )
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: c-test-fns.cl
+;;;; Purpose: UFFI Example file for zlib compression
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: c-test-fns.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(unless (uffi:load-foreign-library
+ (uffi:find-foreign-library "c-test-fns" *load-truename*)
+ :supporting-libraries '("c")
+ :force-load t)
+ (warn "Unable to load c-test-fns library"))
+
+(uffi:def-function ("cs_to_upper" cs-to-upper)
+ ((input (* :unsigned-char)))
+ :returning :void
+ )
+
+(defun string-to-upper (str)
+ (uffi:with-foreign-string (str-foreign str)
+ (cs-to-upper str-foreign)
+ (uffi:convert-from-foreign-string str-foreign)))
+
+(uffi:def-function ("cs_count_upper" cs-count-upper)
+ ((input :cstring))
+ :returning :int
+ )
+
+(defun string-count-upper (str)
+ (uffi:with-cstring (str-cstring str)
+ (cs-count-upper str-cstring)))
+
+(uffi:def-function ("half_double_vector" half-double-vector)
+ ((size :int)
+ (vec (* :double)))
+ :returning :void)
+
+(uffi:def-constant +double-vec-length+ 10)
+(defun test-half-double-vector ()
+ (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
+ results)
+ (dotimes (i +double-vec-length+)
+ (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))
+ (uffi:free-foreign-object vec)
+ (nreverse results)))
+
+(defun t2 ()
+ (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+ (dotimes (i +double-vec-length+)
+ (setf (aref vec i) (coerce i 'double-float)))
+ (half-double-vector +double-vec-length+ vec)
+ vec))
+
+#+cmu
+(defun t3 ()
+ (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+ (dotimes (i +double-vec-length+)
+ (setf (aref vec i) (coerce i 'double-float)))
+ (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"))
+
+#+examples-uffi
+(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"))
+
+#+examples-uffi
+(format t "~&(string-count-upper nil) => ~A"
+ (string-count-upper nil))
+
+#+examples-uffi
+(format t "~&Half vector: ~S" (test-half-double-vector))
+
+
+
+#+test-uffi
+(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")
+ (util.test:test (string-to-upper nil) nil
+ :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")
+ (util.test:test (string-count-upper nil) -1
+ :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")
+ )
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: compress.cl
-;;;; Purpose: UFFI Example file for zlib compression
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: compress.cl,v 1.13 2002/09/20 06:03:36 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(unless (uffi:load-foreign-library
- (uffi:find-foreign-library
- "libz"
- '("/usr/local/lib/" "/usr/lib/" "/zlib/")
- :types '("so" "a" "dylib"))
- :module "zlib"
- :supporting-libraries '("c"))
- (warn "Unable to load zlib"))
-
-(uffi:def-function ("compress" c-compress)
- ((dest (* :unsigned-char))
- (destlen (* :long))
- (source :cstring)
- (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)))
- (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)))))))
-
-
-#+examples-uffi
-(progn
- (flet ((print-results (str)
- (multiple-value-bind (compressed len) (compress str)
- (format t "~&(compress ~S) => " str)
- (dotimes (i len)
- (format t "~X" (char-code (char compressed i))))
- (format t ",~D" len))))
- (print-results "")
- (print-results "test")
- (print-results "test2")))
-
-;; Results of the above on my system:
-;; (compress "") => 789c300001,8
-;; (compress "test") => 789c2b492d2e1045d1c1,12
-;; (compress "test2") => 789c2b492d2e31206501f3,13
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: compress.cl
+;;;; Purpose: UFFI Example file for zlib compression
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: compress.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(unless (uffi:load-foreign-library
+ (uffi:find-foreign-library
+ "libz"
+ '("/usr/local/lib/" "/usr/lib/" "/zlib/")
+ :types '("so" "a" "dylib"))
+ :module "zlib"
+ :supporting-libraries '("c"))
+ (warn "Unable to load zlib"))
+
+(uffi:def-function ("compress" c-compress)
+ ((dest (* :unsigned-char))
+ (destlen (* :long))
+ (source :cstring)
+ (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)))
+ (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)))))))
+
+
+#+examples-uffi
+(progn
+ (flet ((print-results (str)
+ (multiple-value-bind (compressed len) (compress str)
+ (format t "~&(compress ~S) => " str)
+ (dotimes (i len)
+ (format t "~X" (char-code (char compressed i))))
+ (format t ",~D" len))))
+ (print-results "")
+ (print-results "test")
+ (print-results "test2")))
+
+;; Results of the above on my system:
+;; (compress "") => 789c300001,8
+;; (compress "test") => 789c2b492d2e1045d1c1,12
+;; (compress "test2") => 789c2b492d2e31206501f3,13
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: file-socket.cl
-;;;; Purpose: UFFI Example file to get a socket on a file
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Jul 2002
-;;;;
-;;;; $Id: file-socket.cl,v 1.2 2002/08/02 14:39:11 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-;; Values for linux
-(uffi:def-constant PF_UNIX 1)
-(uffi:def-constant SOCK_STREAM 1)
-
-(uffi:def-function ("socket" c-socket)
- ((family :int)
- (type :int)
- (protocol :int))
- :returning :int)
-
-(uffi:def-function ("connect" c-connect)
- ((sockfd :int)
- (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)
- (error "Unable to create socket"))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: file-socket.cl
+;;;; Purpose: UFFI Example file to get a socket on a file
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Jul 2002
+;;;;
+;;;; $Id: file-socket.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+;; Values for linux
+(uffi:def-constant PF_UNIX 1)
+(uffi:def-constant SOCK_STREAM 1)
+
+(uffi:def-function ("socket" c-socket)
+ ((family :int)
+ (type :int)
+ (protocol :int))
+ :returning :int)
+
+(uffi:def-function ("connect" c-connect)
+ ((sockfd :int)
+ (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)
+ (error "Unable to create socket"))))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: getenv.cl
-;;;; Purpose: UFFI Example file to get environment variable
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: getenv.cl,v 1.9 2002/04/02 23:27:05 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-
-(uffi:def-function ("getenv" c-getenv)
- ((name :cstring))
- :returning :cstring)
-
-(defun my-getenv (key)
- "Returns an environment variable, or NIL if it does not exist"
- (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))))
- (print-results "USER")
- (print-results "_FOO_")))
-
-
-#+test-uffi
-(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")
-)
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: getenv.cl
+;;;; Purpose: UFFI Example file to get environment variable
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: getenv.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function ("getenv" c-getenv)
+ ((name :cstring))
+ :returning :cstring)
+
+(defun my-getenv (key)
+ "Returns an environment variable, or NIL if it does not exist"
+ (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))))
+ (print-results "USER")
+ (print-results "_FOO_")))
+
+
+#+test-uffi
+(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")
+)
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: gethostname.cl
-;;;; Purpose: UFFI Example file to get hostname of system
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: gethostname.cl,v 1.12 2002/04/03 00:31:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-
-;;; This example is inspired by the example on the CL-Cookbook web site
-
-(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 (c-gethostname name 256)))
- (unwind-protect
- (if (zerop result)
- (uffi:convert-from-foreign-string name)
- (error "gethostname() failed."))
- (uffi:free-foreign-object name))))
-
-(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."))))
-
-#+examples-uffi
-(progn
- (format t "~&Hostname (technique 1): ~A" (gethostname))
- (format t "~&Hostname (technique 2): ~A" (gethostname2)))
-
-#+test-uffi
-(progn
- (let ((hostname1 (gethostname))
- (hostname2 (gethostname2)))
-
- (util.test:test (and (stringp hostname1) (stringp hostname2)) t
- :fail-info "gethostname not string")
- (util.test:test (and (not (zerop (length hostname1)))
- (not (zerop (length hostname2)))) t
- :fail-info "gethostname length 0")
- (util.test:test (string= hostname1 hostname1) t
- :fail-info "gethostname techniques don't match"))
- )
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: gethostname.cl
+;;;; Purpose: UFFI Example file to get hostname of system
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: gethostname.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+;;; This example is inspired by the example on the CL-Cookbook web site
+
+(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 (c-gethostname name 256)))
+ (unwind-protect
+ (if (zerop result)
+ (uffi:convert-from-foreign-string name)
+ (error "gethostname() failed."))
+ (uffi:free-foreign-object name))))
+
+(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."))))
+
+#+examples-uffi
+(progn
+ (format t "~&Hostname (technique 1): ~A" (gethostname))
+ (format t "~&Hostname (technique 2): ~A" (gethostname2)))
+
+#+test-uffi
+(progn
+ (let ((hostname1 (gethostname))
+ (hostname2 (gethostname2)))
+
+ (util.test:test (and (stringp hostname1) (stringp hostname2)) t
+ :fail-info "gethostname not string")
+ (util.test:test (and (not (zerop (length hostname1)))
+ (not (zerop (length hostname2)))) t
+ :fail-info "gethostname length 0")
+ (util.test:test (string= hostname1 hostname1) t
+ :fail-info "gethostname techniques don't match"))
+ )
+
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: getshells.cl
-;;;; Purpose: UFFI Example file to get lisp of legal shells
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: getshells.cl,v 1.6 2002/04/02 21:29:45 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-
-(uffi:def-function "setusershell"
- nil
- :returning :void)
-
-(uffi:def-function "endusershell"
- nil
- :returning :void)
-
-(uffi:def-function "getusershell"
- nil
- :returning :cstring)
-
-(defun getshells ()
- "Returns list of valid shells"
- (setusershell)
- (let (shells)
- (do ((shell (uffi:convert-from-cstring (getusershell))
- (uffi:convert-from-cstring (getusershell))))
- ((null shell))
- (push shell shells))
- (endusershell)
- (nreverse shells)))
-
-#+examples-uffi
-(format t "~&Shells: ~S" (getshells))
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: getshells.cl
+;;;; Purpose: UFFI Example file to get lisp of legal shells
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: getshells.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function "setusershell"
+ nil
+ :returning :void)
+
+(uffi:def-function "endusershell"
+ nil
+ :returning :void)
+
+(uffi:def-function "getusershell"
+ nil
+ :returning :cstring)
+
+(defun getshells ()
+ "Returns list of valid shells"
+ (setusershell)
+ (let (shells)
+ (do ((shell (uffi:convert-from-cstring (getusershell))
+ (uffi:convert-from-cstring (getusershell))))
+ ((null shell))
+ (push shell shells))
+ (endusershell)
+ (nreverse shells)))
+
+#+examples-uffi
+(format t "~&Shells: ~S" (getshells))
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: gettime
-;;;; Purpose: UFFI Example file to get time, use C structures
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: gettime.cl,v 1.9 2002/04/02 23:27:05 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-foreign-type time-t :unsigned-long)
-
-(uffi:def-struct tm
- (sec :int)
- (min :int)
- (hour :int)
- (mday :int)
- (mon :int)
- (year :int)
- (wday :int)
- (yday :int)
- (isdst :int))
-
-(uffi:def-function ("time" c-time)
- ((time (* time-t)))
- :returning time-t)
-
-(uffi:def-function ("localtime" c-localtime)
- ((time (* time-t)))
- :returning (* tm))
-
-(uffi:def-type time-t :unsigned-long)
-(uffi:def-type tm-pointer (* tm))
-
-(defun gettime ()
- "Returns the local time"
- (uffi:with-foreign-object (time 'time-t)
-;; (declare (type time-t time))
- (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))))
-
-
-
-
-#+examples-uffi
-(format t "~&~A" (gettime))
-
-#+test-uffi
-(progn
- (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")))
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: gettime
+;;;; Purpose: UFFI Example file to get time, use C structures
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: gettime.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-foreign-type time-t :unsigned-long)
+
+(uffi:def-struct tm
+ (sec :int)
+ (min :int)
+ (hour :int)
+ (mday :int)
+ (mon :int)
+ (year :int)
+ (wday :int)
+ (yday :int)
+ (isdst :int))
+
+(uffi:def-function ("time" c-time)
+ ((time (* time-t)))
+ :returning time-t)
+
+(uffi:def-function ("localtime" c-localtime)
+ ((time (* time-t)))
+ :returning (* tm))
+
+(uffi:def-type time-t :unsigned-long)
+(uffi:def-type tm-pointer (* tm))
+
+(defun gettime ()
+ "Returns the local time"
+ (uffi:with-foreign-object (time 'time-t)
+;; (declare (type time-t time))
+ (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))))
+
+
+
+
+#+examples-uffi
+(format t "~&~A" (gettime))
+
+#+test-uffi
+(progn
+ (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")))
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: run-examples.cl
-;;;; Purpose: Load and execute all examples for UFFI
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: run-examples.cl,v 1.3 2002/09/20 05:38:01 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-#-uffi (asdf:oos 'asdf:load-op :uffi)
-
-(pushnew :examples-uffi cl:*features*)
-
-(flet ((load-test (name)
- (load (make-pathname :defaults *load-truename* :name name :type "cl"))))
- (load-test "c-test-fns")
- (load-test "arrays")
- (load-test "union")
- (load-test "strtol")
- (load-test "atoifl")
- (load-test "gettime")
- (load-test "getenv")
- (load-test "gethostname")
- (load-test "getshells")
- (load-test "compress"))
-
-(setq cl:*features* (remove :examples-uffi cl:*features*))
-
-
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: run-examples.cl
+;;;; Purpose: Load and execute all examples for UFFI
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: run-examples.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(pushnew :examples-uffi cl:*features*)
+
+(flet ((load-test (name)
+ (load (make-pathname :defaults *load-truename* :name name))))
+ (load-test "c-test-fns")
+ (load-test "arrays")
+ (load-test "union")
+ (load-test "strtol")
+ (load-test "atoifl")
+ (load-test "gettime")
+ (load-test "getenv")
+ (load-test "gethostname")
+ (load-test "getshells")
+ (load-test "compress"))
+
+(setq cl:*features* (remove :examples-uffi cl:*features*))
+
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: strtol.cl
-;;;; Purpose: UFFI Example file to strtol, uses pointer arithmetic
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: strtol.cl,v 1.15 2002/04/02 23:27:05 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(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)
- ((nptr char-ptr)
- (endptr (* char-ptr))
- (base :int))
- :returning :long)
-
-(defun strtol (str &optional (base 10))
- "Returns a long int from a string. Returns number and condition flag.
-Condition flag is T if all of string parses as a long, NIL if
-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)))
-
- (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)))))
- (progn
- (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))))
- (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")))
- (test-strtol "123" '(123 t))
- (test-strtol "0" '(0 t))
- (test-strtol "55a" '(55 2))
- (test-strtol "a" '(nil nil))))
-
-
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: strtol.cl
+;;;; Purpose: UFFI Example file to strtol, uses pointer arithmetic
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: strtol.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(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)
+ ((nptr char-ptr)
+ (endptr (* char-ptr))
+ (base :int))
+ :returning :long)
+
+(defun strtol (str &optional (base 10))
+ "Returns a long int from a string. Returns number and condition flag.
+Condition flag is T if all of string parses as a long, NIL if
+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)))
+
+ (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)))))
+ (progn
+ (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))))
+ (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")))
+ (test-strtol "123" '(123 t))
+ (test-strtol "0" '(0 t))
+ (test-strtol "55a" '(55 2))
+ (test-strtol "a" '(nil nil))))
+
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: test-examples.cl
-;;;; Purpose: Load and execute all examples for UFFI
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: test-examples.cl,v 1.3 2002/09/20 05:38:01 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-#-uffi (asdf:oos 'asdf:load-op :uffi)
-
-(unless (ignore-errors (find-package :util.test))
- (load (make-pathname :name "acl-compat-tester" :type "cl"
- :defaults *load-truename*)))
-
-(defun do-tests ()
- (pushnew :test-uffi cl:*features*)
- (util.test:with-tests (:name "UFFI-Tests")
- (setq util.test:*break-on-test-failures* nil)
- (flet ((load-test (name)
- (load (merge-pathnames
- (make-pathname :name name
- :type "cl")
- *load-truename*))))
- (load-test "c-test-fns")
- (load-test "arrays")
- (load-test "union")
- (load-test "strtol")
- (load-test "atoifl")
- (load-test "gettime")
- (load-test "getenv")
- (load-test "gethostname")
- (load-test "getshells")
- (load-test "compress"))
- (setq cl:*features* (remove :test-uffi cl:*features*))))
-
-(do-tests)
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: test-examples.cl
+;;;; Purpose: Load and execute all examples for UFFI
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: test-examples.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(unless (ignore-errors (find-package :util.test))
+ (load (make-pathname :name "acl-compat-tester" :defaults *load-truename*)))
+
+(defun do-tests ()
+ (pushnew :test-uffi cl:*features*)
+ (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-test "c-test-fns")
+ (load-test "arrays")
+ (load-test "union")
+ (load-test "strtol")
+ (load-test "atoifl")
+ (load-test "gettime")
+ (load-test "getenv")
+ (load-test "gethostname")
+ (load-test "getshells")
+ (load-test "compress"))
+ (setq cl:*features* (remove :test-uffi cl:*features*))))
+
+(do-tests)
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: union.cl
-;;;; Purpose: UFFI Example file to test unions
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: union.cl,v 1.10 2002/09/29 17:31:20 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-union tunion1
- (char :char)
- (int :int)
- (uint :unsigned-int)
- (sf :float)
- (df :double))
-
-(defun run-union-1 ()
- (let ((u (uffi:allocate-foreign-object 'tunion1)))
- (setf (uffi:get-slot-value u 'tunion1 'uint)
- ;; little endian
- #-(or sparc sparc-v9 powerpc ppc)
- (+ (* 1 (char-code #\A))
- (* 256 (char-code #\B))
- (* 65536 (char-code #\C))
- (* 16777216 128))
- ;; big endian
- #+(or sparc sparc-v9 powerpc ppc)
- (+ (* 16777216 (char-code #\A))
- (* 65536 (char-code #\B))
- (* 256 (char-code #\C))
- (* 1 128)))
- (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:free-foreign-object u))
- (values))
-
-#+test-uffi
-(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 mcl)
- (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
- 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")
- (uffi:free-foreign-object u))
- (values))
-
-#+examples-uffi
-(run-union-1)
-
-
-#+test-uffi
-(test-union-1)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: union.cl
+;;;; Purpose: UFFI Example file to test unions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: union.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-union tunion1
+ (char :char)
+ (int :int)
+ (uint :unsigned-int)
+ (sf :float)
+ (df :double))
+
+(defun run-union-1 ()
+ (let ((u (uffi:allocate-foreign-object 'tunion1)))
+ (setf (uffi:get-slot-value u 'tunion1 'uint)
+ ;; little endian
+ #-(or sparc sparc-v9 powerpc ppc)
+ (+ (* 1 (char-code #\A))
+ (* 256 (char-code #\B))
+ (* 65536 (char-code #\C))
+ (* 16777216 128))
+ ;; big endian
+ #+(or sparc sparc-v9 powerpc ppc)
+ (+ (* 16777216 (char-code #\A))
+ (* 65536 (char-code #\B))
+ (* 256 (char-code #\C))
+ (* 1 128)))
+ (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:free-foreign-object u))
+ (values))
+
+#+test-uffi
+(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 mcl)
+ (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
+ 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")
+ (uffi:free-foreign-object u))
+ (values))
+
+#+examples-uffi
+(run-union-1)
+
+
+#+test-uffi
+(test-union-1)
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: aggregates.cl
-;;;; Purpose: UFFI source to handle aggregate types
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: aggregates.cl,v 1.15 2002/09/30 08:50:00 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defmacro def-enum (enum-name args &key (separator-string "#"))
- "Creates a constants for a C type enum list, symbols are created
-in the created in the current package. The symbol is the concatenation
-of the enum-name name, separator-string, and field-name"
- (let ((counter 0)
- (cmds nil)
- (constants nil))
- (declare (fixnum counter))
- (dolist (arg args)
- (let ((name (if (listp arg) (car arg) arg))
- (value (if (listp arg)
- (prog1
- (setq counter (cadr arg))
- (incf counter))
- (prog1
- counter
- (incf counter)))))
- (setq name (intern (concatenate 'string
- (symbol-name enum-name)
- separator-string
- (symbol-name name))))
- (push `(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))
- #+cmu `((alien:def-alien-type ,enum-name alien:signed))
- #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
- #+openmcl `((ccl::def-foreign-type ,enum-name :int))
- (nreverse constants)))
- cmds))
-
-
-(defmacro def-array-pointer (name-array type)
- #+allegro
- `(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)))
- #+cmu
- `(alien:def-alien-type ,name-array
- (* ,(convert-from-uffi-type type :array)))
- #+(and mcl (not openmcl))
- `(def-mcl-type ,name-array '(:array ,type))
- #+openmcl
- `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
- )
-
-(defun process-struct-fields (name fields &optional (variant nil))
- (let (processed)
- (dolist (field fields)
- (let* ((field-name (car field))
- (type (cadr field))
- (def (append (list field-name)
- (if (eq type :pointer-self)
- #+cmu `((* (alien:struct ,name)))
- #+mcl `((:* (:struct ,name)))
- #-(or cmu mcl) `((* ,name))
- `(,(convert-from-uffi-type type :struct))))))
- (if variant
- (push (list def) processed)
- (push def processed))))
- (nreverse processed)))
-
-
-(defmacro def-struct (name &rest fields)
- #+cmu
- `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
- #+allegro
- `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
- #+lispworks
- `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
- #+(and mcl (not openmcl))
- `(ccl:defrecord ,name ,@(process-struct-fields name fields))
- #+openmcl
- `(ccl::def-foreign-type
- nil
- (:struct ,name ,@(process-struct-fields name fields)))
- )
-
-
-(defmacro get-slot-value (obj type slot)
- #+(or lispworks cmu) (declare (ignore type))
- #+allegro
- `(ff:fslot-value-typed ,type :c ,obj ,slot)
- #+lispworks
- `(fli:foreign-slot-value ,obj ,slot)
- #+cmu
- `(alien:slot ,obj ,slot)
- #+mcl
- `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
- )
-
-#+mcl
-(defmacro set-slot-value (obj type slot value) ;use setf to set values
- `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
-
-#+mcl
-(defsetf get-slot-value set-slot-value)
-
-
-(defmacro get-slot-pointer (obj type slot)
- #+(or lispworks cmu) (declare (ignore type))
- #+allegro
- `(ff:fslot-value-typed ,type :c ,obj ,slot)
- #+lispworks
- `(fli:foreign-slot-pointer ,obj ,slot)
- #+cmu
- `(alien:slot ,obj ,slot)
- #+(and mcl (not openmcl))
- `(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)))))
-)
-
-; so we could allow '(:array :long) or deref with other type like :long only
-#+mcl
-(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)))))
- result))
-
-
-(defmacro deref-array (obj type i)
- "Returns a field from a row"
- #+(or lispworks cmu) (declare (ignore type))
- #+cmu `(alien:deref ,obj ,i)
- #+lispworks `(fli:dereference ,obj :index ,i)
- #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
- #+mcl
- (let* ((array-type (array-type 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))))
- )
-
-; this expands to the %set-xx functions which has different params than %put-xx
-#+mcl
-(defmacro deref-array-set (obj type i value)
- (let* ((array-type (array-type type))
- (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
- ,obj
- (* (the fixnum ,i) ,(size-of-foreign-type local-type))
- ,value)))
-
-#+mcl
-(defsetf deref-array deref-array-set)
-
-(defmacro def-union (name &rest fields)
- #+allegro
- `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
- #+lispworks
- `(fli:define-c-union ,name ,@(process-struct-fields name fields))
- #+cmu
- `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
- #+(and mcl (not openmcl))
- `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
- #+openmcl
- `(ccl::def-foreign-type nil
- (:union ,name ,@(process-struct-fields name fields)))
-)
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: aggregates.cl
+;;;; Purpose: UFFI source to handle aggregate types
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: aggregates.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defmacro def-enum (enum-name args &key (separator-string "#"))
+ "Creates a constants for a C type enum list, symbols are created
+in the created in the current package. The symbol is the concatenation
+of the enum-name name, separator-string, and field-name"
+ (let ((counter 0)
+ (cmds nil)
+ (constants nil))
+ (declare (fixnum counter))
+ (dolist (arg args)
+ (let ((name (if (listp arg) (car arg) arg))
+ (value (if (listp arg)
+ (prog1
+ (setq counter (cadr arg))
+ (incf counter))
+ (prog1
+ counter
+ (incf counter)))))
+ (setq name (intern (concatenate 'string
+ (symbol-name enum-name)
+ separator-string
+ (symbol-name name))))
+ (push `(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))
+ #+cmu `((alien:def-alien-type ,enum-name alien:signed))
+ #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
+ #+openmcl `((ccl::def-foreign-type ,enum-name :int))
+ (nreverse constants)))
+ cmds))
+
+
+(defmacro def-array-pointer (name-array type)
+ #+allegro
+ `(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)))
+ #+cmu
+ `(alien:def-alien-type ,name-array
+ (* ,(convert-from-uffi-type type :array)))
+ #+(and mcl (not openmcl))
+ `(def-mcl-type ,name-array '(:array ,type))
+ #+openmcl
+ `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
+ )
+
+(defun process-struct-fields (name fields &optional (variant nil))
+ (let (processed)
+ (dolist (field fields)
+ (let* ((field-name (car field))
+ (type (cadr field))
+ (def (append (list field-name)
+ (if (eq type :pointer-self)
+ #+cmu `((* (alien:struct ,name)))
+ #+mcl `((:* (:struct ,name)))
+ #-(or cmu mcl) `((* ,name))
+ `(,(convert-from-uffi-type type :struct))))))
+ (if variant
+ (push (list def) processed)
+ (push def processed))))
+ (nreverse processed)))
+
+
+(defmacro def-struct (name &rest fields)
+ #+cmu
+ `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
+ #+allegro
+ `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
+ #+lispworks
+ `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
+ #+(and mcl (not openmcl))
+ `(ccl:defrecord ,name ,@(process-struct-fields name fields))
+ #+openmcl
+ `(ccl::def-foreign-type
+ nil
+ (:struct ,name ,@(process-struct-fields name fields)))
+ )
+
+
+(defmacro get-slot-value (obj type slot)
+ #+(or lispworks cmu) (declare (ignore type))
+ #+allegro
+ `(ff:fslot-value-typed ,type :c ,obj ,slot)
+ #+lispworks
+ `(fli:foreign-slot-value ,obj ,slot)
+ #+cmu
+ `(alien:slot ,obj ,slot)
+ #+mcl
+ `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
+ )
+
+#+mcl
+(defmacro set-slot-value (obj type slot value) ;use setf to set values
+ `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
+
+#+mcl
+(defsetf get-slot-value set-slot-value)
+
+
+(defmacro get-slot-pointer (obj type slot)
+ #+(or lispworks cmu) (declare (ignore type))
+ #+allegro
+ `(ff:fslot-value-typed ,type :c ,obj ,slot)
+ #+lispworks
+ `(fli:foreign-slot-pointer ,obj ,slot)
+ #+cmu
+ `(alien:slot ,obj ,slot)
+ #+(and mcl (not openmcl))
+ `(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)))))
+)
+
+; so we could allow '(:array :long) or deref with other type like :long only
+#+mcl
+(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)))))
+ result))
+
+
+(defmacro deref-array (obj type i)
+ "Returns a field from a row"
+ #+(or lispworks cmu) (declare (ignore type))
+ #+cmu `(alien:deref ,obj ,i)
+ #+lispworks `(fli:dereference ,obj :index ,i)
+ #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
+ #+mcl
+ (let* ((array-type (array-type 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))))
+ )
+
+; this expands to the %set-xx functions which has different params than %put-xx
+#+mcl
+(defmacro deref-array-set (obj type i value)
+ (let* ((array-type (array-type type))
+ (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
+ ,obj
+ (* (the fixnum ,i) ,(size-of-foreign-type local-type))
+ ,value)))
+
+#+mcl
+(defsetf deref-array deref-array-set)
+
+(defmacro def-union (name &rest fields)
+ #+allegro
+ `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
+ #+lispworks
+ `(fli:define-c-union ,name ,@(process-struct-fields name fields))
+ #+cmu
+ `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+ #+(and mcl (not openmcl))
+ `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
+ #+openmcl
+ `(ccl::def-foreign-type nil
+ (:union ,name ,@(process-struct-fields name fields)))
+)
+++ /dev/null
-some notes:
- we need the :pascal (:stdcall) calling conventions for
- (def-function names args &key module returning calling-convention)
- so I added this. calling-convention defaults to :cdecl
- but on win32 we mostly use :stdcall
-
- #+corman is invalid, #+cormanlisp instead
-
- cormanlisp doesn't need to load and register the dll, since the underlying
- LoadLibrary() call does this. we need the module keyword for def-function
-instead.
- (should probably default to kernel32.dll)
- I'll think about library.cl, but we'll need more real-world win32 examples.
- (ideally the complete winapi :)
- I also have to look at valentina.
-
-patch -p0 < corman.diff
---
-Reini Urban
-http://xarch.tu-graz.ac.at/home/rurban/
---------------269CD5B1F75AF20CFDFE4FEE
-Content-Type: text/plain; charset=us-ascii; name="corman.diff"
-Content-Disposition: inline; filename="corman.diff"
-Content-Transfer-Encoding: 7bit
-
---- ./examples/getenv-ccl.cl~ Tue Apr 9 21:08:18 2002
-+++ ./examples/getenv-ccl.cl Tue Apr 9 20:58:16 2002
-@@ -0,0 +1,87 @@
-+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-+;;;; *************************************************************************
-+;;;; FILE IDENTIFICATION
-+;;;;
-+;;;; Name: getenv-ccl.cl
-+;;;; Purpose: cormanlisp version
-+;;;; Programmer: "Joe Marshall" <prunesquallor@attbi.com>
-+;;;; Date Started: Feb 2002
-+;;;;
-+;;;; $Id: corman-uffi.cl,v 1.5 2002/09/30 07:52:34 kevin Exp $
-+;;;;
-+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-+;;;;
-+;;;; UFFI users are granted the rights to distribute and use this software
-+;;;; as governed by the terms of the Lisp Lesser GNU Public License
-+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-+;;;; *************************************************************************
-+
-+(in-package :cl-user)
-+
-+(ct:defun-dll c-getenv ((lpname LPSTR)
-+ (lpbuffer LPSTR)
-+ (nsize LPDWORD))
-+ :library-name "kernel32.dll"
-+ :return-type DWORD
-+ :entry-name "GetEnvironmentVariableA"
-+ :linkage-type :pascal)
-+
-+(defun getenv (name)
-+ (let ((nsizebuf (ct:malloc (sizeof :long)))
-+ (buffer (ct:malloc 1))
-+ (cname (ct:lisp-string-to-c-string name)))
-+ (setf (ct:cref lpdword nsizebuf 0) 0)
-+ (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))
-+ nil
-+ (ct:c-string-to-lisp-string buffer1))
-+ (ct:free buffer1)
-+ (ct:free nsizebuf)))))
-+
-+(defun cl:user-homedir-pathname (&optional host)
-+ (cond ((or (stringp host)
-+ (and (consp host)
-+ (every #'stringp host))) nil)
-+ ((or (eq host :unspecific)
-+ (null host))
-+ (let ((homedrive (getenv "HOMEDRIVE"))
-+ (homepath (getenv "HOMEPATH")))
-+ (parse-namestring
-+ (if (and (stringp homedrive)
-+ (stringp homepath)
-+ (= (length homedrive) 2)
-+ (> (length homepath) 0))
-+ (concatenate 'string homedrive homepath "\\")
-+ "C:\\"))))
-+ (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
-+
-+;|
-+(uffi:def-function ("getenv" c-getenv)
-+ ((name :cstring))
-+ :returning :cstring)
-+
-+(defun my-getenv (key)
-+ "Returns an environment variable, or NIL if it does not exist"
-+ (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))))
-+ (print-results "USER")
-+ (print-results "_FOO_")))
-+
-+
-+#+test-uffi
-+(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")
-+)
-+
-+|;
-\ No newline at end of file
---- ./Makefile~ Tue Apr 9 20:03:18 2002
-+++ ./Makefile Tue Apr 9 20:38:03 2002
-@@ -64,3 +64,7 @@
-
- wwwdist: dist
- @./copy
-+
-+TAGS:
-+ if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
-+ find . -name \*.cl -exec /usr/bin/etags -a \{\} \;
---- ./set-logical.cl~ Tue Apr 9 20:03:20 2002
-+++ ./set-logical.cl Tue Apr 9 20:35:44 2002
-@@ -35,10 +35,10 @@
- #+clisp "clisp"
- #+cmu "cmucl"
- #+sbcl "sbcl"
-- #+corman "corman"
-+ #+cormanlisp "cormanlisp"
- #+mcl "mcl"
- #+openmcl "openmcl"
-- #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
-+ #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown")
-
- (defun set-logical-host-for-pathname (host base-pathname)
- (setf (logical-pathname-translations host)
---- ./src/functions.cl~ Tue Apr 9 20:03:24 2002
-+++ ./src/functions.cl Tue Apr 9 21:00:07 2002
-@@ -3,7 +3,7 @@
- ;;;; FILE IDENTIFICATION
- ;;;;
- ;;;; Name: function.cl
--;;;; Purpose: UFFI source to C function defintions
-+;;;; Purpose: UFFI source to C function definitions
- ;;;; Programmer: Kevin M. Rosenberg
- ;;;; Date Started: Feb 2002
- ;;;;
-@@ -21,9 +21,8 @@
-
- (defun process-function-args (args)
- (if (null args)
-- #+lispworks nil
-+ #+(or lispworks cmu cormanlisp) nil
- #+allegro '(:void)
-- #+cmu nil
- (let (processed)
- (dolist (arg args)
- (push (process-one-function-arg arg) processed))
-@@ -34,7 +33,7 @@
- (type (convert-from-uffi-type (cadr arg) :routine)))
- #+cmu
- (list name type :in)
-- #+(or allegro lispworks)
-+ #+(or allegro lispworks cormanlisp)
- (if (and (listp type) (listp (car type)))
- (append (list name) type)
- (list name type))
-@@ -47,15 +46,15 @@
-
- ;; 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 allegro) (declare (ignore module))
-+(defmacro def-function (names args &key module returning calling-convention)
-+ #+(or cmu allegro 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))))
-
-- #+allegro
-+ #+allegro ; todo: calling-convention :stdcall
- `(ff:def-foreign-call (,lisp-name ,foreign-name)
- ,function-args
- :returning ,(allegro-convert-return-type result-type)
-@@ -70,7 +69,13 @@
- ,function-args
- ,@(if module (list :module module) (values))
- :result-type ,result-type
-- :calling-convention :cdecl)
-+ :calling-convention ,calling-convention)
-+ #+cormanlisp
-+ `(ct:defun-dll ,lisp-name (,function-args)
-+ :return-type ,result-type
-+ ,@(if module (list :library-name module) (values))
-+ :entry-name ,foreign-name
-+ :linkage-type ,calling-convention) ; we need :pascal
- ))
-
-
---- ./src/primitives.cl~ Tue Apr 9 20:03:25 2002
-+++ ./src/primitives.cl Tue Apr 9 21:05:13 2002
-@@ -29,9 +29,9 @@
- (defmacro def-type (name type)
- "Generates a (deftype) statement for CL. Currently, only CMUCL
- supports takes advantage of this optimization."
-- #+(or lispworks allegro)
-+ #+(or lispworks allegro cormanlisp)
- (declare (ignore type))
-- #+(or lispworks allegro)
-+ #+(or lispworks allegro cormanlisp)
- `(deftype ,name () t)
- #+cmu
- `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
-@@ -45,6 +45,7 @@
- #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
- #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
- #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
-+ #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
- )
-
- (eval-when (:compile-toplevel :load-toplevel :execute)
-@@ -66,7 +67,7 @@
- (:float . alien:single-float)
- (:double . alien:double-float)
- )
-- "Conversions in CMUCL or def-foreign-type are different thatn in def-function")
-+ "Conversions in CMUCL for def-foreign-type are different that in def-function")
-
-
- #+cmu
-@@ -84,7 +85,7 @@
- (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
- (:float . c-call:float) (:double . c-call:double)
- (:array . alien:array)))
--#+allegro
-+#+(or allegro cormanlisp)
- (defconstant +type-conversion-list+
- '((* . *) (:void . :void)
- (:short . :short)
-@@ -129,7 +130,7 @@
- "Converts from a uffi type to an implementation specific type"
- (if (atom type)
- (cond
-- #+allegro
-+ #+(or allegro cormanlisp)
- ((and (or (eq context :routine) (eq context :return))
- (eq type :cstring))
- (setq type '((* :char) integer)))
---- ./uffi.system~ Tue Apr 9 20:03:20 2002
-+++ ./uffi.system Tue Apr 9 20:36:14 2002
-@@ -27,7 +27,7 @@
- (merge-pathnames
- (make-pathname
- :directory
-- #+(or cmu allegro lispworks)
-+ #+(or cmu allegro lispworks cormanlisp)
- '(:relative "src")
- #+mcl
- '(:relative "src" "mcl")
-
---------------269CD5B1F75AF20CFDFE4FEE--
-
-_______________________________________________
-UFFI-Devel mailing list
-UFFI-Devel@b9.com
-http://www.b9.com/mailman/listinfo/uffi-devel
-
--- /dev/null
+some notes:
+ we need the :pascal (:stdcall) calling conventions for
+ (def-function names args &key module returning calling-convention)
+ so I added this. calling-convention defaults to :cdecl
+ but on win32 we mostly use :stdcall
+
+ #+corman is invalid, #+cormanlisp instead
+
+ cormanlisp doesn't need to load and register the dll, since the underlying
+ LoadLibrary() call does this. we need the module keyword for def-function
+instead.
+ (should probably default to kernel32.dll)
+ I'll think about library.cl, but we'll need more real-world win32 examples.
+ (ideally the complete winapi :)
+ I also have to look at valentina.
+
+patch -p0 < corman.diff
+--
+Reini Urban
+http://xarch.tu-graz.ac.at/home/rurban/
+--------------269CD5B1F75AF20CFDFE4FEE
+Content-Type: text/plain; charset=us-ascii; name="corman.diff"
+Content-Disposition: inline; filename="corman.diff"
+Content-Transfer-Encoding: 7bit
+
+--- ./examples/getenv-ccl.cl~ Tue Apr 9 21:08:18 2002
++++ ./examples/getenv-ccl.cl Tue Apr 9 20:58:16 2002
+@@ -0,0 +1,87 @@
++;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
++;;;; *************************************************************************
++;;;; FILE IDENTIFICATION
++;;;;
++;;;; Name: getenv-ccl.cl
++;;;; Purpose: cormanlisp version
++;;;; Programmer: "Joe Marshall" <prunesquallor@attbi.com>
++;;;; Date Started: Feb 2002
++;;;;
++;;;; $Id: corman-uffi.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
++;;;;
++;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
++;;;;
++;;;; UFFI users are granted the rights to distribute and use this software
++;;;; as governed by the terms of the Lisp Lesser GNU Public License
++;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
++;;;; *************************************************************************
++
++(in-package :cl-user)
++
++(ct:defun-dll c-getenv ((lpname LPSTR)
++ (lpbuffer LPSTR)
++ (nsize LPDWORD))
++ :library-name "kernel32.dll"
++ :return-type DWORD
++ :entry-name "GetEnvironmentVariableA"
++ :linkage-type :pascal)
++
++(defun getenv (name)
++ (let ((nsizebuf (ct:malloc (sizeof :long)))
++ (buffer (ct:malloc 1))
++ (cname (ct:lisp-string-to-c-string name)))
++ (setf (ct:cref lpdword nsizebuf 0) 0)
++ (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))
++ nil
++ (ct:c-string-to-lisp-string buffer1))
++ (ct:free buffer1)
++ (ct:free nsizebuf)))))
++
++(defun cl:user-homedir-pathname (&optional host)
++ (cond ((or (stringp host)
++ (and (consp host)
++ (every #'stringp host))) nil)
++ ((or (eq host :unspecific)
++ (null host))
++ (let ((homedrive (getenv "HOMEDRIVE"))
++ (homepath (getenv "HOMEPATH")))
++ (parse-namestring
++ (if (and (stringp homedrive)
++ (stringp homepath)
++ (= (length homedrive) 2)
++ (> (length homepath) 0))
++ (concatenate 'string homedrive homepath "\\")
++ "C:\\"))))
++ (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
++
++;|
++(uffi:def-function ("getenv" c-getenv)
++ ((name :cstring))
++ :returning :cstring)
++
++(defun my-getenv (key)
++ "Returns an environment variable, or NIL if it does not exist"
++ (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))))
++ (print-results "USER")
++ (print-results "_FOO_")))
++
++
++#+test-uffi
++(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")
++)
++
++|;
+\ No newline at end of file
+--- ./Makefile~ Tue Apr 9 20:03:18 2002
++++ ./Makefile Tue Apr 9 20:38:03 2002
+@@ -64,3 +64,7 @@
+
+ wwwdist: dist
+ @./copy
++
++TAGS:
++ if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
++ find . -name \*.cl -exec /usr/bin/etags -a \{\} \;
+--- ./set-logical.cl~ Tue Apr 9 20:03:20 2002
++++ ./set-logical.cl Tue Apr 9 20:35:44 2002
+@@ -35,10 +35,10 @@
+ #+clisp "clisp"
+ #+cmu "cmucl"
+ #+sbcl "sbcl"
+- #+corman "corman"
++ #+cormanlisp "cormanlisp"
+ #+mcl "mcl"
+ #+openmcl "openmcl"
+- #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
++ #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown")
+
+ (defun set-logical-host-for-pathname (host base-pathname)
+ (setf (logical-pathname-translations host)
+--- ./src/functions.cl~ Tue Apr 9 20:03:24 2002
++++ ./src/functions.cl Tue Apr 9 21:00:07 2002
+@@ -3,7 +3,7 @@
+ ;;;; FILE IDENTIFICATION
+ ;;;;
+ ;;;; Name: function.cl
+-;;;; Purpose: UFFI source to C function defintions
++;;;; Purpose: UFFI source to C function definitions
+ ;;;; Programmer: Kevin M. Rosenberg
+ ;;;; Date Started: Feb 2002
+ ;;;;
+@@ -21,9 +21,8 @@
+
+ (defun process-function-args (args)
+ (if (null args)
+- #+lispworks nil
++ #+(or lispworks cmu cormanlisp) nil
+ #+allegro '(:void)
+- #+cmu nil
+ (let (processed)
+ (dolist (arg args)
+ (push (process-one-function-arg arg) processed))
+@@ -34,7 +33,7 @@
+ (type (convert-from-uffi-type (cadr arg) :routine)))
+ #+cmu
+ (list name type :in)
+- #+(or allegro lispworks)
++ #+(or allegro lispworks cormanlisp)
+ (if (and (listp type) (listp (car type)))
+ (append (list name) type)
+ (list name type))
+@@ -47,15 +46,15 @@
+
+ ;; 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 allegro) (declare (ignore module))
++(defmacro def-function (names args &key module returning calling-convention)
++ #+(or cmu allegro 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))))
+
+- #+allegro
++ #+allegro ; todo: calling-convention :stdcall
+ `(ff:def-foreign-call (,lisp-name ,foreign-name)
+ ,function-args
+ :returning ,(allegro-convert-return-type result-type)
+@@ -70,7 +69,13 @@
+ ,function-args
+ ,@(if module (list :module module) (values))
+ :result-type ,result-type
+- :calling-convention :cdecl)
++ :calling-convention ,calling-convention)
++ #+cormanlisp
++ `(ct:defun-dll ,lisp-name (,function-args)
++ :return-type ,result-type
++ ,@(if module (list :library-name module) (values))
++ :entry-name ,foreign-name
++ :linkage-type ,calling-convention) ; we need :pascal
+ ))
+
+
+--- ./src/primitives.cl~ Tue Apr 9 20:03:25 2002
++++ ./src/primitives.cl Tue Apr 9 21:05:13 2002
+@@ -29,9 +29,9 @@
+ (defmacro def-type (name type)
+ "Generates a (deftype) statement for CL. Currently, only CMUCL
+ supports takes advantage of this optimization."
+- #+(or lispworks allegro)
++ #+(or lispworks allegro cormanlisp)
+ (declare (ignore type))
+- #+(or lispworks allegro)
++ #+(or lispworks allegro cormanlisp)
+ `(deftype ,name () t)
+ #+cmu
+ `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
+@@ -45,6 +45,7 @@
+ #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
+ #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
+ #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
++ #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
+ )
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+@@ -66,7 +67,7 @@
+ (:float . alien:single-float)
+ (:double . alien:double-float)
+ )
+- "Conversions in CMUCL or def-foreign-type are different thatn in def-function")
++ "Conversions in CMUCL for def-foreign-type are different that in def-function")
+
+
+ #+cmu
+@@ -84,7 +85,7 @@
+ (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
+ (:float . c-call:float) (:double . c-call:double)
+ (:array . alien:array)))
+-#+allegro
++#+(or allegro cormanlisp)
+ (defconstant +type-conversion-list+
+ '((* . *) (:void . :void)
+ (:short . :short)
+@@ -129,7 +130,7 @@
+ "Converts from a uffi type to an implementation specific type"
+ (if (atom type)
+ (cond
+- #+allegro
++ #+(or allegro cormanlisp)
+ ((and (or (eq context :routine) (eq context :return))
+ (eq type :cstring))
+ (setq type '((* :char) integer)))
+--- ./uffi.system~ Tue Apr 9 20:03:20 2002
++++ ./uffi.system Tue Apr 9 20:36:14 2002
+@@ -27,7 +27,7 @@
+ (merge-pathnames
+ (make-pathname
+ :directory
+- #+(or cmu allegro lispworks)
++ #+(or cmu allegro lispworks cormanlisp)
+ '(:relative "src")
+ #+mcl
+ '(:relative "src" "mcl")
+
+--------------269CD5B1F75AF20CFDFE4FEE--
+
+_______________________________________________
+UFFI-Devel mailing list
+UFFI-Devel@b9.com
+http://www.b9.com/mailman/listinfo/uffi-devel
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: function.cl
-;;;; Purpose: UFFI source to C function defintions
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: functions.cl,v 1.10 2002/09/30 07:51:01 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defun process-function-args (args)
- (if (null args)
- #+lispworks nil
- #+allegro '(:void)
- #+cmu nil
- #+(and mcl (not openmcl)) nil
- #+mcl (values nil nil)
-
- ;; args not null
- #+(or lispworks allegro cmu (and mcl (not openmcl)))
- (let (processed)
- (dolist (arg args)
- (push (process-one-function-arg arg) processed))
- (nreverse processed))
- #+openmcl
- (let ((processed nil)
- (params nil)
- name type)
- (dolist (arg args)
- (setf name (car arg))
- (setf 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)))
- #+cmu
- (list name type :in)
- #+(or allegro lispworks (and mcl (not openmcl)))
- (if (and (listp type) (listp (car type)))
- (append (list name) type)
- (list name type))
- ))
-
-
-(defun allegro-convert-return-type (type)
- (if (and (listp type) (not (listp (car type))))
- (list type)
- type))
-
-;; 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 allegro mcl) (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))))
-
- #+allegro
- `(ff:def-foreign-call (,lisp-name ,foreign-name)
- ,function-args
- :returning ,(allegro-convert-return-type result-type)
- :call-direct t
- :strings-convert nil)
- #+cmu
- `(alien:def-alien-routine (,foreign-name ,lisp-name)
- ,result-type
- ,@function-args)
- #+lispworks
- `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
- ,function-args
- ,@(if module (list :module module) (values))
- :result-type ,result-type
- :calling-convention :cdecl)
- #+(and mcl (not openmcl))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (ccl:define-entry-point (,lisp-name ,foreign-name)
- ,function-args
- ,result-type))
- #+(and openmcl darwinppc-target)
- (setf foreign-name (concatenate 'string "_" foreign-name))
- #+openmcl
- (multiple-value-bind (params args) (process-function-args args)
- `(defun ,lisp-name ,params
- (ccl::external-call ,foreign-name ,@args ,result-type)))
- ))
-
-
-(defun make-lisp-name (name)
- (let ((converted (substitute #\- #\_ name)))
- (intern
- #+case-sensitive converted
- #-case-sensitive (string-upcase converted))))
-
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: function.cl
+;;;; Purpose: UFFI source to C function defintions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: functions.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defun process-function-args (args)
+ (if (null args)
+ #+lispworks nil
+ #+allegro '(:void)
+ #+cmu nil
+ #+(and mcl (not openmcl)) nil
+ #+mcl (values nil nil)
+
+ ;; args not null
+ #+(or lispworks allegro cmu (and mcl (not openmcl)))
+ (let (processed)
+ (dolist (arg args)
+ (push (process-one-function-arg arg) processed))
+ (nreverse processed))
+ #+openmcl
+ (let ((processed nil)
+ (params nil)
+ name type)
+ (dolist (arg args)
+ (setf name (car arg))
+ (setf 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)))
+ #+cmu
+ (list name type :in)
+ #+(or allegro lispworks (and mcl (not openmcl)))
+ (if (and (listp type) (listp (car type)))
+ (append (list name) type)
+ (list name type))
+ ))
+
+
+(defun allegro-convert-return-type (type)
+ (if (and (listp type) (not (listp (car type))))
+ (list type)
+ type))
+
+;; 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 allegro mcl) (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))))
+
+ #+allegro
+ `(ff:def-foreign-call (,lisp-name ,foreign-name)
+ ,function-args
+ :returning ,(allegro-convert-return-type result-type)
+ :call-direct t
+ :strings-convert nil)
+ #+cmu
+ `(alien:def-alien-routine (,foreign-name ,lisp-name)
+ ,result-type
+ ,@function-args)
+ #+lispworks
+ `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
+ ,function-args
+ ,@(if module (list :module module) (values))
+ :result-type ,result-type
+ :calling-convention :cdecl)
+ #+(and mcl (not openmcl))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ccl:define-entry-point (,lisp-name ,foreign-name)
+ ,function-args
+ ,result-type))
+ #+(and openmcl darwinppc-target)
+ (setf foreign-name (concatenate 'string "_" foreign-name))
+ #+openmcl
+ (multiple-value-bind (params args) (process-function-args args)
+ `(defun ,lisp-name ,params
+ (ccl::external-call ,foreign-name ,@args ,result-type)))
+ ))
+
+
+(defun make-lisp-name (name)
+ (let ((converted (substitute #\- #\_ name)))
+ (intern
+ #+case-sensitive converted
+ #-case-sensitive (string-upcase converted))))
+
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: libraries.cl
-;;;; Purpose: UFFI source to load foreign libraries
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: libraries.cl,v 1.18 2002/09/30 07:51:01 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defvar *loaded-libraries* nil
- "List of foreign libraries loaded. Used to prevent reloading a library")
-
-(defun default-foreign-library-type ()
- "Returns string naming default library type for platform"
- #+(or win32 mswindows) "dll"
- #+macosx "dylib"
- #-(or win32 mswindows macosx) "so"
-)
-
-(defun find-foreign-library (names directories &key types drive-letters)
- "Looks for a foreign library. directories can be a single
-string or a list of strings of candidate directories. Use default
-library type if type is not specified."
- (unless types
- (setq types (default-foreign-library-type)))
- (unless (listp types)
- (setq types (list types)))
- (unless (listp names)
- (setq names (list names)))
- (unless (listp directories)
- (setq directories (list directories)))
- #+(or win32 mswindows)
- (unless (listp drive-letters)
- (setq drive-letters (list drive-letters)))
- #-(or win32 mswindows)
- (setq drive-letters '(nil))
- (dolist (drive-letter drive-letters)
- (dolist (name names)
- (dolist (dir directories)
- (dolist (type types)
- (let ((path (make-pathname
- #+lispworks :host
- #+lispworks (when drive-letter drive-letter)
- #-lispworks :device
- #-lispworks (when drive-letter drive-letter)
- :name name
- :type type
- :directory
- (etypecase dir
- (pathname
- (pathname-directory dir))
- (list
- dir)
- (string
- (pathname-directory
- (parse-namestring dir)))))))
- (when (probe-file path)
- (return-from find-foreign-library path)))))))
- nil)
-
-
-(defun load-foreign-library (filename &key module supporting-libraries
- force-load)
- #+allegro (declare (ignore module supporting-libraries))
- #+lispworks (declare (ignore supporting-libraries))
- #+cmu (declare (ignore module))
- #+openmcl (declare (ignore module supporting-libraries))
-
- (when (and filename (probe-file filename))
- (if (pathnamep filename) ;; ensure filename is a string to check if
- (setq filename (namestring filename))) ; already loaded
-
- (if (and (not force-load)
- (find filename *loaded-libraries* :test #'string-equal))
- t ;; return T, but don't reload library
- (progn
- (when
- #+cmu
- (let ((type (pathname-type (parse-namestring filename))))
- (if (equal type "so")
- (sys::load-object-file filename)
- (alien:load-foreign filename
- :libraries
- (convert-supporting-libraries-to-string
- supporting-libraries))))
- #+lispworks (fli:register-module module :real-name filename)
- #+allegro (load filename)
- #+openmcl (ccl:open-shared-library filename)
- #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t)
-
- (push filename *loaded-libraries*)
- t)))))
-
-(defun convert-supporting-libraries-to-string (libs)
- (let (lib-load-list)
- (dolist (lib libs)
- (push (format nil "-l~A" lib) lib-load-list))
- (nreverse lib-load-list)))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: libraries.cl
+;;;; Purpose: UFFI source to load foreign libraries
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: libraries.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defvar *loaded-libraries* nil
+ "List of foreign libraries loaded. Used to prevent reloading a library")
+
+(defun default-foreign-library-type ()
+ "Returns string naming default library type for platform"
+ #+(or win32 mswindows) "dll"
+ #+macosx "dylib"
+ #-(or win32 mswindows macosx) "so"
+)
+
+(defun find-foreign-library (names directories &key types drive-letters)
+ "Looks for a foreign library. directories can be a single
+string or a list of strings of candidate directories. Use default
+library type if type is not specified."
+ (unless types
+ (setq types (default-foreign-library-type)))
+ (unless (listp types)
+ (setq types (list types)))
+ (unless (listp names)
+ (setq names (list names)))
+ (unless (listp directories)
+ (setq directories (list directories)))
+ #+(or win32 mswindows)
+ (unless (listp drive-letters)
+ (setq drive-letters (list drive-letters)))
+ #-(or win32 mswindows)
+ (setq drive-letters '(nil))
+ (dolist (drive-letter drive-letters)
+ (dolist (name names)
+ (dolist (dir directories)
+ (dolist (type types)
+ (let ((path (make-pathname
+ #+lispworks :host
+ #+lispworks (when drive-letter drive-letter)
+ #-lispworks :device
+ #-lispworks (when drive-letter drive-letter)
+ :name name
+ :type type
+ :directory
+ (etypecase dir
+ (pathname
+ (pathname-directory dir))
+ (list
+ dir)
+ (string
+ (pathname-directory
+ (parse-namestring dir)))))))
+ (when (probe-file path)
+ (return-from find-foreign-library path)))))))
+ nil)
+
+
+(defun load-foreign-library (filename &key module supporting-libraries
+ force-load)
+ #+allegro (declare (ignore module supporting-libraries))
+ #+lispworks (declare (ignore supporting-libraries))
+ #+cmu (declare (ignore module))
+ #+openmcl (declare (ignore module supporting-libraries))
+
+ (when (and filename (probe-file filename))
+ (if (pathnamep filename) ;; ensure filename is a string to check if
+ (setq filename (namestring filename))) ; already loaded
+
+ (if (and (not force-load)
+ (find filename *loaded-libraries* :test #'string-equal))
+ t ;; return T, but don't reload library
+ (progn
+ (when
+ #+cmu
+ (let ((type (pathname-type (parse-namestring filename))))
+ (if (equal type "so")
+ (sys::load-object-file filename)
+ (alien:load-foreign filename
+ :libraries
+ (convert-supporting-libraries-to-string
+ supporting-libraries))))
+ #+lispworks (fli:register-module module :real-name filename)
+ #+allegro (load filename)
+ #+openmcl (ccl:open-shared-library filename)
+ #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t)
+
+ (push filename *loaded-libraries*)
+ t)))))
+
+(defun convert-supporting-libraries-to-string (libs)
+ (let (lib-load-list)
+ (dolist (lib libs)
+ (push (format nil "-l~A" lib) lib-load-list))
+ (nreverse lib-load-list)))
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: readmacros-mcl.cl
-;;;; Purpose: UFFI source to handle objects and pointers
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: objects-mcl.cl,v 1.1 2002/09/30 07:51:01 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-;; trap macros don't work right directly in the macros
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
- #+(and mcl (not openmcl))
- (defun new-ptr (size)
- (#_NewPtr size))
-
- #+(and mcl (not openmcl))
- (defun dispose-ptr (ptr)
- (#_DisposePtr ptr))
-
- #+openmcl
- (defmacro new-ptr (size)
- `(ccl::malloc ,size))
-
- #+openmcl
- (defmacro dispose-ptr (ptr)
- `(ccl::free ,ptr))
- )
-
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: readmacros-mcl.cl
+;;;; Purpose: UFFI source to handle objects and pointers
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: objects-mcl.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+;; trap macros don't work right directly in the macros
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ #+(and mcl (not openmcl))
+ (defun new-ptr (size)
+ (#_NewPtr size))
+
+ #+(and mcl (not openmcl))
+ (defun dispose-ptr (ptr)
+ (#_DisposePtr ptr))
+
+ #+openmcl
+ (defmacro new-ptr (size)
+ `(ccl::malloc ,size))
+
+ #+openmcl
+ (defmacro dispose-ptr (ptr)
+ `(ccl::free ,ptr))
+ )
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: objects.cl
-;;;; Purpose: UFFI source to handle objects and pointers
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: objects.cl,v 1.26 2002/09/30 09:08:48 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defun size-of-foreign-type (type)
- #+lispworks (fli:size-of type)
- #+allegro (ff:sizeof-fobject type)
- #+cmu (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
- #+clisp (values (ffi:size-of type))
- #+(and mcl (not openmcl))
- (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
- #+openmcl (ccl::%foreign-type-or-record-size type :bytes)
- )
-
-
-(defmacro allocate-foreign-object (type &optional (size :unspecified))
- "Allocates an instance of TYPE. If size is specified, then allocate
-an array of TYPE with size SIZE. The TYPE parameter is evaluated."
- (if (eq size :unspecified)
- (progn
- #+cmu
- `(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)
- #+mcl
- `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
- )
- (progn
- #+cmu
- `(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 '(:array ,(convert-from-uffi-type (eval type) :allocate) ,(eval size)) :c)
- #+mcl
- `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
- )))
-
-(defmacro free-foreign-object (obj)
- #+cmu
- `(alien:free-alien ,obj)
- #+lispworks
- `(fli:free-foreign-object ,obj)
- #+allegro
- `(ff:free-fobject ,obj)
- #+mcl
- `(dispose-ptr ,obj)
- )
-
-(defmacro null-pointer-p (obj)
- #+lispworks `(fli:null-pointer-p ,obj)
- #+allegro `(zerop ,obj)
- #+cmu `(alien:null-alien ,obj)
- #+mcl `(ccl:%null-ptr-p ,obj)
- )
-
-(defmacro make-null-pointer (type)
- #+(or allegro cmu mcl) (declare (ignore type))
-
- #+cmu `(system:int-sap 0)
- #+allegro 0
- #+lispworks `(fli:make-pointer :address 0 :type ,type)
- #+mcl `(ccl:%null-ptr)
- )
-
-(defmacro char-array-to-pointer (obj)
- #+cmu `(alien:cast ,obj (* (alien:unsigned 8)))
- #+lispworks `(fli:make-pointer :type '(:unsigned :char)
- :address (fli:pointer-address ,obj))
- #+allegro obj
- #+mcl obj
- )
-
-(defmacro deref-pointer (ptr type)
- "Returns a object pointed"
- #+(or cmu lispworks) (declare (ignore type))
- #+cmu `(alien:deref ,ptr)
- #+lispworks `(fli:dereference ,ptr)
- #+allegro `(ff:fslot-value-typed ,(convert-from-uffi-type type :deref) :c ,ptr)
- #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
- )
-
-#+mcl
-(defmacro deref-pointer-set (ptr type value)
- `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
-
-#+mcl
-(defsetf deref-pointer deref-pointer-set)
-
-#+(or lispworks (and mcl (not openmcl))) ;; with LW, deref is a character
-(defmacro ensure-char-character (obj)
- obj)
-
-#+(or allegro cmu openmcl)
-(defmacro ensure-char-character (obj)
- `(code-char ,obj))
-
-#+(or lispworks (and mcl (not openmcl)))
-(defmacro ensure-char-integer (obj)
- `(char-code ,obj))
-
-#+(or allegro cmu openmcl)
-(defmacro ensure-char-integer (obj)
- obj)
-
-(defmacro pointer-address (obj)
- #+cmu
- `(system:sap-int (alien:alien-sap ,obj))
- #+lispworks
- `(fli:pointer-address ,obj)
- #+allegro
- obj
- #+mcl
- `(ccl:%ptr-to-int ,obj)
- )
-
-;; TYPE is evaluated.
-#-mcl
-(defmacro with-foreign-object ((var type) &rest body)
- #-(or cmu lispworks) ; default version
- `(let ((,var (allocate-foreign-object ,type)))
- (unwind-protect
- (progn ,@body)
- (free-foreign-object ,var)))
- #+cmu
- (let ((obj (gensym)))
- `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
- (let ((,var (alien:addr ,obj)))
- ,@body)))
- #+lispworks
- `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
- (eval type) :allocate)))
- ,@body)
- )
-
-#-mcl
-(defmacro with-foreign-objects (bindings &rest body)
- (if bindings
- `(with-foreign-object ,(car bindings)
- (with-foreign-objects ,(cdr bindings)
- ,@body))
- `(progn ,@body)))
-
-#+mcl
-(defmacro with-foreign-objects (bindings &rest body)
- (let ((params nil) type count)
- (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
- (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
- (setf count 1)
- (when (and (listp type) (eq (first type) :array))
- (setf count (nth 2 type))
- (unless (integerp count) (error "Invalid size for array: ~a" type))
- (setf type (nth 1 type)))
- (push (list (first spec) (* count (size-of-foreign-type type))) params))
- `(ccl:%stack-block ,params ,@body)))
-
-#+mcl
-(defmacro with-foreign-object ((var type) &rest body)
- `(with-foreign-objects ((,var ,type))
- ,@body))
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: objects.cl
+;;;; Purpose: UFFI source to handle objects and pointers
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: objects.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defun size-of-foreign-type (type)
+ #+lispworks (fli:size-of type)
+ #+allegro (ff:sizeof-fobject type)
+ #+cmu (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
+ #+clisp (values (ffi:size-of type))
+ #+(and mcl (not openmcl))
+ (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
+ #+openmcl (ccl::%foreign-type-or-record-size type :bytes)
+ )
+
+
+(defmacro allocate-foreign-object (type &optional (size :unspecified))
+ "Allocates an instance of TYPE. If size is specified, then allocate
+an array of TYPE with size SIZE. The TYPE parameter is evaluated."
+ (if (eq size :unspecified)
+ (progn
+ #+cmu
+ `(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)
+ #+mcl
+ `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
+ )
+ (progn
+ #+cmu
+ `(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 '(:array ,(convert-from-uffi-type (eval type) :allocate) ,(eval size)) :c)
+ #+mcl
+ `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
+ )))
+
+(defmacro free-foreign-object (obj)
+ #+cmu
+ `(alien:free-alien ,obj)
+ #+lispworks
+ `(fli:free-foreign-object ,obj)
+ #+allegro
+ `(ff:free-fobject ,obj)
+ #+mcl
+ `(dispose-ptr ,obj)
+ )
+
+(defmacro null-pointer-p (obj)
+ #+lispworks `(fli:null-pointer-p ,obj)
+ #+allegro `(zerop ,obj)
+ #+cmu `(alien:null-alien ,obj)
+ #+mcl `(ccl:%null-ptr-p ,obj)
+ )
+
+(defmacro make-null-pointer (type)
+ #+(or allegro cmu mcl) (declare (ignore type))
+
+ #+cmu `(system:int-sap 0)
+ #+allegro 0
+ #+lispworks `(fli:make-pointer :address 0 :type ,type)
+ #+mcl `(ccl:%null-ptr)
+ )
+
+(defmacro char-array-to-pointer (obj)
+ #+cmu `(alien:cast ,obj (* (alien:unsigned 8)))
+ #+lispworks `(fli:make-pointer :type '(:unsigned :char)
+ :address (fli:pointer-address ,obj))
+ #+allegro obj
+ #+mcl obj
+ )
+
+(defmacro deref-pointer (ptr type)
+ "Returns a object pointed"
+ #+(or cmu lispworks) (declare (ignore type))
+ #+cmu `(alien:deref ,ptr)
+ #+lispworks `(fli:dereference ,ptr)
+ #+allegro `(ff:fslot-value-typed ,(convert-from-uffi-type type :deref) :c ,ptr)
+ #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
+ )
+
+#+mcl
+(defmacro deref-pointer-set (ptr type value)
+ `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
+
+#+mcl
+(defsetf deref-pointer deref-pointer-set)
+
+#+(or lispworks (and mcl (not openmcl))) ;; with LW, deref is a character
+(defmacro ensure-char-character (obj)
+ obj)
+
+#+(or allegro cmu openmcl)
+(defmacro ensure-char-character (obj)
+ `(code-char ,obj))
+
+#+(or lispworks (and mcl (not openmcl)))
+(defmacro ensure-char-integer (obj)
+ `(char-code ,obj))
+
+#+(or allegro cmu openmcl)
+(defmacro ensure-char-integer (obj)
+ obj)
+
+(defmacro pointer-address (obj)
+ #+cmu
+ `(system:sap-int (alien:alien-sap ,obj))
+ #+lispworks
+ `(fli:pointer-address ,obj)
+ #+allegro
+ obj
+ #+mcl
+ `(ccl:%ptr-to-int ,obj)
+ )
+
+;; TYPE is evaluated.
+#-mcl
+(defmacro with-foreign-object ((var type) &rest body)
+ #-(or cmu lispworks) ; default version
+ `(let ((,var (allocate-foreign-object ,type)))
+ (unwind-protect
+ (progn ,@body)
+ (free-foreign-object ,var)))
+ #+cmu
+ (let ((obj (gensym)))
+ `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
+ (let ((,var (alien:addr ,obj)))
+ ,@body)))
+ #+lispworks
+ `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
+ (eval type) :allocate)))
+ ,@body)
+ )
+
+#-mcl
+(defmacro with-foreign-objects (bindings &rest body)
+ (if bindings
+ `(with-foreign-object ,(car bindings)
+ (with-foreign-objects ,(cdr bindings)
+ ,@body))
+ `(progn ,@body)))
+
+#+mcl
+(defmacro with-foreign-objects (bindings &rest body)
+ (let ((params nil) type count)
+ (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
+ (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
+ (setf count 1)
+ (when (and (listp type) (eq (first type) :array))
+ (setf count (nth 2 type))
+ (unless (integerp count) (error "Invalid size for array: ~a" type))
+ (setf type (nth 1 type)))
+ (push (list (first spec) (* count (size-of-foreign-type type))) params))
+ `(ccl:%stack-block ,params ,@body)))
+
+#+mcl
+(defmacro with-foreign-object ((var type) &rest body)
+ `(with-foreign-objects ((,var ,type))
+ ,@body))
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: package.cl
-;;;; Purpose: Defines UFFI package
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-(defpackage :uffi
- (:use :cl)
- (:export
-
- ;; immediate types
- #:def-constant
- #:def-foreign-type
- #:def-type
- #:null-char-p
-
- ;; aggregate types
- #:def-enum
- #:def-struct
- #:get-slot-value
- #:get-slot-pointer
- #:def-array-pointer
- #:deref-array
- #:def-union
-
- ;; objects
- #:allocate-foreign-object
- #:free-foreign-object
- #:with-foreign-object
- #:with-foreign-objects
- #:size-of-foreign-type
- #:pointer-address
- #:deref-pointer
- #:ensure-char-character
- #:ensure-char-integer
- #:null-pointer-p
- #:make-null-pointer
- #:+null-cstring-pointer+
- #:char-array-to-pointer
-
- ;; string functions
- #:convert-from-cstring
- #:convert-to-cstring
- #:free-cstring
- #:with-cstring
- #:with-cstrings
- #:convert-from-foreign-string
- #:convert-to-foreign-string
- #:allocate-foreign-string
- #:with-foreign-string
-
- ;; function call
- #:def-function
-
- ;; Libraries
- #:find-foreign-library
- #:load-foreign-library
- #:default-foreign-library-type
- ))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.cl
+;;;; Purpose: Defines UFFI package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+
+(defpackage :uffi
+ (:use :cl)
+ (:export
+
+ ;; immediate types
+ #:def-constant
+ #:def-foreign-type
+ #:def-type
+ #:null-char-p
+
+ ;; aggregate types
+ #:def-enum
+ #:def-struct
+ #:get-slot-value
+ #:get-slot-pointer
+ #:def-array-pointer
+ #:deref-array
+ #:def-union
+
+ ;; objects
+ #:allocate-foreign-object
+ #:free-foreign-object
+ #:with-foreign-object
+ #:with-foreign-objects
+ #:size-of-foreign-type
+ #:pointer-address
+ #:deref-pointer
+ #:ensure-char-character
+ #:ensure-char-integer
+ #:null-pointer-p
+ #:make-null-pointer
+ #:+null-cstring-pointer+
+ #:char-array-to-pointer
+
+ ;; string functions
+ #:convert-from-cstring
+ #:convert-to-cstring
+ #:free-cstring
+ #:with-cstring
+ #:with-cstrings
+ #:convert-from-foreign-string
+ #:convert-to-foreign-string
+ #:allocate-foreign-string
+ #:with-foreign-string
+
+ ;; function call
+ #:def-function
+
+ ;; Libraries
+ #:find-foreign-library
+ #:load-foreign-library
+ #:default-foreign-library-type
+ ))
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: primitives.cl
-;;;; Purpose: UFFI source to handle immediate types
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: primitives.cl,v 1.25 2002/09/30 08:50:00 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-#+mcl
-(defvar *keyword-package* (find-package "KEYWORD"))
-
-#+mcl
-; 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)
- obj)
- ((null obj)
- nil)
- ((symbolp obj)
- (intern (symbol-name obj) *keyword-package*))
- ((and (listp obj) (eq (car obj) 'cl:quote))
- (keyword (cadr obj)))
- ((stringp obj)
- (intern obj *keyword-package*))
- (t
- obj)))
-
-; Wrapper for unexported function we have to use
-#+(and mcl (not openmcl))
-(defmacro def-mcl-type (name type)
- `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
-
-(defmacro def-constant (name value &key (export nil))
- "Macro to define a constant and to export it"
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant ,name ,value)
- ,(when export (list 'export `(quote ,name)))
- ',name))
-
-(defmacro def-type (name type)
- "Generates a (deftype) statement for CL. Currently, only CMUCL
-supports takes advantage of this optimization."
- #+(or lispworks allegro mcl)
- (declare (ignore type))
- #+(or lispworks allegro mcl)
- `(deftype ,name () t)
- #+cmu
- `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
- #+sbcl
- `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare)))
- )
-
-(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))
- #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
- #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
- #+mcl
- (let ((mcl-type (convert-from-uffi-type type :type)))
- (unless (or (keywordp mcl-type) (consp mcl-type))
- (setf mcl-type `(quote ,mcl-type)))
- #+(and mcl (not openmcl))
- `(def-mcl-type ,(keyword name) ,mcl-type)
- #+openmcl
- `(ccl::def-foreign-type ,(keyword name) ,mcl-type))
- )
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar +type-conversion-hash+ (make-hash-table :size 20))
- #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20))
- )
-
-#+cmu
-(defconstant +cmu-def-type-list+
- '((:char . (alien:signed 8))
- (:unsigned-char . (alien:unsigned 8))
- (:byte . (alien:signed 8))
- (:unsigned-byte . (alien:unsigned 8))
- (:short . (alien:signed 16))
- (:unsigned-short . (alien:unsigned 16))
- (:int . (alien:signed 32))
- (:unsigned-int . (alien:unsigned 32))
- (:long . (alien:signed 32))
- (:unsigned-long . (alien:unsigned 32))
- (:float . alien:single-float)
- (:double . alien:double-float)
- )
- "Conversions in CMUCL for def-foreign-type are different than in def-function")
-#+sbcl
-(defconstant +cmu-def-type-list+
- '((:char . (sb-alien:signed 8))
- (:unsigned-char . (sb-alien:unsigned 8))
- (:byte . (sb-alien:signed 8))
- (:unsigned-byte . (sb-alien:unsigned 8))
- (:short . (sb-alien:signed 16))
- (:unsigned-short . (sb-alien:unsigned 16))
- (:int . (sb-alien:signed 32))
- (:unsigned-int . (sb-alien:unsigned 32))
- (:long . (sb-alien:signed 32))
- (:unsigned-long . (sb-alien:unsigned 32))
- (:float . sb-alien:single-float)
- (:double . sb-alien:double-float)
- )
- "Conversions in SBCL for def-foreign-type are different than in def-function")
-
-(defparameter +type-conversion-list+ nil)
-
-#+cmu
-(setq +type-conversion-list+
- '((* . *) (:void . c-call:void)
- (:short . c-call:short)
- (:pointer-void . (* t))
- (:cstring . c-call:c-string)
- (:char . c-call:char)
- (:unsigned-char . (alien:unsigned 8))
- (:byte . (alien:signed 8))
- (:unsigned-byte . (alien:unsigned 8))
- (:short . c-call:unsigned-short)
- (:unsigned-short . c-call:unsigned-short)
- (: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 . void)
- (:short . short)
- (:pointer-void . (* t))
- (:cstring . c-string)
- (:char . char)
- (:unsigned-char . (sb-alien:unsigned 8))
- (:byte . (sb-alien:signed 8))
- (:unsigned-byte . (sb-alien:unsigned 8))
- (:short . unsigned-short)
- (:unsigned-short . unsigned-short)
- (:int . integer) (:unsigned-int . unsigned-int)
- (:long . long) (:unsigned-long . unsigned-long)
- (:float . float) (:double . double)
- (:array . array)))
-
-#+allegro
-(setq +type-conversion-list+
- '((* . *) (:void . :void)
- (:short . :short)
- (:pointer-void . (* :void))
- (:cstring . (* :unsigned-char))
- (:byte . :char)
- (:unsigned-byte . :unsigned-byte)
- (:char . :char)
- (:unsigned-char . :unsigned-char)
- (: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)
- (:short . :short)
- (:pointer-void . (:pointer :void))
- (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1)
- :allow-null t))
- (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t))
- (:byte . :byte)
- (:unsigned-byte . (:unsigned :byte))
- (:char . :char)
- (:unsigned-char . (:unsigned :char))
- (:int . :int) (:unsigned-int . (:unsigned :int))
- (:long . :long) (:unsigned-long . (:unsigned :long))
- (:float . :float) (:double . :double)
- (:array . :c-array)))
-
-#+(and mcl (not openmcl))
-(setq +type-conversion-list+
- '((* . :pointer) (:void . :void)
- (:short . :short) (:unsigned-short . :unsigned-short)
- (:pointer-void . :pointer)
- (:cstring . :string)
- (:char . :character)
- (:unsigned-char . :unsigned-byte)
- (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
- (:int . :long) (:unsigned-int . :unsigned-long)
- (:long . :long) (:unsigned-long . :unsigned-long)
- (:float . :single-float) (:double . :double-float)
- (:array . :array)))
-
-#+openmcl
-(setq +type-conversion-list+
- '((* . :address) (:void . :void)
- (:short . :short) (:unsigned-short . :unsigned-short)
- (:pointer-void . :address)
- (:cstring . :address)
- (:char . :signed-char)
- (:unsigned-char . :unsigned-char)
- (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
- (:int . :int) (:unsigned-int . :unsigned-int)
- (:long . :long) (:unsigned-long . :unsigned-long)
- (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword)
- (:float . :single-float) (:double . :double-float)
- (:array . :array)))
-
-(dolist (type +type-conversion-list+)
- (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
-
-#+(or cmu sbcl)
-(dolist (type +cmu-def-type-list+)
- (setf (gethash (car type) +cmu-def-type-hash+) (cdr type)))
-
-(defun basic-convert-from-uffi-type (type)
- (let ((found-type (gethash type +type-conversion-hash+)))
- (if found-type
- found-type
- #-mcl type
- #+mcl (keyword type))))
-
-(defun %convert-from-uffi-type (type context)
- "Converts from a uffi type to an implementation specific type"
- (if (atom type)
- (cond
- #+allegro
- ((and (or (eq context :routine) (eq context :return))
- (eq type :cstring))
- (setq type '((* :char) integer)))
- #+(or cmu sbcl)
- ((eq context :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))
- #+(and mcl (not openmcl))
- ((and (eq type :void) (eq context :return)) nil)
- (t
- (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
- #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
- #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct)
- )
- (:struct
- #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
- #-mcl (%convert-from-uffi-type (cadr type) :struct)
- )
- (t
- (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)))
- (cond
- ((atom result) result)
- #+openmcl
- ((eq (car result) :address)
- (if (eq context :struct)
- (append '(:*) (cdr result))
- :address))
- #+(and mcl (not openmcl))
- ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
- (t result))))
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: primitives.cl
+;;;; Purpose: UFFI source to handle immediate types
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: primitives.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+#+mcl
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+#+mcl
+; 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)
+ obj)
+ ((null obj)
+ nil)
+ ((symbolp obj)
+ (intern (symbol-name obj) *keyword-package*))
+ ((and (listp obj) (eq (car obj) 'cl:quote))
+ (keyword (cadr obj)))
+ ((stringp obj)
+ (intern obj *keyword-package*))
+ (t
+ obj)))
+
+; Wrapper for unexported function we have to use
+#+(and mcl (not openmcl))
+(defmacro def-mcl-type (name type)
+ `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
+
+(defmacro def-constant (name value &key (export nil))
+ "Macro to define a constant and to export it"
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,name ,value)
+ ,(when export (list 'export `(quote ,name)))
+ ',name))
+
+(defmacro def-type (name type)
+ "Generates a (deftype) statement for CL. Currently, only CMUCL
+supports takes advantage of this optimization."
+ #+(or lispworks allegro mcl)
+ (declare (ignore type))
+ #+(or lispworks allegro mcl)
+ `(deftype ,name () t)
+ #+cmu
+ `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
+ #+sbcl
+ `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare)))
+ )
+
+(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))
+ #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
+ #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
+ #+mcl
+ (let ((mcl-type (convert-from-uffi-type type :type)))
+ (unless (or (keywordp mcl-type) (consp mcl-type))
+ (setf mcl-type `(quote ,mcl-type)))
+ #+(and mcl (not openmcl))
+ `(def-mcl-type ,(keyword name) ,mcl-type)
+ #+openmcl
+ `(ccl::def-foreign-type ,(keyword name) ,mcl-type))
+ )
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar +type-conversion-hash+ (make-hash-table :size 20))
+ #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20))
+ )
+
+#+cmu
+(defconstant +cmu-def-type-list+
+ '((:char . (alien:signed 8))
+ (:unsigned-char . (alien:unsigned 8))
+ (:byte . (alien:signed 8))
+ (:unsigned-byte . (alien:unsigned 8))
+ (:short . (alien:signed 16))
+ (:unsigned-short . (alien:unsigned 16))
+ (:int . (alien:signed 32))
+ (:unsigned-int . (alien:unsigned 32))
+ (:long . (alien:signed 32))
+ (:unsigned-long . (alien:unsigned 32))
+ (:float . alien:single-float)
+ (:double . alien:double-float)
+ )
+ "Conversions in CMUCL for def-foreign-type are different than in def-function")
+#+sbcl
+(defconstant +cmu-def-type-list+
+ '((:char . (sb-alien:signed 8))
+ (:unsigned-char . (sb-alien:unsigned 8))
+ (:byte . (sb-alien:signed 8))
+ (:unsigned-byte . (sb-alien:unsigned 8))
+ (:short . (sb-alien:signed 16))
+ (:unsigned-short . (sb-alien:unsigned 16))
+ (:int . (sb-alien:signed 32))
+ (:unsigned-int . (sb-alien:unsigned 32))
+ (:long . (sb-alien:signed 32))
+ (:unsigned-long . (sb-alien:unsigned 32))
+ (:float . sb-alien:single-float)
+ (:double . sb-alien:double-float)
+ )
+ "Conversions in SBCL for def-foreign-type are different than in def-function")
+
+(defparameter +type-conversion-list+ nil)
+
+#+cmu
+(setq +type-conversion-list+
+ '((* . *) (:void . c-call:void)
+ (:short . c-call:short)
+ (:pointer-void . (* t))
+ (:cstring . c-call:c-string)
+ (:char . c-call:char)
+ (:unsigned-char . (alien:unsigned 8))
+ (:byte . (alien:signed 8))
+ (:unsigned-byte . (alien:unsigned 8))
+ (:short . c-call:unsigned-short)
+ (:unsigned-short . c-call:unsigned-short)
+ (: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 . void)
+ (:short . short)
+ (:pointer-void . (* t))
+ (:cstring . c-string)
+ (:char . char)
+ (:unsigned-char . (sb-alien:unsigned 8))
+ (:byte . (sb-alien:signed 8))
+ (:unsigned-byte . (sb-alien:unsigned 8))
+ (:short . unsigned-short)
+ (:unsigned-short . unsigned-short)
+ (:int . integer) (:unsigned-int . unsigned-int)
+ (:long . long) (:unsigned-long . unsigned-long)
+ (:float . float) (:double . double)
+ (:array . array)))
+
+#+allegro
+(setq +type-conversion-list+
+ '((* . *) (:void . :void)
+ (:short . :short)
+ (:pointer-void . (* :void))
+ (:cstring . (* :unsigned-char))
+ (:byte . :char)
+ (:unsigned-byte . :unsigned-byte)
+ (:char . :char)
+ (:unsigned-char . :unsigned-char)
+ (: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)
+ (:short . :short)
+ (:pointer-void . (:pointer :void))
+ (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1)
+ :allow-null t))
+ (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t))
+ (:byte . :byte)
+ (:unsigned-byte . (:unsigned :byte))
+ (:char . :char)
+ (:unsigned-char . (:unsigned :char))
+ (:int . :int) (:unsigned-int . (:unsigned :int))
+ (:long . :long) (:unsigned-long . (:unsigned :long))
+ (:float . :float) (:double . :double)
+ (:array . :c-array)))
+
+#+(and mcl (not openmcl))
+(setq +type-conversion-list+
+ '((* . :pointer) (:void . :void)
+ (:short . :short) (:unsigned-short . :unsigned-short)
+ (:pointer-void . :pointer)
+ (:cstring . :string)
+ (:char . :character)
+ (:unsigned-char . :unsigned-byte)
+ (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+ (:int . :long) (:unsigned-int . :unsigned-long)
+ (:long . :long) (:unsigned-long . :unsigned-long)
+ (:float . :single-float) (:double . :double-float)
+ (:array . :array)))
+
+#+openmcl
+(setq +type-conversion-list+
+ '((* . :address) (:void . :void)
+ (:short . :short) (:unsigned-short . :unsigned-short)
+ (:pointer-void . :address)
+ (:cstring . :address)
+ (:char . :signed-char)
+ (:unsigned-char . :unsigned-char)
+ (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+ (:int . :int) (:unsigned-int . :unsigned-int)
+ (:long . :long) (:unsigned-long . :unsigned-long)
+ (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword)
+ (:float . :single-float) (:double . :double-float)
+ (:array . :array)))
+
+(dolist (type +type-conversion-list+)
+ (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
+
+#+(or cmu sbcl)
+(dolist (type +cmu-def-type-list+)
+ (setf (gethash (car type) +cmu-def-type-hash+) (cdr type)))
+
+(defun basic-convert-from-uffi-type (type)
+ (let ((found-type (gethash type +type-conversion-hash+)))
+ (if found-type
+ found-type
+ #-mcl type
+ #+mcl (keyword type))))
+
+(defun %convert-from-uffi-type (type context)
+ "Converts from a uffi type to an implementation specific type"
+ (if (atom type)
+ (cond
+ #+allegro
+ ((and (or (eq context :routine) (eq context :return))
+ (eq type :cstring))
+ (setq type '((* :char) integer)))
+ #+(or cmu sbcl)
+ ((eq context :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))
+ #+(and mcl (not openmcl))
+ ((and (eq type :void) (eq context :return)) nil)
+ (t
+ (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
+ #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+ #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct)
+ )
+ (:struct
+ #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+ #-mcl (%convert-from-uffi-type (cadr type) :struct)
+ )
+ (t
+ (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)))
+ (cond
+ ((atom result) result)
+ #+openmcl
+ ((eq (car result) :address)
+ (if (eq context :struct)
+ (append '(:*) (cdr result))
+ :address))
+ #+(and mcl (not openmcl))
+ ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
+ (t result))))
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: readmacros-mcl.cl
-;;;; Purpose: This file holds functions using read macros for MCL
-;;;; Programmer: Kevin M. Rosenberg/John Desoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: readmacros-mcl.cl,v 1.1 2002/09/30 07:56:21 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-
-;; trap macros don't work right directly in the macros
-#+(and mcl (not openmcl))
-(defun new-ptr (size)
- (#_NewPtr size))
-
-#+(and mcl (not openmcl))
-(defun dispose-ptr (ptr)
- (#_DisposePtr ptr))
-
-#+openmcl
-(defmacro new-ptr (size)
- `(ccl::malloc ,size))
-
-#+openmcl
-(defmacro dispose-ptr (ptr)
- `(ccl::free ,ptr))
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: readmacros-mcl.cl
+;;;; Purpose: This file holds functions using read macros for MCL
+;;;; Programmer: Kevin M. Rosenberg/John Desoi
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: readmacros-mcl.lisp,v 1.3 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+
+;; trap macros don't work right directly in the macros
+#+(and mcl (not openmcl))
+(defun new-ptr (size)
+ (#_NewPtr size))
+
+#+(and mcl (not openmcl))
+(defun dispose-ptr (ptr)
+ (#_DisposePtr ptr))
+
+#+openmcl
+(defmacro new-ptr (size)
+ `(ccl::malloc ,size))
+
+#+openmcl
+(defmacro dispose-ptr (ptr)
+ `(ccl::free ,ptr))
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: strings.cl
-;;;; Purpose: UFFI source to handle strings, cstring and foreigns
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: strings.cl,v 1.23 2002/09/30 08:50:00 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-
-(defvar +null-cstring-pointer+
- #+cmu nil
- #+allegro 0
- #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
- #+mcl (ccl:%null-ptr)
- #-(or cmu allegro lispworks mcl) nil
-)
-
-(defmacro convert-from-cstring (obj)
- "Converts a string from a c-call. Same as convert-from-foreign-string, except
-that LW/CMU automatically converts strings from c-calls."
- #+cmu obj
- #+lispworks obj
- #+allegro
- (let ((stored (gensym)))
- `(let ((,stored ,obj))
- (if (zerop ,stored)
- nil
- (values (excl:native-to-string ,stored)))))
- #+mcl
- (let ((stored (gensym)))
- `(let ((,stored ,obj))
- (if (ccl:%null-ptr-p ,stored)
- nil
- (values (ccl:%get-cstring ,stored)))))
- )
-
-(defmacro convert-to-cstring (obj)
- #+cmu obj
- #+lispworks obj
- #+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
- #+mcl
- `(if (null ,obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,obj)))))
- (ccl:%put-cstring ptr ,obj)
- ptr))
- )
-
-(defmacro free-cstring (obj)
- #+cmu (declare (ignore obj))
- #+lispworks (declare (ignore obj))
- #+allegro
- `(unless (zerop obj)
- (ff:free-fobject ,obj))
- #+mcl
- `(unless (ccl:%null-ptr-p ,obj)
- (dispose-ptr ,obj))
- )
-
-(defmacro with-cstring ((cstring lisp-string) &body body)
- #+cmu
- `(let ((,cstring ,lisp-string)) ,@body)
- #+lispworks
- `(let ((,cstring ,lisp-string)) ,@body)
- #+allegro
- (let ((acl-native (gensym)))
- `(excl:with-native-string (,acl-native ,lisp-string)
- (let ((,cstring (if ,lisp-string ,acl-native 0)))
- ,@body)))
- #+mcl
- `(if (stringp ,lisp-string)
- (ccl:with-cstrs ((,cstring ,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))
- `(progn ,@body)))
-
-;;; Foreign string functions
-
-(defmacro convert-to-foreign-string (obj)
- #+lispworks
- `(if (null ,obj)
- +null-cstring-pointer+
- (fli:convert-to-foreign-string ,obj))
- #+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
- #+cmu
- (let ((size (gensym))
- (storage (gensym))
- (i (gensym)))
- `(etypecase ,obj
- (null
- (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
- (string
- (let* ((,size (length ,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 ,obj ,i))))
- (setf (alien:deref ,storage ,size) 0))
- ,storage))))
- #+mcl
- `(if (null ,obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,obj)))))
- (ccl:%put-cstring ptr ,obj)
- ptr))
- )
-
-
-;; Either length or null-terminated-p must be non-nil
-(defmacro convert-from-foreign-string (obj &key
- length
- (null-terminated-p t))
- #+allegro
- `(if (zerop ,obj)
- nil
- (values (excl:native-to-string
- ,obj
- ,@(if length (list :length length) (values))
- :truncate (not ,null-terminated-p))))
- #+lispworks
- `(if (fli:null-pointer-p ,obj)
- nil
- (fli:convert-from-foreign-string
- ,obj
- ,@(if length (list :length length) (values))
- :null-terminated-p ,null-terminated-p
- :external-format '(:latin-1 :eol-style :lf)))
- #+cmu
- `(if (null-pointer-p ,obj)
- nil
- (cmucl-naturalize-cstring (alien:alien-sap ,obj)
- :length ,length
- :null-terminated-p ,null-terminated-p))
- #+mcl
- (declare (ignore null-terminated-p))
- #+mcl
- `(if (ccl:%null-ptr-p ,obj)
- nil
- (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
- )
-
-
-
-(defmacro allocate-foreign-string (size &key (unsigned t))
- #+cmu
- (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)))))))
- #+lispworks
- `(fli:allocate-foreign-object :type
- ,(if unsigned
- ''(:unsigned :char)
- :char)
- :nelems ,size)
- #+allegro
- (declare (ignore unsigned))
- #+allegro
- `(ff:allocate-fobject :char :c ,size)
- #+mcl
- (declare (ignore unsigned))
- #+mcl
- `(new-ptr ,size)
- )
-
-(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)))
- (declare (dynamic-extent ,foreign-string))
- (free-foreign-object ,foreign-string)
- ,result)))
-
-
-;; Modified from CMUCL's source to handle non-null terminated strings
-#+cmu
-(defun cmucl-naturalize-cstring (sap &key
- length
- (null-terminated-p t))
- (declare (type system:system-area-pointer sap))
- (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)))))
- (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)))
- (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)))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: strings.cl
+;;;; Purpose: UFFI source to handle strings, cstring and foreigns
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: strings.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+
+(defvar +null-cstring-pointer+
+ #+cmu nil
+ #+allegro 0
+ #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
+ #+mcl (ccl:%null-ptr)
+ #-(or cmu allegro lispworks mcl) nil
+)
+
+(defmacro convert-from-cstring (obj)
+ "Converts a string from a c-call. Same as convert-from-foreign-string, except
+that LW/CMU automatically converts strings from c-calls."
+ #+cmu obj
+ #+lispworks obj
+ #+allegro
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (zerop ,stored)
+ nil
+ (values (excl:native-to-string ,stored)))))
+ #+mcl
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (ccl:%null-ptr-p ,stored)
+ nil
+ (values (ccl:%get-cstring ,stored)))))
+ )
+
+(defmacro convert-to-cstring (obj)
+ #+cmu obj
+ #+lispworks obj
+ #+allegro
+ `(if (null ,obj)
+ 0
+ (values (excl:string-to-native ,obj)))
+ #+mcl
+ `(if (null ,obj)
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,obj)))))
+ (ccl:%put-cstring ptr ,obj)
+ ptr))
+ )
+
+(defmacro free-cstring (obj)
+ #+cmu (declare (ignore obj))
+ #+lispworks (declare (ignore obj))
+ #+allegro
+ `(unless (zerop obj)
+ (ff:free-fobject ,obj))
+ #+mcl
+ `(unless (ccl:%null-ptr-p ,obj)
+ (dispose-ptr ,obj))
+ )
+
+(defmacro with-cstring ((cstring lisp-string) &body body)
+ #+cmu
+ `(let ((,cstring ,lisp-string)) ,@body)
+ #+lispworks
+ `(let ((,cstring ,lisp-string)) ,@body)
+ #+allegro
+ (let ((acl-native (gensym)))
+ `(excl:with-native-string (,acl-native ,lisp-string)
+ (let ((,cstring (if ,lisp-string ,acl-native 0)))
+ ,@body)))
+ #+mcl
+ `(if (stringp ,lisp-string)
+ (ccl:with-cstrs ((,cstring ,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))
+ `(progn ,@body)))
+
+;;; Foreign string functions
+
+(defmacro convert-to-foreign-string (obj)
+ #+lispworks
+ `(if (null ,obj)
+ +null-cstring-pointer+
+ (fli:convert-to-foreign-string ,obj))
+ #+allegro
+ `(if (null ,obj)
+ 0
+ (values (excl:string-to-native ,obj)))
+ #+cmu
+ (let ((size (gensym))
+ (storage (gensym))
+ (i (gensym)))
+ `(etypecase ,obj
+ (null
+ (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+ (string
+ (let* ((,size (length ,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 ,obj ,i))))
+ (setf (alien:deref ,storage ,size) 0))
+ ,storage))))
+ #+mcl
+ `(if (null ,obj)
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,obj)))))
+ (ccl:%put-cstring ptr ,obj)
+ ptr))
+ )
+
+
+;; Either length or null-terminated-p must be non-nil
+(defmacro convert-from-foreign-string (obj &key
+ length
+ (null-terminated-p t))
+ #+allegro
+ `(if (zerop ,obj)
+ nil
+ (values (excl:native-to-string
+ ,obj
+ ,@(if length (list :length length) (values))
+ :truncate (not ,null-terminated-p))))
+ #+lispworks
+ `(if (fli:null-pointer-p ,obj)
+ nil
+ (fli:convert-from-foreign-string
+ ,obj
+ ,@(if length (list :length length) (values))
+ :null-terminated-p ,null-terminated-p
+ :external-format '(:latin-1 :eol-style :lf)))
+ #+cmu
+ `(if (null-pointer-p ,obj)
+ nil
+ (cmucl-naturalize-cstring (alien:alien-sap ,obj)
+ :length ,length
+ :null-terminated-p ,null-terminated-p))
+ #+mcl
+ (declare (ignore null-terminated-p))
+ #+mcl
+ `(if (ccl:%null-ptr-p ,obj)
+ nil
+ (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
+ )
+
+
+
+(defmacro allocate-foreign-string (size &key (unsigned t))
+ #+cmu
+ (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)))))))
+ #+lispworks
+ `(fli:allocate-foreign-object :type
+ ,(if unsigned
+ ''(:unsigned :char)
+ :char)
+ :nelems ,size)
+ #+allegro
+ (declare (ignore unsigned))
+ #+allegro
+ `(ff:allocate-fobject :char :c ,size)
+ #+mcl
+ (declare (ignore unsigned))
+ #+mcl
+ `(new-ptr ,size)
+ )
+
+(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)))
+ (declare (dynamic-extent ,foreign-string))
+ (free-foreign-object ,foreign-string)
+ ,result)))
+
+
+;; Modified from CMUCL's source to handle non-null terminated strings
+#+cmu
+(defun cmucl-naturalize-cstring (sap &key
+ length
+ (null-terminated-p t))
+ (declare (type system:system-area-pointer sap))
+ (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)))))
+ (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)))
+ (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)))
+++ /dev/null
-;; tester.cl
-;; A test harness for Allegro CL.
-;;
-;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
-;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
-;;
-;; 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 Free Software Foundation, as clarified by the Franz
-;; preamble to the LGPL found in
-;; http://opensource.franz.com/preamble.html.
-;;
-;; This code is distributed in the hope that it will be useful,
-;; but without any warranty; without even the implied warranty of
-;; merchantability or fitness for a particular purpose. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; Version 2.1 of the GNU Lesser General Public License can be
-;; found at http://opensource.franz.com/license.html.
-;; If it is not present, you can access it from
-;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
-;; version) or write to the Free Software Foundation, Inc., 59 Temple
-;; Place, Suite 330, Boston, MA 02111-1307 USA
-;;
-;;;; from the original ACL 6.1 sources:
-;; $Id: acl-compat-tester.cl,v 1.3 2002/09/20 05:38:01 kevin Exp $
-
-
-(defpackage :util.test
- (:use :common-lisp)
- (:shadow #:test)
- (:export
-;;;; Control variables:
- #:*break-on-test-failures*
- #:*error-protect-tests*
- #:*test-errors*
- #:*test-successes*
- #:*test-unexpected-failures*
-
-;;;; The test macros:
- #:test
- #:test-error
- #:test-no-error
- #:test-warning
- #:test-no-warning
-
- #:with-tests
- ))
-
-(in-package :util.test)
-
-#+cmu
-(unless (find-class 'break nil)
- (define-condition break (simple-condition) ()))
-
-(define-condition simple-break (error simple-condition) ())
-
-;; the if* macro used in Allegro:
-;;
-;; This is in the public domain... please feel free to put this definition
-;; in your code or distribute it with your version of lisp.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
-
-(defmacro if* (&rest args)
- (do ((xx (reverse args) (cdr xx))
- (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 ((and (symbolp (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)))))
-
-
-
-
-(defvar *break-on-test-failures* nil
- "When a test failure occurs, common-lisp:break is called, allowing
-interactive debugging of the failure.")
-
-(defvar *test-errors* 0
- "The value is the number of test errors which have occurred.")
-(defvar *test-successes* 0
- "The value is the number of test successes which have occurred.")
-(defvar *test-unexpected-failures* 0
- "The value is the number of unexpected test failures which have occurred.")
-
-(defvar *error-protect-tests* nil
- "Protect each test from errors. If an error occurs, then that will be
-taken as a test failure unless test-error is being used.")
-
-(defmacro test-values-errorset (form &optional announce catch-breaks)
- ;; internal macro
- (let ((g-announce (gensym))
- (g-catch-breaks (gensym)))
- `(let* ((,g-announce ,announce)
- (,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)))))
-
-(defmacro test-values (form &optional announce catch-breaks)
- ;; internal macro
- (if* *error-protect-tests*
- then `(test-values-errorset ,form ,announce ,catch-breaks)
- 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)
-
-;;;;;;;;;; internal, undocumented keywords:
-;;;; Note about these keywords: if they were documented, we'd have a
-;;;; problem, since they break the left-to-right order of evaluation.
-;;;; 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))
- "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
-logged, otherwise a success is logged.
-
-Normally the comparison of values is done with `eql'. The `test' keyword
-argument can be used to specify other comparison functions, such as eq,
-equal,equalp, string=, string-equal, etc.
-
-Normally, only the first return value from the test-form is considered,
-however if `multiple-values' is t, then all values returned from test-form
-are considered.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-programs that do regression analysis on the output from a test run to
-discriminate on new versus known failures."
- `(test-check
- :expected-result ,expected-value
- :test-results
- (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
- ,@(when test-given `(:predicate ,test))
- ,@(when multiple-values-given `(:multiple-values ,multiple-values))
- ,@(when fail-info-given `(:fail-info ,fail-info))
- ,@(when known-failure-given `(:known-failure ,known-failure))
- :test-form ',(if reported-form reported-form test-form)
- ,@(when wanted-message-given `(:wanted-message ,wanted-message))
- ,@(when got-message-given `(:got-message ,got-message))))
-
-(defmethod conditionp ((thing condition)) t)
-(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))
- "Test that `form' signals an error. The order of evaluation of the
-arguments is keywords first, then test form.
-
-If `announce' is non-nil, then cause the error message to be printed.
-
-The `catch-breaks' is non-nil then consider a call to common-lisp:break an
-`error'.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-programs that do regression analysis on the output from a test run to
-discriminate on new versus known failures.
-
-If `condition-type' is non-nil, it should be a symbol naming a condition
-type, which is used to check against the signalled condition type. The
-test will fail if they do not match.
-
-`include-subtypes', used with `condition-type', can be used to match a
-condition to an entire subclass of the condition type hierarchy.
-
-`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)))
- `(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)))
- (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))))))
-
-(defmacro test-no-error (form &key announce
- 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.
-
-If `announce' is non-nil, then cause the error message to be printed.
-
-The `catch-breaks' is non-nil then consider a call to common-lisp:break an
-`error'.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-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)))
- `(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)))
- (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))))))
-
-(defvar *warn-cookie* (cons nil nil))
-
-(defmacro test-warning (form &key fail-info known-failure)
- "Test that `form' signals a warning. The order of evaluation of
-the arguments is keywords first, then test form.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-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)))
- `(let* ((,g-fail-info ,fail-info)
- (,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))))
-
-(defmacro test-no-warning (form &key fail-info known-failure)
- "Test that `form' does not signal a warning. The order of evaluation of
-the arguments is keywords first, then test form.
-
-`fail-info' allows more information to be printed with a test failure.
-
-`known-failure' marks the test as a known failure. This allows for
-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)))
- `(let* ((,g-fail-info ,fail-info)
- (,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))))
-
-(defvar *announce-test* nil) ;; if true announce each test that was done
-
-(defmacro errorset (form &optional announce catch-breaks)
- ;; Evaluate FORM, and if there are no errors and FORM returns
- ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an
- ;; error occurs while evaluating FORM, then return nil immediately.
- ;; If ANNOUNCE is t, then the error message will be printed out.
- (if catch-breaks
- `(handler-case (values-list (cons t (multiple-value-list ,form)))
- (error (condition)
- (declare (ignorable condition))
- ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
- nil)
- (simple-break (condition)
- (declare (ignorable condition))
- ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
-)
- nil))
- `(handler-case (values-list (cons t (multiple-value-list ,form)))
- (error (condition)
- (declare (ignorable condition))
- ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
- 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)
- ;; 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)))))
- (when (conditionp test-results)
- (setq condition test-results)
- (setq test-results nil))
- (when (null (car test-results))
- (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))
- 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)))))
- (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*
- "~
-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* "~
-Reason: an error~@[ (of type `~s')~] was detected.~%"
- (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* "~
-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* "~
-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* "~
-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* "~
-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*))
- 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*))
- (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 ~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*))
- ))))
-
-(provide :tester #+module-versions 1.1)
--- /dev/null
+;; tester.cl
+;; A test harness for Allegro CL.
+;;
+;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
+;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
+;;
+;; 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 Free Software Foundation, as clarified by the Franz
+;; preamble to the LGPL found in
+;; http://opensource.franz.com/preamble.html.
+;;
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License can be
+;; found at http://opensource.franz.com/license.html.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple
+;; Place, Suite 330, Boston, MA 02111-1307 USA
+;;
+;;;; from the original ACL 6.1 sources:
+;; $Id: acl-compat-tester.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+
+
+(defpackage :util.test
+ (:use :common-lisp)
+ (:shadow #:test)
+ (:export
+;;;; Control variables:
+ #:*break-on-test-failures*
+ #:*error-protect-tests*
+ #:*test-errors*
+ #:*test-successes*
+ #:*test-unexpected-failures*
+
+;;;; The test macros:
+ #:test
+ #:test-error
+ #:test-no-error
+ #:test-warning
+ #:test-no-warning
+
+ #:with-tests
+ ))
+
+(in-package :util.test)
+
+#+cmu
+(unless (find-class 'break nil)
+ (define-condition break (simple-condition) ()))
+
+(define-condition simple-break (error simple-condition) ())
+
+;; the if* macro used in Allegro:
+;;
+;; This is in the public domain... please feel free to put this definition
+;; in your code or distribute it with your version of lisp.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
+
+(defmacro if* (&rest args)
+ (do ((xx (reverse args) (cdr xx))
+ (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 ((and (symbolp (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)))))
+
+
+
+
+(defvar *break-on-test-failures* nil
+ "When a test failure occurs, common-lisp:break is called, allowing
+interactive debugging of the failure.")
+
+(defvar *test-errors* 0
+ "The value is the number of test errors which have occurred.")
+(defvar *test-successes* 0
+ "The value is the number of test successes which have occurred.")
+(defvar *test-unexpected-failures* 0
+ "The value is the number of unexpected test failures which have occurred.")
+
+(defvar *error-protect-tests* nil
+ "Protect each test from errors. If an error occurs, then that will be
+taken as a test failure unless test-error is being used.")
+
+(defmacro test-values-errorset (form &optional announce catch-breaks)
+ ;; internal macro
+ (let ((g-announce (gensym))
+ (g-catch-breaks (gensym)))
+ `(let* ((,g-announce ,announce)
+ (,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)))))
+
+(defmacro test-values (form &optional announce catch-breaks)
+ ;; internal macro
+ (if* *error-protect-tests*
+ then `(test-values-errorset ,form ,announce ,catch-breaks)
+ 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)
+
+;;;;;;;;;; internal, undocumented keywords:
+;;;; Note about these keywords: if they were documented, we'd have a
+;;;; problem, since they break the left-to-right order of evaluation.
+;;;; 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))
+ "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
+logged, otherwise a success is logged.
+
+Normally the comparison of values is done with `eql'. The `test' keyword
+argument can be used to specify other comparison functions, such as eq,
+equal,equalp, string=, string-equal, etc.
+
+Normally, only the first return value from the test-form is considered,
+however if `multiple-values' is t, then all values returned from test-form
+are considered.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+ `(test-check
+ :expected-result ,expected-value
+ :test-results
+ (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
+ ,@(when test-given `(:predicate ,test))
+ ,@(when multiple-values-given `(:multiple-values ,multiple-values))
+ ,@(when fail-info-given `(:fail-info ,fail-info))
+ ,@(when known-failure-given `(:known-failure ,known-failure))
+ :test-form ',(if reported-form reported-form test-form)
+ ,@(when wanted-message-given `(:wanted-message ,wanted-message))
+ ,@(when got-message-given `(:got-message ,got-message))))
+
+(defmethod conditionp ((thing condition)) t)
+(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))
+ "Test that `form' signals an error. The order of evaluation of the
+arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures.
+
+If `condition-type' is non-nil, it should be a symbol naming a condition
+type, which is used to check against the signalled condition type. The
+test will fail if they do not match.
+
+`include-subtypes', used with `condition-type', can be used to match a
+condition to an entire subclass of the condition type hierarchy.
+
+`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)))
+ `(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)))
+ (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))))))
+
+(defmacro test-no-error (form &key announce
+ 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.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+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)))
+ `(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)))
+ (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))))))
+
+(defvar *warn-cookie* (cons nil nil))
+
+(defmacro test-warning (form &key fail-info known-failure)
+ "Test that `form' signals a warning. The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+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)))
+ `(let* ((,g-fail-info ,fail-info)
+ (,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))))
+
+(defmacro test-no-warning (form &key fail-info known-failure)
+ "Test that `form' does not signal a warning. The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+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)))
+ `(let* ((,g-fail-info ,fail-info)
+ (,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))))
+
+(defvar *announce-test* nil) ;; if true announce each test that was done
+
+(defmacro errorset (form &optional announce catch-breaks)
+ ;; Evaluate FORM, and if there are no errors and FORM returns
+ ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an
+ ;; error occurs while evaluating FORM, then return nil immediately.
+ ;; If ANNOUNCE is t, then the error message will be printed out.
+ (if catch-breaks
+ `(handler-case (values-list (cons t (multiple-value-list ,form)))
+ (error (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+ nil)
+ (simple-break (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
+)
+ nil))
+ `(handler-case (values-list (cons t (multiple-value-list ,form)))
+ (error (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+ 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)
+ ;; 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)))))
+ (when (conditionp test-results)
+ (setq condition test-results)
+ (setq test-results nil))
+ (when (null (car test-results))
+ (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))
+ 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)))))
+ (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*
+ "~
+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* "~
+Reason: an error~@[ (of type `~s')~] was detected.~%"
+ (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* "~
+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* "~
+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* "~
+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* "~
+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*))
+ 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*))
+ (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 ~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*))
+ ))))
+
+(provide :tester #+module-versions 1.1)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: arrays.cl
-;;;; Purpose: UFFI Example file to test arrays
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: arrays.cl,v 1.3 2002/04/02 21:29:45 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-constant +column-length+ 10)
-(uffi:def-constant +row-length+ 10)
-
-(defun test-array-1d ()
- "Tests vector"
- (let ((a (uffi:allocate-foreign-object :long +column-length+)))
- (dotimes (i +column-length+)
- (setf (uffi:deref-array a '(:array :long) i) (* i i)))
- (dotimes (i +column-length+)
- (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i)))
- (uffi:free-foreign-object a))
- (values))
-
-(defun test-array-2d ()
- "Tests 2d array"
- (let ((a (uffi:allocate-foreign-object '(* :long) +row-length+)))
- (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)))))
-
- (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)))))
-
- (uffi:free-foreign-object a))
- (values))
-
-#+examples-uffi
-(test-array-1d)
-
-#+examples-uffi
-(test-array-2d)
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: arrays.cl
+;;;; Purpose: UFFI Example file to test arrays
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: arrays.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-constant +column-length+ 10)
+(uffi:def-constant +row-length+ 10)
+
+(defun test-array-1d ()
+ "Tests vector"
+ (let ((a (uffi:allocate-foreign-object :long +column-length+)))
+ (dotimes (i +column-length+)
+ (setf (uffi:deref-array a '(:array :long) i) (* i i)))
+ (dotimes (i +column-length+)
+ (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i)))
+ (uffi:free-foreign-object a))
+ (values))
+
+(defun test-array-2d ()
+ "Tests 2d array"
+ (let ((a (uffi:allocate-foreign-object '(* :long) +row-length+)))
+ (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)))))
+
+ (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)))))
+
+ (uffi:free-foreign-object a))
+ (values))
+
+#+examples-uffi
+(test-array-1d)
+
+#+examples-uffi
+(test-array-2d)
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: atoifl.cl
-;;;; Purpose: UFFI Example file to atoi/atof/atol
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: atoifl.cl,v 1.5 2002/04/03 00:31:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-function ("atoi" c-atoi)
- ((str :cstring))
- :returning :int)
-
-(uffi:def-function ("atol" c-atol)
- ((str :cstring))
- :returning :long)
-
-(uffi:def-function ("atof" c-atof)
- ((str :cstring))
- :returning :double)
-
-(defun atoi (str)
- "Returns a int from a string."
- (uffi:with-cstring (str-cstring str)
- (c-atoi str-cstring)))
-
-(defun atof (str)
- "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))))
- (print-results "55")))
-
-
-#+test-uffi
-(progn
- (util.test:test (atoi "123") 123 :test #'eql
- :fail-info "Error with atoi")
- (util.test:test (atoi "") 0 :test #'eql
- :fail-info "Error with atoi")
- (util.test:test (atof "2.23") 2.23d0 :test #'eql
- :fail-info "Error with atof")
- )
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: atoifl.cl
+;;;; Purpose: UFFI Example file to atoi/atof/atol
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: atoifl.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-function ("atoi" c-atoi)
+ ((str :cstring))
+ :returning :int)
+
+(uffi:def-function ("atol" c-atol)
+ ((str :cstring))
+ :returning :long)
+
+(uffi:def-function ("atof" c-atof)
+ ((str :cstring))
+ :returning :double)
+
+(defun atoi (str)
+ "Returns a int from a string."
+ (uffi:with-cstring (str-cstring str)
+ (c-atoi str-cstring)))
+
+(defun atof (str)
+ "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))))
+ (print-results "55")))
+
+
+#+test-uffi
+(progn
+ (util.test:test (atoi "123") 123 :test #'eql
+ :fail-info "Error with atoi")
+ (util.test:test (atoi "") 0 :test #'eql
+ :fail-info "Error with atoi")
+ (util.test:test (atof "2.23") 2.23d0 :test #'eql
+ :fail-info "Error with atof")
+ )
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: c-test-fns.cl
-;;;; Purpose: UFFI Example file for zlib compression
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: c-test-fns.cl,v 1.7 2002/04/03 00:31:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(unless (uffi:load-foreign-library
- (uffi:find-foreign-library "c-test-fns" *load-truename*)
- :supporting-libraries '("c")
- :force-load t)
- (warn "Unable to load c-test-fns library"))
-
-(uffi:def-function ("cs_to_upper" cs-to-upper)
- ((input (* :unsigned-char)))
- :returning :void
- )
-
-(defun string-to-upper (str)
- (uffi:with-foreign-string (str-foreign str)
- (cs-to-upper str-foreign)
- (uffi:convert-from-foreign-string str-foreign)))
-
-(uffi:def-function ("cs_count_upper" cs-count-upper)
- ((input :cstring))
- :returning :int
- )
-
-(defun string-count-upper (str)
- (uffi:with-cstring (str-cstring str)
- (cs-count-upper str-cstring)))
-
-(uffi:def-function ("half_double_vector" half-double-vector)
- ((size :int)
- (vec (* :double)))
- :returning :void)
-
-(uffi:def-constant +double-vec-length+ 10)
-(defun test-half-double-vector ()
- (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
- results)
- (dotimes (i +double-vec-length+)
- (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))
- (uffi:free-foreign-object vec)
- (nreverse results)))
-
-(defun t2 ()
- (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
- (dotimes (i +double-vec-length+)
- (setf (aref vec i) (coerce i 'double-float)))
- (half-double-vector +double-vec-length+ vec)
- vec))
-
-#+cmu
-(defun t3 ()
- (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
- (dotimes (i +double-vec-length+)
- (setf (aref vec i) (coerce i 'double-float)))
- (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"))
-
-#+examples-uffi
-(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"))
-
-#+examples-uffi
-(format t "~&(string-count-upper nil) => ~A"
- (string-count-upper nil))
-
-#+examples-uffi
-(format t "~&Half vector: ~S" (test-half-double-vector))
-
-
-
-#+test-uffi
-(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")
- (util.test:test (string-to-upper nil) nil
- :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")
- (util.test:test (string-count-upper nil) -1
- :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")
- )
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: c-test-fns.cl
+;;;; Purpose: UFFI Example file for zlib compression
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: c-test-fns.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(unless (uffi:load-foreign-library
+ (uffi:find-foreign-library "c-test-fns" *load-truename*)
+ :supporting-libraries '("c")
+ :force-load t)
+ (warn "Unable to load c-test-fns library"))
+
+(uffi:def-function ("cs_to_upper" cs-to-upper)
+ ((input (* :unsigned-char)))
+ :returning :void
+ )
+
+(defun string-to-upper (str)
+ (uffi:with-foreign-string (str-foreign str)
+ (cs-to-upper str-foreign)
+ (uffi:convert-from-foreign-string str-foreign)))
+
+(uffi:def-function ("cs_count_upper" cs-count-upper)
+ ((input :cstring))
+ :returning :int
+ )
+
+(defun string-count-upper (str)
+ (uffi:with-cstring (str-cstring str)
+ (cs-count-upper str-cstring)))
+
+(uffi:def-function ("half_double_vector" half-double-vector)
+ ((size :int)
+ (vec (* :double)))
+ :returning :void)
+
+(uffi:def-constant +double-vec-length+ 10)
+(defun test-half-double-vector ()
+ (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
+ results)
+ (dotimes (i +double-vec-length+)
+ (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))
+ (uffi:free-foreign-object vec)
+ (nreverse results)))
+
+(defun t2 ()
+ (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+ (dotimes (i +double-vec-length+)
+ (setf (aref vec i) (coerce i 'double-float)))
+ (half-double-vector +double-vec-length+ vec)
+ vec))
+
+#+cmu
+(defun t3 ()
+ (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+ (dotimes (i +double-vec-length+)
+ (setf (aref vec i) (coerce i 'double-float)))
+ (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"))
+
+#+examples-uffi
+(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"))
+
+#+examples-uffi
+(format t "~&(string-count-upper nil) => ~A"
+ (string-count-upper nil))
+
+#+examples-uffi
+(format t "~&Half vector: ~S" (test-half-double-vector))
+
+
+
+#+test-uffi
+(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")
+ (util.test:test (string-to-upper nil) nil
+ :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")
+ (util.test:test (string-count-upper nil) -1
+ :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")
+ )
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: compress.cl
-;;;; Purpose: UFFI Example file for zlib compression
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: compress.cl,v 1.13 2002/09/20 06:03:36 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(unless (uffi:load-foreign-library
- (uffi:find-foreign-library
- "libz"
- '("/usr/local/lib/" "/usr/lib/" "/zlib/")
- :types '("so" "a" "dylib"))
- :module "zlib"
- :supporting-libraries '("c"))
- (warn "Unable to load zlib"))
-
-(uffi:def-function ("compress" c-compress)
- ((dest (* :unsigned-char))
- (destlen (* :long))
- (source :cstring)
- (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)))
- (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)))))))
-
-
-#+examples-uffi
-(progn
- (flet ((print-results (str)
- (multiple-value-bind (compressed len) (compress str)
- (format t "~&(compress ~S) => " str)
- (dotimes (i len)
- (format t "~X" (char-code (char compressed i))))
- (format t ",~D" len))))
- (print-results "")
- (print-results "test")
- (print-results "test2")))
-
-;; Results of the above on my system:
-;; (compress "") => 789c300001,8
-;; (compress "test") => 789c2b492d2e1045d1c1,12
-;; (compress "test2") => 789c2b492d2e31206501f3,13
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: compress.cl
+;;;; Purpose: UFFI Example file for zlib compression
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: compress.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(unless (uffi:load-foreign-library
+ (uffi:find-foreign-library
+ "libz"
+ '("/usr/local/lib/" "/usr/lib/" "/zlib/")
+ :types '("so" "a" "dylib"))
+ :module "zlib"
+ :supporting-libraries '("c"))
+ (warn "Unable to load zlib"))
+
+(uffi:def-function ("compress" c-compress)
+ ((dest (* :unsigned-char))
+ (destlen (* :long))
+ (source :cstring)
+ (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)))
+ (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)))))))
+
+
+#+examples-uffi
+(progn
+ (flet ((print-results (str)
+ (multiple-value-bind (compressed len) (compress str)
+ (format t "~&(compress ~S) => " str)
+ (dotimes (i len)
+ (format t "~X" (char-code (char compressed i))))
+ (format t ",~D" len))))
+ (print-results "")
+ (print-results "test")
+ (print-results "test2")))
+
+;; Results of the above on my system:
+;; (compress "") => 789c300001,8
+;; (compress "test") => 789c2b492d2e1045d1c1,12
+;; (compress "test2") => 789c2b492d2e31206501f3,13
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: file-socket.cl
-;;;; Purpose: UFFI Example file to get a socket on a file
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Jul 2002
-;;;;
-;;;; $Id: file-socket.cl,v 1.2 2002/08/02 14:39:11 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-;; Values for linux
-(uffi:def-constant PF_UNIX 1)
-(uffi:def-constant SOCK_STREAM 1)
-
-(uffi:def-function ("socket" c-socket)
- ((family :int)
- (type :int)
- (protocol :int))
- :returning :int)
-
-(uffi:def-function ("connect" c-connect)
- ((sockfd :int)
- (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)
- (error "Unable to create socket"))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: file-socket.cl
+;;;; Purpose: UFFI Example file to get a socket on a file
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Jul 2002
+;;;;
+;;;; $Id: file-socket.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+;; Values for linux
+(uffi:def-constant PF_UNIX 1)
+(uffi:def-constant SOCK_STREAM 1)
+
+(uffi:def-function ("socket" c-socket)
+ ((family :int)
+ (type :int)
+ (protocol :int))
+ :returning :int)
+
+(uffi:def-function ("connect" c-connect)
+ ((sockfd :int)
+ (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)
+ (error "Unable to create socket"))))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: getenv.cl
-;;;; Purpose: UFFI Example file to get environment variable
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: getenv.cl,v 1.9 2002/04/02 23:27:05 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-
-(uffi:def-function ("getenv" c-getenv)
- ((name :cstring))
- :returning :cstring)
-
-(defun my-getenv (key)
- "Returns an environment variable, or NIL if it does not exist"
- (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))))
- (print-results "USER")
- (print-results "_FOO_")))
-
-
-#+test-uffi
-(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")
-)
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: getenv.cl
+;;;; Purpose: UFFI Example file to get environment variable
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: getenv.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function ("getenv" c-getenv)
+ ((name :cstring))
+ :returning :cstring)
+
+(defun my-getenv (key)
+ "Returns an environment variable, or NIL if it does not exist"
+ (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))))
+ (print-results "USER")
+ (print-results "_FOO_")))
+
+
+#+test-uffi
+(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")
+)
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: gethostname.cl
-;;;; Purpose: UFFI Example file to get hostname of system
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: gethostname.cl,v 1.12 2002/04/03 00:31:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-
-;;; This example is inspired by the example on the CL-Cookbook web site
-
-(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 (c-gethostname name 256)))
- (unwind-protect
- (if (zerop result)
- (uffi:convert-from-foreign-string name)
- (error "gethostname() failed."))
- (uffi:free-foreign-object name))))
-
-(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."))))
-
-#+examples-uffi
-(progn
- (format t "~&Hostname (technique 1): ~A" (gethostname))
- (format t "~&Hostname (technique 2): ~A" (gethostname2)))
-
-#+test-uffi
-(progn
- (let ((hostname1 (gethostname))
- (hostname2 (gethostname2)))
-
- (util.test:test (and (stringp hostname1) (stringp hostname2)) t
- :fail-info "gethostname not string")
- (util.test:test (and (not (zerop (length hostname1)))
- (not (zerop (length hostname2)))) t
- :fail-info "gethostname length 0")
- (util.test:test (string= hostname1 hostname1) t
- :fail-info "gethostname techniques don't match"))
- )
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: gethostname.cl
+;;;; Purpose: UFFI Example file to get hostname of system
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: gethostname.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+;;; This example is inspired by the example on the CL-Cookbook web site
+
+(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 (c-gethostname name 256)))
+ (unwind-protect
+ (if (zerop result)
+ (uffi:convert-from-foreign-string name)
+ (error "gethostname() failed."))
+ (uffi:free-foreign-object name))))
+
+(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."))))
+
+#+examples-uffi
+(progn
+ (format t "~&Hostname (technique 1): ~A" (gethostname))
+ (format t "~&Hostname (technique 2): ~A" (gethostname2)))
+
+#+test-uffi
+(progn
+ (let ((hostname1 (gethostname))
+ (hostname2 (gethostname2)))
+
+ (util.test:test (and (stringp hostname1) (stringp hostname2)) t
+ :fail-info "gethostname not string")
+ (util.test:test (and (not (zerop (length hostname1)))
+ (not (zerop (length hostname2)))) t
+ :fail-info "gethostname length 0")
+ (util.test:test (string= hostname1 hostname1) t
+ :fail-info "gethostname techniques don't match"))
+ )
+
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: getshells.cl
-;;;; Purpose: UFFI Example file to get lisp of legal shells
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: getshells.cl,v 1.6 2002/04/02 21:29:45 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-
-(uffi:def-function "setusershell"
- nil
- :returning :void)
-
-(uffi:def-function "endusershell"
- nil
- :returning :void)
-
-(uffi:def-function "getusershell"
- nil
- :returning :cstring)
-
-(defun getshells ()
- "Returns list of valid shells"
- (setusershell)
- (let (shells)
- (do ((shell (uffi:convert-from-cstring (getusershell))
- (uffi:convert-from-cstring (getusershell))))
- ((null shell))
- (push shell shells))
- (endusershell)
- (nreverse shells)))
-
-#+examples-uffi
-(format t "~&Shells: ~S" (getshells))
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: getshells.cl
+;;;; Purpose: UFFI Example file to get lisp of legal shells
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: getshells.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function "setusershell"
+ nil
+ :returning :void)
+
+(uffi:def-function "endusershell"
+ nil
+ :returning :void)
+
+(uffi:def-function "getusershell"
+ nil
+ :returning :cstring)
+
+(defun getshells ()
+ "Returns list of valid shells"
+ (setusershell)
+ (let (shells)
+ (do ((shell (uffi:convert-from-cstring (getusershell))
+ (uffi:convert-from-cstring (getusershell))))
+ ((null shell))
+ (push shell shells))
+ (endusershell)
+ (nreverse shells)))
+
+#+examples-uffi
+(format t "~&Shells: ~S" (getshells))
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: gettime
-;;;; Purpose: UFFI Example file to get time, use C structures
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: gettime.cl,v 1.9 2002/04/02 23:27:05 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-foreign-type time-t :unsigned-long)
-
-(uffi:def-struct tm
- (sec :int)
- (min :int)
- (hour :int)
- (mday :int)
- (mon :int)
- (year :int)
- (wday :int)
- (yday :int)
- (isdst :int))
-
-(uffi:def-function ("time" c-time)
- ((time (* time-t)))
- :returning time-t)
-
-(uffi:def-function ("localtime" c-localtime)
- ((time (* time-t)))
- :returning (* tm))
-
-(uffi:def-type time-t :unsigned-long)
-(uffi:def-type tm-pointer (* tm))
-
-(defun gettime ()
- "Returns the local time"
- (uffi:with-foreign-object (time 'time-t)
-;; (declare (type time-t time))
- (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))))
-
-
-
-
-#+examples-uffi
-(format t "~&~A" (gettime))
-
-#+test-uffi
-(progn
- (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")))
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: gettime
+;;;; Purpose: UFFI Example file to get time, use C structures
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: gettime.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-foreign-type time-t :unsigned-long)
+
+(uffi:def-struct tm
+ (sec :int)
+ (min :int)
+ (hour :int)
+ (mday :int)
+ (mon :int)
+ (year :int)
+ (wday :int)
+ (yday :int)
+ (isdst :int))
+
+(uffi:def-function ("time" c-time)
+ ((time (* time-t)))
+ :returning time-t)
+
+(uffi:def-function ("localtime" c-localtime)
+ ((time (* time-t)))
+ :returning (* tm))
+
+(uffi:def-type time-t :unsigned-long)
+(uffi:def-type tm-pointer (* tm))
+
+(defun gettime ()
+ "Returns the local time"
+ (uffi:with-foreign-object (time 'time-t)
+;; (declare (type time-t time))
+ (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))))
+
+
+
+
+#+examples-uffi
+(format t "~&~A" (gettime))
+
+#+test-uffi
+(progn
+ (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")))
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: run-examples.cl
-;;;; Purpose: Load and execute all examples for UFFI
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: run-examples.cl,v 1.3 2002/09/20 05:38:01 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-#-uffi (asdf:oos 'asdf:load-op :uffi)
-
-(pushnew :examples-uffi cl:*features*)
-
-(flet ((load-test (name)
- (load (make-pathname :defaults *load-truename* :name name :type "cl"))))
- (load-test "c-test-fns")
- (load-test "arrays")
- (load-test "union")
- (load-test "strtol")
- (load-test "atoifl")
- (load-test "gettime")
- (load-test "getenv")
- (load-test "gethostname")
- (load-test "getshells")
- (load-test "compress"))
-
-(setq cl:*features* (remove :examples-uffi cl:*features*))
-
-
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: run-examples.cl
+;;;; Purpose: Load and execute all examples for UFFI
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: run-examples.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(pushnew :examples-uffi cl:*features*)
+
+(flet ((load-test (name)
+ (load (make-pathname :defaults *load-truename* :name name))))
+ (load-test "c-test-fns")
+ (load-test "arrays")
+ (load-test "union")
+ (load-test "strtol")
+ (load-test "atoifl")
+ (load-test "gettime")
+ (load-test "getenv")
+ (load-test "gethostname")
+ (load-test "getshells")
+ (load-test "compress"))
+
+(setq cl:*features* (remove :examples-uffi cl:*features*))
+
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: strtol.cl
-;;;; Purpose: UFFI Example file to strtol, uses pointer arithmetic
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: strtol.cl,v 1.15 2002/04/02 23:27:05 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(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)
- ((nptr char-ptr)
- (endptr (* char-ptr))
- (base :int))
- :returning :long)
-
-(defun strtol (str &optional (base 10))
- "Returns a long int from a string. Returns number and condition flag.
-Condition flag is T if all of string parses as a long, NIL if
-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)))
-
- (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)))))
- (progn
- (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))))
- (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")))
- (test-strtol "123" '(123 t))
- (test-strtol "0" '(0 t))
- (test-strtol "55a" '(55 2))
- (test-strtol "a" '(nil nil))))
-
-
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: strtol.cl
+;;;; Purpose: UFFI Example file to strtol, uses pointer arithmetic
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: strtol.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(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)
+ ((nptr char-ptr)
+ (endptr (* char-ptr))
+ (base :int))
+ :returning :long)
+
+(defun strtol (str &optional (base 10))
+ "Returns a long int from a string. Returns number and condition flag.
+Condition flag is T if all of string parses as a long, NIL if
+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)))
+
+ (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)))))
+ (progn
+ (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))))
+ (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")))
+ (test-strtol "123" '(123 t))
+ (test-strtol "0" '(0 t))
+ (test-strtol "55a" '(55 2))
+ (test-strtol "a" '(nil nil))))
+
+
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: test-examples.cl
-;;;; Purpose: Load and execute all examples for UFFI
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: test-examples.cl,v 1.3 2002/09/20 05:38:01 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-#-uffi (asdf:oos 'asdf:load-op :uffi)
-
-(unless (ignore-errors (find-package :util.test))
- (load (make-pathname :name "acl-compat-tester" :type "cl"
- :defaults *load-truename*)))
-
-(defun do-tests ()
- (pushnew :test-uffi cl:*features*)
- (util.test:with-tests (:name "UFFI-Tests")
- (setq util.test:*break-on-test-failures* nil)
- (flet ((load-test (name)
- (load (merge-pathnames
- (make-pathname :name name
- :type "cl")
- *load-truename*))))
- (load-test "c-test-fns")
- (load-test "arrays")
- (load-test "union")
- (load-test "strtol")
- (load-test "atoifl")
- (load-test "gettime")
- (load-test "getenv")
- (load-test "gethostname")
- (load-test "getshells")
- (load-test "compress"))
- (setq cl:*features* (remove :test-uffi cl:*features*))))
-
-(do-tests)
-
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: test-examples.cl
+;;;; Purpose: Load and execute all examples for UFFI
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: test-examples.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(unless (ignore-errors (find-package :util.test))
+ (load (make-pathname :name "acl-compat-tester" :defaults *load-truename*)))
+
+(defun do-tests ()
+ (pushnew :test-uffi cl:*features*)
+ (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-test "c-test-fns")
+ (load-test "arrays")
+ (load-test "union")
+ (load-test "strtol")
+ (load-test "atoifl")
+ (load-test "gettime")
+ (load-test "getenv")
+ (load-test "gethostname")
+ (load-test "getshells")
+ (load-test "compress"))
+ (setq cl:*features* (remove :test-uffi cl:*features*))))
+
+(do-tests)
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: union.cl
-;;;; Purpose: UFFI Example file to test unions
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: union.cl,v 1.10 2002/09/29 17:31:20 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(uffi:def-union tunion1
- (char :char)
- (int :int)
- (uint :unsigned-int)
- (sf :float)
- (df :double))
-
-(defun run-union-1 ()
- (let ((u (uffi:allocate-foreign-object 'tunion1)))
- (setf (uffi:get-slot-value u 'tunion1 'uint)
- ;; little endian
- #-(or sparc sparc-v9 powerpc ppc)
- (+ (* 1 (char-code #\A))
- (* 256 (char-code #\B))
- (* 65536 (char-code #\C))
- (* 16777216 128))
- ;; big endian
- #+(or sparc sparc-v9 powerpc ppc)
- (+ (* 16777216 (char-code #\A))
- (* 65536 (char-code #\B))
- (* 256 (char-code #\C))
- (* 1 128)))
- (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:free-foreign-object u))
- (values))
-
-#+test-uffi
-(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 mcl)
- (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
- 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")
- (uffi:free-foreign-object u))
- (values))
-
-#+examples-uffi
-(run-union-1)
-
-
-#+test-uffi
-(test-union-1)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: union.cl
+;;;; Purpose: UFFI Example file to test unions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: union.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-union tunion1
+ (char :char)
+ (int :int)
+ (uint :unsigned-int)
+ (sf :float)
+ (df :double))
+
+(defun run-union-1 ()
+ (let ((u (uffi:allocate-foreign-object 'tunion1)))
+ (setf (uffi:get-slot-value u 'tunion1 'uint)
+ ;; little endian
+ #-(or sparc sparc-v9 powerpc ppc)
+ (+ (* 1 (char-code #\A))
+ (* 256 (char-code #\B))
+ (* 65536 (char-code #\C))
+ (* 16777216 128))
+ ;; big endian
+ #+(or sparc sparc-v9 powerpc ppc)
+ (+ (* 16777216 (char-code #\A))
+ (* 65536 (char-code #\B))
+ (* 256 (char-code #\C))
+ (* 1 128)))
+ (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:free-foreign-object u))
+ (values))
+
+#+test-uffi
+(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 mcl)
+ (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
+ 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")
+ (uffi:free-foreign-object u))
+ (values))
+
+#+examples-uffi
+(run-union-1)
+
+
+#+test-uffi
+(test-union-1)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Aug 2002
;;;;
-;;;; $Id: uffi.asd,v 1.16 2002/09/30 07:51:00 kevin Exp $
+;;;; $Id: uffi.asd,v 1.17 2002/09/30 10:02:36 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
((:file "uffi-corman")))
))
-
-#+(or allegro lispworks cmu mcl)
-(defmethod source-file-type ((c cl-source-file) (s (eql (find-system :uffi))))
- "cl")
-
#+(or allegro lispworks cmu mcl)
(when (ignore-errors (find-class 'load-compiled-op))
(defmethod perform :after ((op load-compiled-op) (c (eql (find-system :uffi))))
projects / uffi.git / commitdiff