rdnzl-cvs

rdnzl-cvs@common-lisp.net

43 discussions

[rdnzl-cvs] CVS RDNZL/examples
by eweitz 01 Feb '06

01 Feb '06

Update of /project/rdnzl/cvsroot/RDNZL/examples In directory common-lisp:/tmp/cvs-serv4420/examples Modified Files: AproposGui.cs apropos.lisp apropos2.lisp deliver-acl.lisp deliver-ccl.lisp deliver-lw.lisp messagebox.lisp url.lisp Log Message: 0.9.0 release --- /project/rdnzl/cvsroot/RDNZL/examples/AproposGui.cs 2005/01/03 00:55:44 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/examples/AproposGui.cs 2006/02/01 01:00:57 1.2 @@ -1,108 +1,108 @@ -// $Header: /project/rdnzl/cvsroot/RDNZL/examples/AproposGui.cs,v 1.1.1.1 2005/01/03 00:55:44 eweitz Exp $ - -// Copyright (c) 2004-2005, 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 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); - } - } -} +// $Header: /project/rdnzl/cvsroot/RDNZL/examples/AproposGui.cs,v 1.2 2006/02/01 01:00:57 eweitz Exp $ + +// Copyright (c) 2004-2006, 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 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); + } + } +} --- /project/rdnzl/cvsroot/RDNZL/examples/apropos.lisp 2005/01/03 00:55:43 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/examples/apropos.lisp 2006/02/01 01:00:57 1.2 @@ -1,90 +1,88 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/apropos.lisp,v 1.1.1.1 2005/01/03 00:55:43 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - -(use-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")])) - #+:cormanlisp (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])) - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/apropos.lisp,v 1.2 2006/02/01 01:00:57 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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")])) + #+:cormanlisp (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 --- /project/rdnzl/cvsroot/RDNZL/examples/apropos2.lisp 2005/01/03 00:55:43 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/examples/apropos2.lisp 2006/02/01 01:00:57 1.2 @@ -1,201 +1,199 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/apropos2.lisp,v 1.1.1.1 2005/01/03 00:55:43 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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 :cl-user) - -(use-package :rdnzl) - -(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")))) - #+:cormanlisp (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) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/apropos2.lisp,v 1.2 2006/02/01 01:00:57 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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")))) + #+:cormanlisp (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)) [3 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/examples/deliver-acl.lisp 2005/01/03 00:55:44 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/examples/deliver-acl.lisp 2006/02/01 01:00:57 1.2 @@ -1,70 +1,70 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/deliver-acl.lisp,v 1.1.1.1 2005/01/03 00:55:44 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - (run-apropos-form) - (exit))) - - (win:set-default-command-line-arguments #p"examples/apropos/apropos.exe" - ;; suppress console - '("+c"))) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/deliver-acl.lisp,v 1.2 2006/02/01 01:00:57 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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) + (run-apropos-form) + (exit))) + + (win:set-default-command-line-arguments #p"examples/apropos/apropos.exe" + ;; suppress console + '("+c"))) --- /project/rdnzl/cvsroot/RDNZL/examples/deliver-ccl.lisp 2005/01/03 00:55:44 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/examples/deliver-ccl.lisp 2006/02/01 01:00:57 1.2 @@ -1,83 +1,83 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/deliver-ccl.lisp,v 1.1.1.1 2005/01/03 00:55:44 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - (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 +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/deliver-ccl.lisp,v 1.2 2006/02/01 01:00:57 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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) + (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 --- /project/rdnzl/cvsroot/RDNZL/examples/deliver-lw.lisp 2005/07/08 18:45:40 1.2 +++ /project/rdnzl/cvsroot/RDNZL/examples/deliver-lw.lisp 2006/02/01 01:00:57 1.3 @@ -1,97 +1,97 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/deliver-lw.lisp,v 1.2 2005/07/08 18:45:40 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - (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) - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/deliver-lw.lisp,v 1.3 2006/02/01 01:00:57 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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) + (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 --- /project/rdnzl/cvsroot/RDNZL/examples/messagebox.lisp 2005/01/03 00:55:44 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/examples/messagebox.lisp 2006/02/01 01:00:57 1.2 @@ -1,47 +1,45 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/messagebox.lisp,v 1.1.1.1 2005/01/03 00:55:44 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - -(use-package :rdnzl) - -(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) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/messagebox.lisp,v 1.2 2006/02/01 01:00:57 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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) --- /project/rdnzl/cvsroot/RDNZL/examples/url.lisp 2005/01/03 00:55:44 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/examples/url.lisp 2006/02/01 01:00:57 1.2 @@ -1,49 +1,47 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/url.lisp,v 1.1.1.1 2005/01/03 00:55:44 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - -(use-package :rdnzl) - -(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))) - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/examples/url.lisp,v 1.2 2006/02/01 01:00:57 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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

1 0

[rdnzl-cvs] CVS RDNZL/doc
by eweitz 01 Feb '06

01 Feb '06

