From eweitz at common-lisp.net Wed Apr 30 08:26:12 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:26:12 -0400 (EDT) Subject: [rdnzl-cvs] r1 - branches Message-ID: <20080430082612.8F1873A005@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:26:12 2008 New Revision: 1 Added: branches/ Log: Created branches dir From eweitz at common-lisp.net Wed Apr 30 08:26:23 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:26:23 -0400 (EDT) Subject: [rdnzl-cvs] r2 - tags Message-ID: <20080430082623.0DBBC3A005@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:26:22 2008 New Revision: 2 Added: tags/ Log: Created tags dir From eweitz at common-lisp.net Wed Apr 30 08:26:37 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:26:37 -0400 (EDT) Subject: [rdnzl-cvs] r3 - trunk Message-ID: <20080430082637.E38F33A005@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:26:37 2008 New Revision: 3 Added: trunk/ Log: Created trunk dir From eweitz at common-lisp.net Wed Apr 30 08:27:26 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:27:26 -0400 (EDT) Subject: [rdnzl-cvs] r4 - trunk/rdnzl Message-ID: <20080430082726.C9E0B3C010@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:27:26 2008 New Revision: 4 Added: trunk/rdnzl/ Log: RDNZL directory From eweitz at common-lisp.net Wed Apr 30 08:28:05 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:28:05 -0400 (EDT) Subject: [rdnzl-cvs] r5 - in trunk/rdnzl: . doc examples Message-ID: <20080430082805.649BE3C010@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:28:03 2008 New Revision: 5 Added: trunk/rdnzl/CHANGELOG.txt (contents, props changed) trunk/rdnzl/RDNZL.dll (contents, props changed) trunk/rdnzl/README.txt (contents, props changed) trunk/rdnzl/adapter.lisp (contents, props changed) trunk/rdnzl/arrays.lisp (contents, props changed) trunk/rdnzl/container.lisp (contents, props changed) trunk/rdnzl/direct.lisp (contents, props changed) trunk/rdnzl/doc/ trunk/rdnzl/doc/apropos.png (contents, props changed) trunk/rdnzl/doc/box.png (contents, props changed) trunk/rdnzl/doc/box2.png (contents, props changed) trunk/rdnzl/doc/index.html (contents, props changed) trunk/rdnzl/examples/ trunk/rdnzl/examples/AproposGui.cs (contents, props changed) trunk/rdnzl/examples/AproposGui.dll (contents, props changed) trunk/rdnzl/examples/Callback.cs (contents, props changed) trunk/rdnzl/examples/Callback.dll (contents, props changed) trunk/rdnzl/examples/apropos.lisp (contents, props changed) trunk/rdnzl/examples/apropos2.lisp (contents, props changed) trunk/rdnzl/examples/callback.lisp (contents, props changed) trunk/rdnzl/examples/deliver-acl.lisp (contents, props changed) trunk/rdnzl/examples/deliver-ccl.lisp (contents, props changed) trunk/rdnzl/examples/deliver-lw.lisp (contents, props changed) trunk/rdnzl/examples/example.xls (contents, props changed) trunk/rdnzl/examples/excel.lisp (contents, props changed) trunk/rdnzl/examples/messagebox.lisp (contents, props changed) trunk/rdnzl/examples/url.lisp (contents, props changed) trunk/rdnzl/ffi.lisp (contents, props changed) trunk/rdnzl/import.lisp (contents, props changed) trunk/rdnzl/load.lisp (contents, props changed) trunk/rdnzl/packages.lisp (contents, props changed) trunk/rdnzl/port-acl.lisp (contents, props changed) trunk/rdnzl/port-ccl.lisp (contents, props changed) trunk/rdnzl/port-clisp.lisp (contents, props changed) trunk/rdnzl/port-ecl.lisp (contents, props changed) trunk/rdnzl/port-lw.lisp (contents, props changed) trunk/rdnzl/port-sbcl.lisp (contents, props changed) trunk/rdnzl/rdnzl.asd (contents, props changed) trunk/rdnzl/reader.lisp (contents, props changed) trunk/rdnzl/specials.lisp (contents, props changed) trunk/rdnzl/util.lisp (contents, props changed) Log: Import 0.12.2 Added: trunk/rdnzl/CHANGELOG.txt ============================================================================== --- (empty file) +++ trunk/rdnzl/CHANGELOG.txt Wed Apr 30 04:28:03 2008 @@ -0,0 +1,174 @@ +Version 0.12.2 +2008-03-25 +Added section about generic types to documentation (thanks to Iver Odin Kvello) +Added link to DataGridView example code by Matthew O'Connor + +Version 0.12.1 +2008-02-19 +Now based on DLL version 0.7.1 which fixes + +Version 0.12.0 +2008-02-14 +Now based on DLL version 0.7.0 which fixes +Added tests for callbacks in examples folder +Integrated Iver Odin Kvello's code for generic types (see ) + +Version 0.11.2 +2008-01-26 +Increased value of *FFI-ARGS-SIZE* from 10 to 20 (see ) + +Version 0.11.1 +2007-12-30 +Fixed bug in Excel example + +Version 0.11.0 +2007-05-18 +Added COPY-CONTAINER (patch by Iver Odin Kvello) +Modified CAST to work with types loaded with LoadFrom (patch by Iver Odin Kvello) +Updated DLL to version 0.6.0 + +Version 0.10.9 +2007-04-27 +Fixed bug in IMPORT-ASSEMBLY (patch by Iver Odin Kvello) +Added link to example by Richard Fateman + +Version 0.10.8 +2006-10-17 +AllegroCL: clean up external-format initialization (Charles A. Cox) +AllgeroCL: enable RDNZL to run without locking out the rest of Lisp (Charles A. Cox) + +Version 0.10.7 +2006-09-27 +Added FFI-MAKE-NULL-POINTER to all ports +Reset Lisp callback pointers on exit (suggested by Michael Goffioul) +Updated DLL to version 0.5.2 + +Version 0.10.6 +2006-09-15 +Updated DLL to version 0.5.1 + +Version 0.10.5 +2006-09-14 +Fixed bug in reader syntax (reported by Michael Goffioul) + +Version 0.10.4 +2006-09-04 +Fixed typo in apropos.lisp (reported by Dean O'Connor) + +Version 0.10.3 +2006-08-25 +Added Excel example +Fixed bug in AREF* +Changed package handling in system definition (thanks to Christophe Rhodes) + +Version 0.10.2 +2006-08-10 +More DSPEC definitions for LispWorks + +Version 0.10.1 +2006-08-10 +DSPEC definitions for LispWorks + +Version 0.10.0 +2006-06-12 +ECL port (provided by Michael Goffioul) + +Version 0.9.5 +2006-05-24 +Fixed delivery scripts and IMPORT statement for LW + +Version 0.9.4 +2006-02-18 +Fixed LW SINGLE-FLOAT issues (detective work by Dan Muller) + +Version 0.9.3 +2006-02-17 +Added *COERCE-DOUBLE-FLOATS-TO-SINGLE* + +Version 0.9.2 +2006-02-13 +One can now call static methods from specific assemblies (thanks to Jim Sokoloff) + +Version 0.9.1 +2006-02-01 +Added missing WIDE-CHAR support for SBCL/Win32 + +Version 0.9.0 +2006-02-01 +Experimental support for SBCL/Win32 + +Version 0.8.0 +2006-01-13 +Fix mechanism which releases delegate adapters (thanks to Dominic Robinson) +Updated to DLL version 0.5.0 + +Version 0.7.1 +2005-11-21 +Updated to DLL version 0.4.1 + +Version 0.7.0 +2005-07-08 +In WRAP-CLOSURE, prevent callbacks from being able to throw over .NET stack frames (Charles A. Cox) +Modify UNMANGLE-NAME to work in case-preserving readtable-case mode (Charles A. Cox) +Don't redefine in util.lisp what's already there (for LispWorks) + +Version 0.6.1 +2005-01-03 +Make sure SETF accessors in direct.lisp return NEW-VALUE (sigh...) + +Version 0.6.0 +2005-01-03 +Support for "direct calls" +Fixed typo (forgot RESOLVE-TYPE-NAME) in FIELD +Fixed thinko in OR-ENUMS +Make sure SETF accessors in container.lisp return NEW-VALUE + +Version 0.5.1 +2004-12-28 +Make delivery examples for CCL and LW self-contained like Charley's AllegroCL example + +Version 0.5.0 +2004-12-28 +Corman Lisp port now works (thanks to Roger Corman) +Added delivery examples for AllegroCL (by Charles A. Cox) and Corman Lisp + +Version 0.4.5 +2004-12-27 +Cosmetic changes in AproposGUI.cs + +Version 0.4.4 +2004-12-24 +Added correct external encoding to :EF-WC-STRING type in port-lw.lisp (caught by Francisco Rivera) +Changed some code examples from LW to AllegroCL + +Version 0.4.3 +2004-12-23 +Argh!!! Version 0.4.2 included a defective DLL due to a typo + +Version 0.4.2 +2004-12-23 +Added better support for System.Single (thanks to Vasilis Margioulas) + +Version 0.4.1 +2004-12-22 +Some cleanup in docs +All text files now have DOS line endings +[Re-sync with my CVS tree (laptop was broken while 0.4.0 was released)] + +Version 0.4.0 +2004-12-21 +Preliminary CLISP port (provided by Vasilis Margioulas) +CRLF output for AllegroCL (thanks to Charles A. Cox) +[Some files have wrong CVS headers - this'll be fixed in the next version] + +Version 0.3.0 +2004-12-18 +Port to AllegroCL (provided by Charles A. Cox) + +Version 0.2.0 +2004-12-17 +Added proper handling of pass-by-reference calls (thanks again to Pedro Pinto) + +Version 0.1.0 +2004-12-16 +Initial public release Added: trunk/rdnzl/RDNZL.dll ============================================================================== Binary file. No diff available. Added: trunk/rdnzl/README.txt ============================================================================== --- (empty file) +++ trunk/rdnzl/README.txt Wed Apr 30 04:28:03 2008 @@ -0,0 +1,29 @@ +Installation +------------ + +First, put the file 'RDNZL.dll' somewhere where the foreign language +interface of your Lisp can find it. A safe bet is to put it in the +folder where your Lisp image starts up. + +Probably the easiest way to install RDNZL is to LOAD the file +'load.lisp' which comes with the distribution. Evaluate a form like + + (load "c:/path/to/rdnzl/load.lisp") + +or use the facilities of your IDE to LOAD this file. + +This should compile and load RDNZL on most Common Lisp +implementations. + +As an alternative you can use ASDF, RDNZL comes with an ASDF system +definition file 'rdnzl.asd'. + + +Documentation +------------- + +Complete documentation for RDNZL can be found in the 'doc' folder. + +RDNZL also supports Nikodemus Siivola's HYPERDOC, see + and +. Added: trunk/rdnzl/adapter.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/adapter.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,109 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/adapter.lisp,v 1.30 2008/01/26 22:28:30 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :rdnzl) + +(enable-rdnzl-syntax) + +(defun wrap-closure (closure return-type arg-types) + "Generates and returns a wrapper for the Lisp function CLOSURE such +that it can be used as a .NET delegate with the return type +RETURN-TYPE and argument types as in the array ARG-TYPE-ARRAY. Both +RETURN-TYPE and ARG-TYPE-ARRAY are DOT-NET-OBJECTs." + (let ((arg-type-names (map 'vector #`%AssemblyQualifiedName arg-types)) + ;; remember if the delegate doesn't return a result + (void-result-p [Equals return-type + (make-type-from-name "System.Void")])) + ;; wrapper starts here + (lambda (args-pointer &aux completed) + (unwind-protect + (prog1 + (let ((i 0) + args) + ;; loop through the array of arguments and cast each one + ;; to the expected type, convert to native Lisp types if + ;; appropriate + (do-rdnzl-array (arg (wrap-with-container args-pointer)) + (cast* arg (aref arg-type-names i)) + (incf i) + (push (unbox arg) args)) + ;; call the actual function + (let ((result (apply closure (nreverse args)))) + (pointer + (cond (void-result-p + ;; return a dummy System.Void object in case + ;; the delegate doesn't return anything + (make-null-object* "System.Void")) + (t + ;; otherwise wrap the result + (ensure-container result)))))) + (setq completed t)) + ;; block throw attempts + (unless completed + (labels ((block-throw (&aux (block t)) + (unwind-protect + (restart-case + (error "Cannot safely throw over a .NET -> Lisp callback.") + (continue-throw () + :report "Continue throw anyway." + (setq block nil))) + (when block + (block-throw))))) + (block-throw))))))) + +(defun make-adapter (closure return-type arg-types) + "Creates, if necessary, a subtype of DelegateAdapter \(see C++ code) +matching the signature determined by RETURN-TYPE \(a CONTAINER) and +ARG-TYPES \(a list of CONTAINERs). Then creates and returns a new +instance of this type which is used to wrap the Lisp closure CLOSURE." + (let* ((arg-type-array (list-to-rdnzl-array arg-types + (make-type-from-name "System.Type"))) + ;; the signature is a tupel of the return type's name and the + ;; names of the argument types + (signature (mapcar #`%AssemblyQualifiedName + (cons return-type arg-types))) + ;; first check if we have already cached a type for this + ;; signature, otherwise create it (via a call into RDNZL.dll) + (delegate-type (or (gethash signature *signature-hash*) + (setf (gethash signature *signature-hash*) + (build-delegate-type (format nil "_LispCallback_~A" + (incf *delegate-counter*)) + return-type + arg-type-array))))) + (let ((delegate-instance (new delegate-type))) + ;; initialize the new instance by informing it about the index + ;; number of this callback + [init delegate-instance (incf *callback-counter*)] + ;; wrap the Lisp closure with the code for argument marshalling + ;; and store it using the same index number + (setf (gethash *callback-counter* *callback-hash*) + (wrap-closure closure return-type arg-types)) + delegate-instance))) + +(disable-rdnzl-syntax) Added: trunk/rdnzl/arrays.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/arrays.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,119 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/arrays.lisp,v 1.29 2008/02/14 10:33:51 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Utility functions for arrays and enumerations + +(in-package :rdnzl) + +(enable-rdnzl-syntax) + +(defmacro do-rdnzl-array ((var array-form &optional result) &body body) + "ARRAY-FORM should be a form which evaluates to a CONTAINER +structure wrapping a .NET array of rank 1. BODY will be evaluated +with VAR bound to each element of this array \(as a CONTAINER) in +turn. Finally, the result of evaluating the form RESULT is returned." + (with-unique-names (array length i) + ;; this can later be optimized by iterating directly through an + ;; FFI array so we don't have the expensive call to INVOKE on each + ;; iteration - but we don't do that now + `(let* ((,array ,array-form) + (,length (property ,array "Length"))) + (dotimes (,i ,length) + (let ((,var (get-array-element ,array ,i))) + , at body)) + ,result))) + +(defun aref* (array &rest subscripts) + "Returns the element of the .NET array ARRAY \(a CONTAINER) with the +subscripts SUBSCRIPTS. Similar to AREF." + (let* ((element-type [%AssemblyQualifiedName [GetElementType [GetType array]]]) + (value (apply #`GetValue array subscripts))) + ;; VALUE might be NULL pointer, so check for NIL before unboxing + (and value (unbox (cast* value element-type))))) + +(defun (setf aref*) (new-value array &rest subscripts) + "Sets the element of the .NET array ARRAY \(a CONTAINER) with the +subscripts SUBSCRIPTS to the new value NEW-VALUE. Similar to \(SETF +AREF)." + (apply #`SetValue array new-value subscripts) + new-value) + +(defun make-array-type (base-type dimensions) + "Synthesizes a .NET array type with base type BASE-TYPE \(a +CONTAINER) and DIMENSIONS dimensions." + (let* ((base-type-name (get-object-as-string base-type)) + (array-type-name (format nil "~A[~V,,,',A]~A" base-type-name (1- dimensions) "" + (subseq [%AssemblyQualifiedName base-type] + (length base-type-name))))) + (make-type-from-name array-type-name))) + +(defun list-to-rdnzl-array (list &optional (base-type (make-type-from-name "System.Object"))) + "Creates and returns a .NET array of base type BASE-TYPE \(a +CONTAINER, a string, or a tree of strings) and rank 1 with the +elements from the Lisp list LIST." + (when (or (stringp base-type) + (consp base-type)) + (setq base-type (make-type-from-name (resolve-type-name base-type)))) + (let* ((length (length list)) + ;; this is equivalent to calling NEW (see import.lisp) + (new-array (invoke-constructor (make-array-type base-type 1) + length))) + (loop for element in list + for i from 0 + do (setf (aref* new-array i) + (ensure-container element))) + new-array)) + +(defun rdnzl-array-to-list (array) + "Converts a .NET array ARRAY of rank 1 to a Lisp list with the same +elements." + (let (list) + (do-rdnzl-array (element array (nreverse list)) + (push element list)))) + +(defun enum-to-integer (enum) + "Converts the .NET object ENUM of type System.Enum to a Lisp +integer. This is a destructive operation on ENUM." + (unbox (cast* enum "System.Int32"))) + +(defun integer-to-enum (number type) + "Converts the Lisp integer NUMBER to a .NET System.Enum object of +type TYPE \(a string or a CONTAINER)." + (when (or (stringp type)(consp type)) + (setq type (make-type-from-name (resolve-type-name type)))) + (cast [System.Enum.ToObject type number] type)) + +(defun or-enums (&rest enums) + "Combines several .NET objects of type System.Enum with a logical or +and returns the result. All arguments must be of the same .NET type." + (let ((type-name [%AssemblyQualifiedName [GetType (first enums)]])) + (integer-to-enum + (apply #'logior (mapcar #'enum-to-integer enums)) type-name))) + +(disable-rdnzl-syntax) Added: trunk/rdnzl/container.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/container.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,531 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/container.lisp,v 1.52 2008/02/14 11:38:45 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Definition of CONTAINER structure and various functions to deal +;;; with .NET objects. + +(in-package :rdnzl) + +(defstruct (container + (:conc-name nil) + (:copier nil) + ;; Corman Lisp doesn't know :PRINT-OBJECT + (:print-function print-container)) + "Simple structure to wrap a pointer to a DotNetContainer object." + (pointer nil :read-only t) + (refp nil)) + +(defun print-container (container stream depth) + "Prints an unreadable representation of a CONTAINER structure to the +stream STREAM." + (declare (ignore depth)) + (print-unreadable-object (container stream :type t :identity nil) + (let ((pointer (pointer container))) + (unless (ffi-pointer-p pointer) + (error "~S is not an FFI pointer" pointer)) + (format stream "~A #x~X" + (if (%dot-net-container-is-null pointer) + "NULL" + ;; show name of type + (get-type-name container)) + ;; show pointer address + (ffi-pointer-address pointer)))) + container) + +(define-condition rdnzl-error (simple-error) + ((exception :initarg :exception + :reader rdnzl-error-exception)) + (:report (lambda (condition stream) + (format stream "~?" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))) + (:documentation "An error of this type is signaled whenever an +exception occured during a call into .NET. The EXCEPTION slot of this +error object holds a reference \(a CONTAINER) to the corresponding +.NET error object.")) + +(setf (documentation 'rdnzl-error-exception 'function) + "Returns the .NET error object \(as a CONTAINER) which was +responsible for this error.") + +(defun ref (object) + "Makes a pass-by-reference type out of OBJECT and returns OBJECT. +If OBJECT is not a CONTAINER it'll be boxed first \(see BOX). This +function makes only sense if OBJECT is used as an argument to INVOKE!" + (cond ((container-p object) + (%ref-dot-net-container-type (pointer object)) + (setf (refp object) t) + object) + (t + (ref (box object))))) + +(defun unref (container) + "Resets CONTAINER to have the underlying type again. Assumes that +REF was applied to CONTAINER before. Returns CONTAINER." + (%unref-dot-net-container-type (pointer container)) + (setf (refp container) nil) + container) + +(defmacro rdnzl-handler-case (form &rest clauses) + "Like HANDLER-CASE but only for conditions of type RDNZL-ERROR. The +typespecs are either strings \(naming a .NET error type) or of the +form \(OR string-1 ... string-n). A :NO-ERROR clause is also +allowed." + (with-unique-names (e exception) + `(handler-case ,form + (rdnzl-error (,e) + (let ((,exception (rdnzl-error-exception ,e))) + (cond + ,@(loop for (typespec var-list . forms) in clauses + for exception-var = (or (first var-list) (gensym)) + for typespec-list = (cond ((eq typespec :no-error) nil) + ((stringp typespec) + (list typespec)) + ((and (consp typespec) + (eq (first typespec) 'or)) + (rest typespec)) + ;; generic types denoted by trees + ((consp typespec) (list typespec)) + (t (error "Illegal typespec ~S in RDNZL-HANDLER-CASE" + typespec))) + collect `((or ,@(mapcar (lambda (typespec) + `(invoke (make-type-from-name (resolve-type-name ',typespec)) + "IsAssignableFrom" + (invoke ,exception "GetType"))) + typespec-list)) + (let ((,exception-var ,exception)) + (declare (ignorable ,exception-var)) + , at forms))) + (t (error ,e))))) + ,@(let ((no-error-clause (find :no-error clauses + :key #'first + :test #'eq))) + (and no-error-clause (list no-error-clause)))))) + +(defun maybe-free-container-pointer (object) + "This function is to be invoked whenever a CONTAINER structure is +finalized by the garbage collector." + (when (container-p object) + (%free-dot-net-container (pointer object)))) + +(defmacro wrap-with-container (form) + "Evaluates FORM and wraps the result with a CONTAINER structure. +Also makes sure the corresponding DotNetContainer object is garbage +collected. NIL is returned if FORM returns a NULL pointer." + (with-unique-names (block-name container pointer) + `(block ,block-name + (let (,container ,pointer) + (unwind-protect + (progn + (setq ,pointer ,form) + (when (ffi-null-pointer-p ,pointer) + (warn "Returning NIL for NULL FFI pointer.") + (return-from ,block-name nil)) + (setq ,container + (make-container :pointer ,pointer)) + ,container) + (when ,container + #-:sbcl + (flag-for-finalization ,container + #'maybe-free-container-pointer) + #+:sbcl + (sb-ext:finalize ,container + (lambda () + (%free-dot-net-container ,pointer))))))))) + +(defun make-type-from-name (name) + "Returns the .NET type with the name NAME - uses the static function +Type::GetType. If NAME is a tree of strings, it is interpreted as a +generic type using Type::GetType on each `leaf' type and producing the +type using Type::MakeGenericType." + (cond ((stringp name) + (wrap-with-container + (ffi-call-with-foreign-string* %make-type-from-name + name))) + (t (let* ((types (mapcar #'make-type-from-name name)) + (base-type (car types)) + (parameter-types (cdr types))) + (invoke base-type "MakeGenericType" + (list-to-rdnzl-array parameter-types "System.Type")))))) + +(defun get-object-as-string (container) + "Get a string representation of the object denoted by CONTAINER. +Uses 'ToString' internally." + (ffi-get-call-by-ref-string %get-dot-net-container-object-as-string + (pointer container) + %get-dot-net-container-object-string-length)) + +(defun get-type-name (container) + "Get the name of the type of the object denoted by CONTAINER. Uses +'FullName' internally." + (ffi-get-call-by-ref-string %get-dot-net-container-type-as-string + (pointer container) + %get-dot-net-container-type-string-length)) + +(defun box* (object) + "Like BOX but returns the raw pointer." + (typecase object + ((signed-byte 32) + (%make-dot-net-container-from-int object)) + ((signed-byte 64) + ;; this is due to a limitation of LispWorks: we have to pass the + ;; argument as a string + (ffi-call-with-foreign-string* %make-dot-net-container-from-long + (with-standard-io-syntax () + (princ-to-string object)))) + (string + (ffi-call-with-foreign-string* %make-dot-net-container-from-string object)) + (character + (%make-dot-net-container-from-char object)) + (double-float + (cond (*coerce-double-floats-to-single* + (%make-dot-net-container-from-float object)) + (t + (%make-dot-net-container-from-double object)))) + (float + (%make-dot-net-container-from-float object)) + (pathname + (box* (namestring object))) + (boolean + (%make-dot-net-container-from-boolean object)) + (otherwise + (error "Don't know how to convert object ~S of type ~A to a .NET object." + object (type-of object))))) + +(defun box (object) + "If object is a `native' Lisp object which we know how to convert +return a corresponding DotNetContainer object. Otherwise raise an +error." + (wrap-with-container (box* object))) + +(defun ensure-container (object) + "If OBJECT isn't already a CONTAINER then box it." + (cond + ((container-p object) object) + (t (box object)))) + +(defun unbox (container) + "If CONTAINER is of a known .NET type which we know how to convert +return the corresponding `native' Lisp object. Otherwise just return +the container." + (let ((type-name (get-type-name container))) + (cond ((string= type-name "System.String") + (get-object-as-string container)) + ((string= type-name "System.Char") + (%get-dot-net-container-char-value (pointer container))) + ((string= type-name "System.Int32") + (%get-dot-net-container-int-value (pointer container))) + ((string= type-name "System.Int64") + (with-standard-io-syntax + (read-from-string (get-object-as-string container)))) + ((string= type-name "System.Boolean") + (%get-dot-net-container-boolean-value (pointer container))) + ((string= type-name "System.Double") + (%get-dot-net-container-double-value (pointer container))) + ((string= type-name "System.Single") + (%get-dot-net-container-single-value (pointer container))) + (t container)))) + +(defmacro get-invocation-result (form) + "Evaluates FORM which is supposed to return a pointer to an +InvocationResult object. Tries to convert the result into a known +Lisp type, otherwise returns a CONTAINER structure." + (with-unique-names (block-name invocation-result container) + `(block ,block-name + (let (,invocation-result ,container) + (unwind-protect + (progn + (setq ,invocation-result ,form) + (when (%invocation-result-is-void ,invocation-result) + ;; return keyword :VOID if the result was void + (return-from ,block-name :void)) + ;; first create a CONTAINER so we can be sure the + ;; corresponding .NET object will be garbage-collected + (setq ,container + (wrap-with-container + (%get-dot-net-container-from-invocation-result ,invocation-result))) + (when (%invocation-result-is-exception ,invocation-result) + (error 'rdnzl-error + :exception ,container + :format-control ".NET error (~A): ~A" + :format-arguments (list (get-type-name ,container) + (property ,container "Message"))))) + (when ,invocation-result + ;; now free the InvocationResult object which wrapped the + ;; result we were interested in + (%free-invocation-result ,invocation-result))) + (when (%dot-net-container-is-null (pointer ,container)) + (warn "Returning NULL object from .NET call") + (return-from ,block-name (values nil t))) + ;; try to convert some known types to native Lisp types + (unbox ,container))))) + +(defmacro ffi-call-with-foreign-string (function name &rest other-args) + "Like FFI-CALL-WITH-FOREIGN-STRING* but handles the returned +InvocationResult object and accepts an arbitrary number of arguments +greater than one." + `(get-invocation-result + (ffi-call-with-foreign-string* ,function + ,name + (list , at other-args)))) + +(defmacro ffi-call-with-args (function object name args) + "Like FFI-CALL-WITH-ARGS* but OBJECT is assumed to be a CONTAINER +structure while each element of ARGS can be a native Lisp object or +such a structure. The result of calling FUNCTION is assumed to be a +pointer to an InvocationResult which is handled by +GET-INVOCATION-RESULT." + (with-rebinding (object) + (with-unique-names (pointer) + `(let ((,pointer (pointer ,object))) + (when (%dot-net-container-is-null ,pointer) + (error "Trying to call function ~S with NULL object ~S." + ',function ,object)) + (get-invocation-result + (ffi-call-with-args* ,function + ,pointer + ,name + ,args)))))) + +(defun make-type-from-assembly-and-name (assembly name) + "Returns the .NET type with the name NAME from a specific assembly. +If NAME is a tree, it is assumed a generic type is requested, but the +type parameters are resolved normally." + (let* ((base-name (if (stringp name) + name + (concatenate 'string (car name) + (format nil "`~D" (length (cdr name)))))) + (base-type + (ffi-call-with-args %invoke-instance-member + assembly "GetType" (list base-name)))) + (cond ((stringp name) base-type) + (t (let ((parameter-types (mapcar #'make-type-from-name + (mapcar #'resolve-type-name (rest name))))) + (invoke base-type "MakeGenericType" + (list-to-rdnzl-array parameter-types "System.Type"))))))) + +;; generic functions and TYPECASE are avoided below to make delivered +;; images smaller + +(defun invoke (object method-name &rest args) + "Invokes the method named METHOD-NAME \(a string). If OBJECT is a +CONTAINER, then the method is supposed to be an instance method of +this object. If OBJECT is a string, then the method is supposed to be +a static method of the type named OBJECT which will be looked up using +System.Type::GetType. If OBJECT is a tree of strings, then the method +should be a static method of the generic type named OBJECT, with ARGS +being the parameters of the type. Otherwise, OBJECT should be a pair +where the first element is a CONTAINER representing an assembly and +the second element is a string \(or a tree of strings) denoting a type +\(possibly generic), for which METHOD-NAME denotes a static method +\(which will be looked up in that specific assembly). ARGS \(either +CONTAINER structures or Lisp objects which can be converted) are the +arguments to this method." + (let ((result + (cond ((container-p object) + (ffi-call-with-args %invoke-instance-member + object + method-name + args)) + ((or (stringp object) + (and (consp object) + (stringp (car object)))) + (ffi-call-with-args %invoke-static-member + (make-type-from-name (resolve-type-name object)) + method-name + args)) + ((and (consp object) + (container-p (car object)) + (or (stringp (cdr object)) + (consp (cdr object)))) + (ffi-call-with-args %invoke-static-member + (make-type-from-assembly-and-name (car object) (cdr object)) + method-name + args)) + (t (error "Don't know how to invoke ~A on ~S." method-name object))))) + ;; if some of the arguments were pass-by-reference reset them to + ;; their underlying types + (dolist (arg args) + (when (and (container-p arg) + (refp arg)) + (unref arg))) + result)) + +(defun property (object property-name &rest args) + "Returns the property named PROPERTY-NAME \(a string). If OBJECT is +a CONTAINER then the property is supposed to be an instance property +of this object. If OBJECT is a string then the property is supposed +to be a static property of the type named OBJECT. ARGS (either +CONTAINER structures or Lisp objects which can be converted) are the +indexes to this property." + (cond ((container-p object) + (ffi-call-with-args %get-instance-property-value + object + property-name + args)) + ((or (stringp object) + (consp object)) + (ffi-call-with-args %get-static-property-value + (make-type-from-name (resolve-type-name object)) + property-name + args)) + (t (error "Don't know how to get property ~A of ~S." property-name object)))) + +(defun (setf property) (new-value object property-name &rest args) + "Sets the property named PROPERTY-NAME \(a string) to the new value +NEW-VALUE. If OBJECT is a CONTAINER then the property is supposed to +be an instance property of this object. If OBJECT is a string then +the property is supposed to be a static property of the type named +OBJECT. ARGS (either CONTAINER structures or Lisp objects which can +be converted) are the indexes to this property." + (cond ((container-p object) + (ffi-call-with-args %set-instance-property-value + object + property-name + (cons new-value args))) + ((or (stringp object) + (consp object)) + (ffi-call-with-args %set-static-property-value + (make-type-from-name (resolve-type-name object)) + property-name + (cons new-value args))) + (t (error "Don't know how to set property ~A of ~S." property-name object))) + new-value) + +(defun field (object field-name) + "Returns the field named FIELD-NAME \(a string). If OBJECT is a +CONTAINER then the field is supposed to be an instance field of this +object. If OBJECT is a string then the field is supposed to be a +static field of the type named OBJECT." + (cond ((container-p object) + (ffi-call-with-foreign-string %get-instance-field-value + field-name + object)) + ((or (stringp object) + (consp object)) + (ffi-call-with-foreign-string %get-static-field-value + field-name + (make-type-from-name (resolve-type-name object)))) + (t (error "Don't know how to get field ~A of ~S." field-name object)))) + +(defun (setf field) (new-value object field-name) + "Sets the field named FIELD-NAME \(a string) to the new value +NEW-VALUE. If OBJECT is a CONTAINER then the field is supposed to be +an instance field of this object. If OBJECT is a string then the +field is supposed to be a static field of the type named OBJECT." + (cond ((container-p object) + (ffi-call-with-foreign-string %set-instance-field-value + field-name + object + new-value)) + ((or (stringp object)(consp object)) + (ffi-call-with-foreign-string %set-static-field-value + field-name + (make-type-from-name (resolve-type-name object)) + new-value)) + (t (error "Don't know how to set field ~A of ~S." field-name object))) + new-value) + +(defun invoke-constructor (type &rest args) + "Invokes the constructor \(corresponding to the signature determined +by ARGS) of the .NET type TYPE \(a CONTAINER). ARGS (either CONTAINER +structures or Lisp objects which can be converted) are the arguments +to this constructor." + (ffi-call-with-args %invoke-constructor + type + nil + args)) + +(defun get-array-element (array index) + "Shortcut for fast access to elements of .NET arrays with rank 1. +Used only internally by DO-RDNZL-ARRAY." + (get-invocation-result + (%get-array-element (pointer array) + index))) + +(defun cast* (container type-name) + "Like CAST but doesn't try to resolve TYPE-NAME. TYPE-NAME must be +a string." + (ffi-call-with-foreign-string %set-dot-net-container-type-from-string + type-name + container) + container) + +(defun cast-to-type-object (container type) + "Like CAST, but assumes TYPE is a TYPE object. Unlike CAST*, will +work with types loaded in a LoadFrom context." + (ffi-call-with-foreign-string %set-dot-net-container-type-from-container + nil + type + container) + container) + +(defun cast (container type) + "Changes the type of the DotNetContainer object represented by +CONTAINER to TYPE \(a string, tree of strings, or a CONTAINER). +Returns CONTAINER." + (cond ((stringp type) (cast* container (resolve-type-name type))) + ((consp type) + (cast-to-type-object container + (make-type-from-name (resolve-type-name type)))) + (t (cast-to-type-object container type)))) + +(defun copy-container (container) + "Creates and returns a copy of the DotNetContainer object +representend by CONTAINTER." + (wrap-with-container + (%copy-dot-net-container (pointer container)))) + +(defun make-null-object* (type-name) + "Creates a NULL DotNetContainer with the type named by the string +TYPE-NAME." + (wrap-with-container + (ffi-call-with-foreign-string* %make-typed-null-dot-net-container + type-name))) + +(defun make-null-object (type-name) + "Like MAKE-NULL-OBJECT* but resolves TYPE-NAME first." + (cond ((stringp type-name) + (make-null-object* (resolve-type-name type-name))) + (t (make-null-object* + (property + (make-type-from-name + (resolve-type-name type-name)) + "AssemblyQualifiedName"))))) + + +(defun build-delegate-type (type-name return-type arg-type-array) + "Build a subtype of DelegateAdapter \(see C++ code) with the +corresponding signature. TYPE-NAME \(a string) will be the name of +the new type, the other two arguments are CONTAINERs." + (wrap-with-container + (ffi-call-with-foreign-string* %build-delegate-type + type-name + (list return-type + arg-type-array)))) \ No newline at end of file Added: trunk/rdnzl/direct.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/direct.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,301 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/direct.lisp,v 1.12 2008/01/26 22:28:30 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Interface for "direct calls" into .NET + +(in-package :rdnzl) + +(enable-rdnzl-syntax) + +(defun find-interface-method (interfaces method-name arg-types binding-attr) + "A Lisp version of findInterfaceMethod - see InvokeMember.cpp." + (do-rdnzl-array (interface interfaces) + (named-when (method-info [GetMethod interface method-name binding-attr + (make-null-object "System.Reflection.Binder") + arg-types + (make-null-object "System.Reflection.ParameterModifier[]")]) + (return-from find-interface-method method-info)) + (named-when (method-info + (find-interface-method [GetInterfaces interface] method-name arg-types binding-attr)) + (return-from find-interface-method method-info)))) + +(defun find-method* (type method-name arg-types binding-attr) + "A Lisp version of findMethod - see InvokeMember.cpp." + (or [GetMethod type method-name binding-attr + (make-null-object "System.Reflection.Binder") + arg-types + (make-null-object "System.Reflection.ParameterModifier[]")] + (and [%IsInterface type] + (or (find-interface-method [GetInterfaces type] method-name arg-types binding-attr) + (find-method* (make-type-from-name "System.Object") method-name arg-types binding-attr))))) + +(defun find-instance-method (method-name arg-type-names) + "Finds and returns a MethodInfo object \(or NIL) corresponding to +the instance method with the name METHOD-NAME \(a string) and the +signature ARG-TYPE-NAMES \(a list of strings naming types). Note that +the first element of ARG-TYPE-NAMES represents the type to which the +method belongs." + (let ((arg-types (mapcar (lambda (arg-type-name) + (make-type-from-name + (resolve-type-name arg-type-name))) + arg-type-names))) + (find-method* (first arg-types) + method-name + (list-to-rdnzl-array (rest arg-types) + "System.Type") + (or-enums [$System.Reflection.BindingFlags.Instance] + [$System.Reflection.BindingFlags.Public])))) + +(defun find-static-method (method-name type-name arg-type-names) + "Finds and returns a MethodInfo object \(or NIL) corresponding to +the static method of the type named TYPE-NAME \(a string) with the +name METHOD-NAME \(a string) and the signature ARG-TYPE-NAMES \(a list +of strings naming types)." + (let ((arg-types (mapcar (lambda (arg-type-name) + (make-type-from-name + (resolve-type-name arg-type-name))) + arg-type-names))) + (find-method* (make-type-from-name (resolve-type-name type-name)) + method-name + (list-to-rdnzl-array arg-types + "System.Type") + (or-enums [$System.Reflection.BindingFlags.Static] + [$System.Reflection.BindingFlags.Public])))) + +(defun find-property (type property-name arg-types binding-attr) + "Finds a PropertyInfo object. See corresponding code in +Property.cpp." + [GetProperty type property-name binding-attr + (make-null-object "System.Reflection.Binder") + (make-null-object "System.Type") + arg-types + (make-null-object "System.Reflection.ParameterModifier[]")]) + +(defun find-instance-property (property-name arg-type-names) + "Finds and returns a PropertyInfo object \(or NIL) corresponding to +the instance property with the name PROPERTY-NAME \(a string) and the +signature ARG-TYPE-NAMES \(a list of strings naming types). Note that +the first element of ARG-TYPE-NAMES represents the type to which the +property belongs." + (let ((arg-types (mapcar (lambda (arg-type-name) + (make-type-from-name + (resolve-type-name arg-type-name))) + arg-type-names))) + (find-property (first arg-types) + property-name + (list-to-rdnzl-array (rest arg-types) + "System.Type") + (or-enums [$System.Reflection.BindingFlags.Instance] + [$System.Reflection.BindingFlags.Public])))) + +(defun find-static-property (property-name type-name arg-type-names) + "Finds and returns a PropertyInfo object \(or NIL) corresponding to +the static property of the type named TYPE-NAME \(a string) with the +name PROPERTY-NAME \(a string) and the signature ARG-TYPE-NAMES \(a +list of strings naming types)." + (let ((arg-types (mapcar (lambda (arg-type-name) + (make-type-from-name + (resolve-type-name arg-type-name))) + arg-type-names))) + (find-property type-name + property-name + (list-to-rdnzl-array arg-types + "System.Type") + (or-enums [$System.Reflection.BindingFlags.Static] + [$System.Reflection.BindingFlags.Public])))) + +(defun find-field (type field-name binding-attr) + "Finds a FieldInfo object. See corresponding code in Field.cpp." + [GetField type field-name binding-attr]) + +(defun find-instance-field (field-name type-name) + "Finds and returns a FieldInfo object \(or NIL) corresponding to the +instance field with the name FIELD-NAME \(a string). TYPE-NAME \(a +string) names the type to which the field belongs." + (find-field (make-type-from-name (resolve-type-name type-name)) + field-name + (or-enums [$System.Reflection.BindingFlags.Instance] + [$System.Reflection.BindingFlags.Public]))) + +(defun find-static-field (field-name type-name) + "Finds and returns a FieldInfo object \(or NIL) corresponding to the +static field with the name FIELD-NAME \(a string). TYPE-NAME \(a +string) names the type to which the field belongs." + (find-field (make-type-from-name (resolve-type-name type-name)) + field-name + (or-enums [$System.Reflection.BindingFlags.Static] + [$System.Reflection.BindingFlags.Public]))) + +(defmacro define-rdnzl-call (lisp-name + (&key (dotnet-name (unmangle-name lisp-name)) + type-name + (member-kind :method) + doc-string) + args) + "Defines a Lisp function named by the function name LISP-NAME which +can directly \(without the need to search via Reflection) invoke a +.NET method, or get/set the value of a .NET property or field. +DOTNET-NAME is the name of the .NET member, TYPE-NAME is the name of a +.NET type and should only be supplied if a static member is to be +interfaced. MEMBER-KIND if one of :METHOD, :PROPERTY, or :FIELD. +DOC-STRING is the documentation string of the resulting Lisp +function." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (create-direct-call + ',lisp-name + (setf (gethash ',lisp-name *direct-definitions*) + (list ,member-kind ,dotnet-name ,type-name + (list ,@(loop for (nil arg-type-name) in args + collect arg-type-name))))) + (setf (documentation ',lisp-name 'function) + ,(or doc-string + (format nil "~:[Instance~;Static~] ~A ~A of .NET type ~A +with Lisp lambda list (~{~A~^ ~})" + type-name + (ecase member-kind + ((:method) "method") + ((:property) "property") + ((:field) "field")) + dotnet-name + (or type-name (second (first args))) + (loop for (arg-name nil) in args + collect arg-name)))) + #+:lispworks + ;; record location of definition for IDE + (dspec:record-definition '(define-rdnzl-call ,lisp-name) + (dspec:location)) + ',lisp-name)) + +(defun create-direct-call (lisp-name other-args) + "Called by DEFINE-RDNZL-CALL \(and also by REDEFINE-DIRECT-CALLS) to +actually create the function definition for LISP-NAME based on the +necessary data \(which is simply a transformation of the arguments to +DEFINE-RDNZL-CALL) in OTHER-ARGS." + (destructuring-bind (member-kind dotnet-name type-name arg-type-names) + other-args + (ecase member-kind + ((:method) + (cond (type-name + (let ((method-info (find-static-method dotnet-name type-name arg-type-names))) + (unless method-info + (error "Static method ~A(~{~A~^, ~}) for .NET type ~A not found" + dotnet-name arg-type-names type-name)) + (setf (fdefinition lisp-name) + (lambda (&rest args) + (ffi-call-with-args %invoke-static-member-directly + method-info + nil + args))))) + (t + (let ((method-info (find-instance-method dotnet-name arg-type-names))) + (unless method-info + (error "Instance method ~A(~{~A~^, ~}) for .NET type ~A not found" + dotnet-name (rest arg-type-names) (first arg-type-names))) + (setf (fdefinition lisp-name) + (lambda (&rest args) + (ffi-call-with-args %invoke-instance-member-directly + method-info + nil + args))))))) + ((:property) + (cond (type-name + (let ((property-info (find-static-property dotnet-name type-name arg-type-names))) + (unless property-info + (error "Static property ~A(~{~A~^, ~}) for .NET type ~A not found" + dotnet-name arg-type-names type-name)) + (setf (fdefinition lisp-name) + (if (consp lisp-name) + (lambda (new-value &rest other-args) + (ffi-call-with-args %set-static-property-value-directly + property-info + nil + (cons new-value other-args)) + new-value) + (lambda (&rest args) + (ffi-call-with-args %get-static-property-value-directly + property-info + nil + args)))))) + (t + (let ((property-info (find-instance-property dotnet-name arg-type-names))) + (unless property-info + (error "Instance property ~A(~{~A~^, ~}) for .NET type ~A not found" + dotnet-name (rest arg-type-names) (first arg-type-names))) + (setf (fdefinition lisp-name) + (if (consp lisp-name) + (lambda (new-value &rest other-args) + (ffi-call-with-args %set-instance-property-value-directly + property-info + nil + (cons new-value other-args)) + new-value) + (lambda (&rest args) + (ffi-call-with-args %get-instance-property-value-directly + property-info + nil + args)))))))) + ((:field) + (cond (type-name + (let ((field-info (find-static-field dotnet-name type-name))) + (unless field-info + (error "Static field ~A for .NET type ~A not found" + dotnet-name type-name)) + (setf (fdefinition lisp-name) + (if (consp lisp-name) + (lambda (new-value) + (ffi-call-with-foreign-string %set-static-field-value-directly + nil + field-info + new-value) + new-value) + (lambda () + (ffi-call-with-foreign-string %get-static-field-value-directly + nil + field-info)))))) + (t + (let ((field-info (find-instance-field dotnet-name (first arg-type-names)))) + (unless field-info + (error "Instance field ~A for .NET type ~A not found" + dotnet-name (first arg-type-names))) + (setf (fdefinition lisp-name) + (if (consp lisp-name) + (lambda (new-value object) + (ffi-call-with-foreign-string %set-instance-field-value-directly + nil + field-info + object + new-value) + new-value) + (lambda (object) + (ffi-call-with-foreign-string %get-instance-field-value-directly + nil + field-info + object))))))))))) + +(disable-rdnzl-syntax) Added: trunk/rdnzl/doc/apropos.png ============================================================================== Binary file. No diff available. Added: trunk/rdnzl/doc/box.png ============================================================================== Binary file. No diff available. Added: trunk/rdnzl/doc/box2.png ============================================================================== Binary file. No diff available. Added: trunk/rdnzl/doc/index.html ============================================================================== --- (empty file) +++ trunk/rdnzl/doc/index.html Wed Apr 30 04:28:03 2008 @@ -0,0 +1,1259 @@ + + + + + + RDNZL - A .NET layer for Common Lisp + + + + + +

RDNZL - A .NET layer for Common Lisp

+ +
+
 

Abstract

+ +RDNZL (pronounced "Redunzl") enables Common Lisp applications to interact with .NET +libraries. It's more or less a foreign function interface for .NET +languages like C# built atop the C foreign function interface. + +

+ +RDNZL comes with a BSD-style +license so you can basically do with it whatever you want. + +

+Download shortcut: http://weitz.de/files/rdnzl.tar.gz. + +

+ +
+ +
+ +
 

Contents

+
    +
  1. Examples +
  2. Download and installation +
  3. Support and mailing lists +
  4. Supported Lisp implementations +
  5. The RDNZL dictionary +
      +
    1. Representation and creation of .NET objects +
        +
      1. container-p +
      2. box +
      3. unbox +
      4. new +
      5. cast +
      6. copy-container +
      7. make-null-object +
      8. *coerce-double-floats-to-single* +
      +
    2. Accessing .NET methods, properties, and fields +
        +
      1. invoke +
      2. property +
      3. field +
      4. ref +
      +
    3. Arrays and enumerations +
        +
      1. aref* +
      2. do-rdnzl-array +
      3. list-to-rdnzl-array +
      4. rdnzl-array-to-list +
      5. integer-to-enum +
      6. enum-to-integer +
      7. or-enums +
      +
    4. Handling of .NET exceptions +
        +
      1. rdnzl-error +
      2. rdnzl-error-exception +
      3. rdnzl-handler-case +
      +
    5. Type names and assemblies +
        +
      1. import-type +
      2. load-assembly +
      3. import-assembly +
      4. import-types +
      5. use-namespace +
      6. unuse-namespace +
      7. unuse-all-namespaces +
      +
    6. Special reader syntax +
        +
      1. enable-rdnzl-syntax +
      2. disable-rdnzl-syntax +
      +
    7. Direct calls +
        +
      1. define-rdnzl-call +
      +
    8. Saving images and application delivery +
        +
      1. shutdown-rdnzl +
      2. init-rdnzl +
      +
    +
  6. Generic types +
  7. Implementation details and things to watch out for +
  8. Acknowledgements +
+ +
 

Examples

+ +Here's a short example session (using AllegroCL): + +
+The Message BoxCL-USER 1 > (load "/home/lisp/RDNZL/load.lisp")
+; Loading C:\home\lisp\RDNZL\load.lisp
+;   Fast loading C:\home\lisp\RDNZL\packages.fasl
+;   Fast loading C:\home\lisp\RDNZL\specials.fasl
+;   Fast loading C:\home\lisp\RDNZL\util.fasl
+;   Fast loading C:\home\lisp\RDNZL\port-acl.fasl
+;     Fast loading from bundle code\IORDEFS.fasl.
+;       Fast loading from bundle code\EFMACS.fasl.
+;   Fast loading C:\home\lisp\RDNZL\ffi.fasl
+;     Foreign loading RDNZL.dll.
+;   Fast loading C:\home\lisp\RDNZL\container.fasl
+;   Fast loading C:\home\lisp\RDNZL\reader.fasl
+;   Fast loading C:\home\lisp\RDNZL\arrays.fasl
+;   Fast loading C:\home\lisp\RDNZL\adapter.fasl
+;   Fast loading C:\home\lisp\RDNZL\import.fasl
+T
+CL-USER 2 > (in-package :rdnzl-user)
+#<The RDNZL-USER package>
+RDNZL-USER 3 > (enable-rdnzl-syntax)
+RDNZL-USER 4 > (import-types "System.Windows.Forms"
+                             "MessageBox" "MessageBoxButtons" "DialogResult")
+NIL
+RDNZL-USER 5 > (use-namespace "System.Windows.Forms")
+RDNZL-USER 6 > (defun message-box (text &optional (caption "RDNZL"))
+                 ;; check if the "OK" button was pressed
+                 [Equals [MessageBox.Show text caption
+                                          ;; we want the message box to have "OK" and "Cancel" buttons
+                                          [$MessageBoxButtons.OKCancel]]
+                         [$DialogResult.OK]])
+MESSAGE-BOX
+RDNZL-USER 7 > (message-box "Hello World!") ;; user presses "OK" button
+T
+RDNZL-USER 8 > (message-box "Hello World!") ;; user presses "Cancel" button
+NIL
+
+ +(Note: All examples shown here are included in the examples folder of the distribution.) +

+For a more interesting example which interacts with custom .NET code +and demonstrates callbacks into Lisp consider the .NET library +AproposGUI.dll (put it into your Lisp's application folder or use this technique) created +with this C# code: + +

+// compile this with:
+//   csc.exe /target:library AproposGui.cs
+
+using System;
+using System.Collections;
+using System.ComponentModel;
+using System.Drawing;
+using System.Data;
+using System.Windows.Forms;
+
+namespace AproposGUI {
+  public class AproposControl : System.Windows.Forms.UserControl {
+    public System.Windows.Forms.TextBox textBox;
+    public System.Windows.Forms.TextBox listBox;
+    private System.Windows.Forms.Label label;
+    public System.Windows.Forms.Label title;
+    private delegate string callback(string input);
+
+    private System.ComponentModel.Container components = null;
+    
+    public AproposControl() {
+      InitializeComponent();
+    }
+
+    protected override void Dispose(bool disposing) {
+      if (disposing) {
+        if (components != null)
+          components.Dispose();
+      }
+      base.Dispose(disposing);
+    }
+
+    private void InitializeComponent() {
+      this.textBox = new System.Windows.Forms.TextBox();
+      this.listBox = new System.Windows.Forms.TextBox();
+      this.label = new System.Windows.Forms.Label();
+      this.title = new System.Windows.Forms.Label();
+      this.SuspendLayout();
+
+      this.textBox.Location = new System.Drawing.Point(16, 344);
+      this.textBox.Name = "textBox";
+      this.textBox.Size = new System.Drawing.Size(584, 20);
+      this.textBox.TabIndex = 0;
+      this.textBox.Text = "";
+
+      this.listBox.Location = new System.Drawing.Point(16, 56);
+      this.listBox.Multiline = true;
+      this.listBox.Name = "listBox";
+      this.listBox.ReadOnly = true;
+      this.listBox.ScrollBars = System.Windows.Forms.ScrollBars.Vertical;
+      this.listBox.Size = new System.Drawing.Size(584, 248);
+      this.listBox.TabIndex = 1;
+      this.listBox.Text = "";
+
+      this.label.Location = new System.Drawing.Point(24, 312);
+      this.label.Name = "label";
+      this.label.Size = new System.Drawing.Size(576, 23);
+      this.label.TabIndex = 2;
+      this.label.Text = "Enter text below and press RETURN";
+      this.label.TextAlign = System.Drawing.ContentAlignment.MiddleCenter;
+
+      this.title.Font = new System.Drawing.Font("Microsoft Sans Serif", 12F, System.Drawing.FontStyle.Bold, System.Drawing.GraphicsUnit.Point, ((System.Byte)(0)));
+      this.title.Location = new System.Drawing.Point(24, 16);
+      this.title.Name = "title";
+      this.title.Size = new System.Drawing.Size(568, 24);
+      this.title.TabIndex = 3;
+      this.title.Text = "RDNZL Apropos Demo";
+      this.title.TextAlign = System.Drawing.ContentAlignment.MiddleCenter;
+
+      this.Controls.Add(this.title);
+      this.Controls.Add(this.label);
+      this.Controls.Add(this.listBox);
+      this.Controls.Add(this.textBox);
+      this.Name = "MainControl";
+      this.Size = new System.Drawing.Size(616, 384);
+      this.ResumeLayout(false);
+    }
+  }
+}
+
+ +Now load examples/apropos.lisp which looks like this: + +
+Another Message Box(in-package :rdnzl)
+
+(enable-rdnzl-syntax)
+
+(import-types "System.Windows.Forms"
+              "Application" "DockStyle" "Form" "MessageBox" "KeyPressEventHandler" "TextBox")
+
+(import-types "AproposGUI"
+              "AproposControl")
+
+(use-namespace "System.Windows.Forms")
+(use-namespace "AproposGUI")
+
+(defun copy-to-clipboard (text-box)
+  (let ((selection-start [%SelectionStart text-box])
+        (selection-length [%SelectionLength text-box])
+        (text-length [%Length (box [%Text text-box])]))
+    (setf [%SelectionStart text-box] 0
+          [%SelectionLength text-box] text-length)
+    [Copy text-box]
+    (setf [%SelectionStart text-box] selection-start
+          [%SelectionLength text-box] selection-length)))
+
+(let (message-shown)
+  (defun fill-list-box (object event)
+    (when (char= [%KeyChar event] #\Return)
+      (cast object "TextBox")
+      (let* ((input-string [%Text object])
+             (input-length (length input-string)))
+        (when (plusp input-length)
+          (let ((apropos-text
+                  (with-output-to-string (*standard-output*)
+                    (apropos input-string)))
+                (list-box [$listBox (cast [%Parent object] "AproposControl")]))
+            (setf [%Text list-box] apropos-text)
+            (copy-to-clipboard list-box)
+            (unless message-shown
+              [MessageBox.Show "The output of APROPOS has been copied to the clipboard."
+                               "RDNZL"]
+              (setq message-shown t)))
+          (setf [%SelectionStart object] 0
+                [%SelectionLength object] input-length))))))
+
+(defun run-apropos-form ()
+  (let* ((control (new "AproposControl"))
+         (form (new "Form")))
+    (setf [%Dock control] [$DockStyle.Fill]
+          [%ClientSize form] [%ClientSize control]
+          [%Text form] "RDNZL Apropos Demo"
+          [%Text [$title control]]
+            (format nil "RDNZL Apropos Demo (~A)"
+                    (lisp-implementation-type)))
+    [+KeyPress [$textBox control]
+               (new "KeyPressEventHandler" #'fill-list-box)]
+    [Add [%Controls form] control]
+    [Application.Run form]))
+
+(disable-rdnzl-syntax)
+
+ +and evaluate (RUN-APROPOS-FORM). If you want to try this +several times, start the function in its own thread. In AllegroCL or LispWorks +that'd be: + +
+(mp:process-run-function "apropos" #+:lispworks nil #'run-apropos-form)
+
+ +The next example shows how easy it is to access web pages using the +.NET standard library: + +
+RDNZL-USER 9 > (import-types "System" "Net.WebClient")
+NIL
+RDNZL-USER 10 > (defun download-url (url)
+                  (let ((web-client (new "System.Net.WebClient")))
+                    [GetString (new "System.Text.ASCIIEncoding")
+                               [DownloadData web-client url]]))
+DOWNLOAD-URL
+RDNZL-USER 11 > (download-url "http://nanook.agharta.de/")
+"<HTML>
+<HEAD>
+<META HTTP-EQUIV=\"refresh\" CONTENT=\"5;URL=http://www.weitz.de/\">
+</HEAD>
+<BODY><center>
+<table border=3 bordercolor=green cellpadding=5 cellspacing=5><tr><td align=center>
+<pre>
+Linux nanook 2.6.7 #1 Thu Jul 22 01:01:58 CEST 2004 i686 GNU/Linux
+
+ 01:23:23 up 100 days, 19:43,  0 users,  load average: 0.00, 0.00, 0.00
+
+</pre>
+        </td></tr></table></center>
+
+</BODY>
+</HTML>
+"
+
+ +A bit more evolved: + +
+RDNZL-USER 12 > (import-types "System" "Net.WebException")
+NIL
+RDNZL-USER 13 > (use-namespace "System.Net")
+RDNZL-USER 14 > (defun download-url (url)
+                  (rdnzl-handler-case
+                     (let ((web-client (new "WebClient")))
+                       [GetString (new "System.Text.ASCIIEncoding")
+                                  [DownloadData web-client url]])
+                    ("WebException" (e)
+                      (warn "Ooops, probably a typo: ~A" [%Message e])
+                      nil)))
+DOWNLOAD-URL
+RDNZL-USER 15 > (download-url "http://nanook.aharta.de/")
+Warning: Ooops, probably a typo:
+         The underlying connection was closed: The remote name could not be resolved.
+NIL
+
+ +This'll also work with https URLs. +

+The last example +shows Microsoft Office +automation - it extracts values from an Excel spreadsheet. (You'll +obviously need to have a copy of Office on your machine if you want to +try this yourself.) + +

+RDNZL-USER 16 > (import-types "Microsoft.Office.Interop.Excel" "ApplicationClass" "WorkbookClass" "Worksheet")
+NIL
+
+RDNZL-USER 17 > (use-namespace "Microsoft.Office.Interop.Excel")
+
+RDNZL-USER 18 > (defconstant +missing+ [$System.Reflection.Missing.Value])
++MISSING+
+
+RDNZL-USER 19 > (defun get-excel-range (file-name range)
+                  (let* ((app (new "ApplicationClass"))
+                         (workbooks [%Workbooks app])
+                         (workbook (cast [Open workbooks file-name
+                                               +missing+ nil +missing+
+                                               +missing+ +missing+ +missing+
+                                               +missing+ +missing+ +missing+
+                                               +missing+ +missing+ +missing+
+                                               +missing+ +missing+]
+                                         "WorkbookClass"))
+                         (worksheets [%Worksheets workbook])
+                         (sheet (cast [get_Item worksheets 1] "Worksheet"))
+                         (range [get_Range sheet range +missing+]))
+                    (cast [%Value2 [%Cells range]] "System.Array")))
+GET-EXCEL-RANGE
+
+RDNZL-USER 20 > (defun convert-range-array-to-lists (range-array)
+                  (loop for row from 1 to [GetLength range-array 0]
+                        collect (loop for col from 1 to [GetLength range-array 1]
+                                      collect [ToString (aref* range-array row col)])))
+CONVERT-RANGE-ARRAY-TO-LISTS
+
+RDNZL-USER 21 > (defun range-contents (&key (range "A1:C4")
+                                            ;; see "examples" folder for a definition of PROMPT-FOR-FILE
+                                            (file-name (prompt-for-file "Select an Excel file")))
+                  (convert-range-array-to-lists
+                   (get-excel-range file-name range)))
+RANGE-CONTENTS
+
+RDNZL-USER 22 > (pprint
+                 (range-contents :file-name "c:\\home\\lisp\\RDNZL\\examples\\example.xls"))
+
+(("Last name" "First name" "Superhero")
+ ("Kent" "Clark" "Superman")
+ ("Wayne" "Bruce" "Batman")
+ ("Parker" "Peter" "Spiderman"))
+
+ +(This is an adapted version of a C# example from Michael Gold.) + +

+For a much cooler and more sophisticated example of what can be done +with RDNZL see Michael +Goffioul's Lisp +shell +(see ECL's +Sourceforge project page for binaries and source code). +

+See +also this +code by Richard +Fateman that displays some of the possibilities for using RDNZL +for a drop-down menu cascade showing Lisp trees or +these two examples +for DataGridViews by Matthew O'Connor. + +
 

Download and installation

+ +RDNZL together with this documentation can be downloaded from +http://weitz.de/files/rdnzl.tar.gz, the current version is 0.12.2. It +doesn't depend on any other Lisp libraries. The C++ source for the +shared library RDNZL.dll can be downloaded separately from +http://weitz.de/files/rdnzl-cpp.tar.gz (current version is 0.7.1), +but you don't need this archive to deploy RDNZL +- rdnzl.tar.gz already contains RDNZL.dll. +Note that the CVS +repository at common-lisp.net is usually not in sync with the current release +version! +

+Before you load RDNZL make sure you have the .NET framework installed. +Then move the file RDNZL.dll to a location where your Lisp's FFI will +find it - the folder where your Lisp executable is located is +generally a good place for that. +

+Now, to compile and load RDNZL just LOAD the file load.lisp - that's +all. (Or alternatively use ASDF if you like - RDNZL comes with a +system definition for ASDF.) +

+Oh, and - for the moment - don't +use SLIME together +with LispWorks when loading RDNZL - +see this +message for an explanation. + + +
 

Support and mailing lists

+ +For questions, bug reports, feature requests, improvements, or patches +please use the rdnzl-devel +mailing list. If you want to be notified about future releases, +subscribe to the rdnzl-announce +mailing list. These mailing lists and the CVS repository were made available thanks to +the services of common-lisp.net. +

+If you want to send patches, please read this first. + +
 

Supported Lisp implementations

+ +RDNZL is currently targeted at Microsoft Windows. There are other +implementations of the CLR runtime for other operating systems but to +port the "glue" library RDNZL.dll you'll need something similar to +Microsoft's "Managed C++" which can mix managed and unmanaged code. +I'll gladly accepts patches to make RDNZL work on other platforms. +

+The current status for the main Win32 Common Lisp implementations is +as follows: +

    +
  • Corman Common Lisp: Corman Lisp is fully supported thanks to the help of Roger Corman. + +
  • ECL: RDNZL has been ported to ECL by Michael Goffioul. + +
  • Franz AllegroCL: AllegroCL is fully supported thanks to the efforts of Charles A. Cox from Franz Inc. + +
  • GNU CLISP: RDNZL has been ported to CLISP by Vasilis Margioulas. However, the port currently has some GC issues - it only works for simple, non-callback cases. This is probably due to missing MP support. + +
  • LispWorks: LispWorks is fully supported. + +
  • SBCL: Experimental support for the "port in progress" of SBCL to Win32. Based on the 0.9.9 binary release. The APROPOS example doesn't work, most likely because SBCL/Win32 doesn't have MP yet. + +
+All implementation-specific parts of RDNZL are located in files called +port-acl.lisp, port-ccl.lisp, port-lw.lisp, and so on. If you want to port RDNZL to +another Lisp, it should suffice to just create the corresponding +port-xx.lisp file for your implementation. + + +
 

The RDNZL dictionary

+ +

Representation and creation of .NET objects

+ +.NET objects are represented as containers and are printed like this + +
+#<RDNZL::CONTAINER System.Object #xAE28E0>
+
+ +where System.Object is the name of the .NET type of this +object and #xAE28E0 is the hexadecimal representation of a C pointer +that won't change during the lifetime of this object. (Internally +containers are implemented as structures but this might change in +future versions so you shouldn't rely on it.) +

+Note that each container has a .NET type that can be manipulated +independently from its object - see CAST. +

+As long as a container is accessible in Lisp its underlying .NET +object won't be garbage-collected in the CLR. +

+Whenever a RDNZL function accepts .NET objects as arguments (except +for the first argument of INVOKE, PROPERTY, and FIELD) you can also +provide the corresponding "native" Lisp objects as long as they can be +converted to .NET objects by the function BOX. On the other hand, if +a RDNZL function returns a .NET object, it will be automatically +translated to a Lisp object by UNBOX if possible. If a RDNZL function +call doesn't return a result (i.e. if its return type is System.Void), +then the keyword :VOID is returned. If a NULL object is returned, +RDNZL returns NIL and T as a second return value because otherwise +there'd be no difference from returning a false boolean value. + + +


[Function] +
container-p object => generalized-boolean + +


+Returns true if object is a container, NIL otherwise. +
+ +


[Function] +
box object => container + +


+Converts Lisp objects to containers wrapping a +corresponding .NET object if possible, otherwise an error is +signaled. Currently the following conversions are implemented: + +

+ + + + + + + + + + +
Lisp type .NET type Remark
(signed-byte 32) System.Int32
(signed-byte 64) System.Int64 Only integers which aren't (SIGNED-BYTE 32).
character System.Char
string System.String
pathname System.String The namestring of the pathname is used.
double-float System.DoubleSee *COERCE-DOUBLE-FLOATS-TO-SINGLE*.
float System.Single Only floating point numbers which aren't DOUBLE-FLOAT.
boolean System.Boolean
+ +

+ + +


[Function] +
unbox container => object + +


+Converts .NET objects wrapped in a container to a corresponding Lisp +object if possible, otherwise container is returned ummodified. Currently the following conversions are implemented: +

+ + + + + + + + + +
.NET type Lisp type
System.Int32 integer
System.Int64 integer
System.Char character
System.String string
System.Double double-float
System.Single float
System.Boolean boolean
+

+ + +


[Function] +
new type &rest args => new-instance + +


+Creates and return a new instance of the .NET type type. Chooses the +constructor based on the signature determined by args. type can either +be a container representing a .NET type or a string naming the type. +

+If type is a delegate type, then there should be exactly one more +argument to NEW and it must be a Lisp closure with a corresponding +signature. This is how callbacks from .NET into Lisp are implemented. (See the second example above and look for KeyPressEventHandler.) +

+ + +


[Function] +
cast container type => container + +


Changes the type of the .NET object represented +by container to type (a string +naming the type, a tree of strings for generic types, or a container +representing the type). Returns container. +
+ +


[Function] +
copy-container container => container' + +


Creates and returns a copy of the .NET object represented +by container. Useful for keeping a reference to +the object with the original type preserved when +using CAST - see discussion here. +
+ + +


[Function] +
make-null-object type-name => container + +


+Returns a new NULL .NET object of the type named by the string type-name. +
+ + +


[Special variable] +
*coerce-double-floats-to-single* + +


If the value of this variable is true, +then BOX will convert a +Lisp DOUBLE-FLOAT +value to System.Single. This is mainly interesting for +LispWorks, where Lisp floats are always DOUBLE-FLOAT. +
+ + +

Accessing .NET methods, properties, and fields

+ +This section describes the "low-level" access to .NET class members. See the section about the special reader syntax for another approach. + +


[Function] +
invoke object method-name &rest other-args => result + +


+Invokes the public .NET method named by the string method-name. If object is a +container, then the method is supposed to be an instance method of this +object. If object is a string, then the method is supposed to be a +static method of the type named object which will be looked up using +System.Type::GetType. If object is a tree of strings, then the method +should be a static method of the generic type named object, with other-args +being the parameters of the type. Otherwise, object should be a pair +where the first element is a container representing an assembly and +the second element is a string (or a tree of strings) denoting a type +(possibly generic), for which method-name denotes a static method +(which will be looked up in that specific assembly). other-args (either +container structures or Lisp objects which can be +converted) are the arguments to this method. +
+ +


[Accessor] +
property object property-name &rest indexes => property-value +
(setf (property object &rest indexes) new-value) + +


+Gets or sets the public .NET property named by the string +property-name. If object is a container, an instance property is +accessed. If object is a string, the static property of the type named +by this string is accessed. +
+ +


[Accessor] +
field object field-name => field-value +
(setf (field object) new-value) + +


+Gets or sets the public .NET field named by the string field-name. If +object is a container, an instance field is accessed. If object is a +string, the static field of the type named by this string is accessed. +
+ +


[Function] +
ref object => container + +


+ +Makes a pass-by-reference type out of +object and returns object. If +object is not a container, +it'll be boxed first. This function makes only +sense if object is used as an argument to INVOKE! (And after INVOKE has been +called object will be reset to its underlying type so you have to +re-apply REF if you want to use it as a pass-by-reference argument in +another .NET call.) Note that while this is kind of tedious it +corresponds to the C# semantics. +

+Here's an example: If you have a .NET class defined like this (in C#) +

+public class Class1 {
+  public static void foo (ref int a) {
+    a++;
+  }
+}
+
+then you can do this (see below for the reader syntax) in Lisp +
+RDNZL-USER(16): (let ((a (box 41)))
+                  [Class1.foo (ref a)]
+                  (unbox a))
+42
+
+ +while the evaluation of [Class1.foo 41] (or [Class1.foo (box 41)] which is equivalent) will signal an error because the +method won't even be found - the signature of foo is (System.Int32&), not (System.Int32). +
+ +

Arrays and enumerations

+ +This section assembles some convenience functions for .NET arrays and +enumerations. + +


[Accessor] +
aref* array &rest subscripts => value +
(setf (aref* array &rest subscripts) new-value) + +


+Gets or sets the element of the .NET array array with the +subscripts subscripts. +
+ + +


[Macro] +
do-rdnzl-array (var array-form &optional result) &body body => value* + +


+array-form should be a form which evaluates to a container wrapping a +.NET array of rank 1. The body will be evaluated with var bound to +each element of this array in turn. Finally, the result of evaluating +the form result is returned. +
+ + +


[Function] +
list-to-rdnzl-array list &optional base-type => array + +


Creates and returns a .NET array of base +type base-type and rank 1 with the elements +from the Lisp +list list. base-type can be a +container representing a .NET type, a string naming the type, or a +tree of strings. The default for base-type is the +.NET root type System.Object. +
+ +


[Function] +
rdnzl-array-to-list array => list + +


+Converts a .NET array array of rank 1 to a Lisp list with the same +elements. +
+ + +


[Function] +
integer-to-enum number type => enum + +


+Converts the Lisp integer number to a .NET System.Enum object of +type type (a string naming the type or a container representing the type). +
+ + +


[Function] +
enum-to-integer enum => number + +


+Converts the .NET object enum of type System.Enum to a Lisp integer. This is a destructive operation on enum. +
+ +


[Function] +
or-enums &rest enums => enum + +


+Combines several .NET objects of type System.Enum with a bit-wise logical or +and returns the result. All arguments must be of the same .NET type +and there must be at least one argument. +
+ + +

Handling of .NET exceptions

+ +.NET exceptions are propagated to Lisp as described below. + +


[Condition type] +
rdnzl-error + +


+Exceptions raised during .NET calls are signaled in Lisp as errors of this type. +
+ +


[Function] +
rdnzl-error-exception condition => exception + +


+If condition is an error of type RDNZL-ERROR, then this function will +return the .NET exception object that was actually raised. +
+ +


[Macro] +
rdnzl-handler-case form &rest clauses => result* + +


+Like HANDLER-CASE +but only for conditions of type RDNZL-ERROR. The typespecs are +either strings (naming a .NET error type) or of the form (OR string-1 ... string-n). A :NO-ERROR clause is also allowed. +
+ +

Type names and assemblies

+ +Whenever a RDNZL function accepts a string as a type name you usually +have to provide the full assembly-qualified name of that type (with +the exception of types in mscorlib.dll), i.e. something like + +
+"System.Windows.Forms.Button, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089"
+
+ +This is boring and error-prone, so RDNZL provides two ways to make it +easier for you: You can import types and you can use namespaces. +

+If you import a type, RDNZL internally remembers its assembly-qualified +name and you can now use its full name (like +"System.Windows.Forms.Button") instead. +

+If this is still too long for you, you can use namespaces to further +abbreviate type names. So, if you are using the namespace +"System.Windows.Forms", you can just call the type "Button". Note that +this'll only work for imported types, though. + +


[Function] +
import-type type &optional assembly => type' + +


+Imports the .NET type type, i.e. registers its name as one that can be +abbreviated (see USE-NAMESPACE) and creates a mapping from its short +name to its assembly-qualified name (if necessary). If type is a +string and assembly is NIL, then the function will try to create the +type from the string with the static .NET method System.Type::GetType. +If type is a string and assembly is a container representing an +assembly, then instead the .NET instance method +System.Reflection.Assembly::GetType will be used. If type is already +a .NET object (i.e. a container), then the function will just register +its name. If assembly is a true value, then the name will also be +mapped to its assembly-qualified name. In all cases the type itself +(as a container) will be returned. +
+ + +


[Function] +
load-assembly name => assembly + +


+Loads and returns the assembly with the name name (a string), uses the +static .NET method System.Reflection.Assembly::LoadWithPartialName +internally. +
+ + +


[Function] +
import-assembly assembly => assembly' + +


+Imports all public types of the assembly assembly (a string or a +container). If assembly is a string, then the assembly is first loaded +with LOAD-ASSEMBLY. Returns assembly as a container. +
+ + +


[Function] +
import-types assembly-name &rest type-names => NIL + +


+This is a shortcut. It loads the assembly named by the string assembly-name and +imports all types listed from this assembly. The assembly name is +prepended to the type names before importing them. All arguments +should be strings. +
+ + +


[Function] +
use-namespace namespace => | + +


+Adds the .NET namespace namespace +(a string) to the list of namespaces that will be prefixed when trying +to resolve a type name. After calling this function +namespace will be the first entry in this list +unless it has already been there. namespace must +not end with a dot because a dot will be prepended automatically. +
+ +


[Function] +
unuse-namespace namespace => | + +


+Removes the .NET namespace namespace (a string) from the list of +namespaces that will be prefixed when trying to resolve a type name. +
+ +


[Function] +
unuse-all-namespaces => | + +


+Removes all entries from the list of namespaces that will be prefixed +when trying to resolve a type name. +
+ + +

Special reader syntax

+ +In order to make entering .NET forms easier RDNZL provides a modified +read syntax which consists of two parts. +

+First, the left and right bracket characters are modified to be +terminating macro characters. A form like + +

+[IsSubclassOf type other-type]
+
+ +is read as follows: Directly following the left bracket should be a +symbol (IsSubclassOf in this example) which is read as if the standard +readtable was used (except for the special role of the brackets) but +with case preserved. The rest (type other-type in this case) is read +up to the closing bracket by READ-DELIMITED-LIST. This results in a call +to INVOKE like this: +
+(invoke type "IsSubclassOf" other-type)
+
+If the symbol starts with a percent or dollar, sign then it is removed +and the result is a call to PROPERTY or FIELD respectively: + +
+[%IsInterface type]  =>  (property type "IsInterface")
+[$textBox control]  =>  (field control "textBox")
+
+ +If the symbol contains a dot, then in all three cases this'll result in +a static invocation where the part before the (last) dot is used as the name +of the type: + +
+[System.Environment.Exit]  => (invoke "System.Environment" "Exit")
+[%System.Environment.UserName]  =>  (property "System.Environment" "UserName")
+[$OpCodes.Switch]  =>  (field "Opcodes" "Switch")
+
+ +If the symbol starts with a plus or minus sign, then this sign is replaced +with "add_" or "remove_" respectively. This is the convention used to +add or remove event handlers: + +
+[+KeyPress text-box (new "KeyPressEventHandler" #'reply)] => (invoke text-box "add_KeyPress" (new "KeyPressEventHandler" #'reply))
+
+ +The second syntax change is the addition of a new dispatch character +to the # (sharpsign) reader macro, namely ` (backquote). This is +intended to be used similarly to #' but with the syntax described +above, i.e. you can write things like + +
+(mapcar #`%CanFocus list-of-forms)
+(apply #`GetMethod method-info other-args)
+(funcall #`(setf $textBox) new-text-box control)
+
+ +Note that this dispatch character also recognizes function names of +the form (SETF symbol). +The RDNZL source code contains more examples of using this modified +syntax. +

+Read Tim Bradshaw's article + about the implications +of a reader syntax as described above. + + +


[Macro] +
enable-rdnzl-syntax => | + +


+Enables RDNZL reader syntax. After loading RDNZL this reader syntax is by default not enabled. +
+ +


[Macro] +
disable-rdnzl-syntax => | + +


+Restores the readtable which was active before the last call to +ENABLE-RDNZL-SYNTAX. If there was no such call, the standard readtable +is used. +
+ +

Direct calls

+ +Usually, each time you call into .NET via INVOKE, PROPERTY, or FIELD RDNZL will have to search for the +corresponding .NET member via reflection. This can be avoided by +defining direct calls via DEFINE-RDNZL-CALL. For example, instead of calling +
+(invoke "System.Math" "Max" 3.5 3.6)
+
+you'd first define a function DOTNET-MAX like this +
+(define-rdnzl-call dotnet-max
+    (:dotnet-name "Max"
+     :type-name "System.Math")
+  ((x "System.Double")
+   (y "System.Double")))
+
+and then call it as if it were a normal Lisp function (no need for the pesky reader syntax): +
+(dotnet-max 3.5 3.6)
+
+Experiments with AllegroCL and LispWorks show that in the example above you'll safe about half the execution time and half the consing if you use a direct call instead of INVOKE. (It's still faster to call MAX, though... :) +

+The file examples/apropos2.lisp shows how you'd code the APROPOS example with direct calls. + +


[Macro] +
define-rdnzl-call lisp-name (&key member-kind dotnet-name type-name doc-string) args => lisp-name + +


+Defines a Lisp function named by the function name lisp-name which invokes the .NET member named by the string dotnet-name. member-kind must be one of the keywords :METHOD, :PROPERTY, or :FIELD and obviously determines whether a method, a property, or a field is to be invoked - the default is :METHOD. If type-name is NIL (which is the default), an instance member is invoked, otherwise type-name should be a string naming a .NET type and a static member of this type is invoked instead. doc-string, if provided, should be a string, namely the documentation string for the Lisp function which is created. If doc-string is NIL (which is the default), a generic documentation string will be created. +

+If dotnet-name is NIL (which is the default), then the name of the .NET member will be created from lisp-name be the following rules: +Take the symbol name of lisp-name and if it does not consist solely of hyphens and single-case letters, just return it. Otherwise remove the hyphens and downcase all letters except for the first one and those that follow a hyphen - these are upcased. If lisp-name is a list (SETF symbol), then we use symbol instead of lisp-name. Here are some examples (note that the package doesn't matter): +

+ + + + + + +
lisp-name dotnet-name
|Foo| "Foo"
FOO "Foo"
HELP-ME "HelpMe"
(SETF TEXT-BOX) "TextBox"
+ +

+Finally, args describes the arguments to the +newly-created function. It is a list of pairs +(ARG-NAME TYPE-NAME) where ARG-NAME is +a symbol naming the argument and TYPE-NAME is a string +naming the .NET type of the argument. Note that for instance members +the type of the first argument is the .NET type the member belongs to +- this is not the case for static members. +

+For properties and fields, lisp-name can also be a +list (SETF symbol) in which case a setter function +for the corresponding property or field is generated. Note that the +parameter for the new value is not part of the signature described by args. +

+Note: Currently (version 0.6.0) there are some issues with direct +calls and Corman Lisp, so you shouldn't use DEFINE-RDNZL-CALL with CCL +(or you could help fixing these problems). + +

+ +

Saving images and application delivery

+ +It is possible to save images with RDNZL loaded or to deliver RDNZL +executables. However, you have to watch out for certain things: Make +sure that no references to .NET objects remain in the image and +finally call SHUTDOWN-RDNZL prior to saving or delivering. +

+If you restart the image or start the executable, make sure to call +INIT-RDNZL before accessing any RDNZL functionality. That should do +the trick. +

+The examples directory of the RDNZL distribution contains sample +delivery files for AllegroCL, Corman Lisp, and LispWorks to demonstrate this. + +


[Function] +
shutdown-rdnzl &optional no-gc => | + +


+Prepares RDNZL for delivery or image saving. After calling this +function RDNZL can't be used anymore unless INIT-RDNZL is called +again. If no-gc is NIL (the default), a full garbage collection is +also performed. +
+ + +


[Function] +
init-rdnzl => | + +


+Initializes RDNZL. This function must be called once before RDNZL is +used. It is automatically called when you load RDNZL. +
+ +
 

Generic types

+ +In summary, refer to a generic type with type arguments filled with a +list of type names like + +
+("System.Collections.Generic.List" "System.Int32")
+
+ +

Motivation

+ +The name of a generic type, when 'closed' with type arguments so it is +instantiable, is of the form + +
+Basetype?arity[ParameterType1, ..., ParameterTypeN]
+
+ +and type names of this form can in general be used in all contexts +like the argument to NEW and so forth. +However, for this type to be found, all the parameter types must +either lie in the same assembly as the base type or their names must +be assembly-qualified. Furthermore, the full 'path' to each type +would have to be specified even if their namespaces had been imported +with USE-NAMESPACE making +this a bit unpractical. +

+To solve this, all functions that accept a string as a typename +argument will also accept a list of typenames (including sublists for +when type arguments are themselves generic types) where these lists +represent generic types with their parameters. Also, since the length +of the list is enough to determine the arity of the type, the +?arity-part of the type-name can be dropped. Each +type name element of the list will have its name resolved in the +imported namespaces. +

+The upshot is that one can instantiate the type with full name +

+System.Func`2[[System.Int32, mscorlib, Version=2.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089],
+              [System.Int32, mscorlib, Version=2.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089]],
+System.Core, Version=3.5.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089
+
+using +
+(import-assembly "mscorlib")    ; Int32 lives here
+(import-assembly "System.Core") ; Func (of diverse arities) lives here
+(use-namespace "System")
+(new '("Func" "Int32" "Int32") #'1+)
+
+ +
 

Implementation details and things to watch out for

+ +The first implementation of RDNZL (which I demoed in Amsterdam) used +the MOP to map .NET types to CLOS classes. I have removed this code +in favor of a simpler approach because using the MOP results in a lot +of overhead at runtime and doesn't work well with application +delivery. In fact, a lot of the design decisions in RDNZL are based on the +fact that I want to be able to easily deliver small executables. If it were just for speed and/or convenience, RDNZL would look differently. +

+If you're concerned about speed, keep in mind that calls into .NET are +expensive because a lot of marshalling of arguments is happening +behind the scenes and the system deploys the .NET reflection API at +runtime. It is advisable to keep interaction between .NET and Lisp out +of tight loops, i.e. to implement such loops either fully in Lisp or +fully in .NET. +

+If you want to know more about the way methods are +looked up in RDNZL, read Pedro Pinto's paper +about the implementation of Dot-Scheme the basics of which apply to +RDNZL as well. +

+The garbage collectors of Lisp and .NET should generally be able to +co-exist without problems. However, with delegates there's a potential +problem. Consider this example (from Pedro Pinto): +

+(let ((button (new "System.Windows.Form.Button")))
+  [+Click button (new "System.EventHandler"
+                    (lambda (sender event-args)
+                      (declare (ignore sender event-args))
+                      (setf [%Text button] "Clicked!")))])
+
+Now, RDNZL keeps a reference to BUTTON which is closed over by the +event-handler defined above and thus the .NET garbage collector won't +be able to get rid of the button. As a result it can't release the +event handlers of this button either and thus the Lisp garbage +collector won't be notified that the closure is no longer +used. Currently, the only way to avoid these problems with cyclic +references is: "So don't do that!" +

+If .NET calls back into Lisp from a "foreign" thread (one that wasn't +created by Lisp), this'll not work in some implementations. +Specifically, as +Dominic Robinson has pointed out, there might be GC issues in this +case. +See here +and here +for possible workarounds for LispWorks 4.4.x (not needed for LispWorks 5.0 and higher). +

+About the name: It was pretty clear to me from the beginning that the +name of the library should be "RDNZL." +However, I'm not sure what this acronym exactly stands for. Surely, "L" is +for "Lisp" and "DN" is for "DotNet". The rest? You'll figure it out... :) + +
 

Acknowledgements

+ +RDNZL owes very much to Pedro Pinto's Dot-Scheme project, especially +as far as the C++ part is concerned. In fact, I couldn't have written +RDNZL without studying (and partly copying) the Dot-Scheme +implementation. Pedro was also very helpful during the development of +RDNZL and answered a couple of dumb questions of mine. Thank you very +much! (All errors in RDNZL are mine, of course.) +

+Thanks to Charles A. Cox for the port of RDNZL to AllegroCL. Thanks to +Vasilis Margioulas for the CLISP port. Thanks to Roger Corman for his +help with the CCL port. Thanks to Michael Goffioul for the ECL port. +Thanks to Franz Inc. (and particularly Jans Aasman) for supporting the +development of RDNZL. Thanks to Iver Odin Kvello for numerous fixes +and additions. +

+$Header: /usr/local/cvsrep/rdnzl/doc/index.html,v 1.102 2008/03/25 17:06:25 edi Exp $ +

BACK TO MY HOMEPAGE + + + + Added: trunk/rdnzl/examples/AproposGui.cs ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/AproposGui.cs Wed Apr 30 04:28:03 2008 @@ -0,0 +1,107 @@ +// $Header: /usr/local/cvsrep/rdnzl/examples/AproposGui.cs,v 1.10 2008/02/14 11:38:49 edi Exp $ + +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: + +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. + +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. + +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +// compile this with: +// csc.exe /target:library AproposGui.cs +// and put the resulting DLL into your Lisp's application folder + +using System; +using System.Collections; +using System.ComponentModel; +using System.Drawing; +using System.Data; +using System.Windows.Forms; + +namespace AproposGUI { + public class AproposControl : System.Windows.Forms.UserControl { + public System.Windows.Forms.TextBox textBox; + public System.Windows.Forms.TextBox listBox; + private System.Windows.Forms.Label label; + public System.Windows.Forms.Label title; + + private System.ComponentModel.Container components = null; + + public AproposControl() { + InitializeComponent(); + } + + protected override void Dispose(bool disposing) { + if (disposing) { + if (components != null) + components.Dispose(); + } + base.Dispose(disposing); + } + + private void InitializeComponent() { + this.textBox = new System.Windows.Forms.TextBox(); + this.listBox = new System.Windows.Forms.TextBox(); + this.label = new System.Windows.Forms.Label(); + this.title = new System.Windows.Forms.Label(); + this.SuspendLayout(); + + this.textBox.Location = new System.Drawing.Point(16, 344); + this.textBox.Name = "textBox"; + this.textBox.Size = new System.Drawing.Size(584, 20); + this.textBox.TabIndex = 0; + this.textBox.Text = ""; + + this.listBox.Location = new System.Drawing.Point(16, 56); + this.listBox.Multiline = true; + this.listBox.Name = "listBox"; + this.listBox.ReadOnly = true; + this.listBox.ScrollBars = System.Windows.Forms.ScrollBars.Vertical; + this.listBox.Size = new System.Drawing.Size(584, 248); + this.listBox.TabIndex = 1; + this.listBox.Text = ""; + + this.label.Location = new System.Drawing.Point(24, 312); + this.label.Name = "label"; + this.label.Size = new System.Drawing.Size(576, 23); + this.label.TabIndex = 2; + this.label.Text = "Enter text below and press RETURN"; + this.label.TextAlign = System.Drawing.ContentAlignment.MiddleCenter; + + this.title.Font = new System.Drawing.Font("Microsoft Sans Serif", 12F, System.Drawing.FontStyle.Bold, System.Drawing.GraphicsUnit.Point, ((System.Byte)(0))); + this.title.Location = new System.Drawing.Point(24, 16); + this.title.Name = "title"; + this.title.Size = new System.Drawing.Size(568, 24); + this.title.TabIndex = 3; + this.title.Text = "RDNZL Apropos Demo"; + this.title.TextAlign = System.Drawing.ContentAlignment.MiddleCenter; + + this.Controls.Add(this.title); + this.Controls.Add(this.label); + this.Controls.Add(this.listBox); + this.Controls.Add(this.textBox); + this.Name = "MainControl"; + this.Size = new System.Drawing.Size(616, 384); + this.ResumeLayout(false); + } + } +} Added: trunk/rdnzl/examples/AproposGui.dll ============================================================================== Binary file. No diff available. Added: trunk/rdnzl/examples/Callback.cs ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/Callback.cs Wed Apr 30 04:28:03 2008 @@ -0,0 +1,38 @@ +// $Header: /usr/local/cvsrep/rdnzl/examples/Callback.cs,v 1.1 2008/02/14 11:38:49 edi Exp $ + +// Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. + +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: + +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. + +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. + +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +// compile this with: +// csc.exe /target:library Callback.cs +// and put the resulting DLL into your Lisp's application folder + +using System; + +namespace Callback { + public delegate Int32 int32Callback (String input); + public delegate String stringCallback (Int32 input); +} Added: trunk/rdnzl/examples/Callback.dll ============================================================================== Binary file. No diff available. Added: trunk/rdnzl/examples/apropos.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/apropos.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,88 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/apropos.lisp,v 1.12 2008/02/14 11:38:49 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :rdnzl-user) + +(enable-rdnzl-syntax) + +(import-types "System.Windows.Forms" + "Application" "DockStyle" "Form" "MessageBox" "KeyPressEventHandler" "TextBox") + +(import-types "AproposGUI" + "AproposControl") + +(use-namespace "System.Windows.Forms") +(use-namespace "AproposGUI") + +(defun copy-to-clipboard (text-box) + (let ((selection-start [%SelectionStart text-box]) + (selection-length [%SelectionLength text-box]) + (text-length [%Length (box [%Text text-box])])) + (setf [%SelectionStart text-box] 0 + [%SelectionLength text-box] text-length) + [Copy text-box] + (setf [%SelectionStart text-box] selection-start + [%SelectionLength text-box] selection-length))) + +(let (message-shown) + (defun fill-list-box (object event) + (when (char= [%KeyChar event] #\Return) + (cast object "TextBox") + (let* ((input-string [%Text object]) + (input-length (length input-string))) + (when (plusp input-length) + (let ((apropos-text + (with-output-to-string (*standard-output*) + (apropos input-string))) + (list-box [$listBox (cast [%Parent object] "AproposControl")])) + #+(or :cormanlisp :ecl) (setq apropos-text (lf-to-crlf apropos-text)) + (setf [%Text list-box] apropos-text) + (copy-to-clipboard list-box) + (unless message-shown + [MessageBox.Show "The output of APROPOS has been copied to the clipboard." + "RDNZL"] + (setq message-shown t))) + (setf [%SelectionStart object] 0 + [%SelectionLength object] input-length)))))) + +(defun run-apropos-form () + (let* ((control (new "AproposControl")) + (form (new "Form"))) + (setf [%Dock control] [$DockStyle.Fill] + [%ClientSize form] [%ClientSize control] + [%Text form] "RDNZL Apropos Demo" + [%Text [$title control]] + (format nil "RDNZL Apropos Demo (~A)" + (lisp-implementation-type))) + [+KeyPress [$textBox control] + (new "KeyPressEventHandler" #'fill-list-box)] + [Add [%Controls form] control] + [Application.Run form])) + +(disable-rdnzl-syntax) \ No newline at end of file Added: trunk/rdnzl/examples/apropos2.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/apropos2.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,199 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/apropos2.lisp,v 1.10 2008/01/26 22:28:35 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; same as apropos.lisp but using "direct calls" + +(in-package :rdnzl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; wrapped in EVAL-WHEN because these must be available when the + ;; direct calls are defined + (import-types "System.Windows.Forms" + "Application" "Control" "Control+ControlCollection" "DockStyle" "Form" + "MessageBox" "KeyPressEventArgs" "KeyPressEventHandler" "TextBox") + + (import-types "AproposGUI" + "AproposControl") + + (use-namespace "System.Windows.Forms") + (use-namespace "AproposGUI")) + +;; an instance property +(define-rdnzl-call controls + (:member-kind :property) + ((control "Control"))) + +;; we can't use the standard name here because LENGTH is an external +;; symbol of the COMMON-LISP package +(define-rdnzl-call string-length + (:member-kind :property + :dotnet-name "Length") + ((string "System.String"))) + +(define-rdnzl-call text + (:member-kind :property) + ((control "Control"))) + +;; a setter function for an instance property +(define-rdnzl-call (setf text) + (:member-kind :property) + ((control "Control"))) + +(define-rdnzl-call (setf dock) + (:member-kind :property) + ((control "Control"))) + +(define-rdnzl-call client-size + (:member-kind :property) + ((control "Control"))) + +(define-rdnzl-call (setf client-size) + (:member-kind :property) + ((control "Control"))) + +(define-rdnzl-call selection-start + (:member-kind :property) + ((text-box "TextBox"))) + +(define-rdnzl-call (setf selection-start) + (:member-kind :property) + ((text-box "TextBox"))) + +(define-rdnzl-call selection-length + (:member-kind :property) + ((text-box "TextBox"))) + +(define-rdnzl-call (setf selection-length) + (:member-kind :property) + ((text-box "TextBox"))) + +(define-rdnzl-call parent + (:member-kind :property) + ((string "TextBox"))) + +;; an instance method +(define-rdnzl-call copy + () + ((text-box "TextBox"))) + +(define-rdnzl-call key-char + (:member-kind :property) + ((event "KeyPressEventArgs"))) + +;; an instance field (which should have been called "Title" instead of +;; "title") +(define-rdnzl-call title + (:member-kind :field + :dotnet-name "title") + ((control "AproposControl"))) + +(define-rdnzl-call list-box + (:member-kind :field + :dotnet-name "listBox") + ((control "AproposControl"))) + +(define-rdnzl-call text-box + (:member-kind :field + :dotnet-name "textBox") + ((control "AproposControl"))) + +(define-rdnzl-call add + () + ((collection "Control+ControlCollection") + (control "Control"))) + +;; a static method of the .NET type MessageBox +(define-rdnzl-call show + (:type-name "MessageBox") + ((text "System.String") + (caption "System.String"))) + +(define-rdnzl-call run-form + (:type-name "Application" + ;; renamed because deliver-xx.lisp already contains a RUN + ;; function + :dotnet-name "Run") + ((form "Form"))) + +;; a static field of the .NET type DockStyle (which is an enumeration) +(define-rdnzl-call dock-style/fill + (:member-kind :field + :dotnet-name "Fill" + :type-name "DockStyle") + ()) + +(define-rdnzl-call add-key-press + (:dotnet-name "add_KeyPress") + ((text-box "TextBox") + (handler "KeyPressEventHandler"))) + +(defun copy-to-clipboard (text-box) + (let ((selection-start (selection-start text-box)) + (selection-length (selection-length text-box)) + (text-length (string-length (box (text text-box))))) + (setf (selection-start text-box) 0 + (selection-length text-box) text-length) + (copy text-box) + (setf (selection-start text-box) selection-start + (selection-length text-box) selection-length))) + +(let (message-shown) + (defun fill-list-box (object event) + (when (char= (key-char event) #\Return) + (cast object "TextBox") + (let* ((input-string (text object)) + (input-length (length input-string))) + (when (plusp input-length) + (let ((apropos-text + (with-output-to-string (*standard-output*) + (apropos input-string))) + (list-box (list-box (cast (parent object) "AproposControl")))) + #+(or :cormanlisp :ecl) (setq apropos-text (lf-to-crlf apropos-text)) + (setf (text list-box) apropos-text) + (copy-to-clipboard list-box) + (unless message-shown + (show "The output of APROPOS has been copied to the clipboard." + "RDNZL") + (setq message-shown t))) + (setf (selection-start object) 0 + (selection-length object) input-length)))))) + +(defun run-apropos-form () + (let* ((control (new "AproposControl")) + (form (new "Form"))) + (setf (dock control) (dock-style/fill) + (client-size form) (client-size control) + (text form) "RDNZL Apropos Demo" + (text (title control)) + (format nil "RDNZL Apropos Demo (~A)" + (lisp-implementation-type))) + (add-key-press (text-box control) + (new "KeyPressEventHandler" #'fill-list-box)) + (add (controls form) control) + (run-form form))) \ No newline at end of file Added: trunk/rdnzl/examples/callback.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/callback.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,49 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/callback.lisp,v 1.9 2008/02/14 11:38:49 edi Exp $ + +;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; this is a simple test for callbacks - see + +(in-package :rdnzl-user) + +(enable-rdnzl-syntax) + +(import-types "Callback" + "int32Callback" "stringCallback") + +(use-namespace "Callback") + +(defun test-int32-callback (string) + (let ((callback (new "int32Callback" (lambda (string) (length string))))) + (invoke callback "Invoke" string))) + +(defun test-string-callback (int) + (let ((callback (new "stringCallback" (lambda (int) (format nil "~R" int))))) + (invoke callback "Invoke" int))) + +(disable-rdnzl-syntax) \ No newline at end of file Added: trunk/rdnzl/examples/deliver-acl.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/deliver-acl.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,70 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/deliver-acl.lisp,v 1.8 2008/01/26 22:28:35 edi Exp $ + +;;; Copyright (c) 2004-2008, Charles A. Cox. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Example: How to deliver a RDNZL application with AllegroCL + +(in-package :cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :res)) + +(defparameter *rdnzl-directory* + ;; assume this file is in examples/ subdirectory + (merge-pathnames #p".." + (make-pathname :name nil + :type nil + :version nil + :defaults *load-truename*))) + +;; make sure RDNZL is loaded so that we can compile apropos.lisp +;; (better to use provide/require for this?) +(unless (find-package ':rdnzl) + (load (merge-pathnames #p"load.lisp" *rdnzl-directory*))) + +(let ((*default-pathname-defaults* *rdnzl-directory*)) + (generate-application + "apropos" ; application name + (merge-pathnames #p"examples/apropos/") ; application directory + ;; list of files to load in the image being built + (list (merge-pathnames #p"load.lisp") + (merge-pathnames (compile-file #p"examples/apropos.lisp"))) + ;; extra files used at runtime + :application-files (list (merge-pathnames #p"rdnzl.dll") + (merge-pathnames #p"examples/AproposGui.dll")) + :discard-compiler t + :allow-existing-directory t + :post-load-form '(rdnzl:shutdown-rdnzl) + :restart-app-function '(lambda () + (rdnzl:init-rdnzl) + (rdnzl-user::run-apropos-form) + (exit))) + + (win:set-default-command-line-arguments #p"examples/apropos/apropos.exe" + ;; suppress console + '("+c"))) Added: trunk/rdnzl/examples/deliver-ccl.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/deliver-ccl.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,83 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/deliver-ccl.lisp,v 1.9 2008/01/26 22:28:35 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Example: How to deliver a RDNZL application with Corman Common Lisp + +;;; Usage: Start clconsole.exe and from there +;;; (LOAD "/path/to/RDNZL/examples/deliver-ccl.lisp") + +(in-package :cl-user) + +(defun copy-file (from to) + (let ((element-type '(unsigned-byte 8))) + (with-open-file (in from + :element-type element-type) + (with-open-file (out to + :direction :output + :if-exists :supersede + :element-type element-type) + (loop for byte = (read-byte in nil nil) + while byte + do (write-byte byte out)))))) + +(defparameter *rdnzl-directory* + ;; assume this file is in examples/ subdirectory + (make-pathname :name nil + :type nil + :version nil + :directory (butlast (pathname-directory *load-truename*)) + :defaults *load-truename*)) + +(setf (ccl:current-directory) *rdnzl-directory*) + +(load "load.lisp") +(load "examples/apropos.lisp") + +(defun main () + (rdnzl:init-rdnzl) + (rdnzl-user::run-apropos-form) + (shutdown-rdnzl)) + +(rdnzl:shutdown-rdnzl) + +(let ((target-dir + (merge-pathnames "examples/apropos/" *rdnzl-directory*))) + (defun target-path (file-name) + (merge-pathnames file-name target-dir))) + +(copy-file "RDNZL.dll" (ensure-directories-exist + (target-path "RDNZL.dll"))) +(copy-file "examples/AproposGUI.dll" (target-path "AproposGUI.dll")) +(copy-file (concatenate 'string ccl:*cormanlisp-server-directory* "\\msvcr70.dll") + (target-path "msvcr70.dll")) + +(ccl:save-application (namestring (target-path "apropos.exe")) + #'main + :console nil + :static t) \ No newline at end of file Added: trunk/rdnzl/examples/deliver-lw.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/deliver-lw.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,97 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/deliver-lw.lisp,v 1.10 2008/01/26 22:28:36 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Example: How to deliver a RDNZL application with LispWorks + +;;; Usage: Open up a console window and execute somthing like this: +;;; "C:\Program Files\LispWorks\lispworks-4450.exe" -init "C:\path\to\RDNZL\examples\deliver-lw.lisp" + +(in-package :cl-user) + +(defun copy-file (from to) + (let ((element-type '(unsigned-byte 8)) + (buffer-size 8192)) + (with-open-file (in from + :element-type element-type) + (with-open-file (out to + :direction :output + :if-exists :supersede + :element-type element-type) + (let ((buf (make-array buffer-size + :element-type element-type))) + (loop + (let ((pos (read-sequence buf in))) + (when (zerop pos) (return)) + (write-sequence buf out :end pos)))))))) +(compile 'copy-file) + +(defparameter *rdnzl-directory* + ;; assume this file is in examples/ subdirectory + (merge-pathnames #p".." + (make-pathname :name nil + :type nil + :version nil + :defaults *load-truename*))) + +(hcl:change-directory *rdnzl-directory*) +(load "load.lisp") +(load (compile-file "examples/apropos.lisp")) + +(defun run () + (rdnzl:init-rdnzl) + (rdnzl-user::run-apropos-form) + 0) +(compile 'run) + +(rdnzl:shutdown-rdnzl) + +(defparameter *target-directory* + (merge-pathnames "examples/apropos/" *rdnzl-directory*)) + +(defun target-path (file-name) + (merge-pathnames file-name *target-directory*)) +(compile 'target-path) + +(copy-file "RDNZL.dll" (ensure-directories-exist + (target-path "RDNZL.dll"))) +(copy-file "examples/AproposGUI.dll" (target-path "AproposGUI.dll")) + +(hcl:change-directory *target-directory*) + +(lw:deliver #'run "apropos" + ;; we could use 5 here but then APROPOS wouldn't make much + ;; sense... :) + 4 + :compact t + :redefine-compiler-p nil + :keep-symbol-names '(rdnzl::LispCallback rdnzl::ReleaseDelegateAdapter) + :keep-lisp-reader t + :console :input) + +(quit) \ No newline at end of file Added: trunk/rdnzl/examples/example.xls ============================================================================== Binary file. No diff available. Added: trunk/rdnzl/examples/excel.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/excel.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,104 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/excel.lisp,v 1.6 2008/01/26 22:28:36 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; This example is an adapted version of the code found at +;;; . +;;; It was tested with Microsoft Office 2003. + +;;; Note: LOAD this file, before you COMPILE-FILE it. + +(in-package :rdnzl-user) + +(enable-rdnzl-syntax) + +(import-types "System.Windows.Forms" "DialogResult" "OpenFileDialog") +(import-types "Microsoft.Office.Interop.Excel" "ApplicationClass" "WorkbookClass" "Worksheet") + +(use-namespace "Microsoft.Office.Interop.Excel") +(use-namespace "System.Windows.Forms") + +(defvar *this-file* (load-time-value + (or #.*compile-file-pathname* *load-pathname*)) + "The pathname of the file \(`test.lisp') where this variable was +defined.") + +(defconstant +missing+ [$System.Reflection.Missing.Value] + "Represents missing arguments.") + +(defconstant +dialog-ok+ [$DialogResult.OK] + "Returned by `OpenFileDialog' if the user confirmed the dialog.") + +(defconstant +initial-directory+ + (load-time-value + (namestring (make-pathname :name nil :type nil + :defaults *this-file*)))) + +(defconstant +initial-filename+ + (load-time-value + (namestring (make-pathname :name "example" :type "xls" + :defaults *this-file*)))) + +(defun prompt-for-file (title) + (let ((dialog (new "OpenFileDialog"))) + (setf [%InitialDirectory dialog] +initial-directory+ + [%Filter dialog] + "Microsoft Excel files (*.xls)|*.xls|All files (*.*)|*.*" + [%FileName dialog] + +initial-filename+ + [%Title dialog] title) + (and [Equals [ShowDialog dialog] +dialog-ok+] + [%FileName dialog]))) + +(defun get-excel-range (file-name range) + (let* ((app (new "ApplicationClass")) + (workbooks [%Workbooks app]) + (workbook (cast [Open workbooks file-name + +missing+ nil +missing+ + +missing+ +missing+ +missing+ + +missing+ +missing+ +missing+ + +missing+ +missing+ +missing+ + +missing+ +missing+] + "WorkbookClass")) + (worksheets [%Worksheets workbook]) + (sheet (cast [get_Item worksheets 1] "Worksheet")) + (range [get_Range sheet range +missing+])) + (prog1 (cast [%Value2 [%Cells range]] "System.Array") + [Quit app]))) + +(defun convert-range-array-to-lists (range-array) + (loop for row from 1 to [GetLength range-array 0] + collect (loop for col from 1 to [GetLength range-array 1] + collect [ToString (aref* range-array row col)]))) + +(defun range-contents (&key (file-name (prompt-for-file "Select an Excel file")) + (range "A1:C4")) + (convert-range-array-to-lists + (get-excel-range file-name range))) + +(disable-rdnzl-syntax) \ No newline at end of file Added: trunk/rdnzl/examples/messagebox.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/messagebox.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,45 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/messagebox.lisp,v 1.9 2008/01/26 22:28:36 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :rdnzl-user) + +(enable-rdnzl-syntax) + +(import-types "System.Windows.Forms" + "MessageBox" "MessageBoxButtons" "DialogResult") + +(use-namespace "System.Windows.Forms") + +(defun message-box (text &optional (caption "RDNZL")) + [Equals [MessageBox.Show text caption + ;; we want the message box to have "OK" and "Cancel" buttons + [$MessageBoxButtons.OKCancel]] + [$DialogResult.OK]]) + +(disable-rdnzl-syntax) Added: trunk/rdnzl/examples/url.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/examples/url.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,47 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/examples/url.lisp,v 1.10 2008/01/26 22:28:36 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :rdnzl-user) + +(enable-rdnzl-syntax) + +(import-types "System" "Net.WebClient" "Net.WebException") + +(use-namespace "System.Net") + +(defun download-url (url) + (rdnzl-handler-case + (let ((web-client (new "WebClient"))) + [GetString (new "System.Text.ASCIIEncoding") + [DownloadData web-client url]]) + ("WebException" (e) + (warn "Ooops, probably a typo: ~A" [%Message e]) + nil))) + +(disable-rdnzl-syntax) \ No newline at end of file Added: trunk/rdnzl/ffi.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/ffi.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,343 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/ffi.lisp,v 1.34 2008/01/26 22:28:30 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; FFI definitions for all functions exported by RDNZL.dll. See the +;;; C++ source code for details. + +(in-package :rdnzl) + +;; load the C++ library which interfaces with the CLR +(ffi-register-module "RDNZL.dll" :rdnzl) + +(defmacro ffi-define-function (c-name arg-list result-type) + "Like FFI-DEFINE-FUNCTION* but automatically creates the Lisp name +from the C name. A name like \"invokeMethod\" is mapped to +\"%INVOKE-METHOD\"." + `(ffi-define-function* (,(make-lisp-name c-name) + ,c-name) + ,arg-list + ,result-type)) + +(ffi-define-function "DllEnsureInit" + () + ffi-void) + +(ffi-define-function "DllForceTerm" + () + ffi-void) + +(defun dll-ensure-init () + "Wrapper for DllEnsureInit which makes sure the function is called +only once." + (unless *dll-initialized* + (%dll-ensure-init) + (setq *dll-initialized* t))) + +(defun dll-force-term () + "Wrapper for DllForceTerm which makes sure the function is only +called after DllEnsureInit has been called." + (when *dll-initialized* + (%dll-force-term) + (setq *dll-initialized* nil))) + +(ffi-define-function "invokeInstanceMember" + ((method-name ffi-const-string) + (target ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "invokeInstanceMemberDirectly" + ((method-info ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "invokeStaticMember" + ((method-name ffi-const-string) + (type ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "invokeStaticMemberDirectly" + ((method-info ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getInstanceFieldValue" + ((field-name ffi-const-string) + (target ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getStaticFieldValue" + ((field-name ffi-const-string) + (type ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setInstanceFieldValue" + ((field-name ffi-const-string) + (target ffi-void-pointer) + (new-value ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setStaticFieldValue" + ((field-name ffi-const-string) + (type ffi-void-pointer) + (new-value ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getInstanceFieldValueDirectly" + ((field-info ffi-void-pointer) + (target ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getStaticFieldValueDirectly" + ((field-info ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setInstanceFieldValueDirectly" + ((field-info ffi-void-pointer) + (target ffi-void-pointer) + (new-value ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setStaticFieldValueDirectly" + ((field-info ffi-void-pointer) + (new-value ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getInstancePropertyValue" + ((property-name ffi-const-string) + (target ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setInstancePropertyValue" + ((property-name ffi-const-string) + (target ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getStaticPropertyValue" + ((property-name ffi-const-string) + (type ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setStaticPropertyValue" + ((property-name ffi-const-string) + (type ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getInstancePropertyValueDirectly" + ((property-info ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setInstancePropertyValueDirectly" + ((property-info ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getStaticPropertyValueDirectly" + ((property-info ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setStaticPropertyValueDirectly" + ((property-info ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "refDotNetContainerType" + ((ptr ffi-void-pointer)) + ffi-void) + +(ffi-define-function "unrefDotNetContainerType" + ((ptr ffi-void-pointer)) + ffi-void) + +(ffi-define-function "freeDotNetContainer" + ((ptr ffi-void-pointer)) + ffi-void) + +(ffi-define-function "DotNetContainerIsNull" + ((ptr ffi-void-pointer)) + ffi-boolean) + +(ffi-define-function "makeTypedNullDotNetContainer" + ((ptr ffi-const-string)) + ffi-void-pointer) + +(ffi-define-function "InvocationResultIsVoid" + ((ptr ffi-void-pointer)) + ffi-boolean) + +(ffi-define-function "freeInvocationResult" + ((ptr ffi-void-pointer)) + ffi-void) + +(ffi-define-function "getDotNetContainerFromInvocationResult" + ((ptr ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getDotNetContainerTypeStringLength" + ((ptr ffi-void-pointer)) + ffi-integer) + +(ffi-define-function "getDotNetContainerTypeAsString" + ((ptr ffi-void-pointer) + (s ffi-void-pointer)) + ffi-void) + +(ffi-define-function "setDotNetContainerTypeFromString" + ((type ffi-const-string) + (ptr ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setDotNetContainerTypeFromContainer" + ((type ffi-void-pointer) + (ptr ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getDotNetContainerObjectStringLength" + ((ptr ffi-void-pointer)) + ffi-integer) + +(ffi-define-function "getDotNetContainerObjectAsString" + ((ptr ffi-void-pointer) + (s ffi-void-pointer)) + ffi-void) + +(ffi-define-function "getDotNetContainerIntValue" + ((ptr ffi-void-pointer)) + ffi-integer) + +(ffi-define-function "getDotNetContainerCharValue" + ((ptr ffi-void-pointer)) + ffi-wide-char) + +(ffi-define-function "getDotNetContainerBooleanValue" + ((ptr ffi-void-pointer)) + ffi-boolean) + +(ffi-define-function "getDotNetContainerDoubleValue" + ((ptr ffi-void-pointer)) + ffi-double) + +(ffi-define-function "getDotNetContainerSingleValue" + ((ptr ffi-void-pointer)) + ffi-float) + +(ffi-define-function "makeTypeFromName" + ((type ffi-const-string)) + ffi-void-pointer) + +(ffi-define-function "makeDotNetContainerFromChar" + ((c ffi-wide-char)) + ffi-void-pointer) + +(ffi-define-function "makeDotNetContainerFromString" + ((s ffi-const-string)) + ffi-void-pointer) + +(ffi-define-function "makeDotNetContainerFromBoolean" + ((b ffi-boolean)) + ffi-void-pointer) + +(ffi-define-function "makeDotNetContainerFromInt" + ((n ffi-integer)) + ffi-void-pointer) + +(ffi-define-function "makeDotNetContainerFromLong" + ((s ffi-const-string)) + ffi-void-pointer) + +(ffi-define-function "makeDotNetContainerFromFloat" + ((n ffi-float)) + ffi-void-pointer) + +(ffi-define-function "makeDotNetContainerFromDouble" + ((n ffi-double)) + ffi-void-pointer) + +(ffi-define-function "copyDotNetContainer" + ((ptr ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "getArrayElement" + ((ptr ffi-void-pointer) + (index ffi-integer)) + ffi-void-pointer) + +(ffi-define-function "InvocationResultIsException" + ((ptr ffi-void-pointer)) + ffi-boolean) + +(ffi-define-function "invokeConstructor" + ((type ffi-void-pointer) + (nargs ffi-integer) + (args ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-function "setFunctionPointers" + ((fp1 ffi-void-pointer) + (fp2 ffi-void-pointer)) + ffi-void) + +(ffi-define-function "buildDelegateType" + ((type-name ffi-const-string) + (return-type ffi-void-pointer) + (arg-types ffi-void-pointer)) + ffi-void-pointer) + +(ffi-define-callable + (LispCallback ffi-void-pointer) + ((index ffi-integer) + (args ffi-void-pointer)) + ;; here the actual callback, the Lisp closure, is called - see + ;; adapter.lisp + (funcall (gethash index *callback-hash*) args)) + +(ffi-define-callable + (ReleaseDelegateAdapter ffi-void) + ((index ffi-integer)) + ;; remove entry from hash table if CLR is done with it + (remhash index *callback-hash*)) Added: trunk/rdnzl/import.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/import.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,199 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/import.lisp,v 1.59 2008/02/14 10:33:51 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Importing types and assemblies, initialization. + +(in-package :rdnzl) + +(enable-rdnzl-syntax) + +(defun import-type (type &optional assembly) + "Imports the .NET type TYPE, i.e. registers its name as one that can +be abbreviated \(see USE-NAMESPACE) and maybe creates a mapping from +its short name to its assembly-qualified name. If TYPE is a string +and ASSEMBLY is NIL then the function will try to create the type from +the string with the static method System.Type::GetType. If TYPE is a +string and ASSEMBLY is an assembly \(a CONTAINER) then instead the +instance method System.Reflection.Assembly::GetType will be used. If +TYPE is already a .NET object \(i.e. a CONTAINER) then the function +will just register its name. If ASSEMBLY is a true value then the +name will also be mapped to its assembly-qualified name. In all cases +the type itself \(as a CONTAINER) will be returned." + (cond ((container-p type) + (setf (gethash [%FullName type] *type-hash*) + (cond (assembly [%AssemblyQualifiedName type]) + (t t))) + type) + ((stringp type) + (import-type (cond (assembly + (or [GetType assembly type] + (error "Type with name ~S not found in assembly ~S." + type [%FullName assembly]))) + (t + (let ((imported-type (make-type-from-name type))) + (when (%dot-net-container-is-null (pointer imported-type)) + (error "Type with name ~S not found." + type)) + imported-type))) + assembly)) + (t (error "Don't know how to import type ~S." type)))) + +(defun new (type &rest other-args) + "Creates a new .NET object \(a CONTAINER) of the type TYPE. Calls +the constructor determined by OTHER-ARGS \(a list of Lisp object +and/or CONTAINERs), i.e. by the corresponding signature. TYPE can be +a string \(naming the type) or a CONTAINER \(representing the type). +If TYPE is a delegate then the second argument to NEW must be a Lisp +closure with a correspoding signature." + (cond ((or (stringp type) + (consp type)) + (apply #'new + (make-type-from-name (resolve-type-name type)) + other-args)) + ((container-p type) + (cond ([IsAssignableFrom (make-type-from-name "System.Delegate") type] + ;; it's a delegate + (let* ((method-info [GetMethod type "Invoke"]) + (adapter (make-adapter (first other-args) + [%ReturnType method-info] + (mapcar #`%ParameterType + (rdnzl-array-to-list [GetParameters method-info]))))) + (invoke-constructor type + adapter + [GetFunctionPointer [%MethodHandle [GetMethod [GetType adapter] + "InvokeClosure"]]]))) + (t (apply #'invoke-constructor + type + other-args)))) + (t (error "Don't know how to make a new ~S." type)))) + +(defun load-assembly (name) + "Loads and returns the assembly with the name NAME \(a string), uses +LoadWithPartialName." + [System.Reflection.Assembly.LoadWithPartialName name]) + +(defun import-assembly (assembly) + "Imports all public types of the assembly ASSEMBLY \(a string or a +CONTAINER). If ASSEMBLY is a string then the assembly is first loaded +with LOAD-ASSEMBLY. Returns ASSEMBLY as a CONTAINER." + (cond ((container-p assembly) + (do-rdnzl-array (type [GetTypes assembly]) + (when [%IsPublic type] + (import-type type assembly))) + assembly) + ((stringp assembly) + (import-assembly (load-assembly assembly))) + (t (error "Don't know how to import assembly ~S." assembly)))) + +(defun import-types (assembly-name &rest type-names) + "Loads the assembly named ASSEMBLY-NAME and imports \(see function +IMPORT-TYPE) all types listed from this assembly. The assembly name +is prepended to the type names before importing them. All arguments +should be strings." + (let ((assembly (or (load-assembly assembly-name) + (error "Assembly ~S not found" assembly-name)))) + (dolist (type-name type-names) + (import-type (concatenate 'string + assembly-name + "." + type-name) + assembly)))) + +(defun reset-cached-data () + "Resets all relevant global special variables to their initial value, +thereby releasing pointers to DotNetContainer objects if necessary. +Also removes all direct call definitions." + (setq *callback-counter* 0 + *delegate-counter* 0) + (clrhash *callback-hash*) + (clrhash *signature-hash*) + (loop for function-name being the hash-keys in *direct-definitions* + do (fmakunbound function-name))) + +(defun init-rdnzl () + "Initializes RDNZL. This function must be called once before RDNZL +is used." + ;; see + (dll-ensure-init) + ;; inform the DelegateAdapter class about where the Lisp callbacks + ;; are located + (%set-function-pointers (ffi-make-pointer 'LispCallback) + (ffi-make-pointer 'ReleaseDelegateAdapter)) + ;; reset to a sane state + (reset-cached-data) + (reimport-types) + (redefine-direct-calls) + ;; see comment for DLL-ENSURE-INIT above + (register-exit-function #'dll-force-term "Close DLL") + ;; set Lisp callback pointers back to NULL before the image exits + (register-exit-function (lambda () + (%set-function-pointers (ffi-make-null-pointer) + (ffi-make-null-pointer))) + "Clear Lisp callbacks") + (values)) + +(defun shutdown-rdnzl (&optional no-gc) + "Prepares RDNZL for delivery or image saving. After calling this +function RDNZL can't be used anymore unless INIT-RDNZL is called +again. If NO-GC is NIL \(the default) a full garbage collection is +also performed." + (reset-cached-data) + (dll-force-term) + (unless no-gc + (full-gc)) + (values)) + +(defun reimport-types () + "Loops through all imported types and tries to associate them with +the correct assembly. Only relevant for delivery and saved images." + (let ((assembly-hash (make-hash-table :test #'equal))) + (loop for type-name being the hash-keys in *type-hash* + using (hash-value assembly-qualified-name) + ;; only do this for types which need the assembly-qualified + ;; name + when (stringp assembly-qualified-name) + do (let ((assembly-name (find-partial-assembly-name assembly-qualified-name))) + (import-type type-name + (or (gethash assembly-name assembly-hash) + (setf (gethash assembly-name assembly-hash) + (load-assembly assembly-name)))))))) + +(defun redefine-direct-calls () + "Loops through all direct call definition which have been stored in +*DIRECT-DEFINITIONS* and re-animates them. Only relevant for delivery +and saved images." + (loop for function-name being the hash-keys in *direct-definitions* + using (hash-value function-data) + do (create-direct-call function-name function-data))) + +;; when loading this file initialize RDNZL +(eval-when (:load-toplevel :execute) + (init-rdnzl)) + +(disable-rdnzl-syntax) Added: trunk/rdnzl/load.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/load.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,74 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/load.lisp,v 1.20 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Load this file to compile and load all of RDNZL - see README.txt +;;; and the doc folder for details. + +(in-package :cl-user) + +(let ((rdnzl-base-directory + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*)))) + (let (must-compile) + #+:cormanlisp (declare (ignore must-compile)) + (dolist (file '("packages" + "specials" + "util" + #+:allegro "port-acl" + #+:cormanlisp "port-ccl" + #+:clisp "port-clisp" + #+:ecl "port-ecl" + #+:lispworks "port-lw" + #+:sbcl "port-sbcl" + "ffi" + "container" + "reader" + "arrays" + "adapter" + "import" + "direct")) + (let ((pathname (make-pathname :name file :type "lisp" :version nil + :defaults rdnzl-base-directory))) + ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD + ;; will yield compiled functions anyway + #-:cormanlisp + (let ((compiled-pathname (compile-file-pathname pathname))) + (unless (and (not must-compile) + (probe-file compiled-pathname) + (< (file-write-date pathname) + (file-write-date compiled-pathname))) + (setq must-compile t) + (compile-file pathname)) + (setq pathname compiled-pathname)) + (load pathname))))) + + + + + Added: trunk/rdnzl/packages.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/packages.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,77 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/packages.lisp,v 1.32 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Definition of the "RDNZL" package. + +(in-package :cl-user) + +;; Corman Lisp has problems with uninterned symbols like #:aref* +(defpackage :rdnzl + (:use :cl) + #+:sbcl (:shadow :defconstant) + (:export :*coerce-double-floats-to-single* + :aref* + :box + :cast + :container-p + :copy-container + :define-rdnzl-call + :disable-rdnzl-syntax + :do-rdnzl-array + :enable-rdnzl-syntax + :enum-to-integer + :field + :import-assembly + :import-type + :import-types + :integer-to-enum + :invoke + :init-rdnzl + #+(or :cormanlisp :ecl) :lf-to-crlf + :load-assembly + :list-to-rdnzl-array + :make-null-object + :new + :or-enums + :property + :ref + :rdnzl-array-to-list + :rdnzl-error + :rdnzl-error-exception + :rdnzl-handler-case + :shutdown-rdnzl + :unbox + :unuse-all-namespaces + :unuse-namespace + :use-namespace)) + +(defpackage :rdnzl-user + (:use :cl :rdnzl) + (:documentation "This package is intended for playing around +with RDNZL.")) \ No newline at end of file Added: trunk/rdnzl/port-acl.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/port-acl.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,284 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/port-acl.lisp,v 1.18 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Charles A. Cox, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; AllegroCL-specific definitions + +(in-package :rdnzl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :foreign)) + +;; This variable should really evaluate to ':fat-le, but the fat-le +;; external-format was left out of the Allegro CL distribution by +;; mistake. A patch will be available, but a workaround is to use the +;; equivalent "rdnzl-fat" external-format, the definition of which is +;; included below. +(defparameter *wchar-external-format* '(e-crlf :rdnzl-fat)) + +;; Begin rdnzl-fat definition. +(in-package :excl) + +(def-external-format :rdnzl-fat :nulls 2 :width 2) + +(def-char-to-octets-macro :rdnzl-fat (char state + &key put-next-octet external-format) + (declare (ignore external-format state)) + `(let ((code (char-code ,char))) + (,put-next-octet (ldb (byte 8 0) code)) + (,put-next-octet (ldb (byte 8 8) code)))) + +(def-octets-to-char-macro :rdnzl-fat (state-loc &key get-next-octet external-format + octets-count-loc unget-octets) + (declare (ignore external-format state-loc unget-octets)) + `(code-char (+ ,get-next-octet + (progn (incf ,octets-count-loc) + (ash ,get-next-octet 8))))) + +;; force auto-compilation. Suppress the unnecessary notes. +(with-output-to-string (*system-messages*) + (string-to-octets "foo" :external-format :rdnzl-fat)) + +(in-package :rdnzl) +;; End rdnzl-fat definition. + +(defmacro ffi-register-module (path &optional (module-name path)) + "Loads a C library designated by PATH." + (declare (ignore module-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (load ,path))) + +(defgeneric ffi-pointer-p (object) + (:documentation "Tests whether OBJECT is an FFI pointer.")) + +(defmethod ffi-pointer-p ((object ff:foreign-pointer)) + t) + +(defmethod ffi-pointer-p ((object integer)) + t) + +(defmethod ffi-pointer-p ((object t)) + nil) + +(defgeneric ffi-null-pointer-p (pointer) + (:documentation + "Returns whether the FFI pointer POINTER is a null pointer.")) + +(defmethod ffi-null-pointer-p ((pointer (eql 0))) + t) + +(defmethod ffi-null-pointer-p ((pointer ff:foreign-pointer)) + (eql 0 (ff:foreign-pointer-address pointer))) + +(defmethod ffi-null-pointer-p ((pointer t)) + nil) + +(defgeneric ffi-pointer-address (pointer) + (:documentation "Returns the address of the FFI pointer POINTER.")) + +(defmethod ffi-pointer-address ((pointer ff:foreign-pointer)) + (ff:foreign-pointer-address pointer)) + +(defmethod ffi-pointer-address ((pointer integer)) + pointer) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME. +Allegro CL Note: Use only for foreign-callable symbols." + (ff:register-foreign-callable name :reuse t)) + +(defun ffi-make-null-pointer () + "Returns an FFI NULL pointer." + 0) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the Allegro CL FLI." + (ecase type-name + (ffi-void '(:void)) + (ffi-void-pointer '((* :void))) + (ffi-const-string '((* :void))) + (ffi-integer '(:int)) + (ffi-boolean '(:int boolean)) + (ffi-wide-char '(:unsigned-short)) + (ffi-float '(:float)) + (ffi-double '(:double)))) + +(excl:def-fwrapper wchar_t-retval (x) + (code-char (excl:call-next-fwrapper))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + (flet ((arg-spec (arg-list) + (mapcar #'(lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (cons name (ffi-map-type type)))) + arg-list))) + `(progn + (ff:def-foreign-call (,lisp-name ,c-name) ,(arg-spec arg-list) + :returning ,(ffi-map-type result-type) + :strings-convert t + :release-heap :when-ok + :convention ':c) + ,@(when (eq result-type 'ffi-wide-char) + `((excl:fwrap ',lisp-name 'wchar_t-wrapper 'wchar_t-retval)))))) + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp which can be called from C. ARG-LIST is a list +of \(NAME TYPE) pairs. All types are supposed to be symbols +mappable by FFI-MAP-TYPE above." + (declare (ignore result-type)) + `(progn + (ff:defun-foreign-callable ,c-name + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (car (ffi-map-type type))))) + arg-list) + ;; the following is overridden by Windows Allegro CL + ;; (declare (:unwind nil)) + , at body) + (ff:register-foreign-callable ',c-name ':reuse t))) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to call +a C function f with the signature void f\(..., __wchar_t *s) where s +is a result string which is returned by this macro. OBJECT is the +first argument given to f. Prior to calling f the length of the +result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let ((,length (,length-function ,object))) + (excl::with-dynamic-extent-usb8-array (,temp (* 2 (1+ ,length))) + (,function ,object ,temp) + (excl:octets-to-string + ,temp + :external-format *wchar-external-format*)))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +\(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer + foreign-string) + (declare (ignorable foreign-string)) + `(let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(excl:with-native-string + (,foreign-string ,string + :external-format *wchar-external-format*) + (apply #',function ,foreign-string ,ffi-arg-pointers))) + (t + `(apply #',function ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defconstant *ffi-args-size* 20) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer + foreign-name element-count byte-count) + (declare (ignorable foreign-name element-count byte-count)) + ` (let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (ff:with-stack-fobject (,ffi-arg-pointers + '(:array (* :void) ,*ffi-args-size*)) + (when (> ,length ,*ffi-args-size*) + (error "Need more coding here...")) + (loop for ,arg in ,args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + do (setf (ff:fslot-value ,ffi-arg-pointers ,i) + ,arg-pointer)) + ,(cond (name + `(excl:with-native-string + (,foreign-name + ,name + :external-format *wchar-external-format*) + (,function ,foreign-name + ,object + ,length + ,ffi-arg-pointers))) + (t + `(,function ,object + ,length + ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defun flag-for-finalization (object &optional function) + "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT +is removed by GC." + (excl:schedule-finalization object function)) + +(defmacro register-exit-function (function &optional name) + "Makes sure the function FUNCTION \(with no arguments) is called +before the Lisp images exits." + (declare (ignore name)) + `(push + ',(list 'funcall function) + sys:*exit-cleanup-forms*)) + +(defun full-gc () + "Invokes a full garbage collection." + (excl:gc t)) Added: trunk/rdnzl/port-ccl.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/port-ccl.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,286 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/port-ccl.lisp,v 1.29 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Corman-specific definitions + +(in-package :rdnzl) + +(defvar *dll-path* nil + "The name of RDNZL.dll.") + +(defmacro ffi-register-module (dll-path &optional module-name) + "Store the DLL name provided by the argument DLL-PATH." + (declare (ignore module-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *dll-path* ,dll-path))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (ct:cpointerp object)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (ct:cpointer-null pointer)) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (ct:cpointer-value pointer)) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME." + (ct:get-callback-procinst name)) + +(defun ffi-make-null-pointer () + "Returns an FFI NULL pointer." + (ct:create-foreign-ptr)) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the Corman Lisp FFI." + (ecase type-name + (ffi-void :void) + (ffi-void-pointer '(:void *)) + (ffi-const-string '(:void *)) + (ffi-integer :long) + (ffi-boolean :long-bool) + (ffi-wide-char :unsigned-short) + (ffi-float :single-float) + (ffi-double :double-float))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + (cond ((or (eq result-type 'ffi-wide-char) + (find 'ffi-wide-char arg-list :key #'second :test #'eq)) + ;; define a wrapper if one of the args and/or the return type + ;; is a __wchar_t because Corman Lisp doesn't handle this + ;; type automatically + (with-unique-names (internal-name result) + `(progn + (ct:defun-dll ,internal-name + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + :return-type ,(ffi-map-type result-type) + :linkage-type :c + :library-name ,*dll-path* + :entry-name ,c-name) + (defun ,lisp-name ,(mapcar #'first arg-list) + (let ((,result (,internal-name ,@(loop for (name type) in arg-list + when (eq type 'ffi-wide-char) + collect `(char-code ,name) + else + collect name)))) + ,(if (eq result-type 'ffi-wide-char) + ;; only use lower octet... + `(code-char (logand ,result 255)) + result)))))) + (t + `(ct:defun-dll ,lisp-name + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + :return-type ,(ffi-map-type result-type) + :linkage-type :c + :library-name ,*dll-path* + :entry-name ,c-name)))) + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp function which can be called from C. ARG-LIST +is a list of \(NAME TYPE) pairs. All types are supposed to be +symbols mappable by FFI-MAP-TYPE above." + (declare (ignore result-type)) + `(ct:defun-direct-c-callback ,c-name + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + , at body)) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to call +a C function f with the signature void f\(..., __wchar_t *s) where s +is a result string which is returned by this macro. OBJECT is the +first argument given to f. Prior to calling f the length of the +result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let ((,length (,length-function ,object)) + ,temp) + (unwind-protect + (progn + (setq ,temp (ct:malloc (* 2 (1+ ,length)))) + (,function ,object ,temp) + (copy-seq (ct:unicode-to-lisp-string ,temp))) + (when ,temp + (ct:free ,temp))))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +\(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-string) + ` (let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil)) + ,foreign-string) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(progn + (setq ,foreign-string (ct:lisp-string-to-unicode ,string)) + (apply #',function ,foreign-string ,ffi-arg-pointers))) + (t + `(apply #',function ,ffi-arg-pointers)))) + (when ,foreign-string + (ct:free ,foreign-string)) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-name) + ` (let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil)) + ,ffi-arg-pointers + ,foreign-name) + (unwind-protect + (progn + (setq ,ffi-arg-pointers (ct:malloc (* ,length (ct:sizeof '(:void *))))) + (loop for ,arg in ,args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + do (setf (ct:cref ((:void *) *) ,ffi-arg-pointers ,i) + ,arg-pointer)) + ,(cond (name + `(progn + (setq ,foreign-name (ct:lisp-string-to-unicode ,name)) + (,function ,foreign-name + ,object + ,length + ,ffi-arg-pointers))) + (t + `(,function ,object + ,length + ,ffi-arg-pointers)))) + (when ,ffi-arg-pointers + (ct:free ,ffi-arg-pointers)) + (when ,foreign-name + (ct:free ,foreign-name)) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defun flag-for-finalization (object &optional function) + "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT +is removed by GC." + (ccl:register-finalization object function)) + +(defun register-exit-function (function &optional name) + "Makes sure the function FUNCTION \(with no arguments) is called +before the Lisp images exits." + ;; don't know how to do that in Corman Lisp + (declare (ignore function name))) + +(defun full-gc () + "Invokes a full garbage collection." + (ccl:gc 3)) + +(defun lf-to-crlf (string) + "Add #\Return before each #\Newline in STRING." + (loop with new-string = (make-array (length string) + :element-type 'character + :fill-pointer 0) + for c across string + when (char= c #\Newline) + do (vector-push-extend #\Return new-string) + do (vector-push-extend c new-string) + finally (return new-string))) + +;; Corman's WITH-STANDARD-IO-SYNTAX doesn't work correctly so we fix +;; it here for our purposes + +(defvar *standard-readtable* (copy-readtable nil)) +(defvar *standard-pprint-dispatch* (copy-pprint-dispatch nil)) + +(defmacro with-standard-io-syntax (&body body) + `(let ((*package* (find-package :user)) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pprint-dispatch* *standard-pprint-dispatch*) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* nil) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* *standard-readtable*)) + , at body)) Added: trunk/rdnzl/port-clisp.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/port-clisp.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,254 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/port-clisp.lisp,v 1.12 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Vasilis Margioulas, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; CLISP-specific definitions + +(in-package :rdnzl) + +(defvar *dll-path* nil + "The name of RDNZL.dll.") + +(defmacro ffi-register-module (dll-path &optional module-name) + "Store the DLL name provided by the argument DLL-PATH." + (declare (ignore module-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *dll-path* ,dll-path))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (eql (type-of object) 'ffi:foreign-address)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (null pointer)) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (ffi:foreign-address-unsigned pointer)) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME." + (get-function-pointer name)) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the CLISP FFI." + (ecase type-name + (ffi-void nil) + (ffi-void-pointer 'ffi:c-pointer) + (ffi-const-string 'ffi:c-pointer) + (ffi-integer 'ffi:int) + (ffi-boolean 'ffi:boolean) + (ffi-wide-char 'ffi:uint16) + (ffi-float 'ffi:single-float) + (ffi-double 'ffi:double-float))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + (cond ((or (eq result-type 'ffi-wide-char) + (find 'ffi-wide-char arg-list :key #'second :test #'eq)) + ;; define a wrapper if one of the args and/or the return type + ;; is a __wchar_t because CLISP doesn't handle this + ;; type automatically + (with-unique-names (internal-name result) + `(progn + (ffi:def-call-out ,internal-name + (:name ,c-name) + (:arguments ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list)) + ,@(when (ffi-map-type result-type) + `((:return-type ,(ffi-map-type result-type)))) + (:language :stdc) + (:library ,*dll-path*)) + (defun ,lisp-name ,(mapcar #'first arg-list) + (let ((,result (,internal-name ,@(loop for (name type) in arg-list + when (eq type 'ffi-wide-char) + collect `(char-code ,name) + else + collect name)))) + ,(if (eq result-type 'ffi-wide-char) + `(code-char ,result) + result)))))) + (t + `(ffi:def-call-out ,lisp-name + (:name ,c-name) + (:arguments ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list)) + ,@(when (ffi-map-type result-type) + `((:return-type ,(ffi-map-type result-type)))) + (:language :stdc) + (:library ,*dll-path*))))) + +(defgeneric get-function-pointer (name)) + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp function which can be called from C. +ARG-LIST is a list of \(NAME TYPE) pairs. All types are supposed +to be symbols mappable by FFI-MAP-TYPE above." + (with-unique-names (foreign-function) + `(progn + (defun ,c-name ,(mapcar #'first arg-list) + , at body) + + (let ((,foreign-function (ffi:allocate-deep + '(ffi:c-function + (:language :stdc-stdcall) + (:arguments ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list)) + (:return-type ,(ffi-map-type result-type))) + nil))) + + (defmethod get-function-pointer ((name (eql ',c-name))) + (ffi:with-c-place (f-function ,foreign-function) + (unless f-function + (setf f-function #',c-name)) + (ffi:foreign-address f-function))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-unicode-string ((var lisp-string) &body body) + (with-unique-names (str-len ubyte16-array) + `(let ((,str-len (length ,lisp-string))) + (ffi:with-c-var (,ubyte16-array `(ffi:c-array-max ffi:uint16 ,(1+ ,str-len)) + (map 'vector #'char-code ,lisp-string)) + (let ((,var (ffi:c-var-address ,ubyte16-array))) + , at body)))))) + +(defun unicode-string-to-lisp (ubyte16-array) + (map 'string #'code-char ubyte16-array)) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to call +a C function f with the signature void f\(..., __wchar_t *s) where s +is a result string which is returned by this macro. OBJECT is the +first argument given to f. Prior to calling f the length of the +result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let ((,length (,length-function ,object))) + (ffi:with-c-var (,temp `(ffi:c-array-max ffi:uint16 ,(1+ ,length)) #()) + (,function ,object (ffi:c-var-address ,temp)) + (unicode-string-to-lisp ,temp)))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +\(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-string) + (declare (ignorable foreign-string)) + `(let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(with-unicode-string (,foreign-string ,string) + (apply #',function ,foreign-string ,ffi-arg-pointers))) + (t + `(apply #',function ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-name) + `(let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (progn + (ffi:with-c-var + (,ffi-arg-pointers `(ffi:c-array ffi:c-pointer ,,length) + (apply #'vector + (loop for ,arg in ,args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (name + `(with-unicode-string (,foreign-name ,name) + (,function ,foreign-name + ,object + ,length + (ffi:c-var-address ,ffi-arg-pointers)))) + (t `(,function ,object + ,length + (ffi:c-var-address ,ffi-arg-pointers)))))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defun flag-for-finalization (object &optional function) + "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT +is removed by GC." + (ext:finalize object function)) + +(defun register-exit-function (function &optional name) + "Makes sure the function FUNCTION \(with no arguments) is called +before the Lisp images exits." + ;; don't know how to do that in CLISP + (declare (ignore function name))) + +(defun full-gc () + "Invokes a full garbage collection." + (ext:gc)) Added: trunk/rdnzl/port-ecl.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/port-ecl.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,257 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/port-ecl.lisp,v 1.5 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Vasilis Margioulas, Michael Goffioul, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; ECL-specific definitions + +(in-package :rdnzl) + +(defvar *dll-path* nil + "The name of RDNZL.dll.") + +(defmacro ffi-register-module (dll-path &optional module-name) + "Store the DLL name provided by the argument DLL-PATH." + (declare (ignore module-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *dll-path* ,dll-path))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (eql (type-of object) 'si::foreign-data)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (ffi:null-pointer-p pointer)) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (ffi:pointer-address pointer)) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME." + (ffi:callback name)) + +(defun ffi-make-null-pointer () + "Returns an FFI NULL pointer." + (si:allocate-foreign-data :void 0)) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the ECL FFI." + (ecase type-name + (ffi-void :void) + (ffi-void-pointer :pointer-void) + (ffi-const-string '(* :unsigned-short)) + (ffi-integer :int) + (ffi-boolean :byte) + (ffi-wide-char :unsigned-short) + (ffi-float :float) + (ffi-double :double))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + (cond ((or (member result-type '(ffi-wide-char ffi-boolean)) + (find 'ffi-wide-char arg-list :key #'second :test #'eq) + (find 'ffi-boolean arg-list :key #'second :test #'eq)) + ;; define a wrapper if one of the args and/or the return type + ;; is a __wchar_t because ECL doesn't handle this + ;; type automatically + (with-unique-names (internal-name result) + `(progn + (ffi:def-function (,c-name ,internal-name) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + ,@(when (ffi-map-type result-type) + `(:returning ,(ffi-map-type result-type))) + :module ,*dll-path*) + (defun ,lisp-name ,(mapcar #'first arg-list) + (let ((,result (,internal-name ,@(loop for (name type) in arg-list + if (eq type 'ffi-wide-char) + collect `(char-code ,name) + else if (eq type 'ffi-boolean) + collect `(if ,name 1 0) + else + collect name)))) + ,(cond ((eq result-type 'ffi-wide-char) + `(code-char ,result)) + ((eq result-type 'ffi-boolean) + `(if (= ,result 0) nil t)) + (t result))))))) + (t + `(ffi:def-function (,c-name ,lisp-name) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + ,@(when (ffi-map-type result-type) + `(:returning ,(ffi-map-type result-type))) + :module ,*dll-path*)))) + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp function which can be called from C. +ARG-LIST is a list of \(NAME TYPE) pairs. All types are supposed +to be symbols mappable by FFI-MAP-TYPE above." + `(ffi:defcallback ,c-name ,(ffi-map-type result-type) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + , at body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-unicode-string ((var lisp-string) &body body) + (with-unique-names (str-len k) + `(let* ((,str-len (length ,lisp-string))) + (ffi:with-foreign-object (,var `(:array :unsigned-short ,(1+ ,str-len))) + (loop for ,k below ,str-len + do (si::foreign-data-set-elt ,var (* 2 ,k) :unsigned-short (char-code (char ,lisp-string ,k)))) + (si::foreign-data-set-elt ,var (* 2 ,str-len) :unsigned-short 0) + , at body))))) + +(defun unicode-string-to-lisp (ubyte16-array) + (let ((char-list (loop for k from 0 + for uc = (si::foreign-data-ref-elt ubyte16-array (* 2 k) :unsigned-short) + while (/= uc 0) collect (code-char uc)))) + (coerce char-list 'string))) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to call +a C function f with the signature void f\(..., __wchar_t *s) where s +is a result string which is returned by this macro. OBJECT is the +first argument given to f. Prior to calling f the length of the +result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let* ((,length (,length-function ,object))) + (ffi:with-foreign-object (,temp `(:array :unsigned-short ,(1+ ,length))) + (,function ,object ,temp) + (unicode-string-to-lisp ,temp)))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +\(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-string) + (declare (ignorable foreign-string)) + `(let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(with-unicode-string (,foreign-string ,string) + (apply #',function ,foreign-string ,ffi-arg-pointers))) + (t + `(apply #',function ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-name) + `(let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (progn + (ffi:with-foreign-object (,ffi-arg-pointers `(:array :pointer-void ,,length)) + (loop for ,arg in ,args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + do (si::foreign-data-set-elt ,ffi-arg-pointers (* 4 ,i) :pointer-void ,arg-pointer)) + ,(cond (name + `(with-unicode-string (,foreign-name ,name) + (,function ,foreign-name + ,object + ,length + ,ffi-arg-pointers))) + (t `(,function ,object + ,length + ,ffi-arg-pointers))))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defun flag-for-finalization (object &optional function) + "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT +is removed by GC." + ;; don't know how to do that in ECL + (declare (ignore object function))) + +(defun register-exit-function (function &optional name) + "Makes sure the function FUNCTION \(with no arguments) is called +before the Lisp images exits." + ;; don't know how to do that in ECL + (declare (ignore function name))) + +(defun full-gc () + "Invokes a full garbage collection." + (si::gc t)) + +(defun lf-to-crlf (string) + "Add #\Return before each #\Newline in STRING." + (loop with new-string = (make-array (+ (length string) (count #\Newline string)) + :element-type 'character + :fill-pointer 0) + for c across string + when (char= c #\Newline) + do (vector-push-extend #\Return new-string) + do (vector-push-extend c new-string) + finally (return new-string))) Added: trunk/rdnzl/port-lw.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/port-lw.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,230 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/port-lw.lisp,v 1.42 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; LispWorks-specific definitions + +(in-package :rdnzl) + +(defvar *module-name* nil + "Holds the last module name defined by FFI-REGISTER-MODULE. +This is only needed for LispWorks.") + +(defmacro ffi-register-module (path &optional (module-name path)) + "Loads a C library designated by PATH. Optionally \(for +LispWorks) registers this library under the name MODULE-NAME." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (fli:register-module ,module-name + :real-name ,path) + (setq *module-name* ,module-name))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (fli:pointerp object)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (fli:null-pointer-p pointer)) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (fli:pointer-address pointer)) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME." + (fli:make-pointer :symbol-name (symbol-name name))) + +(defun ffi-make-null-pointer () + "Returns an FFI NULL pointer." + fli:*null-pointer*) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the LispWorks FLI." + (ecase type-name + (ffi-void :void) + (ffi-void-pointer :pointer) + (ffi-const-string '(:reference-pass (:ef-wc-string + :external-format :unicode))) + (ffi-integer :int) + (ffi-boolean :boolean) + (ffi-wide-char :wchar-t) + (ffi-float :lisp-float) + (ffi-double :double))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + `(fli:define-foreign-function + (,lisp-name ,c-name) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + :result-type ,(ffi-map-type result-type) + :calling-convention :cdecl + :language :ansi-c + ;; use the last module that was registered + ,@(when *module-name* + (list :module *module-name*)))) + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp function which can be called from C. ARG-LIST +is a list of \(NAME TYPE) pairs. All types are supposed to be +symbols mappable by FFI-MAP-TYPE above." + `(fli:define-foreign-callable + (,(symbol-name c-name) :result-type ,(ffi-map-type result-type) + :calling-convention :cdecl) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + , at body)) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to call +a C function f with the signature void f\(..., __wchar_t *s) where s +is a result string which is returned by this macro. OBJECT is the +first argument given to f. Prior to calling f the length of the +result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let ((,length (,length-function ,object))) + (fli:with-dynamic-foreign-objects () + (let ((,temp (fli:allocate-dynamic-foreign-object :type :wchar-t + :nelems (1+ ,length)))) + (,function ,object ,temp) + (fli:convert-from-foreign-string ,temp :external-format :unicode))))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +\(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer) + `(let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(apply #',function ,string ,ffi-arg-pointers)) + (t + `(apply #',function ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer) + (declare (ignorable foreign-name element-count byte-count)) + ` (let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (fli:with-dynamic-foreign-objects () + (let ((,ffi-arg-pointers (fli:allocate-dynamic-foreign-object :type :pointer + :nelems ,length))) + (loop for ,arg in ,args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + do (setf (fli:dereference ,ffi-arg-pointers :index ,i) + ,arg-pointer)) + (,function ,@(if name (list name) nil) + ,object + ,length + ,ffi-arg-pointers))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +;; register MAYBE-FREE-CONTAINER-POINTER as a finalization +;; function - needed for LispWorks +(hcl:add-special-free-action 'maybe-free-container-pointer) + +(defun flag-for-finalization (object &optional function) + "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT +is removed by GC." + ;; LispWorks can ignore FUNCTION because it was registered globally + ;; above + (declare (ignore function)) + (hcl:flag-special-free-action object)) + +(defvar *exit-function-registered* nil + "Whether LW:DEFINE-ACTION was already called for DllForceTerm.") + +(defmacro register-exit-function (function &optional name) + "Makes sure the function FUNCTION \(with no arguments) is called +before the Lisp images exits." + `(unless *exit-function-registered* + (lw:define-action "When quitting image" + ,name ,function :once) + (setq *exit-function-registered* t))) + +(defun full-gc () + "Invokes a full garbage collection." + (hcl:mark-and-sweep 3)) + +;; help the LispWorks IDE to find definitions +(dspec:define-form-parser ffi-define-function (c-name) + `(,ffi-define-function ,(make-lisp-name c-name))) + +(dspec:define-dspec-alias ffi-define-function (name) + `(fli:define-foreign-function ,name)) + +(dspec:define-form-parser define-rdnzl-call (name) + `(,define-rdnzl-call ,name)) + +(dspec:define-dspec-alias define-rdnzl-call (name) + `(defun ,name)) Added: trunk/rdnzl/port-sbcl.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/port-sbcl.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,309 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/port-sbcl.lisp,v 1.15 2008/01/26 22:28:31 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; SBCL-specific definitions + +(in-package :rdnzl) + +(defconstant +ffi-pointer-size+ + #.(/ (sb-alien:alien-size sb-alien:system-area-pointer) 8) + "The size of a pointer in octets.") + +(defmacro ffi-register-module (path &optional (module-name path)) + "Loads a C library designated by PATH." + (declare (ignore module-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (sb-alien:load-shared-object ,path))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (sb-sys:system-area-pointer-p object)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (zerop (sb-sys:sap-int pointer))) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (sb-sys:sap-int pointer)) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the SBCL FFI." + (ecase type-name + (ffi-void 'sb-alien:void) + (ffi-void-pointer 'sb-alien:system-area-pointer) + (ffi-const-string 'sb-alien:system-area-pointer) + (ffi-integer 'sb-alien:int) + ;; only needed for WIDE-CHAR fake below + (ffi-unsigned-short 'sb-alien:unsigned-short) + (ffi-float 'sb-alien:single-float) + (ffi-double 'sb-alien:double-float))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + ;; there's a more elegant way to do this - see the code in + ;; `port-clisp.lisp' + (cond ((eq result-type 'ffi-boolean) + (with-unique-names (inner-fn) + `(progn + (ffi-define-function* (,inner-fn ,c-name) + ,arg-list + ffi-integer) + (defun ,lisp-name ,(mapcar #'first arg-list) + (not (zerop (,inner-fn ,@(mapcar #'first arg-list)))))))) + ((eq result-type 'ffi-wide-char) + (with-unique-names (inner-fn) + `(progn + (ffi-define-function* (,inner-fn ,c-name) + ,arg-list + ffi-unsigned-short) + (defun ,lisp-name ,(mapcar #'first arg-list) + (code-char (,inner-fn ,@(mapcar #'first arg-list))))))) + ((find 'ffi-boolean arg-list :key #'second) + (with-unique-names (inner-fn) + `(progn + (ffi-define-function* (,inner-fn ,c-name) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (if (eq type 'ffi-boolean) + (list name 'ffi-integer) + name-and-type))) + arg-list) + ,result-type) + (defun ,lisp-name ,(mapcar #'first arg-list) + (,inner-fn ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (if (eq type 'ffi-boolean) + `(if ,name 1 0) + name))) + arg-list)))))) + ((find 'ffi-wide-char arg-list :key #'second) + (with-unique-names (inner-fn) + `(progn + (ffi-define-function* (,inner-fn ,c-name) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (if (eq type 'ffi-wide-char) + (list name 'ffi-unsigned-short) + name-and-type))) + arg-list) + ,result-type) + (defun ,lisp-name ,(mapcar #'first arg-list) + (,inner-fn ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (if (eq type 'ffi-wide-char) + `(char-code ,name) + name))) + arg-list)))))) + (t `(sb-alien:define-alien-routine + (,c-name ,lisp-name) ,(ffi-map-type result-type) + ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list))))) + +(defvar *callbacks* (make-hash-table) + "A hash table which maps symbols \(function names) to +callbacks.") + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp function which can be called from C. ARG-LIST +is a list of \(NAME TYPE) pairs. All types are supposed to be +symbols mappable by FFI-MAP-TYPE above." + `(setf (gethash ',c-name *callbacks*) + (sb-alien:alien-sap + (sb-alien::alien-lambda ,(ffi-map-type result-type) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + , at body)))) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the \(callback) address specified by +the name NAME." + (gethash name *callbacks*)) + +(defun ffi-make-null-pointer () + "Returns an FFI NULL pointer." + (sb-sys:int-sap 0)) + +(defun ffi-alloc (size) + "Allocates an `alien' of size SIZE octets and returns a pointer +to it. Must be freed with FFI-FREE afterwards." + (sb-alien:alien-sap + (sb-alien:make-alien (sb-alien:unsigned 8) size))) + +(defun ffi-free (pointer) + "Frees space that was allocated with FFI-ALLOC." + (sb-alien:free-alien + (sb-alien:sap-alien pointer (* (sb-alien:unsigned 8))))) + +(defun ffi-convert-from-foreign-ucs-2-string (pointer size) + "Converts the foreign UCS-2 string pointed to by POINTER of +size SIZE octets to a Lisp string." + (with-output-to-string (out) + (loop for i from 0 below size by 2 + do (write-char (code-char + (+ (sb-sys:sap-ref-8 pointer i) + (ash (sb-sys:sap-ref-8 pointer (1+ i)) 8))) + out)))) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to +call a C function f with the signature void f\(..., __wchar_t *s) +where s is a result string which is returned by this macro. +OBJECT is the first argument given to f. Prior to calling f the +length of the result string s is obtained by evaluating +\(LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let ((,length (* 2 (,length-function ,object))) + ,temp) + (unwind-protect + (progn + (setq ,temp (ffi-alloc (+ 2 ,length))) + (,function ,object ,temp) + (ffi-convert-from-foreign-ucs-2-string ,temp ,length)) + (when ,temp + (ffi-free ,temp))))))) + +(defmacro with-ucs-2-string ((var lisp-string) &body body) + "Converts the Lisp string LISP-STRING to a foreign string using +UCS-2 encoding and evaluates BODY with VAR bound to this foreign +string." + (with-unique-names (size char char-code i) + `(let (,var) + (unwind-protect + (let ((,size (* 2 (length ,lisp-string)))) + (setq ,var (ffi-alloc (+ 2 ,size))) + (loop for ,i from 0 by 2 + for ,char across ,lisp-string + for ,char-code = (char-code ,char) + do (setf (sb-sys:sap-ref-8 ,var ,i) (ldb (byte 8 0) ,char-code) + (sb-sys:sap-ref-8 ,var (1+ ,i)) (ldb (byte 8 8) ,char-code))) + (setf (sb-sys:sap-ref-8 ,var ,size) 0 + (sb-sys:sap-ref-8 ,var (1+ ,size)) 0) + , at body) + (when ,var + (ffi-free ,var)))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +\(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers + arg i arg-pointer foreign-string) + (declare (ignorable foreign-string)) + `(let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(with-ucs-2-string (,foreign-string ,string) + (apply #',function ,foreign-string ,ffi-arg-pointers))) + (t + `(apply #',function ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i j + arg-pointer foreign-name) + (declare (ignorable foreign-name)) + `(let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil)) + ,ffi-arg-pointers) + (unwind-protect + (progn + (setq ,ffi-arg-pointers + (ffi-alloc + (* ,length +ffi-pointer-size+))) + (loop for ,arg in ,args + for ,i from 0 + for ,j from 0 by +ffi-pointer-size+ + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + do (setf (sb-sys:sap-ref-sap ,ffi-arg-pointers ,j) + ,arg-pointer)) + ,(cond (name + `(with-ucs-2-string (,foreign-name ,name) + (,function ,foreign-name + ,object + ,length + ,ffi-arg-pointers))) + (t `(,function ,object + ,length + ,ffi-arg-pointers)))) + (when ,ffi-arg-pointers + (ffi-free ,ffi-arg-pointers)) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defun register-exit-function (function &optional name) + "Makes sure the function FUNCTION \(with no arguments) is called +before the Lisp images exits." + ;; don't know how to do that in SBCL + (declare (ignore function name))) + +(defun full-gc () + "Invokes a full garbage collection." + (sb-ext:gc :full t)) Added: trunk/rdnzl/rdnzl.asd ============================================================================== --- (empty file) +++ trunk/rdnzl/rdnzl.asd Wed Apr 30 04:28:03 2008 @@ -0,0 +1,50 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/rdnzl.asd,v 1.50 2008/03/25 17:06:23 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; System definition for ASDF - see + +(asdf:defsystem :rdnzl + :serial t + :version "0.12.2" + :components ((:file "packages") + (:file "specials") + (:file "util") + #+:allegro (:file "port-acl") ; AllegroCL-specific stuff here + #+:cormanlisp (:file "port-ccl") ; Corman-specific stuff here + #+:clisp (:file "port-clisp") ; CLISP-specific stuff here + #+:ecl (:file "port-ecl") ; ECL-specific stuff here + #+:lispworks (:file "port-lw") ; LispWorks-specific stuff here + #+:sbcl (:file "port-sbcl") ; SBCL-specific stuff here + (:file "ffi") + (:file "container") + (:file "reader") + (:file "arrays") + (:file "adapter") + (:file "import") + (:file "direct"))) Added: trunk/rdnzl/reader.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/reader.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,268 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/reader.lisp,v 1.20 2008/01/26 22:28:32 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; This file defines the special reader syntax for .NET calls. + +(in-package :rdnzl) + +(define-condition rdnzl-reader-error (simple-condition reader-error) + () + (:report (lambda (condition stream) + (format stream "RDNZL reader error: ~?" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))) + (:documentation "A reader error which can be signalled by ERROR.")) + +(defmacro signal-reader-error (stream format-control &rest format-arguments) + "Like ERROR but signals a SIMPLE-READER-ERROR for the stream +STREAM." + `(error 'rdnzl-reader-error + :stream ,stream + :format-control ,format-control + :format-arguments (list , at format-arguments))) + +(defun read-rdnzl-token (stream) + "Tries to emulate how the Lisp reader reads a token with standard +syntax, but is case-sensitive. Returns a string." + (let ((collector (make-array 0 + :element-type 'character + :fill-pointer t + :adjustable t)) + in-multiple-escape-p + in-single-escape-p + char-seen-p) + (loop + (let ((char (peek-char nil stream nil nil t))) + (cond (in-multiple-escape-p + ;; in multiple escape mode, read everything as is but + ;; don't accept EOF + (unless char + (signal-reader-error stream + "End of file while in multiple~ +escape mode \(i.e. after pipe character).")) + (read-char stream nil nil t) + (cond ((char= char #\|) + ;; end of multiple escape mode + (setq in-multiple-escape-p nil)) + (t + (vector-push-extend char collector)))) + (in-single-escape-p + ;; single escape mode, i.e. last char was backslash - + ;; read next char as is but don't accept EOF + (unless char + (signal-reader-error stream + "End of file while in single~ +escape mode \(i.e. after backslash character).")) + (setq in-single-escape-p nil) + (read-char stream nil nil t) + (vector-push-extend char collector)) + ((null char) + ;; EOF - return what has been read so far + (return-from read-rdnzl-token collector)) + ((and (not char-seen-p) + (whitespacep char)) + ;; skip whitespace after #\[ + (read-char stream nil nil t)) + ((char= char #\|) + ;; switch to multiple escape mode + (setq in-multiple-escape-p t + char-seen-p t) + (read-char stream nil nil t)) + ((char= char #\\) + ;; switch to single escape mode + (setq in-single-escape-p t + char-seen-p t) + (read-char stream nil nil t)) + ((or (whitespacep char) + (member char '(#\" #\' #\( #\) #\[ #\] #\, #\; #\`) + :test #'char=)) + ;; whitespace or terminating macro character, stop + ;; parsing this token + (return-from read-rdnzl-token collector)) + (t + ;; otherwise just consume the character + (setq char-seen-p t) + (read-char stream nil nil t) + (vector-push-extend char collector))))))) + +(defun read-and-parse-rdnzl-token (stream) + "Reads a token like \"%Environment.UserName\" with READ-RDNZL-TOKEN +and dissects it into its parts \(type name and member name) if +necessary. Also returns the corresponding function \(INVOKE, +PROPERTY, or FIELD) from container.lisp." + (let ((token (read-rdnzl-token stream)) + (prepend nil) + (function-name 'invoke)) + (when (string= token "") + (signal-reader-error stream + "Empty token after #\[ character.")) + (when (and (= (length token) 1) + (member (char token 0) '(#\% #\$ #\+ #\-) + :test #'char=)) + (signal-reader-error stream + "Illegal token \"~C\" after #\[ character." + token)) + (let ((first-char (char token 0))) + (case first-char + ((#\%) + ;; first char #\% means property + (setq function-name 'property + token (subseq token 1))) + ((#\$) + ;; first char #\$ means field + (setq function-name 'field + token (subseq token 1))) + ((#\+) + ;; first char #\+ adds "add_" + (setq token (subseq token 1) + prepend "add_")) + ((#\-) + ;; first char #\- adds "remove_" + (setq token (subseq token 1) + prepend "remove_")))) + ;; find last dot (if any) in token + (let ((dot-pos (position #\. token :test #'char= :from-end t))) + (cond (dot-pos + ;; if there is a dot we have a static invocation and the + ;; part before the dot is the type name + (when (= dot-pos (1- (length token))) + (signal-reader-error stream + "Dot at end of token.")) + (let ((type-name (subseq token 0 dot-pos)) + (member-name (subseq token (1+ dot-pos)))) + (values (if prepend + (concatenate 'string prepend member-name) + member-name) + function-name + type-name))) + (t + ;; otherwise it's an instance invocation + (values (if prepend + (concatenate 'string prepend token) + token) + function-name)))))) + + +(defun rdnzl-list-reader (stream char) + (declare (ignore char)) + "The reader function for the RDNZL \[] notation." + ;; read the first token after the opening bracket with + ;; READ-RDNZL-TOKEN + (multiple-value-bind (member-name function-name type-name) + (read-and-parse-rdnzl-token stream) + ;; now read rest until #\] + (let ((args (read-delimited-list #\] stream t))) + (cond (type-name + ;; static invocation + (list* function-name type-name member-name args)) + (t + ;; instance invocation + (unless args + ;; we always need at least one argument - the object + ;; instance itself + (signal-reader-error stream + "Missing arguments after token \"~A~A\"." + (case function-name + ((invoke) "") + ((property) "%") + ((field) "$")) + member-name)) + (list* function-name (first args) member-name (rest args))))))) + +(defun rdnzl-function-reader (stream char arg) + "The reader function for the RDNZL #` notation. Always returns a +function object." + (declare (ignore char arg)) + (cond ((char= #\( (peek-char nil stream t nil t)) + ;; starts with a left parenthesis, so we expect #`(SETF ...) + (read-char stream t nil t) + (let ((symbol (read stream t nil t))) + (unless (eq symbol 'setf) + (signal-reader-error stream + "Expected CL:SETF after \"#`(\"")) + (multiple-value-bind (member-name function-name type-name) + (read-and-parse-rdnzl-token stream) + (unless (char= #\) (peek-char t stream t nil t)) + (signal-reader-error stream + "Expected #\) after \"#`(CL:SETF ~A\"." + (if type-name + (concatenate 'string type-name "." member-name) + member-name))) + (read-char stream t nil t) + (cond (type-name + `(lambda (new-value &rest args) + (apply #'(setf ,function-name) + new-value ,type-name ,member-name args))) + (t + `(lambda (new-value object &rest args) + (apply #'(setf ,function-name) + new-value object ,member-name args))))))) + (t + (multiple-value-bind (member-name function-name type-name) + (read-and-parse-rdnzl-token stream) + (cond (type-name + `(lambda (&rest args) + (apply #',function-name + ,type-name ,member-name args))) + (t + `(lambda (object &rest args) + (apply #',function-name + object ,member-name args)))))))) + +(defun %enable-rdnzl-syntax () + "Internal function used to enable reader syntax and store current +readtable on stack." + (push *readtable* + *previous-readtables*) + (setq *readtable* (copy-readtable)) + (set-syntax-from-char #\] #\) *readtable*) + ;; make #\[ non-terminating + (set-macro-character #\[ + #'rdnzl-list-reader) + (set-dispatch-macro-character #\# #\` #'rdnzl-function-reader) + (values)) + +(defun %disable-rdnzl-syntax () + "Internal function used to restore previous readtable." + (if *previous-readtables* + (setq *readtable* (pop *previous-readtables*)) + (setq *readtable* (copy-readtable nil))) + (values)) + +(defmacro enable-rdnzl-syntax () + "Enables RDNZL reader syntax." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-rdnzl-syntax))) + +(defmacro disable-rdnzl-syntax () + "Restores the readtable which was active before the last call to +ENABLE-RDNZL-SYNTAX. If there was no such call, the standard readtable +is used." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-rdnzl-syntax))) Added: trunk/rdnzl/specials.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/specials.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,112 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/specials.lisp,v 1.29 2008/01/26 22:28:32 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Global special variables (and constants) used by RDNZL. + +(in-package :rdnzl) + +#+:sbcl +(defmacro defconstant (name form &optional documentation) + ;; see + `(cl:defconstant ,name + (cond ((boundp ',name) (symbol-value ',name)) + (t ,form)) + ,@(and documentation (list documentation)))) + +(defvar *used-namespaces* nil + "A list of namespaces which are `used.' See USE-NAMESPACE and +related functions.") + +(defvar *dll-initialized* nil + "Whether RDNZL.dll was initialized with DllEnsureInit.") + +(defconstant +private-assembly-name+ "RDNZLPrivateAssembly" + "The name of the assembly which is generated at run time to create +subtypes of DelegateAdapter.") + +(defvar *callback-counter* 0 + "The index of the last closure from which a delegate was created - +or 0 if no delegate has been created yet. Used as a key in the +*CALLBACK-HASH* hash table.") + +(defvar *callback-hash* (make-hash-table) + "A hash table which maps integers to closures used as delegates - +see the instance variable indexIntoLisp in DelegateAdapter.cpp.") + +(defvar *delegate-counter* 0 + "Counter used to make sure each subtype of DelegateAdapter has a +unique name.") + +(defvar *signature-hash* (make-hash-table :test #'equal) + "A hash table which maps delegate signatures to subtypes of +DelegateAdapter so that we only create one such subtype for each +signature.") + +(defvar *type-hash* (make-hash-table :test #'equal) + "A hash table which maps short type names of `imported' types to +fully qualified type names \(or to T if the type can be retrieved by +Type::GetType without a fully qualified name).") + +(defvar *direct-definitions* (make-hash-table :test #'equal) + "Maps function names \(for direct calls) to data structures which +can be used to re-construct the function.") + +(defconstant +whitespace-char-list+ + '(#\Space #\Tab #\Linefeed #\Newline #\Return #\Page) + "A list of all characters which are considered to be whitespace.") + +(defvar *previous-readtables* nil + "A stack which holds the previous readtables that have been pushed +here by ENABLE-RDNZL-SYNTAX.") + +(defvar *coerce-double-floats-to-single* nil + "If this is true, then BOX will convert a Lisp DOUBLE-FLOAT +value to System.Single. This is mainly interesting for +LispWorks, where Lisp floats are always DOUBLE-FLOAT.") + +(pushnew :rdnzl *features*) + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see +;; and +;; also used by LW-ADD-ONS + +(defvar *hyperdoc-base-uri* "http://weitz.de/rdnzl/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :rdnzl + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) Added: trunk/rdnzl/util.lisp ============================================================================== --- (empty file) +++ trunk/rdnzl/util.lisp Wed Apr 30 04:28:03 2008 @@ -0,0 +1,247 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/rdnzl/util.lisp,v 1.27 2008/02/14 10:33:51 edi Exp $ + +;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Several utility functions. + +(in-package :rdnzl) + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'lw:with-unique-names)) + +#-:lispworks +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; by Vebjorn Ljosa - see also + ;; + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + , at body)) + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (macro-function 'with-rebinding) + (macro-function 'lw:rebinding))) + +#-:lispworks +(defmacro with-rebinding (bindings &body body) + "WITH-REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; by Vebjorn Ljosa - see also + ;; + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,, at temps) + ,, at body)))))) + +(defun starts-with (string sub-string) + "Returns true if the string STRING starts with the string +SUB-STRING." + (let ((mismatch (mismatch string sub-string :test #'char-equal))) + (or (null mismatch) + (>= mismatch (length sub-string))))) + +(defmacro named-when ((var form) &body body) + "Executes BODY if FORM evaluates to a true value. During the +execution of BODY VAR is bound to the value returned by FORM." + `(let ((,var ,form)) + (when ,var + , at body))) + +(defun use-namespace (namespace) + "Adds the .NET namespace NAMESPACE \(a string) to the list of +namespaces that will be prefixed when trying to resolve a type name. +After calling this function NAMESPACE will be the first entry in this +list unless it has already been there." + (pushnew (concatenate 'string namespace ".") + *used-namespaces* + :test #'string=) + (values)) + +(defun unuse-namespace (namespace) + "Removes the .NET namespace NAMESPACE \(a string) from the list of +namespaces that will be prefixed when trying to resolve a type name." + (setq *used-namespaces* + (delete (concatenate 'string namespace ".") + *used-namespaces* + :test #'string=)) + (values)) + +(defun unuse-all-namespaces () + "Removes all entries from the list of namespaces that will be +prefixed when trying to resolve a type name." + (setq *used-namespaces* nil) + (values)) + +(defun resolve-type-name (name) + "If NAME is a string which names a type which has been previously +imported via IMPORT-TYPE, then return its assembly-qualified name. If +a type named NAME can't be found directly, then also try the `used' +namespaces. If NAME is a tree of strings, interpret this as a generic +type and resolve each leaf as above, except that for the first \(base) +type the suffix giving the number of parameters is added +automatically" + (cond ((stringp name) + (loop for namespace in (cons "" *used-namespaces*) + for full-name = (concatenate 'string namespace name) + for hashed-name = (gethash full-name *type-hash*) + when hashed-name + do (return (cond ((stringp hashed-name) hashed-name) + (t full-name))) + finally (return name))) + (t (let ((first-type-name + (concatenate 'string (car name) + (format nil "`~D" (length (rest name)))))) + (mapcar #'resolve-type-name (cons first-type-name (rest name))))))) + +(defun mangle-name (string) + "Converts the string STRING into another string with case determined +by the current readtable-case and where a hyphen is inserted whenever +the case changes from lower to upper, e.g. \"myCoolFoo\" becomes +\"MY-COOL-FOO\"." + (symbol-name + (read-from-string + (with-output-to-string (out) + (loop for last-char = #\. then char + for char across string + when (and (lower-case-p last-char) + (upper-case-p char)) + do (write-char #\- out) + do (write-char (char-downcase char) out)))))) + +(defun make-lisp-name (c-name) + "Makes a Lisp name \(a symbol in the RDNZL package) from a C name." + (intern (concatenate 'string "%" (mangle-name c-name)) :rdnzl)) + +(defun unmangle-name* (string) + "STRING is assumed to be a string consisting solely of single-case +letters and hyphens. This function will return a string with all +hyphens removed and all characters downcased except for the first one +and those following a hyphen - these are upcased." + (with-output-to-string (out) + (loop with upcase = t + for c across string + do (cond ((char= c #\-) + (setq upcase t)) + (upcase + (write-char (char-upcase c) out) + (setq upcase nil)) + (t + (write-char (char-downcase c) out)))))) + +(defun unmangle-name (function-name) + "FUNCTION-NAME is assumed to be a function name, i.e. a symbol +or a cons of the form \(SETF symbol). If the symbol name of this +symbol consists solely of single-case letters appropriate for the +current readtable-case and hyphens then UNMANGLE-NAME* is applied +to it, otherwise the symbol name itself is returned. Note that +the return value is always a symbol even if the argument was a +cons." + (let* ((symbol (cond ((consp function-name) + (second function-name)) + (t function-name))) + (symbol-name (symbol-name symbol))) + (let ((case-test (case (readtable-case *readtable*) + ((:upcase :invert) #'upper-case-p) + (t #'lower-case-p)))) + (cond ((every (lambda (c) + (or (funcall case-test c) + (char= c #\-))) + symbol-name) + (unmangle-name* symbol-name)) + (t symbol-name))))) + +(defun find-partial-assembly-name (type-name) + "Tries to extract the partial assembly name from the +assembly-qualified type name TYPE-NAME." + (let ((length (length type-name))) + (flet ((find-comma (start) + "Finds the position of the first comma within TYPE-NAME +\(starting from position START) which is not preceded by a backslash." + (loop for i = start then (1+ pos) + for pos = (and (< i length) + (position #\, type-name :test #'char= :start i)) + while (and pos + (plusp pos) + (char= (char type-name (1- pos)) #\\)) + finally (return pos)))) + (let* ((first-comma (find-comma 0)) + ;; now skip spaces + (non-space (and first-comma + (position #\Space type-name :test #'char/= :start (1+ first-comma)))) + (second-comma (and non-space + (find-comma non-space)))) + (or (and second-comma + (> second-comma non-space) + (subseq type-name non-space second-comma)) + (error "Couldn't find partial assembly name in ~S" type-name)))))) + +(defun whitespacep (chr) + "Tests whether a character is whitespace." + (member chr +whitespace-char-list+ :test #'char=)) + From eweitz at common-lisp.net Wed Apr 30 08:29:39 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:29:39 -0400 (EDT) Subject: [rdnzl-cvs] r6 - trunk/rdnzl-cpp Message-ID: <20080430082939.16AC34204C@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:29:38 2008 New Revision: 6 Added: trunk/rdnzl-cpp/ Log: Created rdnzl-cpp dir From eweitz at common-lisp.net Wed Apr 30 08:30:07 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:30:07 -0400 (EDT) Subject: [rdnzl-cvs] r7 - in trunk/rdnzl-cpp: . RDNZL Message-ID: <20080430083007.4B3A953019@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:30:03 2008 New Revision: 7 Added: trunk/rdnzl-cpp/CHANGELOG.txt (contents, props changed) trunk/rdnzl-cpp/RDNZL/ trunk/rdnzl-cpp/RDNZL.sln (contents, props changed) trunk/rdnzl-cpp/RDNZL/AssemblyInfo.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/DelegateAdapter.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/DelegateAdapter.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/DotNetContainer.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/DotNetContainer.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/DotNetReference.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/DotNetReference.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/Field.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/Field.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/InvocationResult.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/InvocationResult.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/InvokeConstructor.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/InvokeConstructor.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/InvokeMember.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/InvokeMember.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/Property.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/Property.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/RDNZL.vcproj (contents, props changed) trunk/rdnzl-cpp/RDNZL/Stdafx.cpp (contents, props changed) trunk/rdnzl-cpp/RDNZL/Stdafx.h (contents, props changed) trunk/rdnzl-cpp/RDNZL/rdnzl.def (contents, props changed) trunk/rdnzl-cpp/README.txt (contents, props changed) Log: Import 0.7.1 Added: trunk/rdnzl-cpp/CHANGELOG.txt ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/CHANGELOG.txt Wed Apr 30 04:30:03 2008 @@ -0,0 +1,52 @@ +Version 0.7.1 +2008-02-19 +Fixed nullptr check in InvokeMember.cpp (thanks to Per Arild Fiskum and Iver Odin Kvello) + +Version 0.7.0 +2008-02-14 +Fixed return value of the generated delegate adapters (thanks to Iver Odin Kvello and Michael Mills) +Moved to Visual Studio 2005 (thanks to Michael Goffioul and Matthew D Swank) + +Version 0.6.0 +2007-05-18 +Added copyDotNetContainer (patch from Iver Odin Kvello) +Added setDotNetContainerTypeFromContainer (patch from Iver Odin Kvello) + +Version 0.5.2 +2006-09-27 +Only call back into Lisp if callback pointers aren't NULL (suggested by Michael Goffioul) + +Version 0.5.1 +2006-09-15 +Set apartment state to STA (thanks to Michael Goffioul) + +Version 0.5.0 +2006-01-13 +Fix mechanism which releases delegate adapters (thanks to Dominic Robinson) + +Version 0.4.1 +2005-11-21 +Added missing constructor for single float (caught by Andrew Wolven) + +Version 0.4.0 +2005-01-03 +Added interface functions for "direct calls" +Added ChangeType code to setDotNetContainerTypeFromString + +Version 0.3.1 +2004-12-23 +Fixed typo in declaration of makeDotNetContainerFromFloat + +Version 0.3.0 +2004-12-23 +Added better support for System.Single (thanks to Vasilis Margioulas) + +Version 0.2.0 +2004-12-17 +Added support for pass-by-reference handling +Correct linker settings for release configuration +Some cleanup in routines that throw errors + +Version 0.1.0 +2004-12-16 +Initial public release Added: trunk/rdnzl-cpp/RDNZL.sln ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL.sln Wed Apr 30 04:30:03 2008 @@ -0,0 +1,19 @@ +Microsoft Visual Studio Solution File, Format Version 9.00 +# Visual C++ Express 2005 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "RDNZL", "RDNZL\RDNZL.vcproj", "{08A74849-5B79-4488-8F41-731C19FE3A13}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Release|Win32 = Release|Win32 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {08A74849-5B79-4488-8F41-731C19FE3A13}.Debug|Win32.ActiveCfg = Release|Win32 + {08A74849-5B79-4488-8F41-731C19FE3A13}.Debug|Win32.Build.0 = Release|Win32 + {08A74849-5B79-4488-8F41-731C19FE3A13}.Release|Win32.ActiveCfg = Release|Win32 + {08A74849-5B79-4488-8F41-731C19FE3A13}.Release|Win32.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal Added: trunk/rdnzl-cpp/RDNZL/AssemblyInfo.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/AssemblyInfo.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,34 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/AssemblyInfo.cpp,v 1.11 2008/02/14 07:34:30 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" + +[assembly:AssemblyTitleAttribute("RDNZL")]; +[assembly:AssemblyDescriptionAttribute("DLL to be used by the RDNZL library which interfaces Common Lisp to .NET")]; +[assembly:AssemblyCopyrightAttribute("(c) Dr. Edmund Weitz 2004")]; +[assembly:AssemblyVersionAttribute("0.1.0.0")]; Added: trunk/rdnzl-cpp/RDNZL/DelegateAdapter.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DelegateAdapter.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,66 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DelegateAdapter.cpp,v 1.20 2008/02/14 11:54:02 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "DelegateAdapter.h" + +// the destructor notifies Lisp that this instance is no longer used - +// might be called from a "foreign" thread, see docs +DelegateAdapter::~DelegateAdapter() { + if (release != NULL) { + release(indexIntoLisp); + } +} + +// initialize the instance with an index that points back to the +// actual Lisp closure (via a Lisp hash table) +void DelegateAdapter::init(int index) { + indexIntoLisp = index; +} + +// this does all the work (by calling the Lisp closure) after the +// wrapper (build at runtime from Lisp via reflection) has marshalled +// the delegate's arguments into an array of objects +Object^ DelegateAdapter::invoke (cli::array ^args) { + if (callback != NULL) { + void *ptr = callback(indexIntoLisp, new DotNetContainer(args)); + // the Lisp closure is supposed to return a pointer to a + // DotNetContainer which we marshall back into the underlying object + return static_cast(ptr)->getContainerObject(); + } else { + // a dummy object... + return gcnew Object(); + } +} + +// this static function is called once in the beginning to initialize +// the function pointers pointing to two Lisp callbacks +void setFunctionPointers(void *(*callback_fp)(int, void *), void (*release_fp)(int)) { + DelegateAdapter::callback = callback_fp; + DelegateAdapter::release = release_fp; +} Added: trunk/rdnzl-cpp/RDNZL/DelegateAdapter.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DelegateAdapter.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,48 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DelegateAdapter.h,v 1.13 2008/02/14 07:34:30 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "DotNetContainer.h" + +public ref class DelegateAdapter { + public: + ~DelegateAdapter(); + void init(int index); + Object ^invoke (cli::array ^args); + static void *(*callback)(int, void *); + static void (*release)(int); + private: + // the index into the Lisp hash table which holds the closures - + // should be a 64-bit integer in the future + int indexIntoLisp; +}; + +extern "C" { + __declspec(dllexport) void setFunctionPointers(void *(*callback_fp)(int, void *), void (*release_fp)(int)); +} Added: trunk/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,137 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.cpp,v 1.11 2008/02/14 11:54:02 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "DelegateAdapterBuilder.h" + +// always returns the same module builder which is cached +ModuleBuilder ^DelegateAdapterBuilder::getModuleBuilder() { + if (moduleBuilder != nullptr) + return moduleBuilder; + + // if not cached already create it once + AssemblyName ^assemblyName = gcnew AssemblyName(); + assemblyName->Name = privateAssemblyName; + assemblyName->Version = gcnew Version("1.0.0.0"); + + AppDomain ^appDomain = Thread::GetDomain(); + AssemblyBuilder ^assemblyBuilder = appDomain->DefineDynamicAssembly( + assemblyName, + AssemblyBuilderAccess::Run + ); + + moduleBuilder = assemblyBuilder->DefineDynamicModule(privateAssemblyName); + + return moduleBuilder; +} + +// creates a constructor for our new type +void DelegateAdapterBuilder::generateConstructor(ILGenerator ^ilGenerator) { + // the simplest one possible - no arguments, just call the + // constructor of the base type + ilGenerator->Emit(OpCodes::Ldarg_0); + ilGenerator->Emit(OpCodes::Call, DelegateAdapter::typeid->GetConstructor(gcnew cli::array(0))); + ilGenerator->Emit(OpCodes::Ret); +} + +// creates the "InvokeClosure" method which calls DelegateAdapter's +// "invoke" +void DelegateAdapterBuilder::generateInvokeMethod(ILGenerator ^ilGenerator, Type ^returnType, cli::array ^argTypes) { + int nargs = argTypes->Length; + + // create a System.Object array of the same length as argTypes + ilGenerator->DeclareLocal(cli::array::typeid /*__typeof(Object*[])*/); + ilGenerator->Emit(OpCodes::Ldc_I4, nargs); + ilGenerator->Emit(OpCodes::Newarr, System::Object::typeid); + ilGenerator->Emit(OpCodes::Stloc_0); + + // store method arguments in this array + for (int i = 0; i < nargs; i++) { + ilGenerator->Emit(OpCodes::Ldloc_0); + ilGenerator->Emit(OpCodes::Ldc_I4, i); + ilGenerator->Emit(OpCodes::Ldarg, i + 1); + + Type ^argType = argTypes[i]; + if (argType->IsValueType) + ilGenerator->Emit(OpCodes::Box, argType); + ilGenerator->Emit(OpCodes::Stelem_Ref); + } + + // call "invoke" with this array + ilGenerator->Emit(OpCodes::Ldarg_0); + ilGenerator->Emit(OpCodes::Ldloc_0); + ilGenerator->Emit(OpCodes::Call,DelegateAdapter::typeid->GetMethod("invoke")); + + // handle return value of "invoke" + if (returnType->Equals(Void::typeid)) + ilGenerator->Emit(OpCodes::Pop); + else if (returnType->IsValueType) + ilGenerator->Emit(OpCodes::Unbox_Any, returnType); + + ilGenerator->Emit(OpCodes::Ret); +} + +// build a new type which derives from DelegateAdapter and is +// responsible for Lisp callbacks with a signature as described by +// returnType and argTypes +Type ^DelegateAdapterBuilder::buildDelegateType (String ^typeName, Type ^returnType, cli::array ^argTypes) { + TypeBuilder ^typeBuilder = getModuleBuilder()->DefineType( + String::Concat(privateAssemblyName, ".", typeName), + TypeAttributes::Public, + DelegateAdapter::typeid + ); + + generateConstructor(typeBuilder->DefineConstructor( + MethodAttributes::Public, + CallingConventions::Standard, + gcnew cli::array(0) + )->GetILGenerator()); + generateInvokeMethod( + typeBuilder->DefineMethod( + "InvokeClosure", + MethodAttributes::Public, + returnType, + argTypes + )->GetILGenerator(), + returnType, + argTypes + ); + + return typeBuilder->CreateType(); +} + +// the C interface +__declspec(dllexport) void *buildDelegateType(const __wchar_t *typeName, void *returnType, void *argTypes) { + Type ^newType = DelegateAdapterBuilder::buildDelegateType( + gcnew String(typeName), + safe_cast(static_cast(returnType)->getContainerObject()), + safe_cast ^>(static_cast(argTypes)->getContainerObject()) + ); + + return new DotNetContainer(newType); +} Added: trunk/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,49 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DelegateAdapterBuilder.h,v 1.7 2008/02/14 07:34:31 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "stdafx.h" +#include "DelegateAdapter.h" + +public ref class DelegateAdapterBuilder { + public: + static Type ^buildDelegateType (String ^typeName, Type ^returnType, cli::array ^argTypes); + private: + static String ^privateAssemblyName = "RDNZLPrivateAssembly"; + // cache for ModuleBuilder object + static ModuleBuilder ^moduleBuilder = nullptr; + + static ModuleBuilder ^getModuleBuilder(); + static void generateConstructor(ILGenerator ^ilGenerator); + static void generateInvokeMethod(ILGenerator ^ilGenerator, Type ^returnType, cli::array ^argTypes); +}; + +extern "C" { + __declspec(dllexport) void *buildDelegateType(const __wchar_t *typeName, void *returnType, void *argTypes); +} Added: trunk/rdnzl-cpp/RDNZL/DotNetContainer.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DotNetContainer.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,246 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DotNetContainer.cpp,v 1.26 2008/02/14 12:13:04 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "DotNetContainer.h" + +// helper function for constructors - initialize both object and type +// slot, with NULL DotNetReference if necessary +void DotNetContainer::init(Object ^o, Type ^t) { + object = (o != nullptr) ? new DotNetReference(o) : new DotNetReference(); + type = (t != nullptr) ? new DotNetReference(t) : new DotNetReference(); +} + +// another helper function - calls init above +void DotNetContainer::init(Object ^o) { + if (o == nullptr) { + init(nullptr, nullptr); + } else { + // if type isn't explicitely provided, derive it from the object + init(o, o->GetType()); + } +} + +// constructor if type is explicitely set +DotNetContainer::DotNetContainer(Object ^o, Type ^t) { + init(o, t); +} + +// standard constructor +DotNetContainer::DotNetContainer(Object ^o) { + init(o); +} + +// the following five constructors box values types +DotNetContainer::DotNetContainer(bool b) { + init(b); +} + +DotNetContainer::DotNetContainer(__int32 n) { + init(n); +} + +DotNetContainer::DotNetContainer(__int64 n) { + init(n); +} + +DotNetContainer::DotNetContainer(float f) { + init(f); +} + +DotNetContainer::DotNetContainer(double d) { + init(d); +} + +DotNetContainer::DotNetContainer(__wchar_t c) { + init(c); +} + +// this constructor converts a C string into a .NET string +DotNetContainer::DotNetContainer(const __wchar_t *s) { + init(gcnew String(s)); +} + +// whether the stored object is NULL +bool DotNetContainer::isNull() { + return (object->getObject() == nullptr); +} + +Object ^DotNetContainer::getContainerObject() { + return object->getObject(); +} + +Type ^DotNetContainer::getContainerType() { + return safe_cast(type->getObject()); +} + +// change the value of the object slot +void DotNetContainer::setContainerObject(Object ^o) { + object = new DotNetReference(o); +} + +// change the value of the type slot (see CAST in Lisp code) +void DotNetContainer::setContainerType(Type ^t) { + type = new DotNetReference(t); +} + +DotNetContainer::~DotNetContainer() { + if (object) { + delete object; + } + if (type) { + delete type; + } +} + +// make a passed-by-reference type out of the container's type (if it +// isn't one already) +void DotNetContainer::refContainerType() { + Type ^t = safe_cast(type->getObject()); + if (!t->IsByRef) + type = new DotNetReference(t->Assembly->GetType(String::Concat(t->FullName, "&"))); +} + +// set the container's type to be its underlying type if it was passed +// by reference +void DotNetContainer::unrefContainerType() { + Type ^t = safe_cast(type->getObject()); + if (t->IsByRef) { + type = new DotNetReference(t->GetElementType()); + } +} + +// most of the functions below export the public interface of the +// DotNetContainer class to C + +__declspec(dllexport) bool DotNetContainerIsNull(void *ptr) { + return static_cast(ptr)->isNull(); +} + +// make a copy of an existing DotNetContainer +__declspec(dllexport) void *copyDotNetContainer(void *ptr) { + DotNetContainer* original = static_cast (ptr); + return new DotNetContainer(original->getContainerObject(), original->getContainerType()); +} + +// create a "placeholder" (NULL) container which only has a type +__declspec(dllexport) void *makeTypedNullDotNetContainer(const __wchar_t *type) { + return new DotNetContainer(nullptr, Type::GetType(gcnew String(type))); +} + +// create a container representing a type (obtained from its name) +__declspec(dllexport) void *makeTypeFromName(const __wchar_t *type) { + return new DotNetContainer(Type::GetType(gcnew String(type)), Type::typeid); +} + +__declspec(dllexport) void *makeDotNetContainerFromBoolean(bool b) { + return new DotNetContainer(b); +} + +__declspec(dllexport) void *makeDotNetContainerFromInt(int n) { + return new DotNetContainer(n); +} + +__declspec(dllexport) void *makeDotNetContainerFromLong(const __wchar_t *s) { + return new DotNetContainer(Int64::Parse(gcnew String(s))); +} + +__declspec(dllexport) void *makeDotNetContainerFromFloat(float d) { + return new DotNetContainer(d); +} + +__declspec(dllexport) void *makeDotNetContainerFromDouble(double d) { + return new DotNetContainer(d); +} + +__declspec(dllexport) void *makeDotNetContainerFromString(const __wchar_t *s) { + return new DotNetContainer(s); +} + +__declspec(dllexport) void *makeDotNetContainerFromChar(__wchar_t c) { + return new DotNetContainer(c); +} + +// we need to know the length to allocate storage on the Lisp side +__declspec(dllexport) int getDotNetContainerTypeStringLength(void *ptr) { + return static_cast(ptr)->getContainerType()->FullName->Length; +} + +// temporarily disable warnings here as we know that the destination is large enough +#pragma warning(disable:4996) +__declspec(dllexport) void getDotNetContainerTypeAsString(void *ptr, __wchar_t *s) { + cli::pin_ptr temp = PtrToStringChars(static_cast(ptr)->getContainerType()->FullName); + wcscpy(s, temp); + #pragma warning(default:4996) +} + +// we need to know the length to allocate storage on the Lisp side +__declspec(dllexport) int getDotNetContainerObjectStringLength(void *ptr) { + return static_cast(ptr)->getContainerObject()->ToString()->Length; +} + +#pragma warning(disable:4996) +__declspec(dllexport) void getDotNetContainerObjectAsString(void *ptr, __wchar_t *s) { + cli::pin_ptr temp = PtrToStringChars(static_cast(ptr)->getContainerObject()->ToString()); + wcscpy(s, temp); + #pragma warning(disable:4996) +} + +__declspec(dllexport) void refDotNetContainerType(void *ptr) { + static_cast(ptr)->refContainerType(); +} + +__declspec(dllexport) void unrefDotNetContainerType(void *ptr) { + static_cast(ptr)->unrefContainerType(); +} + +// "unboxing" + +__declspec(dllexport) __wchar_t getDotNetContainerCharValue(void *ptr) { + return *safe_cast(static_cast(ptr)->getContainerObject()); +} + +__declspec(dllexport) int getDotNetContainerIntValue(void *ptr) { + return *safe_cast(static_cast(ptr)->getContainerObject()); +} + +__declspec(dllexport) bool getDotNetContainerBooleanValue(void *ptr) { + return *safe_cast(static_cast(ptr)->getContainerObject()); +} + +__declspec(dllexport) double getDotNetContainerDoubleValue(void *ptr) { + return *safe_cast(static_cast(ptr)->getContainerObject()); +} + +__declspec(dllexport) float getDotNetContainerSingleValue(void *ptr) { + return *safe_cast(static_cast(ptr)->getContainerObject()); +} + +__declspec(dllexport) void freeDotNetContainer(void *ptr) { + delete static_cast(ptr); +} Added: trunk/rdnzl-cpp/RDNZL/DotNetContainer.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DotNetContainer.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,91 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DotNetContainer.h,v 1.21 2008/02/14 07:34:31 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "DotNetReference.h" +#include "DelegateAdapter.h" + +class DotNetContainer { + public: + DotNetContainer(Object ^o, Type ^t); + DotNetContainer(Object ^o); + DotNetContainer(bool b); + DotNetContainer(__int32 n); + DotNetContainer(__int64 n); + DotNetContainer(float f); + DotNetContainer(double d); + DotNetContainer(__wchar_t c); + DotNetContainer(const __wchar_t *s); + ~DotNetContainer(); + + bool isNull(); + Object ^getContainerObject(); + Type ^getContainerType(); + void setContainerObject(Object ^o); + void setContainerType(Type ^t); + void refContainerType(); + void unrefContainerType(); + private: + // the actual object + DotNetReference* object; + // the type of this object as seen from RDNZL + DotNetReference* type; + + void init(Object ^o, Type ^t); + void init(Object ^o); +}; + +extern "C" { + __declspec(dllexport) void *makeTypeFromName(const __wchar_t *type); + __declspec(dllexport) void *makeTypedNullDotNetContainer(const __wchar_t *type); + __declspec(dllexport) void *makeDotNetContainerFromBoolean(bool b); + __declspec(dllexport) void *makeDotNetContainerFromInt(int n); + __declspec(dllexport) void *makeDotNetContainerFromLong(const __wchar_t *s); + __declspec(dllexport) void *makeDotNetContainerFromFloat(float d); + __declspec(dllexport) void *makeDotNetContainerFromDouble(double d); + __declspec(dllexport) void *makeDotNetContainerFromChar(__wchar_t c); + __declspec(dllexport) void *makeDotNetContainerFromString(const __wchar_t *s); + __declspec(dllexport) bool DotNetContainerIsNull(void *ptr); + __declspec(dllexport) int getDotNetContainerTypeStringLength(void *ptr); + __declspec(dllexport) void getDotNetContainerTypeAsString(void *ptr, __wchar_t *s); + __declspec(dllexport) int getDotNetContainerObjectStringLength(void *ptr); + __declspec(dllexport) void getDotNetContainerObjectAsString(void *ptr, __wchar_t *s); + __declspec(dllexport) int getDotNetContainerIntValue(void *ptr); + __declspec(dllexport) __wchar_t getDotNetContainerCharValue(void *ptr); + __declspec(dllexport) bool getDotNetContainerBooleanValue(void *ptr); + __declspec(dllexport) double getDotNetContainerDoubleValue(void *ptr); + __declspec(dllexport) float getDotNetContainerSingleValue(void *ptr); + __declspec(dllexport) void refDotNetContainerType(void *ptr); + __declspec(dllexport) void unrefDotNetContainerType(void *ptr); + __declspec(dllexport) void freeDotNetContainer(void *ptr); + __declspec(dllexport) void *copyDotNetContainer(void *ptr); + // function definition is in InvocationResult.cpp + __declspec(dllexport) void *setDotNetContainerTypeFromString(const __wchar_t *type, void *ptr); + __declspec(dllexport) void *setDotNetContainerTypeFromContainer(void *type, void *ptr); +} Added: trunk/rdnzl-cpp/RDNZL/DotNetReference.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DotNetReference.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,54 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DotNetReference.cpp,v 1.9 2008/02/14 07:34:31 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "DotNetReference.h" + +// if constructor is called with no arguments act as NULL object +DotNetReference::DotNetReference() : ptr(0) {} + +// normal constructor +DotNetReference::DotNetReference(Object ^o) { + // acquire pointer to object so it can't be reclaimed by the .NET + // garbage collector until explicitely freed + ptr = ((IntPtr) GCHandle::Alloc(o)).ToPointer(); +} + +// destructor +DotNetReference::~DotNetReference() { + if (ptr) { + // give up pointer so garbage collector regains control + static_cast((IntPtr)ptr).Free(); + } +} + +Object ^DotNetReference::getObject() { + // return the object the instance was initialized with + return ptr ? safe_cast(static_cast((IntPtr)ptr).Target) : nullptr; +} + Added: trunk/rdnzl-cpp/RDNZL/DotNetReference.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/DotNetReference.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,40 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/DotNetReference.h,v 1.8 2008/02/14 07:34:31 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +class DotNetReference { + public: + DotNetReference(); + DotNetReference(Object ^o); + ~DotNetReference(); + + Object ^getObject(); + private: + void *ptr; +}; Added: trunk/rdnzl-cpp/RDNZL/Field.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/Field.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,149 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/Field.cpp,v 1.16 2008/02/14 11:54:02 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "Field.h" + +// provide informative message about which field wasn't found +void Field::throwFieldNotFoundError(Type ^type, const __wchar_t *fieldName, BindingFlags bindingAttr) { + throw gcnew Exception(String::Concat( + (int)(BindingFlags::Static & bindingAttr) ? "Static field not found: " : "Instance field not found: ", + type->FullName, + "->", + gcnew String(fieldName) + )); +} + +// helper function to get values of static and instance fields +void *Field::getFieldValue(Object ^o, Type ^t, const __wchar_t *fieldName, BindingFlags bindingAttr) { + try { + // find field by name and binding attributes + FieldInfo ^fi = t->GetField(gcnew String(fieldName), bindingAttr); + + if (fi == nullptr) + throwFieldNotFoundError(t, fieldName, bindingAttr); + + return new InvocationResult(fi->GetValue(o), fi->FieldType); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// helper function to get values of static and instance fields +void *Field::getFieldValueDirectly(void *fieldInfo, Object ^o) { + try { + FieldInfo ^fi = safe_cast(static_cast(fieldInfo)->getContainerObject()); + return new InvocationResult(fi->GetValue(o), fi->FieldType); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// helper function to set values of static and instance fields +void *Field::setFieldValue(Object ^o, Type ^t, const __wchar_t *fieldName, Object ^newValue, BindingFlags bindingAttr) { + try { + // find field by name and binding attributes + FieldInfo ^fi = t->GetField(gcnew String(fieldName), bindingAttr); + + if (fi == nullptr) + throwFieldNotFoundError(t, fieldName, bindingAttr); + + fi->SetValue(o, newValue); + return new InvocationResult(); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// helper function to set values of static and instance fields +void *Field::setFieldValueDirectly(void *fieldInfo, Object ^o, void *newValue) { + try { + FieldInfo ^fi = safe_cast(static_cast(fieldInfo)->getContainerObject()); + + fi->SetValue(o, static_cast(newValue)->getContainerObject()); + return new InvocationResult(); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// below void pointers always point to DotNetContainer objects + +__declspec(dllexport) void *getInstanceFieldValue(const __wchar_t *fieldName, void *target) { + DotNetContainer *container = static_cast(target); + Type ^t = container->getContainerType(); + Object ^o = container->getContainerObject(); + return Field::getFieldValue(o, t, fieldName, static_cast(BindingFlags::Instance | BindingFlags::Public)); +} + +__declspec(dllexport) void *getStaticFieldValue(const __wchar_t *fieldName, void *type) { + Type ^t = safe_cast(static_cast(type)->getContainerObject()); + return Field::getFieldValue(nullptr, t, fieldName, static_cast(BindingFlags::Static | BindingFlags::Public)); +} + +__declspec(dllexport) void *setInstanceFieldValue(const __wchar_t *fieldName, void *target, void *newValue) { + DotNetContainer *container = static_cast(target); + Type ^t = container->getContainerType(); + Object ^o = container->getContainerObject(); + return Field::setFieldValue(o, t, fieldName, + static_cast(newValue)->getContainerObject(), + safe_cast(BindingFlags::Instance | BindingFlags::Public)); +} + +__declspec(dllexport) void *setStaticFieldValue(const __wchar_t *fieldName, void *type, void *newValue) { + Type ^t = safe_cast(static_cast(type)->getContainerObject()); + return Field::setFieldValue(nullptr, t, fieldName, + static_cast(newValue)->getContainerObject(), + safe_cast(BindingFlags::Static | BindingFlags::Public)); +} + +__declspec(dllexport) void *getInstanceFieldValueDirectly(void *fieldInfo, void *target) { + Object ^o = static_cast(target)->getContainerObject(); + return Field::getFieldValueDirectly(fieldInfo, o); +} + +__declspec(dllexport) void *getStaticFieldValueDirectly(void *fieldInfo) { + return Field::getFieldValueDirectly(fieldInfo, nullptr); +} + +__declspec(dllexport) void *setInstanceFieldValueDirectly(void *fieldInfo, void *target, void *newValue) { + Object ^o = static_cast(target)->getContainerObject(); + return Field::setFieldValueDirectly(fieldInfo, o, newValue); +} + +__declspec(dllexport) void *setStaticFieldValueDirectly(void *fieldInfo, void *newValue) { + return Field::setFieldValueDirectly(fieldInfo, nullptr, newValue); +} Added: trunk/rdnzl-cpp/RDNZL/Field.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/Field.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,52 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/Field.h,v 1.12 2008/02/14 07:34:31 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "InvocationResult.h" + +public ref class Field { + public: + static void *getFieldValue(Object ^o, Type ^t, const __wchar_t *fieldName, BindingFlags bindingAttr); + static void *getFieldValueDirectly(void *fieldInfo, Object ^o); + static void *setFieldValue(Object ^o, Type ^t, const __wchar_t *fieldName, Object ^newValue, BindingFlags bindingAttr); + static void *setFieldValueDirectly(void *fieldInfo, Object ^o, void *newValue); + private: + static void throwFieldNotFoundError(Type ^type, const __wchar_t *fieldName, BindingFlags bindingAttr); +}; + +extern "C" { + __declspec(dllexport) void *getInstanceFieldValue(const __wchar_t *fieldName, void *target); + __declspec(dllexport) void *getStaticFieldValue(const __wchar_t *fieldName, void *type); + __declspec(dllexport) void *setInstanceFieldValue(const __wchar_t *fieldName, void *target, void *newValue); + __declspec(dllexport) void *setStaticFieldValue(const __wchar_t *fieldName, void *type, void *newValue); + __declspec(dllexport) void *getInstanceFieldValueDirectly(void *fieldInfo, void *target); + __declspec(dllexport) void *getStaticFieldValueDirectly(void *fieldInfo); + __declspec(dllexport) void *setInstanceFieldValueDirectly(void *fieldInfo, void *target, void *newValue); + __declspec(dllexport) void *setStaticFieldValueDirectly(void *fieldInfo, void *newValue); +} Added: trunk/rdnzl-cpp/RDNZL/InvocationResult.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/InvocationResult.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,114 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/InvocationResult.cpp,v 1.14 2008/02/14 07:43:41 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "InvocationResult.h" + +// constructor for "void" results +InvocationResult::InvocationResult() : isVoid_(true), isException_(false), result(0) {} + +// standard constructor +InvocationResult::InvocationResult(Object ^o, bool excp) : + isVoid_(false), isException_(excp), result(new DotNetContainer(o)) {} + +// constructor for results which are explicitely typed +InvocationResult::InvocationResult(Object ^o, Type ^t, bool excp) : + isVoid_(false), isException_(excp), result(new DotNetContainer(o, t)) {} + +bool InvocationResult::isVoid() { + return isVoid_; +} + +bool InvocationResult::isException() { + return isException_; +} + +DotNetContainer *InvocationResult::getResult() { + return result; +} + +__declspec(dllexport) bool InvocationResultIsVoid(void *ptr) { + return static_cast(ptr)->isVoid(); +} + +__declspec(dllexport) bool InvocationResultIsException(void *ptr) { + return static_cast(ptr)->isException(); +} + +__declspec(dllexport) void *getDotNetContainerFromInvocationResult(void *ptr) { + // this returns a NULL pointer if the result is void + return static_cast(ptr)->getResult(); +} + +__declspec(dllexport) void freeInvocationResult(void *ptr) { + delete static_cast(ptr); +} + +// helper function for setDotNetContainerTypeFromString and setDotNetContainerTypeFromContainer. +void *setDotNetContainerType(Type ^newType, void *ptr) { + try { + DotNetContainer *container = static_cast(ptr); + Type ^oldType = container->getContainerType(); + + if (oldType->IsAssignableFrom(newType)) { + container->setContainerType(newType); + } else { + Object ^newObject = Convert::ChangeType(container->getContainerObject(), newType); + container->setContainerObject(newObject); + container->setContainerType(newType); + } + // return void result + return new InvocationResult(); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// this should actually be in DotNetContainer.cpp but couldn't be defined there + +// if possible, change the type of the DotNetContainer given the string name of a type that will be found in the Load context. +__declspec(dllexport) void *setDotNetContainerTypeFromString(const __wchar_t *type, void *ptr) { + try { + // throw an exception if something happens + Type ^newType = Type::GetType(gcnew String(type), true); + return setDotNetContainerType(newType, ptr); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// change the type of the DotNetContainer, if possible, given a Type object. +__declspec(dllexport) void *setDotNetContainerTypeFromContainer(void *type, void *ptr) { + try { + // throw an exception if something happens + Type ^newType = safe_cast(static_cast(type)->getContainerObject()); + return setDotNetContainerType(newType, ptr); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} \ No newline at end of file Added: trunk/rdnzl-cpp/RDNZL/InvocationResult.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/InvocationResult.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,57 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/InvocationResult.h,v 1.10 2008/02/14 07:34:31 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "DotNetContainer.h" + +class InvocationResult { + public: + InvocationResult(); + InvocationResult(Object ^o, bool excp = false); + InvocationResult(Object ^o, Type ^t, bool excp = false); + + bool isVoid(); + bool isException(); + DotNetContainer *getResult(); + private: + // whether the object represents the "result" of a method which + // doesn't return anything + bool isVoid_; + // whether an exception occured + bool isException_; + // the actual result, if there was one + DotNetContainer *result; +}; + +extern "C" { + __declspec(dllexport) bool InvocationResultIsVoid(void *ptr); + __declspec(dllexport) bool InvocationResultIsException(void *ptr); + __declspec(dllexport) void *getDotNetContainerFromInvocationResult(void *ptr); + __declspec(dllexport) void freeInvocationResult(void *ptr); +} Added: trunk/rdnzl-cpp/RDNZL/InvokeConstructor.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/InvokeConstructor.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,49 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/InvokeConstructor.cpp,v 1.11 2008/02/14 11:54:03 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "InvokeConstructor.h" + +// invoke the constructor of the specified type and signature, the +// void pointers are pointers to DotNetContainer objects +__declspec(dllexport) void* invokeConstructor(void *type, int nargs, void *args[]) { + cli::array ^realArgs = gcnew cli::array(nargs); + for (int i = 0; i < nargs; i++) { + realArgs[i] = static_cast(args[i])->getContainerObject(); + } + + try { + Type ^t = safe_cast(static_cast(type)->getContainerObject()); + Object ^newInstance = Activator::CreateInstance(t, realArgs); + return new InvocationResult(newInstance); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} Added: trunk/rdnzl-cpp/RDNZL/InvokeConstructor.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/InvokeConstructor.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,35 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/InvokeConstructor.h,v 1.8 2008/02/14 07:34:31 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "InvocationResult.h" + +extern "C" { + __declspec(dllexport) void* invokeConstructor(void *type, int nargs, void *args[]); +} Added: trunk/rdnzl-cpp/RDNZL/InvokeMember.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/InvokeMember.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,200 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/InvokeMember.cpp,v 1.22 2008/02/19 18:40:54 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "InvokeMember.h" + +// helper function for findMethod - recursively descends into +// all interfaces +MethodInfo^ InvokeMember::findInterfaceMethod(cli::array ^interfaces, const __wchar_t *methodName, cli::array ^argTypes, BindingFlags bindingAttr) { + MethodInfo ^mi = nullptr; + + for (int i = 0; i < interfaces->Length && !mi; i++) { + mi = interfaces[i]->GetMethod(gcnew String(methodName), bindingAttr, nullptr, argTypes, nullptr); + if (mi == nullptr) + mi = findInterfaceMethod(interfaces[i]->GetInterfaces(), methodName, argTypes, bindingAttr); + } + return mi; +} + +// find method named methodName with signature as described by +// argTypes and binding attributes bindingAttr +MethodInfo^ InvokeMember::findMethod(Type ^type, const __wchar_t *methodName, cli::array ^argTypes, BindingFlags bindingAttr) { + // first try it directly + MethodInfo ^mi = type->GetMethod(gcnew String(methodName), bindingAttr, nullptr, argTypes, nullptr); + + // then try for all interfaces + if (mi == nullptr && type->IsInterface) { + mi = findInterfaceMethod(type->GetInterfaces(), methodName, argTypes, bindingAttr); + + // finally (still not found) check if its a method inherited from + // System.Object + if (mi == nullptr) + mi = findMethod(Object::typeid, methodName, argTypes, bindingAttr); + } + return mi; +} + +// provide informative message about which method wasn't found +void InvokeMember::throwMethodNotFoundError(Type ^type, const __wchar_t *methodName, cli::array ^argTypes, BindingFlags bindingAttr) { + String ^msg = String::Concat( + (int)(BindingFlags::Static & bindingAttr) ? "Static method not found: " : "Instance method not found: ", + type->FullName, + "::", + gcnew String(methodName) + ); + msg = String::Concat(msg, "("); + for (int i = 0; i < argTypes->Length; i++) { + if (i) + msg = String::Concat(msg, ","); + msg = String::Concat(msg, argTypes[i]->FullName); + } + msg = String::Concat(msg, ")"); + throw gcnew Exception (msg); +} + +// helper function to invoke static as well as instance methods +void* InvokeMember::invokeMethod(Object ^o, Type ^t, const __wchar_t *methodName, int nargs, void *args[], BindingFlags bindingAttr) { + try { + // first convert index arguments - nargs is the number of + // arguments, and args is an array of pointers to DotNetContainer + // objects + cli::array ^realArgs = gcnew cli::array(nargs); + cli::array ^realTypes = gcnew cli::array(nargs); + for (int i = 0; i < nargs; i++) { + DotNetContainer *c = static_cast(args[i]); + realArgs[i] = c->getContainerObject(); + realTypes[i] = c->getContainerType(); + } + + MethodInfo ^mi = findMethod(t, methodName, realTypes, bindingAttr); + if (mi == nullptr) + throwMethodNotFoundError(t, methodName, realTypes, bindingAttr); + + Object ^newInstance = mi->Invoke(o, realArgs); + + // for arguments that were pass-by-reference update the object + // slots of the corresponding containers + cli::array ^pi = mi->GetParameters(); + for (int i = 0; i < nargs; i++) + if (pi[i]->ParameterType->IsByRef) { + DotNetContainer *c = static_cast(args[i]); + c->setContainerObject(realArgs[i]); + } + + if (mi->ReturnType->Equals(Void::typeid)) { + // return a "void" InvocationResult object if the method doesn't + // return anything + return new InvocationResult(); + } else { + return new InvocationResult(newInstance, mi->ReturnType); + } + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// helper function to invoke static as well as instance methods +void* InvokeMember::invokeMethodDirectly(void *methodInfo, int nargs, void *args[], bool staticp) { + try { + // first convert index arguments - nargs is the number of + // arguments, and args is an array of pointers to DotNetContainer + // objects + int offset = staticp ? 0 : 1; + cli::array ^realArgs = gcnew cli::array(nargs - offset); + for (int i = 0; i + offset < nargs; i++) + realArgs[i] = static_cast(args[i + offset])->getContainerObject(); + + Object ^o = nullptr; + if (!staticp) + o = static_cast(args[0])->getContainerObject(); + + MethodInfo ^mi = safe_cast(static_cast(methodInfo)->getContainerObject()); + + Object ^newInstance = mi->Invoke(o, realArgs); + + // for arguments that were pass-by-reference update the object + // slots of the corresponding containers + cli::array ^pi = mi->GetParameters(); + for (int i = 0; i + offset < nargs; i++) + if (pi[i]->ParameterType->IsByRef) { + DotNetContainer *c = static_cast(args[i + offset]); + c->setContainerObject(realArgs[i]); + } + + if (mi->ReturnType->Equals(Void::typeid)) { + // return a "void" InvocationResult object if the method doesn't + // return anything + return new InvocationResult(); + } else { + return new InvocationResult(newInstance, mi->ReturnType); + } + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// below void pointers always point to DotNetContainer objects + +__declspec(dllexport) void* invokeInstanceMember(const __wchar_t *methodName, void *target, int nargs, void *args[]) { + DotNetContainer *container = static_cast(target); + Type ^t = container->getContainerType(); + Object ^o = container->getContainerObject(); + return InvokeMember::invokeMethod(o, t, methodName, nargs, args, static_cast(BindingFlags::Instance | BindingFlags::Public)); +} + +__declspec(dllexport) void* invokeInstanceMemberDirectly(void *methodInfo, int nargs, void *args[]) { + return InvokeMember::invokeMethodDirectly(methodInfo, nargs, args, false); +} + +__declspec(dllexport) void* invokeStaticMember(const __wchar_t *methodName, void *type, int nargs, void *args[]) { + Type ^t = safe_cast(static_cast(type)->getContainerObject()); + return InvokeMember::invokeMethod(nullptr, t, methodName, nargs, args, static_cast(BindingFlags::Static | BindingFlags::Public)); +} + +__declspec(dllexport) void* invokeStaticMemberDirectly(void *methodInfo, int nargs, void *args[]) { + return InvokeMember::invokeMethodDirectly(methodInfo, nargs, args, true); +} + +// not directly related, but I didn't know where to put it... :) +// "shortcut" function used by DO-RDNZL-ARRAY (see Lisp code) - +// returns an array element for arrays of rank 1 +__declspec(dllexport) void *getArrayElement(void *ptr, int index) { + try { + Array ^array = safe_cast(static_cast(ptr)->getContainerObject()); + Type ^elementType = array->GetType()->GetElementType(); + + return new InvocationResult(array->GetValue(index), elementType); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} Added: trunk/rdnzl-cpp/RDNZL/InvokeMember.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/InvokeMember.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,49 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/InvokeMember.h,v 1.14 2008/02/14 07:34:32 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "InvocationResult.h" + +public ref class InvokeMember { + public: + static void* invokeMethod(Object ^o, Type ^t, const __wchar_t *methodName, int nargs, void *args [], BindingFlags bindingAttr); + static void* invokeMethodDirectly(void *methodInfo, int nargs, void *args [], bool staticp); + private: + static MethodInfo^ findInterfaceMethod(cli::array ^interfaces, const __wchar_t *methodName, cli::array ^argTypes, BindingFlags bindingAttr); + static MethodInfo^ findMethod(Type ^type, const __wchar_t *methodName, cli::array ^argTypes, BindingFlags bindingAttr); + static void throwMethodNotFoundError(Type ^type, const __wchar_t *methodName, cli::array ^argTypes, BindingFlags bindingAttr); +}; + +extern "C" { + __declspec(dllexport) void *invokeInstanceMember(const __wchar_t *methodName, void *target, int nargs, void *args[]); + __declspec(dllexport) void* invokeInstanceMemberDirectly(void *methodInfo, int nargs, void *args[]); + __declspec(dllexport) void *invokeStaticMember(const __wchar_t *methodName, void *type, int nargs, void *args[]); + __declspec(dllexport) void* invokeStaticMemberDirectly(void *methodInfo, int nargs, void *args[]); + __declspec(dllexport) void *getArrayElement(void *ptr, int index); +} Added: trunk/rdnzl-cpp/RDNZL/Property.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/Property.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,195 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/Property.cpp,v 1.17 2008/02/14 11:54:03 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" +#include "Property.h" + +// provide informative message about which property wasn't found +void Property::throwPropertyNotFoundError(Type ^type, const __wchar_t *propertyName, cli::array ^argTypes, BindingFlags bindingAttr) { + String ^msg = String::Concat( + (int)(BindingFlags::Static & bindingAttr) ? "Static property not found: " : "Instance property not found: ", + type->FullName, + "->", + gcnew String(propertyName) + ); + for (int i = 0; i < argTypes->Length; i++) + msg = String::Concat(msg, "[", argTypes[i]->FullName, "]"); + throw gcnew Exception (msg); +} + +// helper function to get values of static and instance properties +void *Property::getPropertyValue(Object ^o, Type ^t, const __wchar_t *propertyName, BindingFlags bindingAttr, int nargs, void *args[]) { + try { + // first convert index arguments - nargs is the number of + // arguments, and args is an array of pointers to DotNetContainer + // objects + cli::array ^realArgs = gcnew cli::array(nargs); + cli::array ^realTypes = gcnew cli::array(nargs); + for (int i = 0; i < nargs; i++) { + DotNetContainer *c = static_cast(args[i]); + realArgs[i] = c->getContainerObject(); + realTypes[i] = c->getContainerType(); + } + + // find property by name, binding attributes and index signature + PropertyInfo ^pi = t->GetProperty(gcnew String(propertyName), bindingAttr, nullptr, nullptr, realTypes, nullptr); + + if (pi == nullptr) + throwPropertyNotFoundError(t, propertyName, realTypes, bindingAttr); + + return new InvocationResult(pi->GetValue(o, realArgs), pi->PropertyType); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// helper function to get values of static and instance properties +void *Property::getPropertyValueDirectly(void *propertyInfo, int nargs, void *args[], bool staticp) { + try { + // first convert index arguments - nargs is the number of + // arguments, and args is an array of pointers to DotNetContainer + // objects + int offset = staticp ? 0 : 1; + cli::array ^realArgs = gcnew cli::array(nargs - offset); + for (int i = 0; i + offset < nargs; i++) + realArgs[i] = static_cast(args[i + offset])->getContainerObject(); + Object ^o = nullptr; + if (!staticp) + o = static_cast(args[0])->getContainerObject(); + + PropertyInfo ^pi = safe_cast(static_cast(propertyInfo)->getContainerObject()); + + return new InvocationResult(pi->GetValue(o, realArgs), pi->PropertyType); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// helper function to set values of static and instance properties +void *Property::setPropertyValue(Object ^o, Type ^t, const __wchar_t *propertyName, BindingFlags bindingAttr, int nargs, void *args[]) { + try { + // first convert index arguments - nargs is the number of + // arguments, and args is an array of pointers to DotNetContainer + // objects + cli::array ^realArgs = gcnew cli::array(nargs - 1); + cli::array ^realTypes = gcnew cli::array(nargs - 1); + for (int i = 1; i < nargs; i++) { + DotNetContainer *c = static_cast(args[i]); + realArgs[i - 1] = c->getContainerObject(); + realTypes[i - 1] = c->getContainerType(); + } + + // find property by name, binding attributes and index signature + PropertyInfo ^pi = t->GetProperty(gcnew String(propertyName), bindingAttr, nullptr, nullptr, realTypes, nullptr); + + if (pi == nullptr) + throwPropertyNotFoundError(t, propertyName, realTypes, bindingAttr); + + // note that the new value is the first element of args + pi->SetValue(o, static_cast(args[0])->getContainerObject(), realArgs); + return new InvocationResult(); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// helper function to set values of static and instance properties +void *Property::setPropertyValueDirectly(void *propertyInfo, int nargs, void *args[], bool staticp) { + try { + // first convert index arguments - nargs is the number of + // arguments, and args is an array of pointers to DotNetContainer + // objects + int offset = staticp ? 0 : 1; + cli::array ^realArgs = gcnew cli::array(nargs - 1 - offset); + for (int i = 1; i + offset < nargs; i++) + realArgs[i - 1] = static_cast(args[i + offset])->getContainerObject(); + + Object ^o = nullptr; + if (!staticp) + o = static_cast(args[1])->getContainerObject(); + + PropertyInfo ^pi = safe_cast(static_cast(propertyInfo)->getContainerObject()); + + // note that the new value is the first element of args + pi->SetValue(o, static_cast(args[0])->getContainerObject(), realArgs); + return new InvocationResult(); + } catch (TargetInvocationException ^e) { + return new InvocationResult(e->InnerException, true); + } catch (Exception ^e) { + return new InvocationResult(e, true); + } +} + +// below void pointers always point to DotNetContainer objects + +__declspec(dllexport) void *getInstancePropertyValue(const __wchar_t *propertyName, void *target, int nargs, void *args[]) { + DotNetContainer *container = static_cast(target); + Type ^t = container->getContainerType(); + Object ^o = container->getContainerObject(); + return Property::getPropertyValue(o, t, propertyName, static_cast(BindingFlags::Instance | BindingFlags::Public), nargs, args); +} + +__declspec(dllexport) void *getStaticPropertyValue(const __wchar_t *propertyName, void *type, int nargs, void *args[]) { + Type ^t = safe_cast(static_cast(type)->getContainerObject()); + return Property::getPropertyValue(nullptr, t, propertyName, static_cast(BindingFlags::Static | BindingFlags::Public), nargs, args); +} + +__declspec(dllexport) void *setInstancePropertyValue(const __wchar_t *propertyName, void *target, int nargs, void *args[]) { + DotNetContainer *container = static_cast(target); + Type ^t = container->getContainerType(); + Object ^o = container->getContainerObject(); + return Property::setPropertyValue(o, t, propertyName, static_cast(BindingFlags::Instance | BindingFlags::Public), nargs, args); +} + +__declspec(dllexport) void *setStaticPropertyValue(const __wchar_t *propertyName, void *type, int nargs, void *args[]) { + Type ^t = safe_cast(static_cast(type)->getContainerObject()); + return Property::setPropertyValue(nullptr, t, propertyName, static_cast(BindingFlags::Static | BindingFlags::Public), nargs, args); +} + +__declspec(dllexport) void *getInstancePropertyValueDirectly(void *propertyInfo, int nargs, void *args[]) { + return Property::getPropertyValueDirectly(propertyInfo, nargs, args, false); +} + +__declspec(dllexport) void *getStaticPropertyValueDirectly(void *propertyInfo, int nargs, void *args[]) { + return Property::getPropertyValueDirectly(propertyInfo, nargs, args, true); +} + +__declspec(dllexport) void *setInstancePropertyValueDirectly(void *propertyInfo, int nargs, void *args[]) { + return Property::setPropertyValueDirectly(propertyInfo, nargs, args, false); +} + +__declspec(dllexport) void *setStaticPropertyValueDirectly(void *propertyInfo, int nargs, void *args[]) { + return Property::setPropertyValueDirectly(propertyInfo, nargs, args, true); +} + Added: trunk/rdnzl-cpp/RDNZL/Property.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/Property.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,52 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/Property.h,v 1.14 2008/02/14 07:34:32 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#include "InvocationResult.h" + +public ref class Property { + public: + static void *getPropertyValue(Object ^o, Type ^t, const __wchar_t *propertyName, BindingFlags bindingAttr, int nargs, void *args[]); + static void *setPropertyValue(Object ^o, Type ^t, const __wchar_t *propertyName, BindingFlags bindingAttr, int nargs, void *args[]); + static void *getPropertyValueDirectly(void *propertyInfo, int nargs, void *args[], bool staticp); + static void *setPropertyValueDirectly(void *propertyInfo, int nargs, void *args[], bool staticp); + private: + static void throwPropertyNotFoundError(Type ^type, const __wchar_t *propertyName, cli::array ^argTypes, BindingFlags bindingAttr); +}; + +extern "C" { + __declspec(dllexport) void *getInstancePropertyValue(const __wchar_t *propertyName, void *target, int nargs, void *args[]); + __declspec(dllexport) void *setInstancePropertyValue(const __wchar_t *propertyName, void *target, int nargs, void *args[]); + __declspec(dllexport) void *getStaticPropertyValue(const __wchar_t *propertyName, void *type, int nargs, void *args[]); + __declspec(dllexport) void *setStaticPropertyValue(const __wchar_t *propertyName, void *type, int nargs, void *args[]); + __declspec(dllexport) void *getInstancePropertyValueDirectly(void *propertyInfo, int nargs, void *args[]); + __declspec(dllexport) void *getStaticPropertyValueDirectly(void *propertyInfo, int nargs, void *args[]); + __declspec(dllexport) void *setInstancePropertyValueDirectly(void *propertyInfo, int nargs, void *args[]); + __declspec(dllexport) void *setStaticPropertyValueDirectly(void *propertyInfo, int nargs, void *args[]); +} Added: trunk/rdnzl-cpp/RDNZL/RDNZL.vcproj ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/RDNZL.vcproj Wed Apr 30 04:30:03 2008 @@ -0,0 +1,304 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Added: trunk/rdnzl-cpp/RDNZL/Stdafx.cpp ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/Stdafx.cpp Wed Apr 30 04:30:03 2008 @@ -0,0 +1,38 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/Stdafx.cpp,v 1.12 2008/02/14 11:54:03 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "stdafx.h" + +// see + +extern "C" __declspec(dllexport) void __stdcall DllEnsureInit(void) { + System::Threading::Thread::CurrentThread->ApartmentState = System::Threading::ApartmentState::STA; +} + +extern "C" __declspec(dllexport) void __stdcall DllForceTerm(void) { +} Added: trunk/rdnzl-cpp/RDNZL/Stdafx.h ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/Stdafx.h Wed Apr 30 04:30:03 2008 @@ -0,0 +1,41 @@ +// $Header: /usr/local/cvsrep/rdnzl-cpp/RDNZL/Stdafx.h,v 1.14 2008/02/14 11:54:03 edi Exp $ +// +// Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions +// are met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following +// disclaimer in the documentation and/or other materials +// provided with the distribution. +// +// THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +// OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +// WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +// ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +// DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +// GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +// WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#pragma once + +#using + +#include +#include + +using namespace System; +using namespace System::Reflection; +using namespace System::Reflection::Emit; +using namespace System::Runtime::CompilerServices; +using namespace System::Runtime::InteropServices; +using namespace System::Threading; Added: trunk/rdnzl-cpp/RDNZL/rdnzl.def ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/RDNZL/rdnzl.def Wed Apr 30 04:30:03 2008 @@ -0,0 +1,5 @@ +LIBRARY RDNZL + +EXPORTS + DllEnsureInit PRIVATE + DllForceTerm PRIVATE Added: trunk/rdnzl-cpp/README.txt ============================================================================== --- (empty file) +++ trunk/rdnzl-cpp/README.txt Wed Apr 30 04:30:03 2008 @@ -0,0 +1,6 @@ +This is the code for the "glue" library RDNZL.dll which belongs to the +RDNZL .NET bridge for Common Lisp. + +This C++ source code is known to work with Microsoft Visual Studio 2005. + +For more info about RDNZL see . From eweitz at common-lisp.net Wed Apr 30 08:36:17 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:36:17 -0400 (EDT) Subject: [rdnzl-cvs] r8 - in trunk/cl-gd: . doc test test/orig Message-ID: <20080430083617.C83916F23D@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:36:15 2008 New Revision: 8 Added: trunk/cl-gd/ trunk/cl-gd/CHANGELOG trunk/cl-gd/Makefile trunk/cl-gd/README trunk/cl-gd/cl-gd-glue.c trunk/cl-gd/cl-gd-test.asd trunk/cl-gd/cl-gd-test.lisp trunk/cl-gd/cl-gd.asd trunk/cl-gd/colors-aux.lisp trunk/cl-gd/colors.lisp trunk/cl-gd/doc/ trunk/cl-gd/doc/anti-aliased-lines.png (contents, props changed) trunk/cl-gd/doc/brushed-arc.png (contents, props changed) trunk/cl-gd/doc/chart.png (contents, props changed) trunk/cl-gd/doc/clipped-tangent.png (contents, props changed) trunk/cl-gd/doc/demooutp.png (contents, props changed) trunk/cl-gd/doc/gddemo.c trunk/cl-gd/doc/index.html trunk/cl-gd/doc/smallzappa.png (contents, props changed) trunk/cl-gd/doc/strings.png (contents, props changed) trunk/cl-gd/doc/triangle.png (contents, props changed) trunk/cl-gd/doc/zappa-ellipse.png (contents, props changed) trunk/cl-gd/doc/zappa-green.jpg (contents, props changed) trunk/cl-gd/doc/zappa.jpg (contents, props changed) trunk/cl-gd/drawing.lisp trunk/cl-gd/gd-uffi.lisp trunk/cl-gd/images.lisp trunk/cl-gd/init.lisp trunk/cl-gd/misc.lisp trunk/cl-gd/packages.lisp trunk/cl-gd/specials.lisp trunk/cl-gd/strings.lisp trunk/cl-gd/svn-commit.tmp trunk/cl-gd/test/ trunk/cl-gd/test/demoin.png (contents, props changed) trunk/cl-gd/test/orig/ trunk/cl-gd/test/orig/anti-aliased-lines.png (contents, props changed) trunk/cl-gd/test/orig/brushed-arc.png (contents, props changed) trunk/cl-gd/test/orig/chart.png (contents, props changed) trunk/cl-gd/test/orig/circle.png (contents, props changed) trunk/cl-gd/test/orig/clipped-tangent.png (contents, props changed) trunk/cl-gd/test/orig/one-line.jpg (contents, props changed) trunk/cl-gd/test/orig/one-line.png (contents, props changed) trunk/cl-gd/test/orig/one-pixel.jpg (contents, props changed) trunk/cl-gd/test/orig/one-pixel.png (contents, props changed) trunk/cl-gd/test/orig/triangle.png (contents, props changed) trunk/cl-gd/test/orig/zappa-ellipse.png (contents, props changed) trunk/cl-gd/test/orig/zappa-green.jpg (contents, props changed) trunk/cl-gd/test/smallzappa.png (contents, props changed) trunk/cl-gd/test/zappa.jpg (contents, props changed) trunk/cl-gd/transform.lisp trunk/cl-gd/util.lisp Log: Import 0.5.6 Added: trunk/cl-gd/CHANGELOG ============================================================================== --- (empty file) +++ trunk/cl-gd/CHANGELOG Wed Apr 30 04:36:15 2008 @@ -0,0 +1,102 @@ +Version 0.5.6 +2007-07-29 +Make WITH-TRANSFORMATIONS thread-safe (thanks to Alain Picard) + +Version 0.5.5 +2007-04-24 +Ugh, fix the fix once more (again thanks to Jong-won Choi) + +Version 0.5.4 +2007-04-06 +Trying to fix the 0.5.3 fix... (bug reported by Jong-won Choi) + +Version 0.5.3 +2007-03-19 +Fixed bug in DRAW-FREETYPE-STRING (reported by Andrei Stebakov) + +Version 0.5.2 +2007-02-28 +Fix CONVERT-TO-CHAR-REFERENCES (bug caught by Luo Yong) +Documentation fixes (thanks to Yoni Rabkin Katzenell) + +Version 0.5.1 +2005-10-04 +Support for OpenMCL via CFFI (thanks to Bryan O'Connor) + +Version 0.5.0 +2005-09-26 +Experimental CLISP/CFFI support (thanks to Luis Oliveira) +Don't redefine what's already there (for LispWorks) + +Version 0.4.8 +2005-05-17 +Re-enabled the ability to build without GIF support + +Version 0.4.7 +2005-05-07 +Added GET-PIXEL (provided by Alan Shields) + +Version 0.4.6 +2005-03-31 +Fixed typo in WITH-IMAGE* (thanks to Peter Barabas) +Handle CMUCL search lists correctly (thanks to Hans H?bner) +Added -lc option to linker call and included makefile (thanks to Hans H?bner) + +Version 0.4.5 +2005-03-16 +Fixed type check in MAKE-STREAM-FN (thanks to Walter C. Pelissero) + +Version 0.4.4 +2005-03-09 +More bug fixes (thanks to Carlos Ungil) + +Version 0.4.3 +2005-03-09 +Some bug fixes (thanks to Carlos Ungil) + +Version 0.4.2 +2004-11-26 +Build GIF support by default +Added link to cl-gd-glue.dll for Windows and corresponding documentation +Updated files in test/orig + +Version 0.4.1 +2004-05-21 +Replaced WRITE-BYTE with WRITE-SEQUENCE for LispWorks - see + +Version 0.3.1 +2004-04-25 +Two separate C source files (with and without GIF support) +Added note about failed tests +Added hyperdoc support +Added :CL-GD to *FEATURES* + +Version 0.3.0 +2004-03-29 +Added GIF support (thanks to Hans H?bner) +Added Gentoo link + +Version 0.2.0 +2003-10-26 +Added DO-PIXELS and friends (proposed by Kevin Rosenberg) +Added Debian link + +Version 0.1.4 +2003-08-29 +Added library path for Debian compatibility (thanks to Kevin Rosenberg) + +Version 0.1.3 +2003-08-29 +Make CL-GD-TEST output less verbose for SBCL (thanks to Christophe Rhodes) + +Version 0.1.2 +2003-08-28 +Changed WITH-TRANSFORMATION macro to keep SBCL from complaining (thanks to Christophe Rhodes) + +Version 0.1.1 +2003-08-28 +Fixed *NULL-IMAGE* bug in DRAW-FREETYPE-STRING + +Version 0.1.0 +2003-08-26 +Initial release Added: trunk/cl-gd/Makefile ============================================================================== --- (empty file) +++ trunk/cl-gd/Makefile Wed Apr 30 04:36:15 2008 @@ -0,0 +1,11 @@ +# this should work for FreeBSD and most Linux distros + +cl-gd-glue.so: + gcc -I/usr/local/include -fPIC -c cl-gd-glue.c + ld -shared -lgd -lz -lpng -ljpeg -lfreetype -liconv -lm -lc cl-gd-glue.o -o cl-gd-glue.so -L/usr/local/lib + rm cl-gd-glue.o + +# this should work for Mac OS X + +cl-gd-glue.dylib: + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib Added: trunk/cl-gd/README ============================================================================== --- (empty file) +++ trunk/cl-gd/README Wed Apr 30 04:36:15 2008 @@ -0,0 +1,69 @@ +Complete documentation for CL-GD can be found in the 'doc' +directory. + +CL-GD also supports Nikodemus Siivola's HYPERDOC, see + and +. + +1. Installation (see doc/index.html for Windows instructions) + +1.1. Download and install a recent version of asdf. + +1.2. Download and install UFFI. CL-GD needs at least version 1.3.4 of + UFFI to work properly. However, as of August 2003, only + AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported + because CL-GD needs the new UFFI macros WITH-CAST-POINTER and + DEF-FOREIGN-VAR which haven't yet been ported to all UFFI + platforms. + +1.3. Download and install a recent version of GD and its supporting + libraries libpng, zlib, libjpeg, libiconv, and libfreetype. CL-GD has + been tested with GD 2.0.33, versions older than 2.0.28 won't + work. Note that you won't be able to compile CL-GD unless you have + installed all supporting libraries. This is different from using + GD directly from C where you only have to install the libraries + you intend to use. + +1.4. Unzip and untar the file cl-gd.tgz and put the resulting + directory wherever you want, then cd into this directory. + +1.5. Compile cl-gd-glue.c into a shared library for your platform. On + Linux this would be + + gcc -fPIC -c cl-gd-glue.c + ld -lgd -lz -lpng -ljpeg -lfreetype -lm -liconv -shared cl-gd-glue.o -o cl-gd-glue.so + rm cl-gd-glue.o + + For Mac OS X, use + + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib + +1.6. Make sure that cl-gd.asd can be seen from asdf (this is usually + achieved by a symbolic link), start your favorite Lisp, and compile + CL-GD: + + (asdf:oos 'asdf:compile-op :cl-gd) + + From now on you can simply load CL-GD into a running Lisp image + with + + (asdf:oos 'asdf:load-op :cl-gd) + +2. Test + +CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then + + (asdf:oos 'asdf:load-op :cl-gd-test) + (cl-gd-test:test) + +If you have the georgiab.ttf TrueType font from Microsoft you can also +check the FreeType support of CL-GD with + + (cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf") + +where you should obviously replace the path above with the full path +to the font on your machine. + +(See the note about failed tests in the documentation.) \ No newline at end of file Added: trunk/cl-gd/cl-gd-glue.c ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd-glue.c Wed Apr 30 04:36:15 2008 @@ -0,0 +1,187 @@ +/* Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE + GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + +#include +#include +#include "gd.h" + +gdImagePtr gdImageCreateFromJpegFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromJpeg(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +#ifndef GD_DONT_USE_GIF +gdImagePtr gdImageCreateFromGifFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGif(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} +#endif + +gdImagePtr gdImageCreateFromPngFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromPng(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGdFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2File (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2PartFile (char *filename, int *err, int srcX, int srcY, int w, int h) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2Part(in, srcX, srcY, w, h); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromXbmFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromXbm(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +int gdImageGetAlpha (gdImagePtr im, int color) { + return gdImageAlpha(im, color); +} + +int gdImageGetRed (gdImagePtr im, int color) { + return gdImageRed(im, color); +} + +int gdImageGetGreen (gdImagePtr im, int color) { + return gdImageGreen(im, color); +} + +int gdImageGetBlue (gdImagePtr im, int color) { + return gdImageBlue(im, color); +} + +int gdImageGetSX (gdImagePtr im) { + return gdImageSX(im); +} + +int gdImageGetSY (gdImagePtr im) { + return gdImageSY(im); +} + +int gdImageGetColorsTotal (gdImagePtr im) { + return gdImageColorsTotal(im); +} + +/* dumb names, I know... */ +int gdImageGetGetInterlaced (gdImagePtr im) { + return gdImageGetInterlaced(im); +} + +int gdImageGetGetTransparent (gdImagePtr im) { + return gdImageGetTransparent(im); +} Added: trunk/cl-gd/cl-gd-test.asd ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd-test.asd Wed Apr 30 04:36:15 2008 @@ -0,0 +1,45 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.asd,v 1.11 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd-test.system + (:use :cl :asdf)) + +(in-package :cl-gd-test.system) + +(defparameter *cl-gd-test-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd-test + :version "0.4.8" + :components ((:file "cl-gd-test")) + :depends-on (:cl-gd)) + Added: trunk/cl-gd/cl-gd-test.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd-test.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,490 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.lisp,v 1.26 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage #:cl-gd-test + (:use #:cl + #:cl-gd) + (:export #:test)) + +(in-package :cl-gd-test) + +(defparameter *test-directory* + (merge-pathnames (make-pathname :directory '(:relative "test")) + (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + + "Where test files are put.") + +(defun test-file-location (name &optional (type :unspecific)) + "Create test file location from NAME and TYPE component." + (make-pathname :name name + :type type + :defaults *test-directory*)) + +(defun compare-files (file &key type expected-result) + "Compare test file FILE to orginal file in subdirectory ORIG." + (with-image-from-file (image file) + (with-image-from-file (orig (merge-pathnames + (make-pathname :type + (or type (pathname-type file)) + :directory + '(:relative "orig")) + file)) + (equal (differentp image orig) + expected-result)))) + +(defun test-001 () + (let ((file (test-file-location "one-pixel" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-002 () + (let ((file (test-file-location "one-pixel" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-003 () + (let ((file (test-file-location "one-line" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-004 () + (let ((file (test-file-location "one-line" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing PNG file + (compare-files file))) + +(defun test-005 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (let ((num (number-of-colors))) + (find-color 255 255 255 :resolve t) + (multiple-value-bind (width height) + (image-size) + (and (= width 40) + (= height 40) + ;; FIND-COLOR should not have changed the number of + ;; colors + (= num (number-of-colors))))))) + +(defun test-006 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (with-transformation (:x1 0.1 :x2 0.5 :y1 10.8 :y2 20.9) + (multiple-value-bind (width height) + (image-size) + ;; make sure WITH-TRANSFORMATION returns transformed size + (and (>= 0.0001 (abs (- 0.4 width))) + (>= 0.0001 (abs (- 10.1 height)))))))) + +(defun test-007 () + (let ((file (test-file-location "circle" "png"))) + (with-image* (40 40) + (allocate-color 255 255 255) + (let ((black (allocate-color 0 0 0))) + (with-default-color (black) + ;; move origin to center and stretch + (with-transformation (:x1 -100 :width 200 :y1 -100 :height 200) + (draw-filled-circle 0 0 50) + (write-image-to-file file + :if-exists :supersede))))) + (compare-files file))) + +(defun test-008 () + (with-image (image 40 40) + (allocate-color 255 255 255 :image image) + (with-default-color ((allocate-color 0 0 0 :image image)) + ;; no transformation and use more general ellipse function + (draw-filled-ellipse 20 20 20 20 :image image) + (with-image-from-file (other-image + (test-file-location "circle" "png")) + (not (differentp image other-image)))))) + +(defun test-009 () + (let ((file (test-file-location "chart" "png"))) + ;; create 200x200 pixel image + (with-image* (200 200) + ;; background color + (allocate-color 68 70 85) + (let ((beige (allocate-color 222 200 81)) + (brown (allocate-color 206 150 75)) + (green (allocate-color 104 156 84)) + (red (allocate-color 163 83 84)) + (white (allocate-color 255 255 255)) + (two-pi (* 2 pi))) + ;; move origin to center of image + (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t) + ;; draw some 'pie slices' + (draw-arc 0 0 130 130 0 (* .6 two-pi) + :center-connect t :filled t :color beige) + (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi) + :center-connect t :filled t :color brown) + (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi) + :center-connect t :filled t :color green) + (draw-arc 0 0 130 130 (* .95 two-pi) two-pi + :center-connect t :filled t :color red) + ;; use GD fonts + (with-default-color (white) + (with-default-font (:small) + (draw-string -8 -30 "60%") + (draw-string -20 40 "20%") + (draw-string 20 30 "15%")) + (draw-string -90 90 "Global Revenue" + :font :large)) + (write-image-to-file file + :compression-level 6 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-010 () + (let ((file (test-file-location "zappa-green" "jpg"))) + ;; get JPEG from disk + (with-image-from-file (old (test-file-location "zappa" "jpg")) + (multiple-value-bind (width height) + (image-size old) + (with-image (new width height) + ;; green color for background + (allocate-color 0 255 0 :image new) + ;; merge with original JPEG + (copy-image old new 0 0 0 0 width height + :merge 50) + (write-image-to-file file + :image new + :if-exists :supersede)))) + (compare-files file))) + +(defun test-011 () + ;; small image + (with-image* (10 10) + (loop for i below +max-colors+ do + ;; allocate enough colors (all gray) to fill the palette + (allocate-color i i i)) + (and (= +max-colors+ (number-of-colors)) + (null (find-color 255 0 0 :exact t)) + (let ((match (find-color 255 0 0))) ; green + (and (= 85 + (color-component :red match) + (color-component :green match) + (color-component :blue match))))))) + +(defun test-012 () + (let ((file (test-file-location "triangle" "png"))) + (with-image* (100 100) + (allocate-color 255 255 255) ; white background + (let ((red (allocate-color 255 0 0)) + (yellow (allocate-color 255 255 0)) + (orange (allocate-color 255 165 0))) + ;; thin black border + (draw-rectangle* 0 0 99 99 + :color (allocate-color 0 0 0)) + ;; lines are five pixels thick + (with-thickness (5) + ;; colored triangle + (draw-polygon (list 10 10 90 50 50 90) + ;; styled color + :color (list red red red + yellow yellow yellow + nil nil nil + orange orange orange)) + (write-image-to-file file + :compression-level 8 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-013 () + (let ((file (test-file-location "brushed-arc" "png"))) + (with-image* (200 100) + (allocate-color 255 165 0) ; orange background + (with-image (brush 6 6) + (let* ((black (allocate-color 0 0 0 :image brush)) ; black background + (red (allocate-color 255 0 0 :image brush)) + (blue (allocate-color 0 0 255 :image brush))) + (setf (transparent-color brush) black) ; make background transparent + ;; now set the pixels in the brush + (set-pixels '(2 2 2 3 3 2 3 3) + :color blue :image brush) + (set-pixels '(1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4) + :color red :image brush) + ;; then use it to draw an arc + (draw-arc 100 50 180 80 180 300 :color (make-brush brush))) + (write-image-to-file file + :compression-level 7 + :if-exists :supersede))) + (compare-files file))) + +(defun test-014 () + (let ((file (test-file-location "anti-aliased-lines" "png"))) + (with-image* (150 50) + (let ((orange (allocate-color 255 165 0)) ; orange background + (white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0))) + ;; white background rectangle in the middle third + (draw-rectangle* 50 0 99 49 + :filled t + :color white) + (with-thickness (2) + ;; just a red line + (draw-line 5 10 145 10 :color red) + ;; anti-aliased red line + (draw-line 5 25 145 25 :color (make-anti-aliased red)) + ;; anti-aliased red line which should stand out against + ;; orange background + (draw-line 5 40 145 40 :color (make-anti-aliased red orange)))) + (write-image-to-file file + :compression-level 3 + :if-exists :supersede)) + (compare-files file))) + +(defun test-015 () + (let ((file (test-file-location "clipped-tangent" "png"))) + (with-image* (150 150) + (allocate-color 255 255 255) ; white background + ;; transform such that x axis ranges from (- PI) to PI and y + ;; axis ranges from -3 to 3 + (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3) + (let ((black (allocate-color 0 0 0)) + (red (allocate-color 255 0 0)) + (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5))) + (with-default-color (black) + ;; draw axes + (draw-line 0 -3 0 3 :color black) + (draw-line (- pi) 0 pi 0)) + ;; show clipping rectangle (styled) + (draw-rectangle rectangle :color (list black black black nil black nil)) + (with-clipping-rectangle (rectangle) + ;; draw tangent function + (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do + (set-pixel x (tan x) :color red))))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun gd-demo-picture (file random-state &optional write-file) + (with-image* ((+ 256 384) 384 t) + (let ((white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0)) + (green (allocate-color 0 255 0)) + (blue (allocate-color 0 0 255)) + (vertices (list 64 0 0 128 128 128)) + (image-width (image-width)) + (image-height (image-height))) + (setf (transparent-color) white) + (draw-rectangle* 0 0 image-width image-height :color white) + (with-image-from-file (in-file (test-file-location "demoin" "png")) + (copy-image in-file *default-image* + 0 0 32 32 192 192 + :resize t + :dest-width 255 + :dest-height 255 + :resample t) + (multiple-value-bind (in-width in-height) + (image-size in-file) + (loop for a below 360 by 45 do + (copy-image in-file *default-image* + 0 0 + (+ 256 192 (* 128 (cos (* a .0174532925)))) + (- 192 (* 128 (sin (* a .0174532925)))) + in-width in-height + :rotate t + :angle a)) + (with-default-color (green) + (with-thickness (4) + (draw-line 16 16 240 16) + (draw-line 240 16 240 240) + (draw-line 240 240 16 240) + (draw-line 16 240 16 16)) + (draw-polygon vertices :filled t)) + (dotimes (i 3) + (incf (nth (* 2 i) vertices) 128)) + (draw-polygon vertices + :color (make-anti-aliased green) + :filled t) + (with-default-color (blue) + (draw-arc 128 128 60 20 0 720) + (draw-arc 128 128 40 40 90 270) + (fill-image 8 8)) + (with-image (brush 16 16 t) + (copy-image in-file brush + 0 0 0 0 + in-width in-height + :resize t + :dest-width (image-width brush) + :dest-height (image-height brush)) + (draw-line 0 255 255 0 + :color (cons (make-brush brush) + (list nil nil nil nil nil nil nil t)))))) + (with-default-color (red) + (draw-string 32 32 "hi" :font :giant) + (draw-string 64 64 "hi" :font :small)) + (with-clipping-rectangle* (0 (- image-height 100) 100 image-height) + (with-default-color ((make-anti-aliased white)) + (dotimes (i 100) + (draw-line (random image-width random-state) + (random image-height random-state) + (random image-width random-state) + (random image-height random-state)))))) + (setf (interlacedp) t) + (true-color-to-palette) + (if write-file + (write-image-to-file file + :if-exists :supersede) + (with-image-from-file (demo-file file) + (not (differentp demo-file *default-image*)))))) + +(defun test-016 () + (let* ((file (test-file-location "demooutp" "png")) + (random-state-1 (make-random-state t)) + (random-state-2 (make-random-state random-state-1))) + (gd-demo-picture file random-state-1 t) + (gd-demo-picture file random-state-2))) + +(defun test-017 () + (let ((file (test-file-location "zappa-ellipse" "png"))) + (with-image* (250 150) + (with-image-from-file (zappa (test-file-location "smallzappa" "png")) + (setf (transparent-color) (allocate-color 255 255 255)) + (draw-filled-ellipse 125 75 250 150 + :color (make-tile zappa))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun test-018 () + (let (result) + (with-image* (3 3) + (allocate-color 255 255 255) + (draw-line 0 0 2 2 :color (allocate-color 0 0 0)) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 1) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 1) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 1)))))) + +(defun test-019 () + (let (result) + (with-image* (3 3 t) + (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0)) + (draw-line 0 0 2 2 :color (allocate-color 255 255 255)) + (do-pixels () + (unless (zerop (raw-pixel)) + (decf (raw-pixel) #xff))) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 #xffff00) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 #xffff00) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 #xffff00)))))) + +(defun test-020 (georgia) + ;; not used for test suite because of dependency on font + (with-image* (200 200) + ;; set background (white) and make it transparent + (setf (transparent-color) + (allocate-color 255 255 255)) + (loop for angle from 0 to (* 2 pi) by (/ pi 6) + for blue downfrom 255 by 20 do + (draw-freetype-string 100 100 "Common Lisp" + :font-name georgia + :angle angle + ;; note that ALLOCATE-COLOR won't work + ;; here because the anti-aliasing uses + ;; up too much colors + :color (find-color 0 0 blue + :resolve t))) + (write-image-to-file (test-file-location "strings" "png") + :if-exists :supersede))) + +(defun test% (georgia) + (loop for i from 1 to (if georgia 20 19) do + (handler-case + (format t "Test ~A ~:[failed~;succeeded~].~%" i + (let ((test-function + (intern (format nil "TEST-~3,'0d" i) + :cl-gd-test))) + (if (= i 20) + (funcall test-function georgia) + (funcall test-function)))) + (error (condition) + (format t "Test ~A failed with the following error: ~A~%" + i condition))) + (force-output)) + (format t "Done.~%")) + +(defun test (&optional georgia) + #-:sbcl + (test% georgia) + #+:sbcl + (handler-bind ((sb-ext:compiler-note #'muffle-warning)) + (test% georgia))) \ No newline at end of file Added: trunk/cl-gd/cl-gd.asd ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd.asd Wed Apr 30 04:36:15 2008 @@ -0,0 +1,58 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd.asd,v 1.18 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd.system + (:use :cl :asdf) + (:export :*cl-gd-directory*)) + +(in-package :cl-gd.system) + +(defparameter *cl-gd-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd + :version "0.5.6" + :serial t + :components ((:file "packages") + (:file "util") + (:file "specials") + (:file "init") + (:file "gd-uffi") + (:file "transform") + (:file "images") + (:file "colors-aux") + (:file "colors") + (:file "drawing") + (:file "strings") + (:file "misc")) + :depends-on (#-(or :clisp :openmcl) :uffi + #+(or :clisp :openmcl) :cffi-uffi-compat)) Added: trunk/cl-gd/colors-aux.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/colors-aux.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,168 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun current-brush (&optional (image *default-image*)) + "Returns the GD image which is the current brush of IMAGE \(or NIL +if there is no current brush)." + (check-type image image) + (let ((brush (get-slot-value (img image) 'gd-image 'brush))) + (if (null-pointer-p brush) + nil + brush))) + +(defun (setf current-brush) (brush &optional (image *default-image*)) + "Sets BRUSH \(which must be a GD image) to be the current brush +for IMAGE." + (check-type brush image) + (check-type image image) + (gd-image-set-brush (img image) (img brush)) + brush) + +(defun current-tile (&optional (image *default-image*)) + "Returns the GD image which is the current tile of IMAGE \(or NIL +if there is no current tile)." + (check-type image image) + (let ((tile (get-slot-value (img image) 'gd-image 'tile))) + (if (null-pointer-p tile) + nil + tile))) + +(defun (setf current-tile) (tile &optional (image *default-image*)) + "Sets TILE \(which must be a GD image) to be the current tile +for IMAGE." + (check-type tile (or image null)) + (check-type image image) + (gd-image-set-tile (img image) (img tile)) + tile) + +(defun current-style (&optional (image *default-image*)) + "Returns the current style of IMAGE as a list." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop for i below style-length + collect (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))))) + +(defun current-style* (&key (image *default-image*)) + "Returns the current style of IMAGE as an array." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop with result = (make-array style-length) + for i below style-length + do (setf (aref result i) + (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))) + finally (return result)))) + +(defgeneric (setf current-style) (style &optional image) + (:documentation "Sets STYLE to be the current drawing style for +IMAGE. STYLE can be a LIST or a VECTOR. Each element of STYLE is +either a color or NIL \(for transparent pixels).")) + +(defmethod (setf current-style) ((style list) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color in style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defmethod (setf current-style) ((style vector) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color across style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defun set-anti-aliased (color do-not-blend &optional (image *default-image*)) + "Set COLOR to be the current anti-aliased color of +IMAGE. DO-NOT-BLEND \(if provided) is the background color +anti-aliased lines stand out against clearly." + (check-type color integer) + (check-type do-not-blend (or integer null)) + (check-type image image) + (gd-image-set-anti-aliased-do-not-blend (img image) + color + (or do-not-blend -1))) + +(defun resolve-c-color (color image) + "Accepts a CL-GD 'color' COLOR and returns the corresponding +argument for GD, modifying internal slots of IMAGE if needed." + (etypecase color + (brush + (setf (current-brush image) color) + +brushed+) + (tile + (setf (current-tile image) color) + +tiled+) + ((cons brush (or vector list)) + (setf (current-brush image) (car color) + (current-style image) (cdr color)) + +styled-brushed+) + (anti-aliased-color + (set-anti-aliased (color color) + (do-not-blend color) + image) + +anti-aliased+) + ((or vector list) + (setf (current-style image) color) + +styled+) + (integer + color))) + +(defmacro with-color-argument (&body body) + "Internal macro used to give correct color arguments to enclosed +foreign functions. Assumes fixed names COLOR and IMAGE." + (with-unique-names (c-color-arg) + `(let ((,c-color-arg (resolve-c-color color image))) + ,@(sublis (list (cons 'color c-color-arg)) + body :test #'eq)))) Added: trunk/cl-gd/colors.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/colors.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,247 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors.lisp,v 1.25 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-color ((color) &body body) + "Executes BODY with *DEFAULT-COLOR* bound to COLOR so that you don't +have to provide the COLOR keyword/optional argument to drawing +functions." + `(let ((*default-color* ,color)) + , at body)) + +(defun allocate-color (red green blue &key alpha (errorp t) (image *default-image*)) + "Finds the first available color index in the image IMAGE specified, +sets its RGB values to those requested \(255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value +in the case of a true color image. In either case you can then use the +returned value as a COLOR parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If ALPHA +\(not greater than 127) is provided, an RGBA color will always be +allocated. If all +GD-MAX-COLORS+ have already been allocated this +function will, depending on the value of ERRORP, either raise an error +or return NIL." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (let ((result + (if alpha + (gd-image-color-allocate-alpha (img image) red green blue alpha) + (gd-image-color-allocate (img image) red green blue)))) + (cond ((and errorp + (= result -1)) + (error "Can't allocate color")) + ((= result -1) + nil) + (t + result)))) + +(defun deallocate-color (color &optional (image *default-image*)) + "Marks the specified color COLOR as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image IMAGE." + (check-type color integer) + (check-type image image) + (gd-image-color-deallocate (img image) color)) + +(defun transparent-color (&optional (image *default-image*)) + "Returns the transparent color of IMAGE \(or NIL if there is none)." + (check-type image image) + (gd-image-get-transparent (img image))) + +(defun (setf transparent-color) (color &optional (image *default-image*)) + "Makes COLOR the transparent color of IMAGE. If COLOR is NIL the +image won't have a transparent color. Note that JPEG images don't +support transparency." + (check-type color (or null integer)) + (check-type image image) + (gd-image-color-transparent (img image) (or color -1)) + color) + +(defun true-color-p (&optional (image *default-image*)) + "Returns true iff IMAGE is a true color image." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'true-color)))) + +(defun number-of-colors (&key (image *default-image*)) + "Returns the number of color allocated in IMAGE. Returns NIL if +IMAGE is a true color image." + (check-type image image) + (if (true-color-p image) + nil + (get-slot-value (img image) 'gd-image 'colors-total))) + +(defun find-color (red green blue &key alpha exact hwb resolve (image *default-image*)) + "Tries to find and/or allocate a color from IMAGE's color +palette. If EXACT is true, the color will only be returned if it is +already allocated. If EXACT is NIL, a color which is 'close' to the +color specified by RED, GREEN, and BLUE \(and probably ALPHA) might be +returned \(unless there aren't any colors allocated in the image +yet). If HWB is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If RESOLVE is true a color \(probably a new one) will +always be returned, otherwise the result of this function might be +NIL. If ALPHA \(not greater than 127) is provided, an RGBA color (or +NIL) will be returned. + +ALPHA, EXACT, and HWB are mutually exclusive. RESOLVE can't be used +together with EXACT or HWB." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (when (< 1 (count-if #'identity (list alpha exact hwb))) + (error "You can't specify two of ALPHA, EXACT, and HWB at the same +time")) + (when (and hwb resolve) + (error "You can't specify HWB and RESOLVE at the same time")) + (when (and exact resolve) + (error "You can't specify EXACT and RESOLVE at the same time")) + (let ((result + (cond ((and resolve alpha) + (gd-image-color-resolve-alpha (img image) red green blue alpha)) + (resolve + (gd-image-color-resolve (img image) red green blue)) + (alpha + (gd-image-color-closest-alpha (img image) red green blue alpha)) + (exact + (gd-image-color-exact (img image) red green blue)) + (hwb + (gd-image-color-closest-hwb (img image) red green blue)) + (t + (gd-image-color-closest (img image) red green blue))))) + (if (= result -1) + nil + result))) + +(defun thickness (&optional (image *default-image*)) + "Gets the width of lines drawn by the drawing functions. Note that +this is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type image image) + (get-slot-value (img image) 'gd-image 'thick)) + +(defun (setf thickness) (thickness &optional (image *default-image*)) + "Sets the width of lines drawn by the drawing functions. Note that +THICKNESS is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type thickness integer) + (check-type image image) + (gd-image-set-thickness (img image) thickness) + thickness) + +(defmacro with-thickness ((thickness &key (image '*default-image*)) &body body) + "Executes BODY with the current line width of IMAGE set to +THICKNESS. The image's previous line width is guaranteed to be +restored before the macro exits. Note that the line width is measured +in pixels and is not affected by WITH-TRANSFORMATION." + (with-unique-names (old-thickness) + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (thickness image) + `(let ((,old-thickness (thickness ,image))) + (unwind-protect + (progn + (setf (thickness ,image) ,thickness)) + , at body) + (setf (thickness ,image) ,old-thickness))))) + +(defun alpha-blending-p (&optional (image *default-image*)) + "Returns whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(return value is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(return value is true). This is +only meaningful for true color images." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'alpha-blending-flag)))) + +(defun (setf alpha-blending-p) (blending &optional (image *default-image*)) + "Determines whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(if BLENDING is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(if BLENDING is true). This is +only meaningful for true color images." + (check-type image image) + (gd-image-alpha-blending (img image) (if blending 1 0)) + blending) + +(defun save-alpha-p (&optional (image *default-image*)) + "Returns whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'save-alpha-flag)))) + +(defun (setf save-alpha-p) (save &key (image *default-image*)) + "Determines whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (gd-image-save-alpha (img image) (if save 1 0)) + save) + +(defun color-component (component color &key (image *default-image*)) + "Returns the specified color component of COLOR. COMPONENT can be +one of :RED, :GREEN, :BLUE, and :ALPHA." + (check-type color integer) + (check-type image image) + (funcall (ecase component + ((:red) #'gd-image-get-red) + ((:green) #'gd-image-get-green) + ((:blue) #'gd-image-get-blue) + ((:alpha) #'gd-image-get-alpha)) + (img image) + color)) + +(defun color-components (color &key (image *default-image*)) + "Returns a list of the color components of COLOR. The +components are in the order red, green, blue, alpha." + (mapcar #'(lambda (c) (color-component c color :image image)) + '(:red :green :blue :alpha))) + +(defun find-color-from-image (color source-image &key alpha exact hwb + resolve (image *default-image*)) + "Returns the color in IMAGE corresponding to COLOR in +SOURCE-IMAGE. The keyword parameters are passed to FIND-COLOR." + (let ((red (color-component :red color + :image source-image)) + (blue (color-component :blue color + :image source-image)) + (green (color-component :green color + :image source-image)) + (alpha (when alpha + (color-component :alpha color + :image source-image)))) + (find-color red green blue + :alpha alpha + :exact exact + :hwb hwb + :resolve resolve + :image image))) Added: trunk/cl-gd/doc/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/brushed-arc.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/chart.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/demooutp.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/gddemo.c ============================================================================== --- (empty file) +++ trunk/cl-gd/doc/gddemo.c Wed Apr 30 04:36:15 2008 @@ -0,0 +1,169 @@ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include +#include +#include +#include "gd.h" +#include "gdfontg.h" +#include "gdfonts.h" + +int +main (void) +{ +#ifdef HAVE_LIBPNG + /* Input and output files */ + FILE *in; + FILE *out; + + /* Input and output images */ + gdImagePtr im_in = 0, im_out = 0; + + /* Brush image */ + gdImagePtr brush; + + /* Color indexes */ + int white; + int blue; + int red; + int green; + + /* Points for polygon */ + gdPoint points[3]; + int i; + + /* Create output image, in true color. */ + im_out = gdImageCreateTrueColor (256 + 384, 384); + /* 2.0.2: first color allocated would automatically be background in a + palette based image. Since this is a truecolor image, with an + automatic background of black, we must fill it explicitly. */ + white = gdImageColorAllocate (im_out, 255, 255, 255); + gdImageFilledRectangle (im_out, 0, 0, gdImageSX (im_out), + gdImageSY (im_out), white); + + /* Set transparent color. */ + gdImageColorTransparent (im_out, white); + + /* Try to load demoin.png and paste part of it into the + output image. */ + in = fopen ("demoin.png", "rb"); + if (!in) + { + fprintf (stderr, "Can't load source image; this demo\n"); + fprintf (stderr, "is much more impressive if demoin.png\n"); + fprintf (stderr, "is available.\n"); + im_in = 0; + } + else + { + int a; + im_in = gdImageCreateFromPng (in); + fclose (in); + /* Now copy, and magnify as we do so */ + gdImageCopyResampled (im_out, im_in, 32, 32, 0, 0, 192, 192, 255, 255); + /* Now display variously rotated space shuttles in a circle of our own */ + for (a = 0; (a < 360); a += 45) + { + int cx = cos (a * .0174532925) * 128; + int cy = -sin (a * .0174532925) * 128; + gdImageCopyRotated (im_out, im_in, + 256 + 192 + cx, 192 + cy, + 0, 0, gdImageSX (im_in), gdImageSY (im_in), a); + } + } + red = gdImageColorAllocate (im_out, 255, 0, 0); + green = gdImageColorAllocate (im_out, 0, 255, 0); + blue = gdImageColorAllocate (im_out, 0, 0, 255); + /* Fat Rectangle */ + gdImageSetThickness (im_out, 4); + gdImageLine (im_out, 16, 16, 240, 16, green); + gdImageLine (im_out, 240, 16, 240, 240, green); + gdImageLine (im_out, 240, 240, 16, 240, green); + gdImageLine (im_out, 16, 240, 16, 16, green); + gdImageSetThickness (im_out, 1); + /* Circle */ + gdImageArc (im_out, 128, 128, 60, 20, 0, 720, blue); + /* Arc */ + gdImageArc (im_out, 128, 128, 40, 40, 90, 270, blue); + /* Flood fill: doesn't do much on a continuously + variable tone jpeg original. */ + gdImageFill (im_out, 8, 8, blue); + /* Polygon */ + points[0].x = 64; + points[0].y = 0; + points[1].x = 0; + points[1].y = 128; + points[2].x = 128; + points[2].y = 128; + gdImageFilledPolygon (im_out, points, 3, green); + /* 2.0.12: Antialiased Polygon */ + gdImageSetAntiAliased (im_out, green); + for (i = 0; (i < 3); i++) + { + points[i].x += 128; + } + gdImageFilledPolygon (im_out, points, 3, gdAntiAliased); + /* Brush. A fairly wild example also involving a line style! */ + if (im_in) + { + int style[8]; + brush = gdImageCreateTrueColor (16, 16); + gdImageCopyResized (brush, im_in, + 0, 0, 0, 0, + gdImageSX (brush), gdImageSY (brush), + gdImageSX (im_in), gdImageSY (im_in)); + gdImageSetBrush (im_out, brush); + /* With a style, so they won't overprint each other. + Normally, they would, yielding a fat-brush effect. */ + style[0] = 0; + style[1] = 0; + style[2] = 0; + style[3] = 0; + style[4] = 0; + style[5] = 0; + style[6] = 0; + style[7] = 1; + gdImageSetStyle (im_out, style, 8); + /* Draw the styled, brushed line */ + gdImageLine (im_out, 0, 255, 255, 0, gdStyledBrushed); + } + /* Text (non-truetype; see gdtestft for a freetype demo) */ + gdImageString (im_out, gdFontGiant, 32, 32, (unsigned char *) "hi", red); + gdImageStringUp (im_out, gdFontSmall, 64, 64, (unsigned char *) "hi", red); + /* Random antialiased lines; coordinates all over the image, + but the output will respect a small clipping rectangle */ + gdImageSetClip(im_out, 0, gdImageSY(im_out) - 100, + 100, gdImageSY(im_out)); + /* Fixed seed for reproducibility of results */ + srand(100); + for (i = 0; (i < 100); i++) { + int x1 = rand() % gdImageSX(im_out); + int y1 = rand() % gdImageSY(im_out); + int x2 = rand() % gdImageSX(im_out); + int y2 = rand() % gdImageSY(im_out); + gdImageSetAntiAliased(im_out, white); + gdImageLine (im_out, x1, y1, x2, y2, gdAntiAliased); + } + /* Make output image interlaced (progressive, in the case of JPEG) */ + gdImageInterlace (im_out, 1); + out = fopen ("demoout.png", "wb"); + /* Write PNG */ + gdImagePng (im_out, out); + fclose (out); + /* 2.0.12: also write a paletteized version */ + out = fopen ("demooutp.png", "wb"); + gdImageTrueColorToPalette (im_out, 0, 256); + gdImagePng (im_out, out); + fclose (out); + gdImageDestroy (im_out); + if (im_in) + { + gdImageDestroy (im_in); + } +#else + fprintf (stderr, "No PNG library support.\n"); +#endif /* HAVE_LIBPNG */ + return 0; +} Added: trunk/cl-gd/doc/index.html ============================================================================== --- (empty file) +++ trunk/cl-gd/doc/index.html Wed Apr 30 04:36:15 2008 @@ -0,0 +1,1441 @@ + + + + + + CL-GD - Use the GD Graphics library from Common Lisp + + + + + +

CL-GD - Use the GD Graphics library from Common Lisp

+ +
+
 

Abstract

+ +CL-GD is a library for Common Lisp which provides an interface to the +GD Graphics Library for the +dynamic creation of images. It is based on UFFI and should thus be portable to all +CL implementations supported by UFFI. +

+A version which also works with CLISP is available from http://ungil.com/cl-gd-clisp.tgz +thanks to Carlos Ungil. Also, beginning from version 0.5.0/0.5.1, CL-GD +contains initial code to support CLISP and OpenMCL via CFFI (thanks to Luis +Oliveira and Bryan O'Connor). Please try it and report to the mailing list if you +have problems. +

+The focus of CL-GD is convenience and correctness, not necessarily speed. If you think CL-GD is too slow and you're concerned about speed, contact me before you start coding in C... :) +

+CL-GD comes with a BSD-style +license so you can basically do with it whatever you want. Please send bug reports to the mailing list mentioned below if you encounter any problems with CL-GD. (I'm glad to fix CL-GD but I can't do much about GD, of course. So if CL-GD basically works for you but you encounter seemingly strange behaviour when drawing please try if and how you can achieve the intended result with GD directly. That would help me a lot. Thanks.) +

+CL-GD is used by QuickHoney. + +

+Download shortcut: http://weitz.de/files/cl-gd.tar.gz. +

+ +
 

A simple example

+ +The image to the right was created with this piece of code: + +
+chart.png(with-image* (200 200) ; create 200x200 pixel image
+  (allocate-color 68 70 85) ; background color
+  (let ((beige (allocate-color 222 200 81))
+        (brown (allocate-color 206 150 75))
+        (green (allocate-color 104 156 84))
+        (red (allocate-color 163 83 84))
+        (white (allocate-color 255 255 255))
+        (two-pi (* 2 pi)))
+    ;; move origin to center of image
+    (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t)
+      ;; draw some 'pie slices'
+      (draw-arc 0 0 130 130 0 (* .6 two-pi)
+                :center-connect t :filled t :color beige)
+      (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi)
+                :center-connect t :filled t :color brown)
+      (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi)
+                :center-connect t :filled t :color green)
+      (draw-arc 0 0 130 130 (* .95 two-pi) two-pi
+                :center-connect t :filled t :color red)
+      (with-default-color (white)
+        (with-default-font (:small)
+          (draw-string -8 -30 "60%")
+          (draw-string -20 40 "20%")
+          (draw-string 20 30 "15%"))
+        (draw-freetype-string -90 75 "Global Revenue"
+                              ;; this assumes that 'DEFAULT_FONTPATH'
+                              ;; is set correctly
+                              :font-name "verdanab"))))
+  (write-image-to-file "chart.png"
+                       :compression-level 6 :if-exists :supersede))
+
+ +

+See below for more examples. + +
 

Contents

+ + +
 

Download and installation

+ +CL-GD together with this documentation can be downloaded from http://weitz.de/files/cl-gd.tar.gz. The +current version is 0.5.6. A Debian package is available thanks to Peter van Eynde and Kevin Rosenberg, so if you're on Debian you should have no problems installing CL-GD. There's also a port +for Gentoo Linux thanks to Matthew Kennedy. Otherwise, proceed like this: +
    +
  • Download and install a recent version of asdf. +
  • Download and install UFFI. CL-GD needs at least version 1.3.4 of UFFI to work properly. However, as of August 2003, only AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported because CL-GD needs the new UFFI macros WITH-CAST-POINTER and DEF-FOREIGN-VAR which haven't yet been ported to all UFFI platforms. Note: For CLISP or OpenMCL download and install CFFI instead. +
  • Download and install a recent version of GD and its supporting libraries libpng, zlib, libjpeg, libfreetype, and maybe libiconv. CL-GD has been tested and developed with GD 2.0.28, older version probably won't work. Note that you won't be able to compile CL-GD unless you have installed all supporting libraries. This is different from using GD directly from C where you only have to install the libraries you intend to use. +
  • Download cl-gd.tar.gz, unzip and untar the file and put the resulting directory wherever you want, then cd into this directory. +
  • Compile cl-gd-glue.c into a shared library for your platform. On FreeBSD or Linux this would be +
    +gcc -fPIC -c cl-gd-glue.c
+ld -lgd -lz -lpng -ljpeg -lfreetype -lm -shared cl-gd-glue.o -o cl-gd-glue.so
+rm cl-gd-glue.o
+
    +(Note: On older versions of Linux, you might have to add -liconv.) +

    +For Mac OS X, use +

    +gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib
+
    +
  • Make sure that cl-gd.asd can be seen from asdf (this is usually achieved by a symbolic link), start your favorite Lisp, and compile CL-GD: +
    +(asdf:oos 'asdf:compile-op :cl-gd)
+
    +
  • From now on you can simply load CL-GD into a running Lisp image with +
    +(asdf:oos 'asdf:load-op :cl-gd)
+
    +
  • To build without GIF support compile the C library with the option -DGD_DONT_USE_GIF and push the symbol :CL-GD-NO-GIF onto *FEATURES* before compiling CL-GD. + +
  • CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then +
    +(asdf:oos 'asdf:load-op :cl-gd-test)
+(cl-gd-test:test)
+
    +If you have the georgiab.ttf +TrueType font from Microsoft you can also check the FreeType +support of CL-GD with +
    +(cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf")
+
    +where you should obviously replace the path above with the pull path +to the font on your machine.
+

+Note that CL-GD might work correctly even if some of the tests fail +(as long as you don't get error messages). The exact results of the +tests seem to depend on the versions of the C libraries which are +used. +

+It is recommended that you at least skim over the original GD documentation before you start using CL-GD. +

+Note: If you're on Windows you might want to try this: +

    +
  • Download and install the supporting libraries (see above) from GnuWin32 and put the DLLs into a place where your Lisp's FFI will find them. The folder where your Lisp image starts up is usually a good place. +
  • Download the file cl-gd-glue.dll from http://weitz.de/files/cl-gd-glue.dll and put it into the CL-GD folder. You don't need to download and install GD itself because it's already integrated into cl-gd-glue.dll. +
  • Start your Lisp and compile CL-GD as described above. +
+This works for me on Windows XP pro SP2 with AllegroCL 6.2 trial as well as with LispWorks 4.3.7 pro. +

+Luís Oliveira maintains a darcs +repository of CL-GD +at http://common-lisp.net/~loliveira/ediware/. + + +
 

Support and mailing lists

+ +For questions, bug reports, feature requests, improvements, or patches +please use the cl-gd-devel +mailing list. If you want to be notified about future releases +subscribe to the cl-gd-announce +mailing list. These mailing lists were made available thanks to +the services of common-lisp.net. +

+If you want to send patches, please read this first. + +
 

Images

+ +In order to work with CL-GD you first have to create at least one +image - think of it as your canvas, kind of. Images can be +created from scratch or you can load an existing image file from +disk. After you've drawn something or otherwise modified your image +you can write it to a file or a stream. Once you're done with it you +must destroy it to avoid memory leaks. It is recommended that +you use the WITH-IMAGE- macros instead of the +CREATE-IMAGE- functions so you can be sure that images +will always be destroyed no matter what happens. + +


[Function] +
create-image width height &optional true-color => image + +


+Allocates and returns an image with size width x height (in pixels). Creates a true color image if +true-color is true - the default is NIL. You are responsible for +destroying the image after you're done with it. It is advisable to use +WITH-IMAGE instead. +
+ +


[Function] +
create-image-from-file file-name &optional type => image + +


+Creates an image from the file specified by file-name (which is +either a pathname or a string). The type of the image can be provided +as type (one of the keywords :JPG, :JPEG, :GIF, :PNG, :GD, :GD2, :XBM, or :XPM), or otherwise it will be guessed from the PATHNAME-TYPE of +file-name. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead. +
+ +


[Function] +
create-image-from-gd2-part file-name src-x src-y width height => image + +


+Creates an image from the part of the GD2 file specified by file-name (which is +either a pathname or a string) specified by src-x, src-y, width, and height. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead. +
+ +


[Function] +
destroy-image image => result + +


+Destroys (deallocates) image which has been created by CREATE-IMAGE, +CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART. result is always NIL. +
+ +


[Macro] +
with-image (name width height &optional true-color) form* => results + +


+Creates an image as with CREATE-IMAGE and executes +form* with the image bound to +name. The image is +guaranteed to be destroyed before this macro exits. +
+ +


[Macro] +
with-image-from-file (name file-name &optional type) form* => results + +


+Creates an image as with CREATE-IMAGE-FROM-FILE and executes +form* with the image bound to +name. The image is +guaranteed to be destroyed before this macro exits. +
+ +
+(with-image-from-file (old "zappa.jpg")zappa-green.jpgzappa.jpg
+  (multiple-value-bind (width height)
+      (image-size old)
+    (with-image (new width height)
+      (allocate-color 0 255 0 :image new) ; green background
+      (copy-image old new 0 0 0 0 width height
+                  :merge 50)
+      (write-image-to-file "zappa-green.jpg"
+                           :image new
+                           :if-exists :supersede))))
+
+ +


[Macro] +
with-image-from-gd2-part (name file-name src-x src-y width height) form* => results + +


+Creates an image as with CREATE-IMAGE-FROM-GD2-PART and executes +form* with the image bound to +name. The image is +guaranteed to be destroyed before this macro exits. +
+ +


[Special variable] +
*default-image* + +


+Whenever a CL-GD function or macro has an optional or keyword argument called image the default is to use *default-image*. The idea behind this is that you'll never have to provide these arguments as long as you work with one image at a time (which should be the usual case). See the example at the top of the page. +
+ +


[Macro] +
with-default-image (image) form* => results + +


+This is just a convenience macro which will execute form* with *DEFAULT-IMAGE* bound to image. +
+ + +


[Macro] +
with-image* (width height &optional true-color) form* => results +


[Macro] +
with-image-from-file* (file-name &optional type) form* => results +


[Macro] +
with-image-from-gd2-part* (file-name src-x src-y width height) form* => results + +


+These are essentially like their asterisk-less counterparts but bind the image to *DEFAULT-IMAGE* instead. +
+ + +

+For the rest of this document, whenever a function expects an image as +one of its arguments you must pass a value which was created +with one of the functions or macros above. An image should be +considered an opaque object which you can pass to CL-GD functions but +should otherwise leave alone. (Internally it is a foreign pointer +wrapped in a CL-GD::IMAGE structure in order to enable +type checking.) + +


[Function] +
write-jpeg-to-stream stream &key quality image => image + +


+Writes image image to the stream +stream as a JPEG file. If +quality is not specified, the default IJG JPEG +quality value is used. Otherwise, +quality must be an integer in the range 0-100. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-png-to-stream stream &key compression-level image => image + +


+Writes image image to the stream +stream as a PNG file. If +compression-level is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of 1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-wbmp-to-stream stream &key foreground image => image + +


+Writes image image to the stream +stream as a WBMP (wireless bitmap) file. WBMP file support is black and white +only. The color specified by the foreground argument is the +"foreground," and only pixels of this color will be set in the WBMP +file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-gd-to-stream stream &key image => image + +


+Writes image image to the stream +stream as a GD file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-gif-to-stream stream &key image => image + +


+Writes image image to the stream +stream as a GIF file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-gd2-to-stream stream &key image => image + +


+Writes image image to the stream +stream as a GD2 file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-image-to-stream stream type &key &allow-other-keys => image + +


+Writes image image to the stream +stream. The type of the image is determined by type +which must be one of the keywords :JPG, :JPEG, :GIF, :PNG, :WBMP, :GD, or :GD2. The rest of the keyword arguments are handed over to the corresponding WRITE-XXX-TO-STREAM function. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-image-to-file file-name &key type if-exists &allow-other-keys => image + +


+Writes image image to the file specified by file-name (which is +either a pathname or a string). The type argument is interpreted as in WRITE-IMAGE-TO-STREAM. If it is not provided it will be guessed from the PATHNAME-TYPE of +file-name. The if-exists keyword argument is given to OPEN, +the rest of the keyword arguments are handed over to the corresponding WRITE-XXX-TO-STREAM function. +
+ +


[Function] +
image-width &optional image => width + +


+Returns the width of the image image. The result of this function is affected by WITH-TRANSFORMATION. +
+ +


[Function] +
image-height &optional image => height + +


+Returns the height of the image image. The result of this function is affected by WITH-TRANSFORMATION. +
+ +


[Function] +
image-size &optional image => width, height + +


+Returns the width and height of the image image as two values. The results of this function are affected by WITH-TRANSFORMATION. +
+ +
 

Colors

+ +Images in CL-GD are usually palette-based (although true color images +are also supported) and colors have to be allocated before they can be used, i.e. whenever a function expects a color as +one of its arguments you must pass a value which was created +with one of the functions below or with a 'special' color as described in the next section. +

+Colors +are determined by specifying values for their red, green, blue, and +optionally alpha components. The first +three have to be integer values in the range 0-255 while the last +one has to be in the range 0-127. For a palette-based image the +first color you allocate will be its background color. Note that +colors are allocated per image, i.e. you can't allocate a color in one +image and then use it to draw something in another image. +

+See also the next section for some 'special colors.' + +


[Special variable] +
*default-color* + +


+Whenever a CL-GD function or macro has an optional or keyword argument called color the default is to use *default-color*. See WITH-DEFAULT-COLOR below. +
+ +


[Macro] +
with-default-color (color) form* => results + +


+This is just a convenience macro which will execute form* with *DEFAULT-COLOR* bound to color. +
+ +


[Function] +
allocate-color red green blue &key alpha errorp image => color + +


+Finds the first available color index in the image image specified, +sets its RGB values to those requested (255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value in +the case of a true color image. In either case you can then use the +returned value as a color parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If +alpha (not greater than 127) is provided, an RGBA color will always +be allocated. If all +MAX-COLORS+ have already been allocated this +function will, depending on the value of errorp, either raise an error +or return NIL. The default is to raise an error. +
+ +


[Function] +
find-color red green blue &key alpha exact hwb resolve image => color + +


+Tries to find and/or allocate a color from image's color +palette. If exact is true, the color will only be returned if it is +already allocated. If exact is false, a color which is 'close' to +the color specified by red, green, and blue (and probably alpha) +might be returned (unless there aren't any colors allocated in the +image yet). If hwb is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If resolve is true a color (probably a new one) will +always be returned, otherwise the result of this function might be +NIL. If alpha (not greater than 127) is provided, an RGBA color (or +NIL) will be returned. +alpha, exact, and hwb are mutually exclusive. resolve can't be used +together with exact or hwb. +
+ +


[Function] +
find-color-from-image color source-image &key alpha exact hwb resolve image => color + +


+Tries to find and/or allocate a color from image's color +palette that corresponds to color in source-image. +find-color-from-image calls find-color +with the color components of color. +Refer to find-color for a description of the +keyword arguments. +
+ +


[Function] +
color-component color component &key image => component + +


+Returns the specified color component of color. component can be +one of :RED, :GREEN, :BLUE, and :ALPHA. +
+ +


[Function] +
color-components color &key image => components + +


+Returns the color components of color as a list. The components are in the +order red, green, blue, alpha. +
+ +
+* (defun foo ()
+    (with-image* (10 10)
+      (loop for i below +max-colors+ do
+            ;; allocate enough colors (all gray) to fill the palette
+            (allocate-color i i i))
+      (format t "Number of colors allocated: ~A~%" (number-of-colors))
+      (format t "Maximal number of colors: ~A~%" +max-colors+)
+      (format t "Exact match for red: ~A~%" (find-color 255 0 0 :exact t))
+      (format t "Red, green, and blue components of 'closest' match for red: ~A~%"
+              (let ((match (find-color 255 0 0)))
+                (if match
+                  (list (color-component :red match)
+                        (color-component :green match)
+                        (color-component :blue match))))))
+    (values))
+
+FOO
+* (foo)
+Number of colors allocated: 256
+Maximal number of colors: 256
+Exact match for red: NIL
+Red, green, and blue components of 'closest' match for red: (64 64 64)
+
+ +


[Function] +
deallocate-color color &optional image => color + +


+Marks the specified color color as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image image. +
+ +


[Function] +
true-color-p &optional image => result + +


+Returns true iff image is a true color image. +
+ +


[Function] +
number-of-colors &optional image => result + +


+Returns the number of colors allocated in image or NIL if image is a true color image. +
+ +


[Constant] +
+max-colors+ + +


+Maximum number of colors for palette-based images. +
+ +


[Accessor] +
transparent-color &optional image => color +
(setf (transparent-color &optional image) color) + +


+Gets and sets the transparent color of image. If color is NIL there is no transparent color. +
+ +


[Accessor] +
alpha-blending-p &optional image => blending +
(setf (alpha-blending-p &optional image) blending) + +


+Gets and set whether pixels drawn on image will be copied literally +including alpha channel information (if blending is false) or if +their alpha channel information will determine how much of the +underlying color will shine through (if blending is true). This is +only meaningful for true color images. +
+ +


[Accessor] +
save-alpha-p &optional image => save +
(setf (save-alpha-p &optional image) save) + +


+Gets and sets whether PNG images will be saved with full alpha channel information. +
+ +
+(with-image* (200 100)brushed-arc.png
+  (allocate-color 255 165 0) ; orange background
+  (with-image (brush 6 6)
+    (let* ((black (allocate-color 0 0 0 :image brush)) ; black background
+           (red (allocate-color 255 0 0 :image brush))
+           (blue (allocate-color 0 0 255 :image brush)))
+      (setf (transparent-color brush) black) ; make background transparent
+      ;; now set the pixels in the brush
+      (set-pixels '(2 2 2 3 3 2 3 3)
+                  :color blue :image brush)
+      (set-pixels '(3 2 3 3 1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4)
+                  :color red :image brush)
+      ;; then use it to draw an arc
+      (draw-arc 100 50 180 80 180 300
+                ;; convert BRUSH to brush
+                :color (make-brush brush)))
+  (write-image-to-file "brushed-arc.png"
+                       :compression-level 7
+                       :if-exists :supersede)))
+
+ +
 

Styles, brushes, tiles, anti-aliased lines

+ +Most drawing and string +functions (with DRAW-FREETYPE-STRING +being the only exception) will, when expecting a color, also accept other types of arguments. The +full range of allowed types which can be used for +color keyword arguments is listed below: + +
    +
  • A style which is either a list or a vector of colors + allocated with one of the functions described above or + NIL for transparent colors. When a style is used as the + color, the colors of the pixels are drawn successively from the + sequence provided. If the corresponding element of the sequence is + NIL, that pixel is not altered. + +
  • A brush as created with MAKE-BRUSH for drawing lines. A + brush is itself an image created as described + above. When a brush is used as the color, the brush image is drawn + in place of each pixel of the line drawn. (The brush is usually + larger than one pixel, creating the effect of a wide paintbrush.) + +
  • A tile as created with MAKE-TILE for filling regions. A + tile is itself an image created as described + above. When a tile is used as the color, a pixel from the tile image + is selected in such a way as to ensure that the filled area will be + tiled with copies of the tile image. + +
  • A CONS where the CAR is a brush and + the CDR is a list or a vector. This is called a + styled brush. When a styled brush is used as the color, the + brush image is drawn at each pixel of the line, provided that the + corresponding element of the style sequence is true. + (Pixels are drawn successively from the style as the line is drawn, + returning to the beginning when the available pixels in the style + are exhausted.) Note that the semantics described here differ + slightly from the styles described above. + +
  • An anti-aliased color as created with MAKE-ANTI-ALIASED for + drawing lines. When an anti-aliased color is used, the line is drawn + with anti-aliasing mechanisms to minimize any "jagged" + appearance. + +
  • A 'normal' color as created with one of the functions from the + previous section. + +
+ +Note that you can't arbitrarily combine 'color types' and drawing +functions, e.g. you can't set an anti-aliased pixel. However, it +should generally be obvious which types make sense and which don't. +Check the original GD +documentation for more details. +

+In GD itself, if you, say, change a brush after you've 'set' it with +gdImageSetBrush +but before you actually use it for drawing these changes won't be +visible, i.e. the brush is 'frozen' once it's 'set.' The same applies +to tiles and styles. CL-GD's behaviour differs in this regard, +i.e. brushes, tiles, and styles are 'set' at the very moment they're +used. This introduces a little bit of overhead but feels more 'Lisp-y' +and intuitive to me. + +


[Function] +
make-brush image => brush + +


+ +Creates a brush from the image image. Note that the new +brush is still 'linked' to image, i.e. changes you +make to image will also be visible in the +brush - the brush is just a kind of 'tagged' image. + +
+ +


[Function] +
make-tile image => tile + +


+ +Creates a tile from the image image. Note that the new +tile is still 'linked' to image, i.e. changes you +make to image will also be visible in the +tile - the tile is just a kind of 'tagged' image. + +
+ +


[Function] +
make-anti-aliased color &optionaldo-not-blend => color' + +


+ +Creates an anti-aliased color from the +color +color. do-not-blend (if provided) is the +color anti-aliased lines stand out against clearly. + +
+ +
+(with-image* (150 50)anti-aliased-lines.png
+  (let ((orange (allocate-color 255 165 0)) ; orange background
+        (white (allocate-color 255 255 255))
+        (red (allocate-color 255 0 0)))
+    ;; white background rectangle in the middle third
+    (draw-rectangle* 50 0 99 49
+                    :filled t
+                    :color white)
+    (with-thickness (2)
+      ;; just a red line
+      (draw-line 5 10 145 10 :color red)
+      ;; anti-aliased red line
+      (draw-line 5 25 145 25 :color (make-anti-aliased red))
+      ;; anti-aliased red line which should stand out against
+      ;; orange background
+      (draw-line 5 40 145 40 :color (make-anti-aliased red orange))))
+  (write-image-to-file "anti-aliased-lines.png"
+                       :compression-level 3
+                       :if-exists :supersede))
+
+ +
 

Transformations

+ +Usually, CL-GD coordinates and dimensions (width and height) have to be integers. The origin (0,0) of an image is its upper left corner and all other points like (X,Y) have positive X and Y values. Angles are also provided as integers (in the range 0-360) meaning degrees. A transformation provides a way to change this. + +


[Macro] +
with-transformation (&key x1 x2 width y1 y2 height reverse-x reverse-y radians image) form* => results + +


+Executes form* such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of image will start at x1 and end at x2 and +have length width. The new y-axis of image will start at y1 and end at +y2 and have length height. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +reverse-x is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to reverse-y, of course. If radians is true angles inside of +the macro's body will be assumed to be provided in radians, otherwise in degrees. The previous transformation (if any) will be restored before this macro exits. +

+with-transformation macros can be nested but they always transform the original coordinates of the image, i.e. you shouldn't expect that, say, two succesive applications of reverse-x will neutralize each other. There's a little bit of overhead involved with this macro, so it is recommended to wrap it around everything you do with an image instead of calling it repeatedly. Note that transformations are always bound to one particular image. +

+ +


[Macro] +
without-transformations form* => results + +


+Executes form* without any transformations applied. +
+ +
 

Drawing and filling

+ +This section (and the next one about strings) finally describes how you can actually change the visual appearance of an image. You can set single pixels, draw lines or geometric figures, and fill regions. Note that the current transformation (if any) applies to the input and output of these functions. + +


[Function] +
get-pixel x y &key image => color + +


+Returns the color of the pixel specified by x and y. +
+ +


[Function] +
set-pixel x y &key color image => x, y + +


+Sets the pixel specified by x and y to the color specified by color. +
+ +


[Generic function] +
set-pixels points &key color image => points + +


+Sets the pixels specified by points which can be a list (X1 Y1 X2 Y2 ...) or a vector #(X1 Y1 X2 Y2 ...) to the color specified by color. +
+ +


[Function] +
draw-line x1 y1 x2 y2 &key color image => x1, y1, x2, y2 + +


+Draws a line with color color from point (x1,y1) to point (x2,y2). +
+ +


[Function] +
draw-rectangle rectangle &key filled color image => rectangle + +


+Draws a rectangle with upper left corner (X1,Y1) and lower right corner (X2,Y2) where rectangle is the list (X1 Y2 X2 Y2). If filled is true the rectangle will be filled with color, otherwise it will be outlined. +
+ +


[Function] +
draw-rectangle* x1 y1 x2 y2 &key filled color image => x1, y1, x2, y2 + +


+Draws a rectangle with upper left corner (x1,y1) and lower right corner (x2,y2). If filled is true the rectangle will be filled with color, otherwise it will be outlined. +
+ +


[Generic function] +
draw-polygon vertices &key filled start end color image => vertices + +


+Draws a polygon with the vertices (at least three) +specified as a list (X1 Y1 X2 Y2 ...) or as a vector #\(X1 Y1 X2 Y2 ...). +If filled is true the polygon will be filled with the color color, +otherwise it will be outlined. If start and/or end are specified then +only the corresponding part of vertices is used as input. +
+ +
+(with-image* (100 100)triangle.png
+  (allocate-color 255 255 255) ; white background
+  (let ((red (allocate-color 255 0 0))
+        (yellow (allocate-color 255 255 0))
+        (orange (allocate-color 255 165 0)))
+    ;; thin black border
+    (draw-rectangle* 0 0 99 99
+                     :color (allocate-color 0 0 0))
+    ;; line thickness is five pixels
+    (with-thickness (5)
+      ;; triangle
+      (draw-polygon (list 10 10 90 50 50 90)
+                    ;; styled color
+                    :color (list red red red
+                                 yellow yellow yellow
+                                 nil nil nil
+                                 orange orange orange))
+      (write-image-to-file "triangle.png"
+                           :compression-level 8
+                           :if-exists :supersede))))
+
+ +


[Function] +
draw-filled-circle center-x center-y radius &key color image => center-x center-y radius + +


+Draws a filled circle with center (center-x,center-y) and radius radius. +
+ +


[Function] +
draw-filled-ellipse center-x center-y width height &key color image => center-x center-y width height + +


+Draws a filled ellipse with center (center-x,center-y), width width, and height height. +
+ +
+(with-image* (250 150)
+  (with-image-from-file (zappa "smallzappa.png")zappa-ellipse.png
+    (setf (transparent-color) (allocate-color 255 255 255))
+    (draw-filled-ellipse 125 75 250 150
+                         :color (make-tile zappa)))
+  (write-image-to-file "zappa-ellipse.png"
+                       :if-exists :supersede))
+
+ +


[Function] +
draw-arc center-x center-y width height start end &key straight-line center-connect filled color image => center-x, center-y, width, height, start, end + +


+Draws a partial ellipse centered at (center-x,center-y) with +width width and height height. The arc begins at angle start and ends +at angle end. If straight-line is true the start and end points are +just connected with a straight line. If center-connect is true, they +are connected to the center (which is useful to create 'pie +slices' - see example at the top of the page.). If filled is true the arc will be filled with the color color, otherwise it will be outlined. +
+ +


[Function] +
fill-image x y &key border color image => x, y + +


+Floods a portion of the image image with the color color beginning +at point (x,y) and extending into the surrounding region. If border +is true it must be a color and the filling will stop at the specified +border color. (You can't use 'special colors' for the border color.) Otherwise only points with the same color as the +starting point will be colored. If color is a tile the tile must not have a transparent color. +
+ +


[Accessor] +
clipping-rectangle &optional image => rectangle +
(setf (clipping-rectangle &optional image) rectangle) + +


+Gets and sets the clipping rectangle of image where rectangle should be a +list (X1 Y1 X2 Y2) describing the upper left and lower right corner of the rectangle. Once a clipping rectangle has been set, all future drawing operations on image will remain within the specified clipping area, until a new clipping rectangle is established. For instance, if a clipping rectangle (25 25 75 75) has been set within a 100x100 image, a diagonal line from (0,0) to (99,99) will appear only between (25,25) and (75,75). See also CLIPPING-RECTANGLE* and SET-CLIPPING-RECTANGLE*. +
+ +


[Function] +
clipping-rectangle* &optional image => x1, y1, x2, y2 + +


+Returns the clipping rectangle of image as four values. +
+ +


[Function] +
set-clipping-rectangle* x1 y1 x2 y2 &optional image => x1, y1, x2, y2 + +


+Sets the clipping rectangle of image as if set with (SETF (CLIPPING-RECTANGLE IMAGE) (LIST X1 Y1 X2 Y2)). +
+ +


[Macro] +
with-clipping-rectangle (rectangle &key image) form* => results + +


+Executes form* with the clipping rectangle of image set to rectangle +which should be a list as in CLIPPING-RECTANGLE. The previous clipping rectangle +is guaranteed to be restored before the macro exits. +
+ +


[Macro] +
with-clipping-rectangle* (x1 y1 x2 y2 &key image) form* => results + +


+Executes form* with the clipping rectangle of image set as if set with (SETF (CLIPPING-RECTANGLE IMAGE) (LIST X1 Y1 X2 Y2)). The previous clipping rectangle +is guaranteed to be restored before the macro exits. +
+ +
+(with-image* (150 150)clipped-tangent.png
+  (allocate-color 255 255 255) ; white background
+  ;; transform such that x axis ranges from (- PI) to PI and y
+  ;; axis ranges from -3 to 3
+  (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3)
+    (let ((black (allocate-color 0 0 0))
+          (red (allocate-color 255 0 0))
+          (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5)))
+      (with-default-color (black)
+        ;; draw axes
+        (draw-line 0 -3 0 3 :color black)
+        (draw-line (- pi) 0 pi 0))
+      ;; show clipping rectangle (styled)
+      (draw-rectangle rectangle :color (list black black black nil black nil))
+      (with-clipping-rectangle (rectangle)
+        ;; draw tangent function
+        (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do
+              (set-pixel x (tan x) :color red)))))
+  (write-image-to-file "clipped-tangent.png"
+                       :if-exists :supersede))
+
+ +


[Accessor] +
current-thickness &optional image => thickness +
(setf (current-thickness &optional image) thickness) + +


+Get and sets the current thickness of image in pixels. This determines the width of lines drawn with the drawing functions. thickness has to be an integer. See also WITH-THICKNESS. +
+ +


[Macro] +
with-thickness (thickness &key image) form* => results + +


+Executes form* with the current thickness of image set to thickness. The image's previous thickness is guaranteed to be restored +before the macro exits. +
+ +
 

Characters and strings

+ +CL-GD (actually GD) comes with five included fonts which can be accessed with the keywords :TINY, :SMALL, :MEDIUM, :MEDIUM-BOLD (a synonym for :MEDIUM), :LARGE, and :GIANT and used with DRAW-STRING and DRAW-CHARACTER. Using these fonts will make your application portable to all platforms supported by CL-GD (and thus GD). You can also invoke the FreeType library to draw (anti-aliased) strings with arbitrary TrueType fonts, sizes, and angles. This is, however, subject to the availability and location of the corresponding fonts on your target platform. + +


[Special variable] +
*default-font* + +


+Whenever a CL-GD string or character function has an optional or keyword argument called font or font-name the default is to use *default-font*. See WITH-DEFAULT-FONT below. +
+ +


[Macro] +
with-default-font (font) form* => results + +


+This is just a convenience macro which will execute form* with *DEFAULT-FONT* bound to font. But +note that the fonts used for DRAW-STRING/DRAW-CHARACTER and DRAW-FREETYPE-STRING are incompatible +
+ +


[Function] +
draw-character x y char &key up font color image => char + +


+Draws the character char from font font in color color at position (x,y). If +up is true the character will be drawn from bottom to top (rotated 90 degrees). font must be one of the keywords listed above. +
+ +


[Function] +
draw-string x y string &key up font color image => string + +


+Draws the string string in color color at position (y,y). If +up is true the string will be drawn from bottom to top (rotated 90 degrees). font must be one of the keywords listed above. +
+ +


[Function] +
draw-freetype-string x y string &key anti-aliased point-size angle convert-chars line-spacing font-name do-not-draw color image => bounding-rectangle + +


+Draws the string string in color color at position (x,y) using the +FreeType library. font-name is the full path (a pathname or a string) +to a TrueType font file, or a font face name if the GDFONTPATH +environment variable or FreeType's DEFAULT_FONTPATH variable have been +set intelligently. The string may be arbitrarily scaled (point-size) +and rotated (angle in radians). The direction of rotation is +counter-clockwise, with 0 radians (0 degrees) at 3 o'clock and (/ PI 2) radians (90 degrees) at 12 o'clock. Note that the angle argument is +purposefully not affected by WITH-TRANSFORMATION. If anti-aliased if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +line-spacing, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like "&#192;". If convert-chars is true (which is the default) +characters of string with CHAR-CODE greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's CHAR-CODE +function returns ISO/IEC 10646 (Unicode) character codes. +

+The return value is an array containing 8 elements representing +the 4 corner coordinates (lower left, lower right, upper right, upper left) of the bounding rectangle around the +string that was drawn. The points are relative to the text regardless +of the angle, so "upper left" means in the top left-hand +corner seeing the text horizontally. Set do-not-draw +to true to get the bounding +rectangle without rendering. This is a relatively cheap operation if +followed by a rendering of the same string, because of the caching of +the partial rendering during bounding rectangle calculation. +

+ +
+(with-image* (200 200)strings.png
+  ;; set background (white) and make it transparent
+  (setf (transparent-color)
+          (allocate-color 255 255 255))
+  (loop for angle from 0 to (* 2 pi) by (/ pi 6)
+        for blue downfrom 255 by 20 do
+        (draw-freetype-string 100 100 "Common Lisp"
+                              :font-name "/usr/X11R6/lib/X11/fonts/truetype/georgia.ttf"
+                              :angle angle
+                              ;; note that ALLOCATE-COLOR won't work
+                              ;; here because the anti-aliasing uses
+                              ;; up too much colors
+                              :color (find-color 0 0 blue
+                                                 :resolve t)))
+  (write-image-to-file "strings.png"
+                       :if-exists :supersede))
+
+ +
 

Miscellaneous

+ +Things that didn't seem to fit into one of the other categories... + +


[Macro] +
do-rows (y-var &optional image) declaration* form* => results + +


+This macro loops through all rows (from top to bottom) in turn and +executes form* for each row with +y-var bound to the vertical index of the current row +(starting with 0). It is not affected by WITH-TRANSFORMATION. +
+ +


[Local macro] +
do-pixels-in-row (x-var) declaration* form* => results + +


+This macro is only available within the body of a DO-ROWS form. +It loops through all pixels (from left to right) in turn and +executes form* for each pixel with +x-var bound to the horizontal index of the current pixel +(starting with 0). It is not affected by WITH-TRANSFORMATION. +
+ +


[Macro] +
do-pixels (&optional image) declaration* form* => results + +


+This is a shortcut for the previous two macros. It loops through all pixels and executes form* for each pixel. Obviously it only makes sense when used together with RAW-PIXEL. +
+ +


[Accessor] +
raw-pixel => pixel +
(setf (raw-pixel) pixel) + +


+This accessor is only available within the body of a DO-PIXELS-IN-ROW form (and +thus also within DO-PIXELS +forms). It provides access to the "raw" pixel the loop is +currently at, i.e. for true color images you access an element of the +im->tpixels array, for palette-based images it's +im->pixels. Read the original GD +documentation for details. Make sure you know what you're doing if +you change these values... +
+ +
+* (with-image* (3 3 t) ; true-color image with 3x3 pixels
+    (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0)) ; black background
+    (draw-line 0 0 2 2 :color (allocate-color 255 255 255)) ; white line
+    (do-pixels ()
+      ;; loop through all pixels and change those which arent't black
+      (unless (zerop (raw-pixel))
+        (decf (raw-pixel) #xff)))
+    (do-rows (y)
+      ;; loop through all rows
+      (format t "Starting with row ~A~%" y)
+      (do-pixels-in-row (x)
+        ;; loop through all pixels in row
+        (format t "  Pixel <~A,~A> has value ~X~%" x y (raw-pixel)))
+      (format t "Done with row ~A~%" y)))
+Starting with row 0
+  Pixel <0,0> has value FFFF00 ; the line is yellow now
+  Pixel <1,0> has value 0
+  Pixel <2,0> has value 0
+Done with row 0
+Starting with row 1
+  Pixel <0,1> has value 0
+  Pixel <1,1> has value FFFF00
+  Pixel <2,1> has value 0
+Done with row 1
+Starting with row 2
+  Pixel <0,2> has value 0
+  Pixel <1,2> has value 0
+  Pixel <2,2> has value FFFF00
+Done with row 2
+NIL
+
+ +


[Accessor] +
interlacedp &optional image => interlaced +
(setf (interlacedp &optional image) interlaced) + +


+Gets or sets whether image will be stored in an interlaced fashion. +
+ +


[Function] +
differentp image1 image2 => different + +


+Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images. +
+ +


[Function] +
copy-image source destination source-x source-y dest-x dest-y width height &key resample rotate angle resize dest-width dest-height merge merge-gray => destination + +


+Copies (a part of) the image source into the image destination. Copies the +rectangle with the upper left corner (source-x,source-y) and size +width x height to the rectangle with the upper left corner (dest-x,dest-y). + +If resample is true pixel colors will be +smoothly interpolated. If resize is true +the copied rectangle will be strechted or shrunk so that its size is +dest-width x +dest-height. If rotate is true +the image will be rotated by angle. In this +particular case dest-x and +dest-y specify the center of the copied +image rather than its upper left corner! If merge +is true then it has to be an integer in the range 0-100 and the +two images will be 'merged' by the amount specified. If +merge is 100 then the source image will simply be +copied. If instead merge-gray is true the hue of +the source image is preserved by converting the destination area to +gray pixels before merging. + +The keyword arguments resample, rotate, resize, merge, and merge-gray +are mutually exclusive (with the exception of resample and +resize). angle is assumed to be specified in degrees if it's an +integer, and in radians otherwise. This function is not affected by WITH-TRANSFORMATION. +
+ +


[Function] +
copy-palette source destination => destination + +


+Copies the palette of the image source to the image destination attempting to +match the colors in the target image to the colors in the source palette. +
+ +


[Function] +
true-color-to-palette &key dither colors-wanted image => image + +


+Converts the true color image image to a palette-based image using +a high-quality two-pass quantization routine. If dither is true, the +image will be dithered to approximate colors better, at the expense of +some obvious "speckling." colors-wanted can be any positive integer +up to 256 (which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image. +
+ +
+(with-image* ((+ 256 384) 384 t)
+  (let ((white (allocate-color 255 255 255))
+        (red (allocate-color 255 0 0))
+        (green (allocate-color 0 255 0))
+        (blue (allocate-color 0 0 255))
+        (vertices (list 64 0 0 128 128 128))
+        (image-width (image-width))
+        (image-height (image-height)))
+    (setf (transparent-color) white)
+    (draw-rectangle* 0 0 image-width image-height :color white)
+    ;; "demoin.png" is part of the GD distribution
+    (with-image-from-file (in-file "demoin.png")
+      (copy-image in-file *default-image*
+                  0 0 32 32 192 192
+                  :resize t
+                  :dest-width 255
+                  :dest-height 255
+                  :resample t)
+      (multiple-value-bind (in-width in-height)
+          (image-size in-file)
+        (loop for a below 360 by 45 do
+              (copy-image in-file *default-image*
+                          0 0
+                          (+ 256 192 (* 128 (cos (* a .0174532925))))
+                          (- 192 (* 128 (sin (* a .0174532925))))
+                          in-width in-height
+                          :rotate t
+                          :angle a))
+        (with-default-color (green)
+          (with-thickness (4)
+            (draw-line 16 16 240 16)
+            (draw-line 240 16 240 240)
+            (draw-line 240 240 16 240)
+            (draw-line 16 240 16 16))
+          (draw-polygon vertices :filled t))
+        (dotimes (i 3)
+          (incf (nth (* 2 i) vertices) 128))
+        (draw-polygon vertices
+                      :color (make-anti-aliased green)
+                      :filled t)
+        (with-default-color (blue)
+          (draw-arc 128 128 60 20 0 720)
+          (draw-arc 128 128 40 40 90 270)
+          (fill-image 8 8))
+        (with-image (brush 16 16 t)
+          (copy-image in-file brush
+                      0 0 0 0
+                      in-width in-height
+                      :resize t
+                      :dest-width (image-width brush)
+                      :dest-height (image-height brush))
+          (draw-line 0 255 255 0
+                     :color (cons (make-brush brush)
+                                  (list nil nil nil nil nil nil nil t))))))
+    (with-default-color (red)
+      (draw-string 32 32 "hi" :font :giant)
+      (draw-string 64 64 "hi" :font :small))
+    (with-clipping-rectangle* (0 (- image-height 100) 100 image-height)
+      (with-default-color ((make-anti-aliased white))
+        (dotimes (i 100)
+          (draw-line (random image-width)
+                     (random image-height)
+                     (random image-width)
+                     (random image-height))))))
+  (setf (interlacedp) t)
+  (write-image-to-file "demoout.png"
+                       :if-exists :supersede)
+  (true-color-to-palette)
+  (write-image-to-file "demooutp.png"
+                       :if-exists :supersede))
+
+ +This last example is the demo which comes with GD. The equivalent C code is here. + +

+demooutp.png + +
 

Acknowledgements

+ +Thanks to Thomas Boutell for GD and thanks to Kevin Rosenberg +for UFFI without which CL-GD would +not have been possible. Kevin was also extremely helpful when I needed +functionality which wasn't yet part of UFFI. Thanks to Hans +Hübner for the GIF patches. Thanks to Manuel Odendahl for lots of useful patches. +Thanks to Luis Oliveira for CLISP/CFFI support and to Bryan O'Connor for OpenMCL support. +

+$Header: /usr/local/cvsrep/gd/doc/index.html,v 1.75 2007/07/29 16:37:15 edi Exp $ +

BACK TO MY HOMEPAGE + + + Added: trunk/cl-gd/doc/smallzappa.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/strings.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/triangle.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/zappa.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/drawing.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/drawing.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,354 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/drawing.lisp,v 1.28 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun get-pixel (x y &key (image *default-image*)) + "Gets the color associated with point \(X,Y)." + (check-type image image) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-get-pixel (img image) x y))) + +(defun set-pixel (x y &key (color *default-color*) (image *default-image*)) + "Draws a pixel with color COLOR at point \(X,Y)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel (img image) x y color))) + (values x y)) + +(defgeneric set-pixels (points &key color image) + (:documentation "Draws a list \(X1 Y1 X2 Y2 ...) or vector #\(X1 Y1 +X2 Y2 ...) of pixels.")) + +(defmethod set-pixels ((points list) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (unless (evenp (length points)) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for (x y) on points by #'cddr do + (check-type x integer) + (check-type y integer) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel img x y color)) + finally (return image))) + +(defmethod set-pixels ((points vector) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (let ((length (length points))) + (unless (evenp length) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for i below length by 2 do + (check-type (aref points i) integer) + (check-type (aref points (1+ i)) integer) + (with-transformed-alternative + (((aref points i) x-transformer) + ((aref points (1+ i)) y-transformer)) + (gd-image-set-pixel img + (aref points i) + (aref points (1+ i)) + color)) + finally (return image)))) + +(defun draw-line (x1 y1 x2 y2 &key (color *default-color*) (image *default-image*)) + "Draws a line with color COLOR from point \(X1,Y1) to point \(X2,Y2)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-line (img image) x1 y1 x2 y2 color))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle* (x1 y1 x2 y2 &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2). If FILLED is true the rectangle will be filled with +COLOR, otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (if filled + (gd-image-filled-rectangle (img image) x1 y1 x2 y2 color) + (gd-image-rectangle (img image) x1 y1 x2 y2 color)))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle (rectangle &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2) where RECTANGLE is the list \(X1 Y1 X2 Y2). If FILLED +is true the rectangle will be filled with COLOR, otherwise it will be +outlined." + (draw-rectangle* (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle) + :filled filled + :color color + :image image) + rectangle) + +(defgeneric draw-polygon (vertices &key filled start end color image) + (:documentation "Draws a polygon with the VERTICES \(at least three) +specified as a list \(x1 y1 x2 y2 ...) or as a vector #\(x1 y1 x2 y2 +...). If FILLED is true the polygon will be filled with COLOR, +otherwise it will be outlined. If START and/or END are specified then +only the corresponding part of VERTICES is used as input.")) + +(defmethod draw-polygon ((vertices vector) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((aref vertices i) x-transformer) + ((aref vertices (1+ i)) y-transformer)) + (loop for i from start below end by 2 + for point-ptr = (deref-array arr '(:array gd-point) (/ (- i start) 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (aref vertices i) + (get-slot-value point-ptr 'gd-point 'y) + (aref vertices (1+ i)))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defmethod draw-polygon ((vertices list) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((first x/y) x-transformer) + ((second x/y) y-transformer)) + (loop for i below (- end start) by 2 + ;; we don't use LOOP's destructuring capabilities here + ;; because of your simple WITH-TRANSFORMED-ALTERNATIVE + ;; macro which would get confused + for x/y on (nthcdr start vertices) by #'cddr + for point-ptr = (deref-array arr '(:array gd-point) (/ i 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (first x/y) + (get-slot-value point-ptr 'gd-point 'y) + (second x/y))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defun draw-filled-ellipse (center-x center-y width height &key (color *default-color*) (image *default-image*)) + "Draws a filled ellipse centered at \(CENTER-X, CENTER-Y) with width +WIDTH and height HEIGHT." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer)) + (gd-image-filled-ellipse (img image) center-x center-y width height color))) + (values center-x center-y width height)) + +(defun draw-filled-circle (center-x center-y radius &key (color *default-color*) (image *default-image*)) + "Draws a filled circle centered at \(CENTER-X, CENTER-Y) with radius +RADIUS." + (draw-filled-ellipse center-x center-y (* 2 radius) (* 2 radius) + :color color :image image) + (values center-x center-y radius)) + +(defun draw-arc (center-x center-y width height start end &key straight-line center-connect filled (color *default-color*) (image *default-image*)) + "Draws a partial ellipse centered at \(CENTER-X, CENTER-Y) with +width WIDTH and height HEIGHT. The arc begins at angle START and ends +at angle END. If STRAIGHT-LINE is true the start and end points are +just connected with a straight line. If CENTER-CONNECT is true, they +are connected to the center \(which is useful to create 'pie +slices'). If FILLED is true the arc will be filled with COLOR, +otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer) + (start angle-transformer) + (end angle-transformer)) + (cond ((not (or straight-line filled center-connect)) + (gd-image-arc (img image) center-x center-y width height start end color)) + (t + (gd-image-filled-arc (img image) center-x center-y width height start end color + (logior (if straight-line +gd-chord+ 0) + (if filled 0 +gd-no-fill+) + (if center-connect +gd-edged+ 0))))))) + (values center-x center-y width height start end)) + +(defun fill-image (x y &key border (color *default-color*) (image *default-image*)) + "Floods a portion of the image IMAGE with the color COLOR beginning +at point \(X, Y) and extending into the surrounding region. If BORDER +is true it must be a color and the filling will stop at the specified +border color. Otherwise only points with the same color as the +starting point will be colored." + (check-type border (or null integer)) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if border + (gd-image-fill-to-border (img image) x y border color) + (gd-image-fill (img image) x y color)))) + (values x y)) + +(defun clipping-rectangle (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as a list of four +elements." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (list (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun (setf clipping-rectangle) (rectangle &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE where rectangle should be a +list \(X1 Y1 X2 Y2)." + (check-type image image) + (with-transformed-alternative + (((first rectangle) x-transformer) + ((second rectangle) y-transformer) + ((third rectangle) x-transformer) + ((fourth rectangle) y-transformer)) + (gd-image-set-clip (img image) + (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle))) + rectangle) + +(defun clipping-rectangle* (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as four values." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (values (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun set-clipping-rectangle* (x1 y1 x2 y2 &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE to be the rectangle with upper +left corner \(X1, Y1) and lower right corner \(X2, Y2)." + (check-type image image) + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-set-clip (img image) x1 y1 x2 y2)) + (values x1 y1 x2 y2)) + +(defmacro with-clipping-rectangle ((rectangle &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to RECTANGLE +which should be a list \(X1 Y1 X2 Y2). The previous clipping rectangle +is guaranteed to be restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (rectangle image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (setf (clipping-rectangle ,image) ,rectangle) + , at body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) + +(defmacro with-clipping-rectangle* ((x1 y1 x2 y2 &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to the +rectangle with upper left corner \(X1, Y1) and lower right corner +\(X2, Y2). The previous clipping rectangle is guaranteed to be +restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (x1 y1 x2 y2 image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (set-clipping-rectangle* ,x1 ,y1 ,x2 ,y2 ,image) + , at body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) Added: trunk/cl-gd/gd-uffi.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/gd-uffi.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,731 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/gd-uffi.lisp,v 1.32 2007/04/05 23:22:24 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +;; internal representation of an image in GD +(def-struct gd-image + (pixels (* (* :unsigned-char))) + (sx :int) + (sy :int) + (colors-total :int) + (red (:array :int #.+max-colors+)) + (green (:array :int #.+max-colors+)) + (blue (:array :int #.+max-colors+)) + (open (:array :int #.+max-colors+)) + (transparent :int) + (poly-ints (* :int)) + (poly-allocated :int) + (brush :pointer-self) + (tile :pointer-self) + (brush-color-map (:array :int #.+max-colors+)) + (tile-color-map (:array :int #.+max-colors+)) + (style-length :int) + (style-pos :int) + (style (* :int)) + (interface :int) + (thick :int) + (alpha (:array :int #.+max-colors+)) + (true-color :int) + (t-pixels (* (* :int))) + (alpha-blending-flag :int) + (save-alpha-flag :int) + (aa :int) + (aa-color :int) + (aa-do-not-blend :int) + (aa-opacity (* (* :unsigned-char))) + (aa-polygon :int) + (aal-x1 :int) + (aal-y1 :int) + (aal-x2 :int) + (aal-y2 :int) + (aal-bx-ax :int) + (aal-by-ay :int) + (aal-lab-2 :int) + (aal-lab :float) + (cx1 :int) + (cy1 :int) + (cx2 :int) + (cy2 :int)) + +(def-type pixels-array (* (* :unsigned-char))) +(def-type pixels-row (* :unsigned-char)) +(def-type t-pixels-array (* (* :int))) +(def-type t-pixels-row (* :int)) + +(def-foreign-type gd-image-ptr (* gd-image)) + +;; initialize special variable +(setq *null-image* (make-image (make-null-pointer 'gd-image))) + +;; internal representation of a point in GD, used by the polygon +;; functions +(def-struct gd-point + (x :int) + (y :int)) + +(def-foreign-type gd-point-ptr (* gd-point)) + +;; internal representation of a font in GD, used by the (non-FreeType) +;; functions which draw characters and strings +(def-struct gd-font + (nchars :int) + (offset :int) + (w :int) + (h :int) + (data (* :char))) + +(def-foreign-type gd-font-ptr (* gd-font)) + +;; additional info for calls to the FreeType library - currently only +;; used for line spacing +(def-struct gd-ft-string-extra + (flags :int) + (line-spacing :double) + (charmap :int)) + +(def-foreign-type gd-ft-string-extra-ptr (* gd-ft-string-extra)) + +;; the GD standard fonts used when drawing characters or strings +;; without invoking the FreeType library +(def-foreign-var ("gdFontTiny" +gd-font-tiny+) gd-font-ptr "gd") +(def-foreign-var ("gdFontSmall" +gd-font-small+) gd-font-ptr "gd") +(def-foreign-var ("gdFontMediumBold" +gd-font-medium-bold+) gd-font-ptr "gd") +(def-foreign-var ("gdFontLarge" +gd-font-large+) gd-font-ptr "gd") +(def-foreign-var ("gdFontGiant" +gd-font-giant+) gd-font-ptr "gd") + +;;; all GD functions which are accessed from CL-GD + +(def-function ("gdImageCreate" gd-image-create) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateTrueColor" gd-image-create-true-color) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromJpegFile" gd-image-create-from-jpeg-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromPngFile" gd-image-create-from-png-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGdFile" gd-image-create-from-gd-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2File" gd-image-create-from-gd2-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2PartFile" gd-image-create-from-gd2-part-file) + ((filename :cstring) + (err (* :int)) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromXbmFile" gd-image-create-from-xbm-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +#-:win32 +(def-function ("gdImageCreateFromXpm" gd-image-create-from-xpm) + ((filename :cstring)) + :returning gd-image-ptr + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageCreateFromGifFile" gd-image-create-from-gif-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageJpegPtr" gd-image-jpeg-ptr) + ((im gd-image-ptr) + (size (* :int)) + (quality :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGdPtr" gd-image-gd-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGd2Ptr" gd-image-gd2-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageWBMPPtr" gd-image-wbmp-ptr) + ((im gd-image-ptr) + (size (* :int)) + (fg :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtr" gd-image-png-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtrEx" gd-image-png-ptr-ex) + ((im gd-image-ptr) + (size (* :int)) + (level :int)) + :returning :pointer-void + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageGifPtr" gd-image-gif-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageDestroy" gd-image-destroy) + ((im gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageColorAllocate" gd-image-color-allocate) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorAllocateAlpha" gd-image-color-allocate-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorDeallocate" gd-image-color-deallocate) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageColorExact" gd-image-color-exact) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosest" gd-image-color-closest) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestHWB" gd-image-color-closest-hwb) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestAlpha" gd-image-color-closest-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolve" gd-image-color-resolve) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolveAlpha" gd-image-color-resolve-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorTransparent" gd-image-color-transparent) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetTransparent" gd-image-get-transparent) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetAntiAliased" gd-image-set-anti-aliased) + ((im gd-image-ptr) + (c :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetAntiAliasedDontBlend" gd-image-set-anti-aliased-do-not-blend) + ((im gd-image-ptr) + (c :int) + (dont-blend :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetBrush" gd-image-set-brush) + ((im gd-image-ptr) + (brush gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetTile" gd-image-set-tile) + ((im gd-image-ptr) + (tile gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetStyle" gd-image-set-style) + ((im gd-image-ptr) + (style (* :int)) + (style-length :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetThickness" gd-image-set-thickness) + ((im gd-image-ptr) + (thickness :int)) + :returning :void + :module "gd") + +(def-function ("gdImageAlphaBlending" gd-image-alpha-blending) + ((im gd-image-ptr) + (blending :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSaveAlpha" gd-image-save-alpha) + ((im gd-image-ptr) + (save-flag :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetRed" gd-image-get-red) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetGreen" gd-image-get-green) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetBlue" gd-image-get-blue) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetAlpha" gd-image-get-alpha) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetColorsTotal" gd-image-get-colors-total) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetClip" gd-image-set-clip) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetClip" gd-image-get-clip) + ((im gd-image-ptr) + (x1p (* :int)) + (y1p (* :int)) + (x2p (* :int)) + (y2p (* :int))) + :returning :void + :module "gd") + +(def-function ("gdImageSetPixel" gd-image-set-pixel) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageLine" gd-image-line) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePolygon" gd-image-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledPolygon" gd-image-filled-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageRectangle" gd-image-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledRectangle" gd-image-filled-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledEllipse" gd-image-filled-ellipse) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageArc" gd-image-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledArc" gd-image-filled-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int) + (style :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFill" gd-image-fill) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFillToBorder" gd-image-fill-to-border) + ((im gd-image-ptr) + (x :int) + (y :int) + (border :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageChar" gd-image-char) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCharUp" gd-image-char-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageString" gd-image-string) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringUp" gd-image-string-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringFT" gd-image-string-ft) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring)) + :returning :cstring + :module "gd") + +(def-function ("gdImageStringFTEx" gd-image-string-ft-ex) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring) + (strex gd-ft-string-extra-ptr)) + :returning :cstring + :module "gd") + +(def-function ("gdImageGetPixel" gd-image-get-pixel) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageBoundsSafe" gd-image-bounds-safe) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSX" gd-image-get-sx) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSY" gd-image-get-sy) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageInterlace" gd-image-interlace) + ((im gd-image-ptr) + (interlace :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetInterlaced" gd-image-get-interlaced) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageCopy" gd-image-copy) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMerge" gd-image-copy-merge) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMergeGray" gd-image-copy-merge-gray) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResized" gd-image-copy-resized) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResampled" gd-image-copy-resampled) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyRotated" gd-image-copy-rotated) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :double) + (dst-y :double) + (src-x :int) + (src-y :int) + (src-w :int) + (src-h :int) + (angle :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePaletteCopy" gd-image-palette-copy) + ((dst gd-image-ptr) + (src gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageCompare" gd-image-compare) + ((im1 gd-image-ptr) + (im2 gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageTrueColorToPalette" gd-image-true-color-to-palette) + ((im gd-image-ptr) + (dither :int) + (colors-wanted :int)) + :returning :void + :module "gd") + +(def-function ("gdFree" gd-free) + ((ptr :pointer-void)) + :returning :void + :module "gd") Added: trunk/cl-gd/images.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/images.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,411 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/images.lisp,v 1.33 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun create-image (width height &optional true-color) + "Allocates and returns a GD image structure with size WIDTH x +HEIGHT. Creates a true color image if TRUE-COLOR is true. You are +responsible for destroying the image after you're done with it. It is +advisable to use WITH-IMAGE instead." + (check-type width integer) + (check-type height integer) + (let ((image-ptr + (if true-color + (gd-image-create-true-color width height) + (gd-image-create width height)))) + (when (null-pointer-p image-ptr) + (error "Could not allocate image of size ~A x ~A" width height)) + (let ((image (make-image image-ptr))) + image))) + +(defun destroy-image (image) + "Destroys \(deallocates) IMAGE which has been created by +CREATE-IMAGE, CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART." + (check-type image image) + (gd-image-destroy (img image)) + nil) + +(defmacro with-default-image ((image) &body body) + "Executes BODY with *DEFAULT-IMAGE* bound to IMAGE so that you don't +have to provide the IMAGE keyword/optional argument to CL-GD +functions." + `(let ((*default-image* ,image)) + , at body)) + +(defmacro with-image ((name width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT, and executes BODY with +the image bound to NAME. If TRUE-COLOR is true, creates a true color +image. The image is guaranteed to be destroyed before this macro +exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (width height true-color) + `(with-safe-alloc (,name + (create-image ,width ,height ,true-color) + (destroy-image ,name)) + , at body))) + +(defmacro with-image* ((width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT and executes BODY with +the image bound to *DEFAULT-IMAGE*. If TRUE-COLOR is true, creates a +true color image. The image is guaranteed to be destroyed before this +macro exits." + `(with-image (*default-image* ,width ,height ,true-color) + , at body)) + +(defun create-image-from-file (file-name &optional type) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string). The type of the image can be provided +as TYPE or otherwise it will be guessed from the PATHNAME-TYPE of +FILE-NAME. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead." + (check-type file-name (or pathname string)) + (let* ((pathname-type (pathname-type file-name)) + (%type (or type + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + ((string-equal pathname-type "xbm") + :xbm) + #-:win32 + ((string-equal pathname-type "xpm") + :xpm) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif))))) + (unless %type + (error "No type provided and it couldn't be guessed from filename")) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (ecase %type + ((:jpg :jpeg) + (gd-image-create-from-jpeg-file c-file-name err)) + ((:png) + (gd-image-create-from-png-file c-file-name err)) + ((:gd) + (gd-image-create-from-gd-file c-file-name err)) + ((:gd2) + (gd-image-create-from-gd2-file c-file-name err)) + ((:xbm) + (gd-image-create-from-xbm-file c-file-name err)) + #-:win32 + ((:xpm) + (gd-image-create-from-xpm c-file-name)) + #-:cl-gd-no-gif + ((:gif) + (gd-image-create-from-gif-file c-file-name err))))) + (cond ((null-pointer-p image) + (cond ((or (eq %type :xpm) + (zerop (deref-pointer err :int))) + (error "Could not create image from ~A file ~S" + %type file-name)) + (t + (error "Could not create image from ~A file ~S: errno was ~A" + %type file-name (deref-pointer err :int))))) + (t (let ((image (make-image image))) + image)))))))) + +(defmacro with-image-from-file ((name file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to NAME. The type of the image can be provied as TYPE or otherwise it +will be guessed from the PATHNAME-TYPE of FILE-NAME. The image is +guaranteed to be destroyed before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name type) + `(with-safe-alloc (,name + (create-image-from-file ,file-name ,type) + (destroy-image ,name)) + , at body))) + +(defmacro with-image-from-file* ((file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to *DEFAULT-IMAGE*. The type of the image can be provied as TYPE or +otherwise it will be guessed from the PATHNAME-TYPE of FILE-NAME. The +image is guaranteed to be destroyed before this macro exits." + `(with-image-from-file (*default-image* ,file-name ,type) + , at body)) + +(defun create-image-from-gd2-part (file-name src-x src-y width height) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified by SRC-X, SRC-Y, WIDTH, and +HEIGHT. You are responsible for destroying the image after you're done +with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead." + (check-type file-name (or string pathname)) + (check-type src-x integer) + (check-type src-y integer) + (check-type width integer) + (check-type height integer) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (gd-image-create-from-gd2-part-file c-file-name err src-x src-y width height))) + (cond ((null-pointer-p image) + (error "Could not create GD2 image from file ~S: errno was ~A" + file-name (deref-pointer err :int))) + (t image)))))) + +(defmacro with-image-from-gd2-part ((name file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to NAME. The type of the +image can be provied as TYPE or otherwise it will be guessed from the +PATHNAME-TYPE of FILE-NAME. The image is guaranteed to be destroyed +before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name src-x src-y width height) + `(with-safe-alloc (,name + (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height) + (destroy-image ,name)) + , at body))) + +(defmacro with-image-from-gd2-part* ((file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to *DEFAULT-IMAGE*. The +type of the image can be provied as TYPE or otherwise it will be +guessed from the PATHNAME-TYPE of FILE-NAME. The image is guaranteed +to be destroyed before this macro exits." + `(with-image-from-gd2-part (*default-image* ,file-name ,src-x ,src-y ,width ,height) + , at body)) + +(defmacro make-stream-fn (name signature gd-call type-checks docstring) + "Internal macro used to generate WRITE-JPEG-TO-STREAM and friends." + `(defun ,name ,signature + ,docstring + , at type-checks + (cond ((or #+(and :allegro :allegro-version>= (version>= 6 0)) + (typep stream 'excl:simple-stream) + #+:lispworks4.3 + (subtypep 'base-char (stream-element-type stream)) + (subtypep '(unsigned-byte 8) (stream-element-type stream))) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (let (#+:lispworks4.3 + (temp-array (make-array 1 :element-type + '(unsigned-byte 8)))) + (with-cast-pointer (temp memory :unsigned-byte) + (dotimes (i (deref-pointer size :int)) + ;; LispWorks workaround, WRITE-BYTE won't work - see + ;; + #+:lispworks4.3 + (setf (aref temp-array 0) + (deref-array temp '(:array :unsigned-byte) i)) + #+:lispworks4.3 + (write-sequence temp-array stream) + #-:lispworks4.3 + (write-byte (deref-array temp '(:array :unsigned-byte) i) + stream)) + image))))) + ((subtypep 'character (stream-element-type stream)) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (with-cast-pointer (temp memory + #+(or :cmu :scl :sbcl) :unsigned-char + #-(or :cmu :scl :sbcl) :char) + (dotimes (i (deref-pointer size :int)) + (write-char (ensure-char-character + (deref-array temp '(:array :char) i)) + stream)) + image)))) + (t (error "Can't use a stream with element-type ~A" + (stream-element-type stream)))))) + +(make-stream-fn write-jpeg-to-stream (stream &key (quality -1) (image *default-image*)) + (gd-image-jpeg-ptr (img image) size quality) + ((check-type stream stream) + (check-type quality (integer -1 100)) + (check-type image image)) + "Writes image IMAGE to stream STREAM as JPEG. If +QUALITY is not specified, the default IJG JPEG quality value is +used. Otherwise, for practical purposes, quality should be a value in +the range 0-95. STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format is +yields faithful output of all 8-bit characters.") + +(make-stream-fn write-png-to-stream (stream &key compression-level (image *default-image*)) + (cond (compression-level + (gd-image-png-ptr-ex (img image) size compression-level)) + (t + (gd-image-png-ptr (img image) size))) + ((check-type stream stream) + (check-type compression-level (or null (integer -1 9))) + (check-type image image)) + "Writes image IMAGE to stream STREAM as PNG. If +COMPRESSION-LEVEL is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of +1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format yields +faithful output of all 8-bit characters.") + +#-:cl-gd-no-gif +(make-stream-fn write-gif-to-stream (stream &key (image *default-image*)) + (gd-image-gif-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GIF. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-wbmp-to-stream (stream &key foreground (image *default-image*)) + (gd-image-wbmp-ptr (img image) size foreground) + ((check-type stream stream) + (check-type foreground integer) + (check-type image image)) + "Writes image IMAGE to stream STREAM as WBMP. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters. WBMP file support is black and white +only. The color index specified by the FOREGOUND argument is the +\"foreground,\" and only pixels of this color will be set in the WBMP +file") + +(make-stream-fn write-gd-to-stream (stream &key (image *default-image*)) + (gd-image-gd-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-gd2-to-stream (stream &key (image *default-image*)) + (gd-image-gd2-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(defun write-image-to-stream (stream type &rest rest &key &allow-other-keys) + "Writes image to STREAM. The type of the image is determined by TYPE +which must be one of :JPG, :JPEG, :PNG, :WBMP, :GD, or :GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters." + (apply (ecase type + ((:jpg :jpeg) + #'write-jpeg-to-stream) + ((:png) + #'write-png-to-stream) + ((:wbmp) + #'write-wbmp-to-stream) + ((:gd) + #'write-gd-to-stream) + ((:gd2) + #'write-gd2-to-stream) + #-:cl-gd-no-gif + ((:gif) + #'write-gif-to-stream)) + stream rest)) + +(defun write-image-to-file (file-name &rest rest &key type (if-exists :error) &allow-other-keys) + "Writes image to the file specified by FILE-NAME \(a pathname or a +string). The TYPE argument is interpreted as in +WRITE-IMAGE-TO-STREAM. If it is not provided it is guessed from the +PATHNAME-TYPE of FILE-NAME. The IF-EXISTS keyword argument is given to +OPEN. Other keyword argument like QUALITY or COMPRESSION-LEVEL can be +provided depending on the images's type." + (with-open-file (stream file-name :direction :output + :if-exists if-exists + :element-type '(unsigned-byte 8)) + (apply #'write-image-to-stream + stream + (or type + (let ((pathname-type (pathname-type (truename file-name)))) + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "wbmp") + :wbmp) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif) + (t + (error "Can't determine the type of the image"))))) + (sans rest :type :if-exists)))) + +(defun image-width (&optional (image *default-image*)) + "Returns width of IMAGE." + (check-type image image) + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer)) + (gd-image-get-sx (img image)))) + +(defun image-height (&optional (image *default-image*)) + (check-type image image) + "Returns height of IMAGE." + (with-transformed-alternative + (((gd-image-get-sy (img image)) h-inv-transformer)) + (gd-image-get-sy (img image)))) + +(defun image-size (&optional (image *default-image*)) + (check-type image image) + "Returns width and height of IMAGE as two values." + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer) + ((gd-image-get-sy (img image)) h-inv-transformer)) + (values (gd-image-get-sx (img image)) + (gd-image-get-sy (img image))))) Added: trunk/cl-gd/init.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/init.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,46 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/init.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun load-gd-glue () + "Load the little glue library we have to create for the image input +functions." + ;; try to find the library at different places + (let ((filename (find-foreign-library "cl-gd-glue" + *shared-library-directories* + :types *shared-library-types* + :drive-letters *shared-library-drive-letters*))) + (load-foreign-library filename + :module "gd" + :supporting-libraries *gd-supporting-libraries*))) + +;; invoke the function, i.e. load the library (and thus GD itself) +;; before gd-uffi.lisp is loaded/compiled +(load-gd-glue) Added: trunk/cl-gd/misc.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/misc.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,238 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/misc.lisp,v 1.15 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun interlacedp (&optional (image *default-image*)) + "Returns whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (not (zerop (gd-image-get-interlaced (img image))))) + +(defun (setf interlacedp) (interlaced &optional (image *default-image*)) + "Sets whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (gd-image-interlace (img image) (if interlaced 1 0)) + interlaced) + +(defun differentp (image1 image2) + "Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images." + (check-type image1 image) + (check-type image2 image) + (let ((result (gd-image-compare (img image1) (img image2)))) + (cond ((zerop (logand +gd-cmp-image+ result)) + nil) + (t + (loop for (gd-flag keyword) in `((,+gd-cmp-num-colors+ + :different-number-of-colors) + (,+gd-cmp-color+ + :different-colors) + (,+gd-cmp-size-x+ + :different-widths) + (,+gd-cmp-size-y+ + :different-heights) + (,+gd-cmp-transparent+ + :different-transparent-colors) + (,+gd-cmp-background+ + :different-background-colors) + (,+gd-cmp-interlace+ + :different-interlace-settings) + (,+gd-cmp-true-color+ + :true-color-versus-palette-based)) + when (plusp (logand gd-flag result)) + collect keyword))))) + +(defun copy-image (source destination + source-x source-y + dest-x dest-y + width height + &key resample + rotate angle + resize dest-width dest-height + merge merge-gray) + "Copies \(a part of) image SOURCE into image DESTINATION. Copies the +rectangle with the upper left corner \(SOURCE-X,SOURCE-Y) and size +WIDTH x HEIGHT to the rectangle with the upper left corner +\(DEST-X,DEST-Y). + +If RESAMPLE is true pixel colors will be smoothly interpolated. If +RESIZE is true the copied rectangle will be strechted or shrinked so +that its size is DEST-WIDTH x DEST-HEIGHT. If ROTATE is true the image +will be rotated by ANGLE. In this particular case DEST-X and DEST-Y +specify the CENTER of the copied image rather than its upper left +corner! If MERGE is true it has to be an integer in the range 0-100 +and the two images will be 'merged' by the amount specified. If MERGE +is 100 then the source image will simply be copied. If instead +MERGE-GRAY is true the hue of the source image is preserved by +converting the destination area to gray pixels before merging. + +The keyword options RESAMPLE, ROTATE, RESIZE, MERGE, and MERGE-GRAY +are mutually exclusive \(with the exception of RESAMPLE and +RESIZE). ANGLE is assumed to be specified in degrees if it's an +integer, and in radians otherwise." + (check-type source image) + (check-type destination image) + (check-type source-x integer) + (check-type source-y integer) + (unless rotate + (check-type dest-x integer) + (check-type dest-y integer)) + (check-type width integer) + (check-type height integer) + (check-type angle (or null number)) + (check-type dest-width (or null integer)) + (check-type dest-height (or null integer)) + (check-type merge (or null (integer 0 100))) + (check-type merge-gray (or null (integer 0 100))) + (when (and merge merge-gray) + (error "You can't specify MERGE and MERGE-GRAY at the same time.")) + (when (and (or merge merge-gray) + (or resample rotate resize)) + (error "MERGE and MERGE-GRAY can't be combined with RESAMPLE, ROTATE, or RESIZE.")) + (when (and (or dest-width dest-height) + (not resize)) + (error "Use RESIZE if you want to specify DEST-WIDTH or DEST-HEIGHT")) + (when (and resize + (not (or dest-width dest-height))) + (error "Please specify DEST-WIDTH and DEST-HEIGHT together with RESIZE.")) + (when (and angle + (not rotate)) + (error "Use ROTATE if you want to specify ANGLE.")) + (when (and rotate + (not angle)) + (error "Please specify ANGLE together with ROTATE.")) + (when (and rotate + (or resample resize)) + (error "ROTATE can't be used together with RESAMPLE or RESIZE.")) + (cond ((and resample resize) + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (resample + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + width height width height)) + ((and rotate (integerp angle)) + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height angle)) + (rotate + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height + (round (* angle +radians-to-degree-factor+)))) + (resize + (gd-image-copy-resized (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (merge + (gd-image-copy-merge (img destination) (img source) + dest-x dest-y source-x source-y + width height merge)) + (merge-gray + (gd-image-copy-merge-gray (img destination) (img source) + dest-x dest-y source-x source-y + width height merge-gray)) + (t + (gd-image-copy (img destination) (img source) dest-x dest-y + source-x source-y width height))) + destination) + +(defun copy-palette (source destination) + "Copies palette of image SOURCE to image DESTINATION attempting to +match the colors in the target image to the colors in the source +palette." + (check-type source image) + (check-type destination image) + (gd-image-palette-copy (img destination) (img source)) + destination) + +(defun true-color-to-palette (&key dither (colors-wanted 256) (image *default-image*)) + "Converts the true color image IMAGE to a palette-based image using +a high-quality two-pass quantization routine. If DITHER is true, the +image will be dithered to approximate colors better, at the expense of +some obvious \"speckling.\" COLORS-WANTED can be any positive integer +up to 256 \(which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image." + (check-type image image) + (check-type colors-wanted (integer 0 256)) + (gd-image-true-color-to-palette (img image) + (if dither 1 0) + colors-wanted) + image) + +(defmacro do-rows ((y-var &optional (image '*default-image*)) &body body) + (with-rebinding (image) + (with-unique-names (img width height true-color-p raw-pixels row x-var inner-body) + `(let* ((,img (img ,image)) + (,width (gd-image-get-sx ,img)) + (,height (gd-image-get-sy ,img)) + (,true-color-p (true-color-p ,image))) + (declare (fixnum ,width ,height)) + (cond (,true-color-p + (let ((,raw-pixels (get-slot-value ,img 'gd-image 't-pixels))) + (declare (type t-pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :int)) ,y-var))) + (declare (type t-pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :int) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + , at body)))))) + (t + (let ((,raw-pixels (get-slot-value ,img 'gd-image 'pixels))) + (declare (type pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-char)) ,y-var))) + (declare (type pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :unsigned-char) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + , at body))))))))))) + +(defmacro do-pixels ((&optional (image '*default-image*)) &body body) + (with-unique-names (x y) + `(do-rows (,y ,image) + (do-pixels-in-row (,x) + , at body)))) \ No newline at end of file Added: trunk/cl-gd/packages.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/packages.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,80 @@ +(in-package #:cl-user) + +(defpackage #:cl-gd + (:use #:cl #:uffi) + (:export #:*default-image* + #:*default-color* + #:*default-font* + #:+max-colors+ + #:without-transformations + #:with-transformation + #:create-image + #:destroy-image + #:with-image + #:create-image-from-file + #:with-image-from-file + #:create-image-from-gd2-part + #:with-image-from-gd2-part + #:with-default-image + #:with-image* + #:with-image-from-file* + #:with-image-from-gd2-part* + #:write-jpeg-to-stream + #:write-png-to-stream + #:write-wbmp-to-stream + #:write-gd-to-stream + #:write-gd2-to-stream + #-:cl-gd-no-gif #:write-gif-to-stream + #:write-image-to-stream + #:write-image-to-file + #:image-width + #:image-height + #:image-size + #:make-brush + #:make-tile + #:make-anti-aliased + #:with-default-color + #:allocate-color + #:deallocate-color + #:transparent-color + #:true-color-p + #:number-of-colors + #:find-color + #:find-color-from-image + #:thickness + #:with-thickness + #:alpha-blending-p + #:save-alpha-p + #:color-component + #:color-components + #:draw-polygon + #:draw-line + #:get-pixel + #:set-pixel + #:set-pixels + #:draw-rectangle + #:draw-rectangle* + #:draw-arc + #:draw-filled-ellipse + #:draw-filled-circle + #:fill-image + #:clipping-rectangle + #:clipping-rectangle* + #:set-clipping-rectangle* + #:with-clipping-rectangle + #:with-clipping-rectangle* + #:with-default-font + #:draw-character + #:draw-string + #:draw-freetype-string + #:interlacedp + #:differentp + #:copy-image + #:copy-palette + #:true-color-to-palette + #:do-rows + #:do-pixels-in-row + #:do-pixels + #:raw-pixel)) + +(pushnew :cl-gd *features*) Added: trunk/cl-gd/specials.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/specials.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,173 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/specials.lisp,v 1.29 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package #:cl-gd) + +(defvar *default-image* nil + "The default image. This special variable is usually bound by +WITH-IMAGE or WITH-IMAGE-FROM-FILE.") + +(defvar *default-color* nil + "The default color. This special variable is usually bound by +WITH-COLOR.") + +(defvar *default-font* nil + "The default font. This special variable is usually bound by +WITH-FONT.") + +(defstruct (image + (:conc-name nil) + (:constructor make-image (img)) + (:copier nil)) + img) + +(defstruct (brush + (:include image) + (:constructor %make-brush (img)) + (:copier nil))) + +(defun make-brush (image) + (%make-brush (img image))) + +(defstruct (tile + (:include image) + (:constructor %make-tile (img)) + (:copier nil))) + +(defun make-tile (image) + (%make-tile (img image))) + +(defstruct (anti-aliased-color + (:conc-name nil) + (:constructor %make-anti-aliased (color do-not-blend)) + (:copier nil)) + color do-not-blend) + +(defun make-anti-aliased (color &optional do-not-blend) + (%make-anti-aliased color do-not-blend)) + +;; the following variable will be initialized in "gd-uffi.lisp" +(defvar *null-image* nil + "A 'null' image which might be useful for DRAW-FREETYPE-STRING.") + +(defconstant +max-colors+ 256 + "Maximum number of colors for palette-based images.") + +(defconstant +gd-chord+ 1 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-no-fill+ 2 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-edged+ 4 + "Used internally by GD-FILLED-ARC") + +(defconstant +brushed+ -3 + "Special 'color' for lines drawn with brush.") +(defconstant +styled+ -2 + "Special 'color' for styled lines.") +(defconstant +styled-brushed+ -4 + "Special 'color' for lines drawn with styled brush.") +(defconstant +transparent+ -6 + "Special 'color' used in GD function 'gdImageSetStyle' for transparent color.") +(defconstant +tiled+ -5 + "Special fill 'color' used for tiles.") +(defconstant +anti-aliased+ -7 + "Special 'color' for anti-aliased lines.") + +(defconstant +gd-ftex-linespace+ 1 + "Indicate line-spacing for FreeType library.") + +(defconstant +gd-cmp-image+ 1 + "Images will appear different when displayed.") +(defconstant +gd-cmp-num-colors+ 2 + "Number of colors in palette differ.") +(defconstant +gd-cmp-color+ 4 + "Image colors differ.") +(defconstant +gd-cmp-size-x+ 8 + "Image widths differ.") +(defconstant +gd-cmp-size-y+ 16 + "Image heights differ.") +(defconstant +gd-cmp-transparent+ 32 + "Transparent color is different.") +(defconstant +gd-cmp-background+ 64 + "Background color is different.") +(defconstant +gd-cmp-interlace+ 128 + "Interlace settings are different.") +(defconstant +gd-cmp-true-color+ 256 + "One image is a true-color image, the other one is palette-based.") + +(defvar *shared-library-directories* + `(,(namestring (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + "/usr/local/lib/" + "/usr/lib/" + "/usr/lib/cl-gd/" + "/cygwin/usr/local/lib/" + "/cygwin/usr/lib/") + "A list of directories where UFFI tries to find cl-gd-glue.so") +(defvar *shared-library-types* '("so" "dll" "dylib") + "The list of types a shared library can have. Used when looking for +cl-gd-glue.so") +(defvar *shared-library-drive-letters* '("C" "D" "E" "F" "G") + "The list of drive letters \(used by Wintendo) used when looking for +cl-gd-glue.dll.") + +(defvar *gd-supporting-libraries* '("c" "gd" "png" "z" "jpeg" "freetype" "iconv" "m") + "The libraries which are needed by cl-gd-glues.so \(and GD +itself). Only needed for Python-based Lisps like CMUCL, SBCL, or +SCL.") + +(defconstant +radians-to-degree-factor+ (/ 360 (* 2 pi)) + "Factor to convert from radians to degrees.") + +(defvar *transformers* nil + "Stack of currently active transformer objects.") + +(defconstant +most-positive-unsigned-byte-32+ + (1- (expt 2 31)) + "Name says it all...") + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see +;; and + +(defvar *hyperdoc-base-uri* "http://weitz.de/cl-gd/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :cl-gd + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) \ No newline at end of file Added: trunk/cl-gd/strings.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/strings.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,194 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/strings.lisp,v 1.23 2007/04/24 09:01:39 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-font ((font) &body body) + "Execute BODY with *DEFAULT-FONT* bound to FONT so that you +don't have to provide the FONT keyword/optional argument to +string functions. But note that the fonts used for +DRAW-STRING/DRAW-CHARACTER and DRAW-FREETYPE-STRING are +incompatible." + `(let ((*default-font* ,font)) + , at body)) + +(defun draw-character (x y char &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the character CHAR from font FONT in color COLOR at position +\(X,Y). If UP is true the character will be drawn from bottom to top +\(rotated 90 degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, +:LARGE, :GIANT." + (check-type char character) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if up + (gd-image-char-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color) + (gd-image-char (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color)))) + char) + +(defun draw-string (x y string &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y). If UP is +true the character will be drawn from bottom to top \(rotated 90 +degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, :LARGE, :GIANT." + (check-type string string) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (with-cstring (c-string string) + (if up + (gd-image-string-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color) + (gd-image-string (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color))))) + string) + +(defun draw-freetype-string (x y string + &key (anti-aliased t) + (point-size 12.0d0) + (angle 0.0d0) + (convert-chars t) + line-spacing + (font-name *default-font*) + do-not-draw + (color *default-color*) + (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y) using the +FreeType library. FONT-NAME is the full path \(a pathname or a string) +to a TrueType font file, or a font face name if the GDFONTPATH +environment variable or FreeType's DEFAULT_FONTPATH variable have been +set intelligently. The string may be arbitrarily scaled \(POINT-SIZE) +and rotated \(ANGLE in radians). The direction of rotation is +counter-clockwise, with 0 radians \(0 degrees) at 3 o'clock and PI/2 +radians \(90 degrees) at 12 o'clock. Note that the ANGLE argument is +purposefully _not_ affected by WITH-TRANSFORMATION. If ANTI-ALIASED if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +LINE-SPACING, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like \"À\". If CONVERT-CHARS is true \(which is the default) +characters of STRING with CHAR-CODE greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's CHAR-CODE +function returns ISO/IEC 10646 (Unicode) character codes. + +The return value is an array containing 8 elements representing the 4 +corner coordinates \(lower left, lower right, upper right, upper left) +of the bounding rectangle around the string that was drawn. The points +are relative to the text regardless of the angle, so \"upper left\" +means in the top left-hand corner seeing the text horizontally. Set +DO-NOT-DRAW to true to get the bounding rectangle without +rendering. This is a relatively cheap operation if followed by a +rendering of the same string, because of the caching of the partial +rendering during bounding rectangle calculation." + (check-type string string) + (check-type font-name (or pathname string)) + (unless do-not-draw + (check-type color integer) + (check-type image image)) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer) + ((deref-array c-bounding-rectangle '(:array :int) i) x-inv-transformer) + ((deref-array c-bounding-rectangle '(:array :int) (1+ i)) y-inv-transformer)) + (when do-not-draw + (setq color 0 + image *null-image*)) + (when (pathnamep font-name) + (setq font-name (namestring font-name))) + (when convert-chars + (setq string (convert-to-char-references string))) + (with-cstring (c-font-name font-name) + (with-cstring (c-string string) + (with-safe-alloc (c-bounding-rectangle + (allocate-foreign-object :int 8) + (free-foreign-object c-bounding-rectangle)) + (let ((msg (convert-from-cstring + (cond (line-spacing + (with-foreign-object (strex 'gd-ft-string-extra) + (setf (get-slot-value strex + 'gd-ft-string-extra + 'flags) + +gd-ftex-linespace+ + (get-slot-value strex + 'gd-ft-string-extra + 'line-spacing) + (coerce line-spacing 'double-float)) + (gd-image-string-ft-ex (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string + strex))) + (t + (gd-image-string-ft (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string)))))) + (when msg + (error "Error in FreeType library: ~A" msg)) + (let ((bounding-rectangle (make-array 8))) + ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE + (loop for i below 8 by 2 do + (setf (aref bounding-rectangle i) + (deref-array c-bounding-rectangle '(:array :int) i)) + (setf (aref bounding-rectangle (1+ i)) + (deref-array c-bounding-rectangle '(:array :int) (1+ i)))) + bounding-rectangle))))))) \ No newline at end of file Added: trunk/cl-gd/svn-commit.tmp ============================================================================== --- (empty file) +++ trunk/cl-gd/svn-commit.tmp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,4 @@ +Branches dir +--This line, and those below, will be ignored-- + +A svn+ssh://eweitz at common-lisp.net/project/cl-gd/svn/trunk/branches Added: trunk/cl-gd/test/demoin.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/brushed-arc.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/chart.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/circle.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-line.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-line.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-pixel.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-pixel.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/triangle.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/smallzappa.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/zappa.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/transform.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/transform.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,193 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/transform.lisp,v 1.21 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defclass transformer () + ((image :initarg :image + :reader image) + (w-transformer :initarg :w-transformer + :reader w-transformer + :type function) + (h-transformer :initarg :h-transformer + :reader h-transformer + :type function) + (x-transformer :initarg :x-transformer + :reader x-transformer + :type function) + (y-transformer :initarg :y-transformer + :reader y-transformer + :type function) + (w-inv-transformer :initarg :w-inv-transformer + :reader w-inv-transformer + :type function) + (h-inv-transformer :initarg :h-inv-transformer + :reader h-inv-transformer + :type function) + (x-inv-transformer :initarg :x-inv-transformer + :reader x-inv-transformer + :type function) + (y-inv-transformer :initarg :y-inv-transformer + :reader y-inv-transformer + :type function) + (angle-transformer :initarg :angle-transformer + :reader angle-transformer + :type function)) + (:documentation "Class used internally for WITH-TRANSFORMATION +macro.")) + +(defmacro without-transformations (&body body) + "Executes BODY without any transformations applied." + `(let (*transformers*) + , at body)) + +(declaim (inline round-to-c-int)) +(defun round-to-signed-byte-32 (x) + "Like ROUND but make sure result isn't longer than 32 bits." + (mod (round x) +most-positive-unsigned-byte-32+)) + +(defmacro with-transformation ((&key x1 x2 width y1 y2 height reverse-x reverse-y (radians t) (image '*default-image*)) &body body) + "Executes BODY such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of IMAGE will start at X1 and end at X2 and +have length WIDTH. The new y-axis of IMAGE will start at Y1 and end at +Y2 and have length HEIGHT. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +REVERSE-X is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to REVERSE-Y, of course. If RADIANS is true angles inside of +BODY will be assumed to be provided in radians, otherwise in degrees." + (with-rebinding (x1 x2 width y1 y2 height reverse-x reverse-y radians image) + (with-unique-names (image-width image-height + stretch-x stretch-y + w-transformer h-transformer + x-transformer y-transformer + w-inv-transformer h-inv-transformer + x-inv-transformer y-inv-transformer + angle-transformer) + ;; rebind for thread safety + `(let ((*transformers* *transformers*)) + (unless (<= 2 (count-if #'identity (list ,x1 ,x2 ,width))) + (error "You must provide at least two of X1, X2, and WIDTH.")) + (unless (<= 2 (count-if #'identity (list ,y1 ,y2 ,height))) + (error "You must provide at least two of Y1, Y2, and HEIGHT.")) + (when (and ,x1 ,x2 ,width + (/= ,width (- ,x2 ,x1))) + (error "X1, X2, and WIDTH don't match. Try to provide just two of the three arguments.")) + (when (and ,y1 ,y2 ,height + (/= ,height (- ,y2 ,y1))) + (error "Y1, Y2, and HEIGHT don't match. Try to provide just two of the three arguments.")) + ;; kludgy code to keep SBCL quiet + (unless ,x1 (setq ,x1 (- ,x2 ,width))) + (unless ,x2 (setq ,x2 (+ ,x1 ,width))) + (unless ,width (setq ,width (- ,x2 ,x1))) + (unless ,y1 (setq ,y1 (- ,y2 ,height))) + (unless ,y2 (setq ,y2 (+ ,y1 ,height))) + (unless ,height (setq ,height (- ,y2 ,y1))) + (multiple-value-bind (,image-width ,image-height) + (without-transformations + (image-size ,image)) + (let* ((,stretch-x (/ ,image-width ,width)) + (,stretch-y (/ ,image-height ,height)) + (,w-transformer (lambda (w) + (round-to-signed-byte-32 + (* w ,stretch-x)))) + (,w-inv-transformer (lambda (w) + (/ w ,stretch-x))) + (,h-transformer (lambda (h) + (round-to-signed-byte-32 + (* h ,stretch-y)))) + (,h-inv-transformer (lambda (h) + (/ h ,stretch-y))) + (,x-transformer (if ,reverse-x + (lambda (x) + (round-to-signed-byte-32 + (* (- ,x2 x) ,stretch-x))) + (lambda (x) + (round-to-signed-byte-32 + (* (- x ,x1) ,stretch-x))))) + (,x-inv-transformer (if ,reverse-x + (lambda (x) + (- ,x2 (/ x ,stretch-x))) + (lambda (x) + (+ ,x1 (/ x ,stretch-x))))) + (,y-transformer (if ,reverse-y + (lambda (y) + (round-to-signed-byte-32 + (* (- y ,y1) ,stretch-y))) + (lambda (y) + (round-to-signed-byte-32 + (* (- ,y2 y) ,stretch-y))))) + (,y-inv-transformer (if ,reverse-y + (lambda (y) + (+ ,y1 (/ y ,stretch-y))) + (lambda (y) + (- ,y2 (/ y ,stretch-y))))) + (,angle-transformer (cond (,radians + (lambda (angle) + (round-to-signed-byte-32 + (* angle + +radians-to-degree-factor+)))) + (t + #'identity)))) + (push (make-instance 'transformer + :image ,image + :w-transformer ,w-transformer + :h-transformer ,h-transformer + :x-transformer ,x-transformer + :y-transformer ,y-transformer + :w-inv-transformer ,w-inv-transformer + :h-inv-transformer ,h-inv-transformer + :x-inv-transformer ,x-inv-transformer + :y-inv-transformer ,y-inv-transformer + :angle-transformer ,angle-transformer) + *transformers*) + (unwind-protect + (progn + , at body) + (pop *transformers*)))))))) + +(defmacro with-transformed-alternative ((&rest transformations) &body body) + "Internal macro used to make functions +transformation-aware. TRANSFORMATION is a list of (EXPR +TRANSFORMATION) pairs where each EXPR will be replaced by the +transformation denoted by TRANSFORMATION." + (with-unique-names (transformer) + (let ((transformations-alist + (loop for (expr transformation) in transformations + collect `(,expr . (funcall (,transformation ,transformer) ,expr))))) + ;; note that we always use the name 'IMAGE' - no problem because + ;; this is a private macro + `(let ((,transformer (find image *transformers* :key #'image))) + (cond (,transformer + ,(sublis transformations-alist + `(progn , at body) + :test #'equal)) + (t (progn + , at body))))))) Added: trunk/cl-gd/util.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/util.lisp Wed Apr 30 04:36:15 2008 @@ -0,0 +1,136 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/util.lisp,v 1.15 2007/02/28 15:47:58 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +#+:lispworks +(import 'lw:with-unique-names) + +#-:lispworks +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; by Vebjorn Ljosa - see also + ;; + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + , at body)) + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (macro-function 'with-rebinding) + (macro-function 'lw:rebinding))) + +#-:lispworks +(defmacro with-rebinding (bindings &body body) + "REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; by Vebjorn Ljosa - see also + ;; + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,, at temps) + ,, at body)))))) + +(defun sans (plist &rest keys) + "Returns PLIST with keyword arguments from KEYS removed." + ;; stolen from Usenet posting <3247672165664225 at naggum.no> by Erik + ;; Naggum + (let ((sans ())) + (loop + (let ((tail (nth-value 2 (get-properties plist keys)))) + ;; this is how it ends + (unless tail + (return (nreconc sans plist))) + ;; copy all the unmatched keys + (loop until (eq plist tail) do + (push (pop plist) sans) + (push (pop plist) sans)) + ;; skip the matched key + (setq plist (cddr plist)))))) + +(defun convert-to-char-references (string) + "Returns a string where all characters of STRING with CHAR-CODE +greater than 127 are converted to XML character entities." + (with-output-to-string (s) + (with-standard-io-syntax + (loop for char across string + for char-code = (char-code char) + when (<= char-code 127) do + (write-char char s) + else do + (write-char #\& s) + (write-char #\# s) + (princ char-code s) + (write-char #\; s))))) + +(defmacro with-safe-alloc ((var alloc free) &rest body) + `(let (,var) + (unwind-protect + (progn (setf ,var ,alloc) + , at body) + (when ,var ,free)))) \ No newline at end of file From eweitz at common-lisp.net Wed Apr 30 08:37:39 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:37:39 -0400 (EDT) Subject: [rdnzl-cvs] r9 - trunk/cl-gd Message-ID: <20080430083739.D2FF350B2@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:37:39 2008 New Revision: 9 Removed: trunk/cl-gd/ Log: Ugh, wrong project... :)