From: Kevin M. Rosenberg Date: Mon, 30 Sep 2002 10:02:36 +0000 (+0000) Subject: r2912: rename .cl to .lisp X-Git-Tag: v1.6.1~284 X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=a95b9a217335917d96b8c0cced4f49c3e4846115;hp=bcd9fb3deb580f2976e7505a7433795ed6ad1bb3;p=uffi.git r2912: rename .cl to .lisp --- diff --git a/benchmarks/allocation.cl b/benchmarks/allocation.cl deleted file mode 100644 index caebce2..0000000 --- a/benchmarks/allocation.cl +++ /dev/null @@ -1,110 +0,0 @@ -;;;; -*- 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) - - - diff --git a/benchmarks/allocation.lisp b/benchmarks/allocation.lisp new file mode 100644 index 0000000..516902a --- /dev/null +++ b/benchmarks/allocation.lisp @@ -0,0 +1,110 @@ +;;;; -*- 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) + + + diff --git a/debian/changelog b/debian/changelog index 86bad87..de48fe1 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (0.9.1-1) unstable; urgency=low + + * Rename .cl files to .lisp files + + -- Kevin M. Rosenberg 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 diff --git a/examples/acl-compat-tester.cl b/examples/acl-compat-tester.cl deleted file mode 100644 index 84e8d57..0000000 --- a/examples/acl-compat-tester.cl +++ /dev/null @@ -1,600 +0,0 @@ -;; 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) diff --git a/examples/acl-compat-tester.lisp b/examples/acl-compat-tester.lisp new file mode 100644 index 0000000..d777311 --- /dev/null +++ b/examples/acl-compat-tester.lisp @@ -0,0 +1,600 @@ +;; 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) diff --git a/examples/arrays.cl b/examples/arrays.cl deleted file mode 100644 index 668171c..0000000 --- a/examples/arrays.cl +++ /dev/null @@ -1,64 +0,0 @@ -;;;; -*- 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) - - diff --git a/examples/arrays.lisp b/examples/arrays.lisp new file mode 100644 index 0000000..75ff5a7 --- /dev/null +++ b/examples/arrays.lisp @@ -0,0 +1,64 @@ +;;;; -*- 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) + + diff --git a/examples/atoifl.cl b/examples/atoifl.cl deleted file mode 100644 index 84e9a72..0000000 --- a/examples/atoifl.cl +++ /dev/null @@ -1,59 +0,0 @@ -;;;; -*- 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") - ) - diff --git a/examples/atoifl.lisp b/examples/atoifl.lisp new file mode 100644 index 0000000..47c194c --- /dev/null +++ b/examples/atoifl.lisp @@ -0,0 +1,59 @@ +;;;; -*- 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") + ) + diff --git a/examples/c-test-fns.cl b/examples/c-test-fns.cl deleted file mode 100644 index 0bdb90f..0000000 --- a/examples/c-test-fns.cl +++ /dev/null @@ -1,121 +0,0 @@ -;;;; -*- 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") - ) diff --git a/examples/c-test-fns.lisp b/examples/c-test-fns.lisp new file mode 100644 index 0000000..c21b39c --- /dev/null +++ b/examples/c-test-fns.lisp @@ -0,0 +1,121 @@ +;;;; -*- 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") + ) diff --git a/examples/compress.cl b/examples/compress.cl deleted file mode 100644 index 1abaff6..0000000 --- a/examples/compress.cl +++ /dev/null @@ -1,77 +0,0 @@ -;;;; -*- 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 diff --git a/examples/compress.lisp b/examples/compress.lisp new file mode 100644 index 0000000..75d79c4 --- /dev/null +++ b/examples/compress.lisp @@ -0,0 +1,77 @@ +;;;; -*- 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 diff --git a/examples/file-socket.cl b/examples/file-socket.cl deleted file mode 100644 index 2caa37a..0000000 --- a/examples/file-socket.cl +++ /dev/null @@ -1,42 +0,0 @@ -;;;; -*- 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")))) diff --git a/examples/file-socket.lisp b/examples/file-socket.lisp new file mode 100644 index 0000000..67fe886 --- /dev/null +++ b/examples/file-socket.lisp @@ -0,0 +1,42 @@ +;;;; -*- 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")))) diff --git a/examples/getenv.cl b/examples/getenv.cl deleted file mode 100644 index b3d620e..0000000 --- a/examples/getenv.cl +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- 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") -) - diff --git a/examples/getenv.lisp b/examples/getenv.lisp new file mode 100644 index 0000000..17d2758 --- /dev/null +++ b/examples/getenv.lisp @@ -0,0 +1,47 @@ +;;;; -*- 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") +) + diff --git a/examples/gethostname.cl b/examples/gethostname.cl deleted file mode 100644 index b668a10..0000000 --- a/examples/gethostname.cl +++ /dev/null @@ -1,65 +0,0 @@ -;;;; -*- 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")) - ) - - diff --git a/examples/gethostname.lisp b/examples/gethostname.lisp new file mode 100644 index 0000000..9098114 --- /dev/null +++ b/examples/gethostname.lisp @@ -0,0 +1,65 @@ +;;;; -*- 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")) + ) + + diff --git a/examples/getshells.cl b/examples/getshells.cl deleted file mode 100644 index ef6bacd..0000000 --- a/examples/getshells.cl +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- 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)) - diff --git a/examples/getshells.lisp b/examples/getshells.lisp new file mode 100644 index 0000000..1b05d10 --- /dev/null +++ b/examples/getshells.lisp @@ -0,0 +1,47 @@ +;;;; -*- 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)) + diff --git a/examples/gettime.cl b/examples/gettime.cl deleted file mode 100644 index c562fad..0000000 --- a/examples/gettime.cl +++ /dev/null @@ -1,76 +0,0 @@ -;;;; -*- 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"))) - - diff --git a/examples/gettime.lisp b/examples/gettime.lisp new file mode 100644 index 0000000..37461ff --- /dev/null +++ b/examples/gettime.lisp @@ -0,0 +1,76 @@ +;;;; -*- 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"))) + + diff --git a/examples/run-examples.cl b/examples/run-examples.cl deleted file mode 100644 index 25afc98..0000000 --- a/examples/run-examples.cl +++ /dev/null @@ -1,39 +0,0 @@ -;;;; -*- 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*)) - - - diff --git a/examples/run-examples.lisp b/examples/run-examples.lisp new file mode 100644 index 0000000..7e80a3f --- /dev/null +++ b/examples/run-examples.lisp @@ -0,0 +1,39 @@ +;;;; -*- 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*)) + + + diff --git a/examples/strtol.cl b/examples/strtol.cl deleted file mode 100644 index 32c5c42..0000000 --- a/examples/strtol.cl +++ /dev/null @@ -1,83 +0,0 @@ -;;;; -*- 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)))) - - - diff --git a/examples/strtol.lisp b/examples/strtol.lisp new file mode 100644 index 0000000..c2956e3 --- /dev/null +++ b/examples/strtol.lisp @@ -0,0 +1,83 @@ +;;;; -*- 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)))) + + + diff --git a/examples/test-examples.cl b/examples/test-examples.cl deleted file mode 100644 index 32def1e..0000000 --- a/examples/test-examples.cl +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- 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) - diff --git a/examples/test-examples.lisp b/examples/test-examples.lisp new file mode 100644 index 0000000..5f780d4 --- /dev/null +++ b/examples/test-examples.lisp @@ -0,0 +1,43 @@ +;;;; -*- 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) + diff --git a/examples/union.cl b/examples/union.cl deleted file mode 100644 index fc14c4a..0000000 --- a/examples/union.cl +++ /dev/null @@ -1,89 +0,0 @@ -;;;; -*- 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) diff --git a/examples/union.lisp b/examples/union.lisp new file mode 100644 index 0000000..856ac49 --- /dev/null +++ b/examples/union.lisp @@ -0,0 +1,89 @@ +;;;; -*- 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) diff --git a/src/aggregates.cl b/src/aggregates.cl deleted file mode 100644 index 83a7995..0000000 --- a/src/aggregates.cl +++ /dev/null @@ -1,191 +0,0 @@ -;;;; -*- 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))) -) diff --git a/src/aggregates.lisp b/src/aggregates.lisp new file mode 100644 index 0000000..a1d8a67 --- /dev/null +++ b/src/aggregates.lisp @@ -0,0 +1,191 @@ +;;;; -*- 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))) +) diff --git a/src/corman/corman-uffi.cl b/src/corman/corman-uffi.cl deleted file mode 100644 index d91d41a..0000000 --- a/src/corman/corman-uffi.cl +++ /dev/null @@ -1,274 +0,0 @@ -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" -+;;;; 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 - diff --git a/src/corman/corman-uffi.lisp b/src/corman/corman-uffi.lisp new file mode 100644 index 0000000..c745c10 --- /dev/null +++ b/src/corman/corman-uffi.lisp @@ -0,0 +1,274 @@ +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" ++;;;; 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 + diff --git a/src/functions.cl b/src/functions.cl deleted file mode 100644 index a797a39..0000000 --- a/src/functions.cl +++ /dev/null @@ -1,114 +0,0 @@ -;;;; -*- 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)))) - - diff --git a/src/functions.lisp b/src/functions.lisp new file mode 100644 index 0000000..03b8d59 --- /dev/null +++ b/src/functions.lisp @@ -0,0 +1,114 @@ +;;;; -*- 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)))) + + diff --git a/src/libraries.cl b/src/libraries.cl deleted file mode 100644 index 96807ee..0000000 --- a/src/libraries.cl +++ /dev/null @@ -1,110 +0,0 @@ -;;;; -*- 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))) diff --git a/src/libraries.lisp b/src/libraries.lisp new file mode 100644 index 0000000..72dbc09 --- /dev/null +++ b/src/libraries.lisp @@ -0,0 +1,110 @@ +;;;; -*- 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))) diff --git a/src/objects-mcl.cl b/src/objects-mcl.cl deleted file mode 100644 index 75eccb2..0000000 --- a/src/objects-mcl.cl +++ /dev/null @@ -1,42 +0,0 @@ -;;;; -*- 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)) - ) - - diff --git a/src/objects-mcl.lisp b/src/objects-mcl.lisp new file mode 100644 index 0000000..6e12650 --- /dev/null +++ b/src/objects-mcl.lisp @@ -0,0 +1,42 @@ +;;;; -*- 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)) + ) + + diff --git a/src/objects.cl b/src/objects.cl deleted file mode 100644 index 0323da9..0000000 --- a/src/objects.cl +++ /dev/null @@ -1,183 +0,0 @@ -;;;; -*- 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)) - diff --git a/src/objects.lisp b/src/objects.lisp new file mode 100644 index 0000000..5a9d21a --- /dev/null +++ b/src/objects.lisp @@ -0,0 +1,183 @@ +;;;; -*- 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)) + diff --git a/src/package.cl b/src/package.cl deleted file mode 100644 index abacbc8..0000000 --- a/src/package.cl +++ /dev/null @@ -1,72 +0,0 @@ -;;;; -*- 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 - )) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..abacbc8 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,72 @@ +;;;; -*- 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 + )) diff --git a/src/primitives.cl b/src/primitives.cl deleted file mode 100644 index 0c35d8a..0000000 --- a/src/primitives.cl +++ /dev/null @@ -1,285 +0,0 @@ -;;;; -*- 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)))) - diff --git a/src/primitives.lisp b/src/primitives.lisp new file mode 100644 index 0000000..6abd855 --- /dev/null +++ b/src/primitives.lisp @@ -0,0 +1,285 @@ +;;;; -*- 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)))) + diff --git a/src/readmacros-mcl.cl b/src/readmacros-mcl.cl deleted file mode 100644 index 74dc32f..0000000 --- a/src/readmacros-mcl.cl +++ /dev/null @@ -1,39 +0,0 @@ -;;;; -*- 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)) - diff --git a/src/readmacros-mcl.lisp b/src/readmacros-mcl.lisp new file mode 100644 index 0000000..dc1fc6c --- /dev/null +++ b/src/readmacros-mcl.lisp @@ -0,0 +1,39 @@ +;;;; -*- 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)) + diff --git a/src/strings.cl b/src/strings.cl deleted file mode 100644 index e317017..0000000 --- a/src/strings.cl +++ /dev/null @@ -1,231 +0,0 @@ -;;;; -*- 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))) diff --git a/src/strings.lisp b/src/strings.lisp new file mode 100644 index 0000000..c2aa4b7 --- /dev/null +++ b/src/strings.lisp @@ -0,0 +1,231 @@ +;;;; -*- 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))) diff --git a/tests/acl-compat-tester.cl b/tests/acl-compat-tester.cl deleted file mode 100644 index 84e8d57..0000000 --- a/tests/acl-compat-tester.cl +++ /dev/null @@ -1,600 +0,0 @@ -;; 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) diff --git a/tests/acl-compat-tester.lisp b/tests/acl-compat-tester.lisp new file mode 100644 index 0000000..d777311 --- /dev/null +++ b/tests/acl-compat-tester.lisp @@ -0,0 +1,600 @@ +;; 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) diff --git a/tests/arrays.cl b/tests/arrays.cl deleted file mode 100644 index 668171c..0000000 --- a/tests/arrays.cl +++ /dev/null @@ -1,64 +0,0 @@ -;;;; -*- 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) - - diff --git a/tests/arrays.lisp b/tests/arrays.lisp new file mode 100644 index 0000000..75ff5a7 --- /dev/null +++ b/tests/arrays.lisp @@ -0,0 +1,64 @@ +;;;; -*- 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) + + diff --git a/tests/atoifl.cl b/tests/atoifl.cl deleted file mode 100644 index 84e9a72..0000000 --- a/tests/atoifl.cl +++ /dev/null @@ -1,59 +0,0 @@ -;;;; -*- 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") - ) - diff --git a/tests/atoifl.lisp b/tests/atoifl.lisp new file mode 100644 index 0000000..47c194c --- /dev/null +++ b/tests/atoifl.lisp @@ -0,0 +1,59 @@ +;;;; -*- 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") + ) + diff --git a/tests/c-test-fns.cl b/tests/c-test-fns.cl deleted file mode 100644 index 0bdb90f..0000000 --- a/tests/c-test-fns.cl +++ /dev/null @@ -1,121 +0,0 @@ -;;;; -*- 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") - ) diff --git a/tests/c-test-fns.lisp b/tests/c-test-fns.lisp new file mode 100644 index 0000000..c21b39c --- /dev/null +++ b/tests/c-test-fns.lisp @@ -0,0 +1,121 @@ +;;;; -*- 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") + ) diff --git a/tests/compress.cl b/tests/compress.cl deleted file mode 100644 index 1abaff6..0000000 --- a/tests/compress.cl +++ /dev/null @@ -1,77 +0,0 @@ -;;;; -*- 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 diff --git a/tests/compress.lisp b/tests/compress.lisp new file mode 100644 index 0000000..75d79c4 --- /dev/null +++ b/tests/compress.lisp @@ -0,0 +1,77 @@ +;;;; -*- 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 diff --git a/tests/file-socket.cl b/tests/file-socket.cl deleted file mode 100644 index 2caa37a..0000000 --- a/tests/file-socket.cl +++ /dev/null @@ -1,42 +0,0 @@ -;;;; -*- 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")))) diff --git a/tests/file-socket.lisp b/tests/file-socket.lisp new file mode 100644 index 0000000..67fe886 --- /dev/null +++ b/tests/file-socket.lisp @@ -0,0 +1,42 @@ +;;;; -*- 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")))) diff --git a/tests/getenv.cl b/tests/getenv.cl deleted file mode 100644 index b3d620e..0000000 --- a/tests/getenv.cl +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- 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") -) - diff --git a/tests/getenv.lisp b/tests/getenv.lisp new file mode 100644 index 0000000..17d2758 --- /dev/null +++ b/tests/getenv.lisp @@ -0,0 +1,47 @@ +;;;; -*- 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") +) + diff --git a/tests/gethostname.cl b/tests/gethostname.cl deleted file mode 100644 index b668a10..0000000 --- a/tests/gethostname.cl +++ /dev/null @@ -1,65 +0,0 @@ -;;;; -*- 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")) - ) - - diff --git a/tests/gethostname.lisp b/tests/gethostname.lisp new file mode 100644 index 0000000..9098114 --- /dev/null +++ b/tests/gethostname.lisp @@ -0,0 +1,65 @@ +;;;; -*- 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")) + ) + + diff --git a/tests/getshells.cl b/tests/getshells.cl deleted file mode 100644 index ef6bacd..0000000 --- a/tests/getshells.cl +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- 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)) - diff --git a/tests/getshells.lisp b/tests/getshells.lisp new file mode 100644 index 0000000..1b05d10 --- /dev/null +++ b/tests/getshells.lisp @@ -0,0 +1,47 @@ +;;;; -*- 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)) + diff --git a/tests/gettime.cl b/tests/gettime.cl deleted file mode 100644 index c562fad..0000000 --- a/tests/gettime.cl +++ /dev/null @@ -1,76 +0,0 @@ -;;;; -*- 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"))) - - diff --git a/tests/gettime.lisp b/tests/gettime.lisp new file mode 100644 index 0000000..37461ff --- /dev/null +++ b/tests/gettime.lisp @@ -0,0 +1,76 @@ +;;;; -*- 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"))) + + diff --git a/tests/run-examples.cl b/tests/run-examples.cl deleted file mode 100644 index 25afc98..0000000 --- a/tests/run-examples.cl +++ /dev/null @@ -1,39 +0,0 @@ -;;;; -*- 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*)) - - - diff --git a/tests/run-examples.lisp b/tests/run-examples.lisp new file mode 100644 index 0000000..7e80a3f --- /dev/null +++ b/tests/run-examples.lisp @@ -0,0 +1,39 @@ +;;;; -*- 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*)) + + + diff --git a/tests/strtol.cl b/tests/strtol.cl deleted file mode 100644 index 32c5c42..0000000 --- a/tests/strtol.cl +++ /dev/null @@ -1,83 +0,0 @@ -;;;; -*- 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)))) - - - diff --git a/tests/strtol.lisp b/tests/strtol.lisp new file mode 100644 index 0000000..c2956e3 --- /dev/null +++ b/tests/strtol.lisp @@ -0,0 +1,83 @@ +;;;; -*- 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)))) + + + diff --git a/tests/test-examples.cl b/tests/test-examples.cl deleted file mode 100644 index 32def1e..0000000 --- a/tests/test-examples.cl +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- 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) - diff --git a/tests/test-examples.lisp b/tests/test-examples.lisp new file mode 100644 index 0000000..5f780d4 --- /dev/null +++ b/tests/test-examples.lisp @@ -0,0 +1,43 @@ +;;;; -*- 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) + diff --git a/tests/union.cl b/tests/union.cl deleted file mode 100644 index fc14c4a..0000000 --- a/tests/union.cl +++ /dev/null @@ -1,89 +0,0 @@ -;;;; -*- 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) diff --git a/tests/union.lisp b/tests/union.lisp new file mode 100644 index 0000000..856ac49 --- /dev/null +++ b/tests/union.lisp @@ -0,0 +1,89 @@ +;;;; -*- 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) diff --git a/uffi.asd b/uffi.asd index dfb8608..76737d3 100644 --- a/uffi.asd +++ b/uffi.asd @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -49,11 +49,6 @@ ((: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))))