Update of /project/rdnzl/cvsroot/RDNZL/doc In directory common-lisp:/tmp/cvs-serv4420/doc Modified Files: index.html Log Message: 0.9.0 release --- /project/rdnzl/cvsroot/RDNZL/doc/index.html 2006/01/13 07:06:34 1.4 +++ /project/rdnzl/cvsroot/RDNZL/doc/index.html 2006/02/01 01:00:57 1.5 @@ -1,1082 +1,1081 @@ -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> -<html> - -<head> - <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> - <title>RDNZL - A .NET layer for Common Lisp</title> - <style type="text/css"> - pre { padding:5px; background-color:#e0e0e0 } - a { text-decoration: none; } - a.noborder { border:0px } - a.noborder:hover { border:0px } - a.none { border:1px solid white; } - a.none:hover { border:1px solid white; } - a { border:1px solid white; } - a:hover { border: 1px solid black; } - </style> -</head> - -<body bgcolor=white> - -<h2>RDNZL - A .NET layer for Common Lisp</h2> - -<blockquote> -   <h3><a name=abstract class=none>Abstract</a></h3> - -<a href="http://globalia.net/donlope/fz/songs/RDNZL.html">RDNZL</a> (pronounced "Redunzl") enables Common Lisp applications to interact with <a href="http://en.wikipedia.org/wiki/Microsoft_.NET">.NET</a> -libraries. It's more or less a foreign function interface for .NET -languages like <a href="http://en.wikipedia.org/wiki/C_Sharp_programming_language">C#</a> built atop the C foreign function interface. - - - -RDNZL comes with a <a -href="http://www.opensource.org/licenses/bsd-license.php">BSD-style -license</a> so you can basically do with it whatever you want. - - -Download shortcut: <a href="http://weitz.de/files/RDNZL.tar.gz">http://weitz.de/files/RDNZL.tar.gz</a>. - -</blockquote> - -<center> -<a class=none title="Apropos Example" href="#apropos"><img src="apropos.png" border=0 width=624 height=411></a> -</center> - -   <h3><a class=none name="contents">Contents</a></h3> -<ol> - <li><a href="#examples">Examples</a> - <li><a href="#download">Download and installation</a> - <li><a href="#mail">Support and mailing lists</a> - <li><a href="#implementations">Supported Lisp implementations</a> - <li><a href="#dictionary">The RDNZL dictionary</a> - <ol> - <li><a href="#objects">Representation and creation of .NET objects</a> - <ol> - <li><a href="#container-p"><code>container-p</code></a> - <li><a href="#box"><code>box</code></a> - <li><a href="#unbox"><code>unbox</code></a> - <li><a href="#new"><code>new</code></a> - <li><a href="#cast"><code>cast</code></a> - <li><a href="#make-null-object"><code>make-null-object</code></a> - </ol> - <li><a href="#methods">Accessing .NET methods, properties, and fields</a> - <ol> - <li><a href="#invoke"><code>invoke</code></a> - <li><a href="#property"><code>property</code></a> - <li><a href="#field"><code>field</code></a> - <li><a href="#ref"><code>ref</code></a> - </ol> - <li><a href="#arrays">Arrays and enumerations</a> - <ol> - <li><a href="#aref*"><code>aref*</code></a> - <li><a href="#do-rdnzl-array"><code>do-rdnzl-array</code></a> - <li><a href="#list-to-rdnzl-array"><code>list-to-rdnzl-array</code></a> - <li><a href="#rdnzl-array-to-list"><code>rdnzl-array-to-list</code></a> - <li><a href="#integer-to-enum"><code>integer-to-enum</code></a> - <li><a href="#enum-to-integer"><code>enum-to-integer</code></a> - <li><a href="#or-enums"><code>or-enums</code></a> - </ol> - <li><a href="#exceptions">Handling of .NET exceptions</a> - <ol> - <li><a href="#rdnzl-error"><code>rdnzl-error</code></a> - <li><a href="#rdnzl-error-exception"><code>rdnzl-error-exception</code></a> - <li><a href="#rdnzl-handler-case"><code>rdnzl-handler-case</code></a> - </ol> - <li><a href="#types">Type names and assemblies</a> - <ol> - <li><a href="#import-type"><code>import-type</code></a> - <li><a href="#load-assembly"><code>load-assembly</code></a> - <li><a href="#import-assembly"><code>import-assembly</code></a> - <li><a href="#import-types"><code>import-types</code></a> - <li><a href="#use-namespace"><code>use-namespace</code></a> - <li><a href="#unuse-namespace"><code>unuse-namespace</code></a> - <li><a href="#unuse-all-namespaces"><code>unuse-all-namespaces</code></a> - </ol> - <li><a href="#reader">Special reader syntax</a> - <ol> - <li><a href="#enable-rdnzl-syntax"><code>enable-rdnzl-syntax</code></a> - <li><a href="#disable-rdnzl-syntax"><code>disable-rdnzl-syntax</code></a> - </ol> - <li><a href="#direct">Direct calls</a> - <ol> - <li><a href="#define-rdnzl-call"><code>define-rdnzl-call</code></a> - </ol> - <li><a href="#delivery">Saving images and application delivery</a> - <ol> - <li><a href="#shutdown-rdnzl"><code>shutdown-rdnzl</code></a> - <li><a href="#init-rdnzl"><code>init-rdnzl</code></a> - </ol> - </ol> - <li><a href="#details">Implementation details and things to watch out for</a> - <li><a href="#ack">Acknowledgements</a> -</ol> - -   <h3><a class=none name="examples">Examples</a></h3> - -Here's a short example session (using <a href="#implementations">AllegroCL</a>): - -<pre> -<img alt="The Message Box" title="The Message Box" align=right border=0 vspace=10 hspace=10 width=185 height=100 src="box.png">CL-USER(1): <a class=noborder href="#download">(load "/home/lisp/RDNZL/load.lisp")</a> -; 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): (use-package :rdnzl) -T -CL-USER(3): (<a class=noborder href="#enable-rdnzl-syntax">enable-rdnzl-syntax</a>) -CL-USER(4): (<a class=noborder href="#import-types">import-types</a> "System.Windows.Forms" - "MessageBox" "MessageBoxButtons" "DialogResult") -NIL -CL-USER(5): (<a class=noborder href="#use-namespace">use-namespace</a> "System.Windows.Forms") -CL-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 -CL-USER(7): (message-box "Hello World!") ;; user presses "OK" button -T -CL-USER(8): (message-box "Hello World!") ;; user presses "Cancel" button -NIL -</pre> - -(Note: All examples shown here are included in the <code>examples</code> folder of the distribution.) - -For a more interesting example which interacts with custom .NET code -and demonstrates callbacks into Lisp consider the .NET library -<code>AproposGUI.dll</code> (put it into your Lisp's application folder) created -with this C# code: - -<pre> -// 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); - } - } -} -</pre> - -Now load <a class=none name="apropos"><code>examples/apropos.lisp</code></a> which looks like this: - -<pre> -<img alt="Another Message Box" title="Another Message Box" align=right border=0 vspace=10 hspace=10 width=308 height=100 src="box2.png">(in-package :cl-user) - -(use-package :rdnzl) - -(<a class=noborder href="#enable-rdnzl-syntax">enable-rdnzl-syntax</a>) - -(<a class=noborder href="#import-types">import-types</a> "System.Windows.Forms" - "Application" "DockStyle" "Form" "MessageBox" "KeyPressEventHandler" "TextBox") - -(import-types "AproposGUI" - "AproposControl") - -(<a class=noborder href="#use-namespace">use-namespace</a> "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])) - -(<a class=noborder href="#disable-rdnzl-syntax">disable-rdnzl-syntax</a>) -</pre> - -and evaluate <code>(RUN-APROPOS-FORM)</code>. If you want to try this -several times, start the function in its own thread. In AllegroCL or LispWorks -that'd be: - -<pre> -(mp:process-run-function "apropos" #+:lispworks nil #'run-apropos-form) -</pre> - -The last example shows how easy it is to access web pages using the -.NET standard library: - -<pre> -CL-USER(9): (<a class=noborder href="#import-types">import-types</a> "System" "Net.WebClient") -NIL -CL-USER(10): (defun download-url (url) - (let ((web-client (new "System.Net.WebClient"))) - [GetString (new "System.Text.ASCIIEncoding") - [DownloadData web-client url]])) -DOWNLOAD-URL -CL-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> -" -</pre> - -A bit more evolved: - -<pre> -CL-USER(12): (<a class=noborder href="#import-types">import-types</a> "System" "Net.WebException") -NIL -CL-USER(13): (<a class=noborder href="#use-namespace">use-namespace</a> "System.Net") -CL-USER(14): (defun download-url (url) - (<a class=noborder href="#rdnzl-handler-case">rdnzl-handler-case</a> - (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 -CL-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 -</pre> - -This'll also work with https URLs. - - - -   <h3><a class=none name="download">Download and installation</a></h3> - -RDNZL together with this documentation can be downloaded from -<a href="http://weitz.de/files/RDNZL.tar.gz">http://weitz.de/files/RDNZL.tar.gz</a>, the current version is 0.8.0. It -doesn't depend on any other Lisp libraries. The C++ source for the -shared library <code>RDNZL.dll</code> can be downloaded separately from -<a href="http://weitz.de/files/RDNZL_cpp.tar.gz">http://weitz.de/files/RDNZL_cpp.tar.gz</a> but you don't need this archive -to deploy RDNZL - <code>RDNZL.tar.gz</code> already contains <code>RDNZL.dll</code>. -You can also access the current RDNZL source code (Lisp and C++) via <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=rdnzl">CVS</a>. - -Before you load RDNZL make sure you have the <a href="http://msdn.microsoft.com/netframework/downloads/framework1_1/">.NET framework</a> installed. -Then move the file <code>RDNZL.dll</code> 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 <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_load.htm"><code>LOAD</code></a> the file <code>load.lisp</code> - that's -all. (Or alternatively use <a href="http://www.cliki.net/asdf">ASDF</a> if you like - RDNZL comes with a -system definition for ASDF.) - -Oh, and - for the moment - don't use <a -href="http://common-lisp.net/project/slime/">SLIME</a> together with -LispWorks when loading RDNZL - see <a href="http://common-lisp.net/pipermail/slime-devel/2004-December/002877.html">this message</a> for an explanation. - - -   <h3><a name="mail" class=none>Support and mailing lists</a></h3> [1766 lines skipped]

1 0

[rdnzl-cvs] CVS RDNZL
by eweitz 01 Feb '06

01 Feb '06

Update of /project/rdnzl/cvsroot/RDNZL In directory common-lisp:/tmp/cvs-serv4420 Modified Files: CHANGELOG.txt RDNZL.dll README.txt adapter.lisp arrays.lisp container.lisp direct.lisp ffi.lisp import.lisp load.lisp packages.lisp port-acl.lisp port-ccl.lisp port-clisp.lisp port-lw.lisp rdnzl.asd reader.lisp specials.lisp util.lisp Added Files: port-sbcl.lisp Log Message: 0.9.0 release --- /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/01/13 07:06:28 1.4 +++ /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/02/01 01:00:56 1.5 @@ -1,3 +1,7 @@ +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) Binary files /project/rdnzl/cvsroot/RDNZL/RDNZL.dll 2005/11/21 14:03:40 1.2 and /project/rdnzl/cvsroot/RDNZL/RDNZL.dll 2006/02/01 01:00:56 1.3 differ --- /project/rdnzl/cvsroot/RDNZL/README.txt 2005/01/03 00:55:40 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/README.txt 2006/02/01 01:00:56 1.2 @@ -1,29 +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 -<http://common-lisp.net/project/hyperdoc/> and -<http://www.cliki.net/hyperdoc>. \ No newline at end of file +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 +<http://common-lisp.net/project/hyperdoc/> and +<http://www.cliki.net/hyperdoc>. --- /project/rdnzl/cvsroot/RDNZL/adapter.lisp 2005/07/08 18:45:33 1.2 +++ /project/rdnzl/cvsroot/RDNZL/adapter.lisp 2006/02/01 01:00:56 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/adapter.lisp,v 1.2 2005/07/08 18:45:33 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/adapter.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2004-2006, 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 --- /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2005/07/08 18:45:33 1.2 +++ /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2006/02/01 01:00:56 1.3 @@ -1,119 +1,119 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.2 2005/07/08 18:45:33 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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 [%Length ,array])) - (dotimes (,i ,length) - (let ((,var (get-array-element ,array ,i))) - ,@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))) - (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 or a string) and rank 1 with the elements from the Lisp list -LIST." - (when (stringp 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) - (push element list)) - (nreverse 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 (stringp 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) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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 [%Length ,array])) + (dotimes (,i ,length) + (let ((,var (get-array-element ,array ,i))) + ,@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))) + (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 or a string) and rank 1 with the elements from the Lisp list +LIST." + (when (stringp 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) + (push element list)) + (nreverse 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 (stringp 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) --- /project/rdnzl/cvsroot/RDNZL/container.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/container.lisp 2006/02/01 01:00:56 1.3 @@ -1,450 +1,456 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/container.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - ;; 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)) - (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)) - ,@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 - (flag-for-finalization ,container #'maybe-free-container-pointer))))))) - -(defun make-type-from-name (name) - "Returns the .NET type with the name NAME - uses the static function -Type::GetType." - (wrap-with-container - (ffi-call-with-foreign-string* %make-type-from-name - name))) - -(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 - (%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 ,@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)))))) - -;; 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. 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)) - ((stringp object) - (ffi-call-with-args %invoke-static-member - (make-type-from-name (resolve-type-name 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)) - ((stringp 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))) - ((stringp 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)) - ((stringp 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)) - ((stringp 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) - [509 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/direct.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/direct.lisp 2006/02/01 01:00:56 1.3 @@ -1,297 +1,297 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/direct.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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)))) - ',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) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/direct.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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) [197 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/ffi.lisp 2006/01/13 07:06:28 1.3 +++ /project/rdnzl/cvsroot/RDNZL/ffi.lisp 2006/02/01 01:00:56 1.4 @@ -1,337 +1,336 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.3 2006/01/13 07:06:28 eweitz Exp $ - -;;; Copyright (c) 2004-2006, 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* (,(intern - (concatenate 'string "%" (mangle-name c-name)) - :rdnzl) - ,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 "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 "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)) - (declare (ignore types)) - ;; 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*)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.4 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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* (,(intern + (concatenate 'string "%" (mangle-name c-name)) + :rdnzl) + ,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* [276 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/import.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/import.lisp 2006/02/01 01:00:56 1.3 @@ -1,193 +1,193 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/import.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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 ((stringp 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) - ((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 <http://msdn.microsoft.com/library/en-us/vcmex/html/vcconconvertingmanagedex…> - (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") - (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) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/import.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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 ((stringp 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) + ((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 <http://msdn.microsoft.com/library/en-us/vcmex/html/vcconconvertingmanagedex…> + (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") + (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) --- /project/rdnzl/cvsroot/RDNZL/load.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/load.lisp 2006/02/01 01:00:56 1.3 @@ -1,72 +1,73 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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" - #+:lispworks "port-lw" - "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))))) - - - - - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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" + #+: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))))) + + + + + --- /project/rdnzl/cvsroot/RDNZL/packages.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/packages.lisp 2006/02/01 01:00:56 1.3 @@ -1,68 +1,74 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/packages.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - (:export :aref* - :box - :cast - :container-p - :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 - :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)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/packages.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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 :aref* + :box + :cast + :container-p + :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 + :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 --- /project/rdnzl/cvsroot/RDNZL/port-acl.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-acl.lisp 2006/02/01 01:00:56 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-acl.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-acl.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ -;;; Copyright (c) 2004-2005, Charles A. Cox, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2004-2006, 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 @@ -131,9 +131,10 @@ (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." + "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 @@ -150,9 +151,9 @@ (defmacro ffi-define-callable ((c-name result-type) arg-list &body body) - "Defines a Lisp which can be called from C as 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." + "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 @@ -274,5 +275,5 @@ sys:*exit-cleanup-forms*)) (defun full-gc () - "Invoke a full garbage collection." + "Invokes a full garbage collection." (excl:gc t)) --- /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2006/02/01 01:00:56 1.3 @@ -1,282 +1,283 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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-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 '(: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 which can be called from C as 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." - (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) - ,@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 () - "Invoke a full garbage collection." - (ccl:gc 3)) - -(export 'lf-to-crlf :rdnzl) -(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*)) - ,@body)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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-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 '(: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)))) + [168 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp 2006/02/01 01:00:56 1.3 @@ -1,254 +1,254 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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 which can be called from C as 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." - (with-unique-names (foreign-function) - `(progn - (defun ,c-name ,(mapcar #'first arg-list) - ,@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))) - ,@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 () - "Invoke a full garbage collection." - (ext:gc)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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) + ,@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)) [111 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/port-lw.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-lw.lisp 2006/02/01 01:00:56 1.3 @@ -1,213 +1,214 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-lw.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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-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 :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 - ;; 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 which can be called from C as 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-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) - ,@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.") - -(defun 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 () - "Invoke a full garbage collection." - (hcl:mark-and-sweep 3)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-lw.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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-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 :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 + ;; 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) + ,@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)) [30 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/01/13 07:06:28 1.3 +++ /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/02/01 01:00:56 1.4 @@ -1,56 +1,57 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.3 2006/01/13 07:06:28 eweitz Exp $ - -;;; Copyright (c) 2004, 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 <http://www.cliki.net/asdf> - -(in-package :cl-user) - -(defpackage #:rdnzl.system - (:use #:cl - #:asdf)) - -(in-package #:rdnzl.system) - -(defsystem #:rdnzl - :serial t - :version "0.8.0" - :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 - #+:lispworks (:file "port-lw") ; LispWorks-specific stuff here - (:file "ffi") - (:file "container") - (:file "reader") - (:file "arrays") - (:file "adapter") - (:file "import") - (:file "direct"))) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.4 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004, 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 <http://www.cliki.net/asdf> + +(in-package :cl-user) + +(defpackage #:rdnzl.system + (:use #:cl + #:asdf)) + +(in-package #:rdnzl.system) + +(defsystem #:rdnzl + :serial t + :version "0.9.0" + :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 + #+: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"))) --- /project/rdnzl/cvsroot/RDNZL/reader.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/reader.lisp 2006/02/01 01:00:56 1.3 @@ -1,260 +1,260 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/reader.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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 ,@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)) - (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 - (setf function-name 'property - token (subseq token 1))) - ((#\$) - ;; first char #\$ means field - (setf function-name 'field - token (subseq token 1))) - ((#\+) - ;; first char #\+ adds "add_" - (setf token (concatenate 'string "add_" - (subseq token 1)))) - ((#\-) - ;; first char #\- adds "remove_" - (setf token (concatenate 'string "remove_" - (subseq token 1)))))) - ;; 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 member-name function-name type-name))) - (t - ;; otherwise it's an instance invocation - (values 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))) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/reader.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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 ,@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)) + (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 + (setf function-name 'property + token (subseq token 1))) + ((#\$) + ;; first char #\$ means field [123 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/specials.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/specials.lisp 2006/02/01 01:00:56 1.3 @@ -1,99 +1,106 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/specials.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, 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) - -(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.") - -(pushnew :rdnzl *features*) - -;; stuff for Nikodemus Siivola's HYPERDOC -;; see <http://common-lisp.net/project/hyperdoc/> -;; and <http://www.cliki.net/hyperdoc> - -(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)))) - \ No newline at end of file +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/specials.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, 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 <http://www.sbcl.org/manual/Defining-Constants.html> + `(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.") + +(pushnew :rdnzl *features*) + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see <http://common-lisp.net/project/hyperdoc/> +;; and <http://www.cliki.net/hyperdoc> + +(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)))) --- /project/rdnzl/cvsroot/RDNZL/util.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/util.lisp 2006/02/01 01:00:56 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/util.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/util.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2004-2006, 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 --- /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/02/01 01:00:57 NONE +++ /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/02/01 01:00:57 1.1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- ;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp,v 1.1 2006/02/01 01:00:56 eweitz Exp $ ;;; Copyright (c) 2004-2006, 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 LispWorks FLI." (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) (ffi-wide-char '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." (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)))))))) ((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)))))) (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) ,@body)))) (defun ffi-make-pointer (name) "Returns an FFI pointer to the \(callback) address specified by the name NAME." (gethash name *callbacks*)) (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) ,@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))

1 0

[rdnzl-cvs] CVS update: RDNZL-cpp/RDNZL/DelegateAdapter.cpp RDNZL-cpp/RDNZL/DelegateAdapter.h
by eweitz＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL In directory common-lisp.net:/tmp/cvs-serv26572/RDNZL Modified Files: DelegateAdapter.cpp DelegateAdapter.h Log Message: delegate adapter fixes (Dominic Robinson), version 0.5.0 Date: Fri Jan 13 08:08:46 2006 Author: eweitz Index: RDNZL-cpp/RDNZL/DelegateAdapter.cpp diff -u RDNZL-cpp/RDNZL/DelegateAdapter.cpp:1.1.1.1 RDNZL-cpp/RDNZL/DelegateAdapter.cpp:1.2 --- RDNZL-cpp/RDNZL/DelegateAdapter.cpp:1.1.1.1 Mon Jan 3 02:00:48 2005 +++ RDNZL-cpp/RDNZL/DelegateAdapter.cpp Fri Jan 13 08:08:46 2006 @@ -1,6 +1,6 @@ -// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DelegateAdapter.cpp,v 1.1.1.1 2005/01/03 01:00:48 eweitz Exp $ +// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DelegateAdapter.cpp,v 1.2 2006/01/13 07:08:46 eweitz Exp $ // -// Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. +// Copyright (c) 2004-2006, 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 @@ -30,7 +30,7 @@ #include "DelegateAdapter.h" // the destructor notifies Lisp that this instance is no longer used - -// at least in theory, this doesn't seem to work right now +// might be called from a "foreign" thread, see docs DelegateAdapter::~DelegateAdapter() { release(indexIntoLisp); } @@ -53,7 +53,7 @@ // 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)) { +void setFunctionPointers(void *(*callback_fp)(int, void *), void (*release_fp)(int)) { DelegateAdapter::callback = callback_fp; DelegateAdapter::release = release_fp; } Index: RDNZL-cpp/RDNZL/DelegateAdapter.h diff -u RDNZL-cpp/RDNZL/DelegateAdapter.h:1.1.1.1 RDNZL-cpp/RDNZL/DelegateAdapter.h:1.2 --- RDNZL-cpp/RDNZL/DelegateAdapter.h:1.1.1.1 Mon Jan 3 02:00:48 2005 +++ RDNZL-cpp/RDNZL/DelegateAdapter.h Fri Jan 13 08:08:46 2006 @@ -1,6 +1,6 @@ -// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DelegateAdapter.h,v 1.1.1.1 2005/01/03 01:00:48 eweitz Exp $ +// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DelegateAdapter.h,v 1.2 2006/01/13 07:08:46 eweitz Exp $ // -// Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. +// Copyright (c) 2004-2006, 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 @@ -36,7 +36,7 @@ void init(int index); Object *invoke (Object* args[]); static void *(*callback)(int, void *); - static void *(*release)(int); + 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 @@ -44,5 +44,5 @@ }; extern "C" { - __declspec(dllexport) void setFunctionPointers(void *(*callback_fp)(int, void *), void *(*release_fp)(int)); + __declspec(dllexport) void setFunctionPointers(void *(*callback_fp)(int, void *), void (*release_fp)(int)); }

1 0

[rdnzl-cvs] CVS update: RDNZL-cpp/CHANGELOG.txt
by eweitz＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/rdnzl/cvsroot/RDNZL-cpp In directory common-lisp.net:/tmp/cvs-serv26572 Modified Files: CHANGELOG.txt Log Message: delegate adapter fixes (Dominic Robinson), version 0.5.0 Date: Fri Jan 13 08:08:45 2006 Author: eweitz Index: RDNZL-cpp/CHANGELOG.txt diff -u RDNZL-cpp/CHANGELOG.txt:1.2 RDNZL-cpp/CHANGELOG.txt:1.3 --- RDNZL-cpp/CHANGELOG.txt:1.2 Mon Nov 21 15:05:40 2005 +++ RDNZL-cpp/CHANGELOG.txt Fri Jan 13 08:08:44 2006 @@ -1,3 +1,7 @@ +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)

1 0

[rdnzl-cvs] CVS update: RDNZL/doc/index.html
by eweitz＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/rdnzl/cvsroot/RDNZL/doc In directory common-lisp.net:/tmp/cvs-serv26247/doc Modified Files: index.html Log Message: delegate fixes (Dominic Robinson), version 0.8.0 Date: Fri Jan 13 08:06:34 2006 Author: eweitz Index: RDNZL/doc/index.html diff -u RDNZL/doc/index.html:1.3 RDNZL/doc/index.html:1.4 --- RDNZL/doc/index.html:1.3 Mon Nov 21 15:03:43 2005 +++ RDNZL/doc/index.html Fri Jan 13 08:06:34 2006 @@ -104,7 +104,7 @@ <li><a href="#delivery">Saving images and application delivery</a> <ol> <li><a href="#shutdown-rdnzl"><code>shutdown-rdnzl</code></a> - <li><a href="#init-rdnzl"><code>shutdown-rdnzl</code></a> + <li><a href="#init-rdnzl"><code>init-rdnzl</code></a> </ol> </ol> <li><a href="#details">Implementation details and things to watch out for</a> @@ -307,7 +307,7 @@ </pre> and evaluate <code>(RUN-APROPOS-FORM)</code>. If you want to try this -several times start the function in its own thread. In AllegroCL or LispWorks +several times, start the function in its own thread. In AllegroCL or LispWorks that'd be: <pre> @@ -373,7 +373,7 @@   <h3><a class=none name="download">Download and installation</a></h3> RDNZL together with this documentation can be downloaded from -<a href="http://weitz.de/files/RDNZL.tar.gz">http://weitz.de/files/RDNZL.tar.gz</a>, the current version is 0.7.1. It +<a href="http://weitz.de/files/RDNZL.tar.gz">http://weitz.de/files/RDNZL.tar.gz</a>, the current version is 0.8.0. It doesn't depend on any other Lisp libraries. The C++ source for the shared library <code>RDNZL.dll</code> can be downloaded separately from <a href="http://weitz.de/files/RDNZL_cpp.tar.gz">http://weitz.de/files/RDNZL_cpp.tar.gz</a> but you don't need this archive @@ -399,7 +399,7 @@ For questions, bug reports, feature requests, improvements, or patches please use the <a href="http://common-lisp.net/mailman/listinfo/rdnzl-devel">rdnzl-devel -mailing list</a>. If you want to be notified about future releases +mailing list</a>. If you want to be notified about future releases, subscribe to the <a href="http://common-lisp.net/mailman/listinfo/rdnzl-announce">rdnzl-announce mailing list</a>. These mailing lists and the CVS repository were made available thanks to @@ -416,7 +416,7 @@ The current status for the main Win32 Common Lisp implementations is as follows: <ul> -<li><a href="http://www.cormanlisp.com/">Corman Common Lisp</a>: Corman Lisp is fully supported thanks to help of Roger Corman. +<li><a href="http://www.cormanlisp.com/">Corman Common Lisp</a>: Corman Lisp is fully supported thanks to the help of Roger Corman. <li><a href="http://ecls.sourceforge.net/">ECL</a>: I'm not familiar enough with ECL to port RDNZL myself. Please send patches if you know how to do it. @@ -431,7 +431,7 @@ </ul> All implementation-specific parts of RDNZL are located in files called <code>port-acl.lisp</code>, <code>port-ccl.lisp</code>, <code>port-lw.lisp</code>, and so on. If you want to port RDNZL to -another Lisp it should suffice to just create the corresponding +another Lisp, it should suffice to just create the corresponding <code>port-xx.lisp</code> file for your implementation. @@ -461,9 +461,9 @@ for the first argument of <a href="#invoke"><code>INVOKE</code></a>, <a href="#property"><code>PROPERTY</code></a>, and <a href="#field"><code>FIELD</code></a>) you can also provide the corresponding "native" Lisp objects as long as they can be converted to .NET objects by the function <a href="#box"><code>BOX</code></a>. On the other hand, if -a RDNZL function returns a .NET object it will be automatically +a RDNZL function returns a .NET object, it will be automatically translated to a Lisp object by <a href="#unbox"><code>UNBOX</code></a> if possible. If a RDNZL function -call doesn't return a result (i.e. if its return type is <code>System.Void</code>) +call doesn't return a result (i.e. if its return type is <code>System.Void</code>), then the keyword <code>:VOID</code> is returned. If a <code>NULL</code> object is returned, RDNZL returns <code>NIL</code> and <code>T</code> as a second return value because otherwise there'd be no difference from returning a false boolean value. @@ -528,7 +528,7 @@ constructor based on the signature determined by <code>args</code>. <code>type</code> can either be a container representing a .NET type or a string naming the type. -If <code>type</code> is a delegate type then there should be exactly one more +If <code>type</code> is a delegate type, then there should be exactly one more argument to <code>NEW</code> and it must be a Lisp closure with a corresponding signature. This is how callbacks from .NET into Lisp are implemented. (See the <a href="#apropos">second example</a> above and look for <code>KeyPressEventHandler</code>.) </blockquote> @@ -560,8 +560,8 @@ <blockquote> Invokes the public .NET method named by the string <code>method-name</code>. If -<code>object</code> is a container an instance method is invoked. If <code>object</code> is a -string the static method of the type named by this string is invoked. +<code>object</code> is a container, an instance method is invoked. If <code>object</code> is a +string, the static method of the type named by this string is invoked. </blockquote> [Accessor] @@ -570,8 +570,8 @@ <blockquote> Gets or sets the public .NET property named by the string -<code>property-name</code>. If <code>object</code> is a container an instance property is -accessed. If <code>object</code> is a string the static property of the type named +<code>property-name</code>. If <code>object</code> is a container, an instance property is +accessed. If <code>object</code> is a string, the static property of the type named by this string is accessed. </blockquote> @@ -581,8 +581,8 @@ <blockquote> Gets or sets the public .NET field named by the string <code>field-name</code>. If -<code>object</code> is a container an instance field is accessed. If <code>object</code> is a -string the static field of the type named by this string is accessed. +<code>object</code> is a container, an instance field is accessed. If <code>object</code> is a +string, the static field of the type named by this string is accessed. </blockquote> [Function] @@ -592,7 +592,7 @@ Makes a pass-by-reference type out of <code>object</code> and returns <code>object</code>. If -<code>object</code> is not a <a href="#objects">container</a> +<code>object</code> is not a <a href="#objects">container</a>, it'll be <a href="#box">boxed</a> first. This function makes only sense if <code>object</code> is used as an argument to <a href="#invoke"><code>INVOKE</code></a>! (And after <a href="#invoke"><code>INVOKE</code></a> has been @@ -707,7 +707,7 @@ <a class=none name="rdnzl-error-exception">rdnzl-error-exception condition => exception</a> <blockquote> -If <code>condition</code> is an error of type <a href="#rdnzl-error"><code>RDNZL-ERROR</code></a> then this function will +If <code>condition</code> is an error of type <a href="#rdnzl-error"><code>RDNZL-ERROR</code></a>, then this function will return the .NET exception object that was actually raised. </blockquote> @@ -735,13 +735,13 @@ This is boring and error-prone, so RDNZL provides two ways to make it easier for you: You can <a href="#import-type">import types</a> and you can <a href="#use-namespace">use namespaces</a>. -If you import a type RDNZL internally remembers its assembly-qualified +If you import a type, RDNZL internally remembers its assembly-qualified name and you can now use its full name (like <code>"System.Windows.Forms.Button"</code>) instead. -If this is still too long for you you can use namespaces to further +If this is still too long for you, you can use namespaces to further abbreviate type names. So, if you are using the namespace -<code>"System.Windows.Forms"</code> you can just call the type <code>"Button"</code>. Note that +<code>"System.Windows.Forms"</code>, you can just call the type <code>"Button"</code>. Note that this'll only work for imported types, though. [Function] @@ -751,13 +751,13 @@ Imports the .NET type <code>type</code>, i.e. registers its name as one that can be abbreviated (see <a href="#use-namespace"><code>USE-NAMESPACE</code></a>) and creates a mapping from its short name to its assembly-qualified name (if necessary). If <code>type</code> is a -string and <code>assembly</code> is <code>NIL</code> then the function will try to create the +string and <code>assembly</code> is <code>NIL</code>, then the function will try to create the type from the string with the static .NET method <code>System.Type::GetType</code>. If <code>type</code> is a string and <code>assembly</code> is a container representing an -assembly then instead the .NET instance method +assembly, then instead the .NET instance method <code>System.Reflection.Assembly::GetType</code> will be used. If <code>type</code> is already -a .NET object (i.e. a <a href="#objects">container</a>) then the function will just register -its name. If <code>assembly</code> is a true value then the name will also be +a .NET object (i.e. a <a href="#objects">container</a>), then the function will just register +its name. If <code>assembly</code> 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. </blockquote> @@ -778,7 +778,7 @@ <blockquote> Imports all public types of the assembly <code>assembly</code> (a string or a -container). If <code>assembly</code> is a string then the assembly is first loaded +container). If <code>assembly</code> is a string, then the assembly is first loaded with <a href="#load-assembly"><code>LOAD-ASSEMBLY</code></a>. Returns <code>assembly</code> as a container. </blockquote> @@ -844,7 +844,7 @@ <pre> (<a class=noborder href="#invoke">invoke</a> type "IsSubclassOf" other-type) </pre> -If the symbol starts with a percent or dollar sign then it is removed +If the symbol starts with a percent or dollar, sign then it is removed and the result is a call to <a href="#property"><code>PROPERTY</code></a> or <a href="#field"><code>FIELD</code></a> respectively: <pre> @@ -852,7 +852,7 @@ [$textBox control] => (<a class=noborder href="#field">field</a> control "textBox") </pre> -If the symbol contains a dot then in all three cases this'll result in +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: @@ -862,7 +862,7 @@ [$OpCodes.Switch] => (<a class=noborder href="#field">field</a> "Opcodes" "Switch") </pre> -If the symbol starts with a plus or minus sign then this sign is replaced +If the symbol starts with a plus or minus sign, then this sign is replaced with <code>"add_"</code> or <code>"remove_"</code> respectively. This is the convention used to add or remove event handlers: @@ -939,10 +939,10 @@ <a class=none name="define-rdnzl-call">define-rdnzl-call lisp-name (<tt>&key</tt> member-kind dotnet-name type-name doc-string) args => lisp-name </a> <blockquote> -Defines a Lisp function named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">function name</a> <code>lisp-name</code> which invokes the .NET member named by the string <code>dotnet-name</code>. <code>member-kind</code> must be one of the keywords <code>:METHOD</code>, <code>:PROPERTY</code>, or <code>:FIELD</code> and obviously determines whether a method, a property, or a field is to be invoked - the default is <code>:METHOD</code>. If <code>type-name</code> is <code>NIL</code> (which is the default) an instance member is invoked, otherwise <code>type-name</code> should be a string naming a .NET type and a static member of this type is invoked instead. <code>doc-string</code>, if provided, should be a string, namely the documentation string for the Lisp function which is created. If <code>doc-string</code> is <code>NIL</code> (which is the default) a generic documentation string will be created. +Defines a Lisp function named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function…">function name</a> <code>lisp-name</code> which invokes the .NET member named by the string <code>dotnet-name</code>. <code>member-kind</code> must be one of the keywords <code>:METHOD</code>, <code>:PROPERTY</code>, or <code>:FIELD</code> and obviously determines whether a method, a property, or a field is to be invoked - the default is <code>:METHOD</code>. If <code>type-name</code> is <code>NIL</code> (which is the default), an instance member is invoked, otherwise <code>type-name</code> should be a string naming a .NET type and a static member of this type is invoked instead. <code>doc-string</code>, if provided, should be a string, namely the documentation string for the Lisp function which is created. If <code>doc-string</code> is <code>NIL</code> (which is the default), a generic documentation string will be created. -If <code>dotnet-name</code> is <code>NIL</code> (which is the default) then the name of the .NET member will be created from <code>lisp-name</code> be the following rules: -Take the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_2.htm">symbol name</a> of <code>lisp-name</code> 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 <code>(SETF symbol)</code> then we use <code>symbol</code> instead of <code>lisp-name</code>. Here are some examples (note that the package doesn't matter): +If <code>dotnet-name</code> is <code>NIL</code> (which is the default), then the name of the .NET member will be created from <code>lisp-name</code> be the following rules: +Take the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_2.htm">symbol name</a> of <code>lisp-name</code> 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 <code>(SETF symbol)</code>, then we use <code>symbol</code> instead of <code>lisp-name</code>. Here are some examples (note that the package doesn't matter): <table border=1 cellspacing=1 cellpadding=3> <tr><th><code>lisp-name</code> </th><th> <code>dotnet-name</code></th></tr> @@ -980,7 +980,7 @@ sure that no references to .NET objects remain in the image and finally call <a href="#shutdown-rdnzl"><code>SHUTDOWN-RDNZL</code></a> prior to saving or delivering. -If you restart the image or start the executable make sure to call +If you restart the image or start the executable, make sure to call <a href="#init-rdnzl"><code>INIT-RDNZL</code></a> before accessing any RDNZL functionality. That should do the trick. @@ -993,7 +993,7 @@ <blockquote> Prepares RDNZL for delivery or image saving. After calling this function RDNZL can't be used anymore unless <a href="#init-rdnzl"><code>INIT-RDNZL</code></a> is called -again. If <code>no-gc</code> is <code>NIL</code> (the default) a full garbage collection is +again. If <code>no-gc</code> is <code>NIL</code> (the default), a full garbage collection is also performed. </blockquote> @@ -1013,10 +1013,10 @@ the <a href="http://www.cliki.net/AMOP">MOP</a> 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 design decisions in RDNZL are based on the +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 +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 @@ -1024,7 +1024,7 @@ fully in .NET. If you want to know more about the way methods are -looked up in RDNZL read <a href="http://www.rivendell.ws/dot-scheme/scheme-workshop-2003-paper.pdf">Pedro Pinto's paper</a> +looked up in RDNZL, read <a href="http://www.rivendell.ws/dot-scheme/scheme-workshop-2003-paper.pdf">Pedro Pinto's paper</a> about the implementation of <a href="http://www.rivendell.ws/dot-scheme/">Dot-Scheme</a> the basics of which apply to RDNZL as well. @@ -1046,10 +1046,21 @@ 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, <a +href="http://common-lisp.net/pipermail/rdnzl-devel/2006-January/000048.html">as +Dominic Robinson has pointed out</a>, there might be GC issues in this +case. +See <a href="http://weitz.de/lw-callbacks/">here</a> +and <a +href="http://common-lisp.net/pipermail/rdnzl-devel/2005-December/000044.html">here</a> +for possible workarounds for LispWorks. + About the name: It was pretty clear to me from the beginning that the name of the library should be "<a href="http://globalia.net/donlope/fz/songs/RDNZL.html">RDNZL</a>." -However, I'm not sure what this acronym exactly stands for. Surely "L" is +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... :)   <h3><a class=none name="ack">Acknowledgements</a></h3> @@ -1063,7 +1074,7 @@ 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 Franz Inc. (and particularly Jans Aasman) for supporting the development of RDNZL. -$Header: /project/rdnzl/cvsroot/RDNZL/doc/index.html,v 1.3 2005/11/21 14:03:43 eweitz Exp $ +$Header: /project/rdnzl/cvsroot/RDNZL/doc/index.html,v 1.4 2006/01/13 07:06:34 eweitz Exp $ <a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> </body>

1 0

[rdnzl-cvs] CVS update: RDNZL/CHANGELOG.txt RDNZL/ffi.lisp RDNZL/rdnzl.asd
by eweitz＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/rdnzl/cvsroot/RDNZL In directory common-lisp.net:/tmp/cvs-serv26247 Modified Files: CHANGELOG.txt ffi.lisp rdnzl.asd Log Message: delegate fixes (Dominic Robinson), version 0.8.0 Date: Fri Jan 13 08:06:29 2006 Author: eweitz Index: RDNZL/CHANGELOG.txt diff -u RDNZL/CHANGELOG.txt:1.3 RDNZL/CHANGELOG.txt:1.4 --- RDNZL/CHANGELOG.txt:1.3 Mon Nov 21 15:03:40 2005 +++ RDNZL/CHANGELOG.txt Fri Jan 13 08:06:28 2006 @@ -1,3 +1,8 @@ +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 Index: RDNZL/ffi.lisp diff -u RDNZL/ffi.lisp:1.2 RDNZL/ffi.lisp:1.3 --- RDNZL/ffi.lisp:1.2 Fri Jul 8 20:45:34 2005 +++ RDNZL/ffi.lisp Fri Jan 13 08:06:28 2006 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.3 2006/01/13 07:06:28 eweitz Exp $ -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2004-2006, 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 @@ -331,7 +331,7 @@ (funcall (gethash index *callback-hash*) args)) (ffi-define-callable - (ReleaseDelegateAdapter ffi-void-pointer) + (ReleaseDelegateAdapter ffi-void) ((index ffi-integer)) ;; remove entry from hash table if CLR is done with it - (remhash index *callback-hash*)) \ No newline at end of file + (remhash index *callback-hash*)) Index: RDNZL/rdnzl.asd diff -u RDNZL/rdnzl.asd:1.2 RDNZL/rdnzl.asd:1.3 --- RDNZL/rdnzl.asd:1.2 Mon Nov 21 15:04:23 2005 +++ RDNZL/rdnzl.asd Fri Jan 13 08:06:28 2006 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.2 2005/11/21 14:04:23 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.3 2006/01/13 07:06:28 eweitz Exp $ ;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved. @@ -39,7 +39,7 @@ (defsystem #:rdnzl :serial t - :version "0.7.1" + :version "0.8.0" :components ((:file "packages") (:file "specials") (:file "util")

1 0

[rdnzl-cvs] CVS update: RDNZL-cpp/RDNZL/DotNetContainer.cpp RDNZL-cpp/RDNZL/DotNetContainer.h
by eweitz＠common-lisp.net 21 Nov '05

21 Nov '05

Update of /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL In directory common-lisp.net:/tmp/cvs-serv23881/RDNZL Modified Files: DotNetContainer.cpp DotNetContainer.h Log Message: version 0.4.1 Date: Mon Nov 21 15:05:41 2005 Author: eweitz Index: RDNZL-cpp/RDNZL/DotNetContainer.cpp diff -u RDNZL-cpp/RDNZL/DotNetContainer.cpp:1.1.1.1 RDNZL-cpp/RDNZL/DotNetContainer.cpp:1.2 --- RDNZL-cpp/RDNZL/DotNetContainer.cpp:1.1.1.1 Mon Jan 3 02:00:48 2005 +++ RDNZL-cpp/RDNZL/DotNetContainer.cpp Mon Nov 21 15:05:41 2005 @@ -1,4 +1,4 @@ -// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DotNetContainer.cpp,v 1.1.1.1 2005/01/03 01:00:48 eweitz Exp $ +// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DotNetContainer.cpp,v 1.2 2005/11/21 14:05:41 eweitz Exp $ // // Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. // @@ -67,6 +67,10 @@ DotNetContainer::DotNetContainer(__int64 n) { init(__box(n)); +} + +DotNetContainer::DotNetContainer(float f) { + init(__box(f)); } DotNetContainer::DotNetContainer(double d) { Index: RDNZL-cpp/RDNZL/DotNetContainer.h diff -u RDNZL-cpp/RDNZL/DotNetContainer.h:1.1.1.1 RDNZL-cpp/RDNZL/DotNetContainer.h:1.2 --- RDNZL-cpp/RDNZL/DotNetContainer.h:1.1.1.1 Mon Jan 3 02:00:48 2005 +++ RDNZL-cpp/RDNZL/DotNetContainer.h Mon Nov 21 15:05:41 2005 @@ -1,4 +1,4 @@ -// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DotNetContainer.h,v 1.1.1.1 2005/01/03 01:00:48 eweitz Exp $ +// $Header: /project/rdnzl/cvsroot/RDNZL-cpp/RDNZL/DotNetContainer.h,v 1.2 2005/11/21 14:05:41 eweitz Exp $ // // Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. // @@ -38,6 +38,7 @@ DotNetContainer(bool b); DotNetContainer(__int32 n); DotNetContainer(__int64 n); + DotNetContainer(float f); DotNetContainer(double d); DotNetContainer(__wchar_t c); DotNetContainer(const __wchar_t *s);

1 0

[rdnzl-cvs] CVS update: RDNZL-cpp/CHANGELOG.txt
by eweitz＠common-lisp.net 21 Nov '05

21 Nov '05

Update of /project/rdnzl/cvsroot/RDNZL-cpp In directory common-lisp.net:/tmp/cvs-serv23881 Modified Files: CHANGELOG.txt Log Message: version 0.4.1 Date: Mon Nov 21 15:05:40 2005 Author: eweitz Index: RDNZL-cpp/CHANGELOG.txt diff -u RDNZL-cpp/CHANGELOG.txt:1.1.1.1 RDNZL-cpp/CHANGELOG.txt:1.2 --- RDNZL-cpp/CHANGELOG.txt:1.1.1.1 Mon Jan 3 02:00:48 2005 +++ RDNZL-cpp/CHANGELOG.txt Mon Nov 21 15:05:40 2005 @@ -1,3 +1,7 @@ +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"

1 0

[rdnzl-cvs] CVS update: RDNZL/rdnzl.asd
by eweitz＠common-lisp.net 21 Nov '05

21 Nov '05

Update of /project/rdnzl/cvsroot/RDNZL In directory common-lisp.net:/tmp/cvs-serv23855 Modified Files: rdnzl.asd Log Message: version in system definition Date: Mon Nov 21 15:04:23 2005 Author: eweitz Index: RDNZL/rdnzl.asd diff -u RDNZL/rdnzl.asd:1.1.1.1 RDNZL/rdnzl.asd:1.2 --- RDNZL/rdnzl.asd:1.1.1.1 Mon Jan 3 01:55:39 2005 +++ RDNZL/rdnzl.asd Mon Nov 21 15:04:23 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.1.1.1 2005/01/03 00:55:39 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.2 2005/11/21 14:04:23 eweitz Exp $ ;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved. @@ -39,6 +39,7 @@ (defsystem #:rdnzl :serial t + :version "0.7.1" :components ((:file "packages") (:file "specials") (:file "util")

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

rdnzl-cvs