[bknr-cvs] r2028 - in branches/xml-class-rework/projects/bos: . m2 web worldpay-test
by bknr＠bknr.net 22 Oct '06
by bknr＠bknr.net 22 Oct '06
22 Oct '06
Author: hhubner
Date: 2006-10-22 12:50:56 -0400 (Sun, 22 Oct 2006)
New Revision: 2028
Modified:
branches/xml-class-rework/projects/bos/build.lisp
branches/xml-class-rework/projects/bos/m2/bos.m2.asd
branches/xml-class-rework/projects/bos/m2/config.lisp
branches/xml-class-rework/projects/bos/m2/m2.lisp
branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
branches/xml-class-rework/projects/bos/web/web.lisp
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
Log:
web server restartable in debug mode
vcard generation
Modified: branches/xml-class-rework/projects/bos/build.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/build.lisp 2006-10-22 16:45:33 UTC (rev 2027)
+++ branches/xml-class-rework/projects/bos/build.lisp 2006-10-22 16:50:56 UTC (rev 2028)
@@ -28,7 +28,7 @@
(defun start-webserver ()
(apply #'bos.m2::reinit (read-configuration "m2.rc"))
- (apply #'bos.web::reinit (read-configuration "web.rc"))
+ (apply #'bos.web::init (read-configuration "web.rc"))
(bknr.cron::start-cron))
(defun start-slime ()
Modified: branches/xml-class-rework/projects/bos/m2/bos.m2.asd
===================================================================
--- branches/xml-class-rework/projects/bos/m2/bos.m2.asd 2006-10-22 16:45:33 UTC (rev 2027)
+++ branches/xml-class-rework/projects/bos/m2/bos.m2.asd 2006-10-22 16:50:56 UTC (rev 2028)
@@ -1,7 +1,7 @@
(in-package :cl-user)
(asdf:defsystem :bos.m2
- :depends-on (:bknr :bknr-modules :net.post-office)
+ :depends-on (:bknr :bknr-modules :net.post-office :cl-mime)
:components ((:file "packages")
(:file "config" :depends-on ("packages"))
(:file "utils" :depends-on ("config"))
Modified: branches/xml-class-rework/projects/bos/m2/config.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/config.lisp 2006-10-22 16:45:33 UTC (rev 2027)
+++ branches/xml-class-rework/projects/bos/m2/config.lisp 2006-10-22 16:50:56 UTC (rev 2028)
@@ -66,4 +66,6 @@
;; Vertraege
(defparameter *manual-contract-expiry-time* (* 42 24 3600))
-(defparameter *online-contract-expiry-time* (* 3600))
\ No newline at end of file
+(defparameter *online-contract-expiry-time* (* 3600))
+
+(defvar *website-url* "http://change-me")
\ No newline at end of file
Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-22 16:45:33 UTC (rev 2027)
+++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-22 16:50:56 UTC (rev 2028)
@@ -363,9 +363,10 @@
#-(or allegro cmu)
...))
-(defun reinit (&key delete directory)
+(defun reinit (&key delete directory website-url)
(format t "~&; Startup Quadratmeterdatenbank...~%")
(force-output)
+ (setf *website-url* website-url)
(unless directory
(error ":DIRECTORY parameter not set in m2.rc"))
(when delete
Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-22 16:45:33 UTC (rev 2027)
+++ branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-22 16:50:56 UTC (rev 2028)
@@ -118,38 +118,37 @@
contract-id))))
(defun worldpay-callback-request-to-vcard (request)
- (handler-case
- (with-query-params (request cartId
- transId
- MC_sponsorid
- MC_donationcert-yearly
- MC_gift
- name
- address
- postcode
- countryString
- email
- tel)
- (with-output-to-string (s)
- (format s "BEGIN:VCARD~%")
- (format s "REV:~A~%" (format-date-time (get-universal-time) :xml-style t))
- (format s "VERSION:2.1~%")
- (format s "FN:~A~%" name)
- (format s "ADR;DOM;HOME;ENCODING=QUOTED-PRINTABLE:;;~A;;;~@[~A~];~A~%" (regex-replace-all #?r"\r?\n" address "=0D=0A") postcode countryString)
- (when tel
- (format s "TEL;WORK;HOME:~A~%" tel))
- (format s "EMAIL;PREF;INTERNET:~A~%" email)
- (format s "URL;WORK:~A/edit-sponsor/~A~%" worldpay-test::*website-url* MC_sponsorid)
- (format s "NOTE:Contract ID: ~A Sponsor ID: ~A WorldPay Transaction ID: ~A Donationcert yearly: ~A Gift: ~A~%"
- cartId
- MC_sponsorid
- transId
- (if MC_donationcert-yearly "Yes" "No")
- (if MC_gift "Yes" "No"))
- (format s "END:VCARD~%")))
- (error (e)
- (warn "vcard could not be generated: ~A~%" e)
- "")))
+ (with-query-params (request cartId
+ transId
+ MC_sponsorid
+ MC_donationcert-yearly
+ MC_gift
+ name
+ address
+ postcode
+ country
+ email
+ tel)
+ (with-output-to-string (s)
+ (format s "BEGIN:VCARD~%")
+ (format s "REV:~A~%" (format-date-time (get-universal-time) :xml-style t))
+ (format s "VERSION:2.1~%")
+ (format s "FN;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:~A~%" (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" name)))
+ (format s "ADR;DOM;HOME;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:;;~A;;;~@[~A~];~A~%"
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" address) :encode-newlines t) postcode country)
+ (when tel
+ (format s "TEL;WORK;HOME:~A~%" tel))
+ (format s "EMAIL;PREF;INTERNET:~A~%" email)
+ (format s "URL;WORK:~A/edit-sponsor/~A~%" *website-url* MC_sponsorid)
+ (format s "NOTE;ENCODING=QUOTED-PRINTABLE:~A~%"
+ (cl-qprint:encode (format nil "Contract ID: ~A~%Sponsor ID: ~A~%WorldPay Transaction ID: ~A~%Donationcert yearly: ~A~%Gift: ~A~%"
+ cartId
+ MC_sponsorid
+ transId
+ (if MC_donationcert-yearly "Yes" "No")
+ (if MC_gift "Yes" "No"))
+ :encode-newlines t))
+ (format s "END:VCARD~%"))))
(defun mail-request-parameters (req subject)
(let ((mime (make-instance 'cl-mime:multipart-mime
@@ -157,6 +156,8 @@
:content (list (make-instance 'cl-mime:text-mime
:type "text"
:subtype "html"
+ :charset "utf-8"
+ :encoding :quoted-printable
:content (format nil "
<table border=\"1\">
<tr>
@@ -170,8 +171,22 @@
(all-request-params req)))))
(make-instance 'cl-mime:text-mime
:type "text"
+ :subtype "xml; name=\"sponsor.xml\""
+ :charset "utf-8"
+ :encoding :quoted-printable
+ :content (format nil "
+<sponsor>
+ ~{<~A>~A</~A>~}
+</sponsor>
+"
+ (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons) (car cons)))
+ (all-request-params req)))))
+ (make-instance 'cl-mime:text-mime
+ :type "text"
:subtype "x-vcard; name=\"sponsor.vcf\""
+ :charset "utf-8"
:content (worldpay-callback-request-to-vcard req))))))
+ (format t "made mame~%")
(send-system-mail :subject subject
:content-type "multipart/mixed"
:more-headers t
Modified: branches/xml-class-rework/projects/bos/web/web.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/web/web.lisp 2006-10-22 16:45:33 UTC (rev 2027)
+++ branches/xml-class-rework/projects/bos/web/web.lisp 2006-10-22 16:50:56 UTC (rev 2028)
@@ -9,18 +9,33 @@
(defvar *webserver* nil)
-(defun reinit (&key (port 8080) (listeners 1) (vhosts '("localhost")) website-directory website-url)
+(defvar *port*)
+(defvar *listeners*)
+(defvar *vhosts*)
+(defvar *website-directory*)
+(defvar *website-url*)
+
+(defun init (&key (port 8080) (listeners 1) (vhosts '("localhost")) website-directory website-url)
+ (setf *port* port)
+ (setf *listeners* listeners)
+ (setf *vhosts* vhosts)
+ (setf *website-url* website-url)
+ (setf *website-directory* website-directory)
+ (unless *website-directory*
+ (error ":website-directory not specified"))
+ (reinit))
+
+(defun reinit (&key debug)
(format t "~&; Publishing BOS handlers.~%")
- (cond
- (website-directory)
- ((probe-file *default-wd*)
- (setf website-directory *default-wd*))
- (t
- (error ":website-directory not specified")))
(unpublish :all t)
- (worldpay-test::publish-worldpay-test :website-directory website-directory
- :vhosts vhosts
- :website-url website-url)
- (format t "~&; Starting aserve.~%")
+ (worldpay-test::publish-worldpay-test :website-directory *website-directory*
+ :vhosts *vhosts*
+ :website-url *website-url*)
+ (format t "~&; Starting aserve~@[ in debug mode~].~%" debug)
(force-output)
- (setq *webserver* (net.aserve:start :port port :listeners listeners)))
+ (setq *webserver*
+ (if debug
+ (progn (net.aserve::debug-on :notrap)
+ (net.aserve:start :port *port* :listeners 0))
+ (progn (net.aserve::debug-off :all)
+ (net.aserve:start :port *port* :listeners *listeners*)))))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-22 16:45:33 UTC (rev 2027)
+++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-22 16:50:56 UTC (rev 2028)
@@ -24,7 +24,7 @@
(defmethod find-template-pathname ((handler worldpay-template-handler) template-name &key request)
(when (scan #?r"(^|.*/)handle-sale" template-name)
- (with-query-params (request cartId email name address country transStatus lang MC_gift MC_donationcert-yearly testMode)
+ (with-query-params (request cartId email name address country transStatus lang MC_gift MC_donationcert-yearly testMode)
(unless (website-supports-language lang)
(setf lang *default-language*))
(let ((contract (get-contract (parse-integer cartId))))
1
0
22 Oct '06
Author: hhubner
Date: 2006-10-22 12:45:33 -0400 (Sun, 22 Oct 2006)
New Revision: 2027
Modified:
branches/xml-class-rework/bknr/src/bknr.asd
branches/xml-class-rework/bknr/src/web/tags.lisp
branches/xml-class-rework/bknr/src/web/web-utils.lisp
Log:
Convert incoming paramter values to utf-8.
Do not create base href tag in generated html
Modified: branches/xml-class-rework/bknr/src/bknr.asd
===================================================================
--- branches/xml-class-rework/bknr/src/bknr.asd 2006-10-22 16:43:35 UTC (rev 2026)
+++ branches/xml-class-rework/bknr/src/bknr.asd 2006-10-22 16:45:33 UTC (rev 2027)
@@ -35,6 +35,7 @@
:bknr-datastore
:bknr-data-impex
:kmrcl
+ :iconv
#+(not allegro)
:acl-compat)
Modified: branches/xml-class-rework/bknr/src/web/tags.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/web/tags.lisp 2006-10-22 16:43:35 UTC (rev 2026)
+++ branches/xml-class-rework/bknr/src/web/tags.lisp 2006-10-22 16:45:33 UTC (rev 2027)
@@ -183,7 +183,7 @@
<link rel=\"stylesheet\" href=\"/static/css/dynastyle_01.css\" ....
"
(html
- ((:base :href (website-base-href *website*)))
+ #+(or) ((:base :href (website-base-href *website*)))
(loop for stylesheet in (website-style-sheet-urls *website*)
do (html ((:link :rel "stylesheet" :type "text/css" :href stylesheet))))
(loop for javascript in (website-javascript-urls *website*)
Modified: branches/xml-class-rework/bknr/src/web/web-utils.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-10-22 16:43:35 UTC (rev 2026)
+++ branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-10-22 16:45:33 UTC (rev 2027)
@@ -60,12 +60,12 @@
(get-all-multipart-data request :limit *upload-file-size-limit*)))))
(when file-size-limit-reached
(error "upload file size limit exceeded"))
- (setf (getf (request-reply-plist request) 'bknr-parsed-parameters) parameters)
+ (setf (getf (request-reply-plist request) 'bknr-parsed-body-parameters) parameters)
(setf (getf (request-reply-plist request) 'uploaded-files) uploaded-files))))
(defun get-urlencoded-form-data (request)
(loop for name-value in (form-urlencoded-to-query (get-request-body request))
- do (push name-value (getf (request-reply-plist request) 'bknr-parsed-parameters))))
+ do (push name-value (getf (request-reply-plist request) 'bknr-parsed-body-parameters))))
(defun parse-request-body (request &key uploads)
(let ((content-type (header-slot-value request :content-type)))
@@ -89,7 +89,7 @@
(defmethod get-parameters-from-body ((request bknr-request))
(unless (getf (request-reply-plist request) 'body-parsed)
- (setf (getf (request-reply-plist request) 'bknr-parsed-parameters) nil)
+ (setf (getf (request-reply-plist request) 'bknr-parsed-body-parameters) nil)
(parse-request-body request :uploads t)
(setf (getf (request-reply-plist request) 'body-parsed) t)))
@@ -112,10 +112,17 @@
body is present in the request, any uploaded files are saved in a temporary file and noted in the
request's plist. Uploaded files will be automatically deleted by the with-bknr-http-response
macro after the request body has been executed."
- (get-parameters-from-body request)
- (remove "" (append (form-urlencoded-to-query (uri-query (request-uri request)))
- (getf (request-reply-plist request) 'bknr-parsed-parameters))
- :key #'cdr :test #'string-equal))
+ (unless (getf (request-reply-plist request) 'bknr-parsed-parameters)
+ (let ((request-charset (or (register-groups-bind (charset) (#?r".*charset=\"?([^\"; ]+).*" (header-slot-value request :content-type)) charset)
+ "utf-8")))
+ (get-parameters-from-body request)
+ (setf (getf (request-reply-plist request) 'bknr-parsed-parameters)
+ (mapcar (lambda (param) (cons (car param)
+ (iconv:iconv request-charset "utf-8" (cdr param))))
+ (remove "" (append (form-urlencoded-to-query (uri-query (request-uri request)))
+ (getf (request-reply-plist request) 'bknr-parsed-body-parameters))
+ :key #'cdr :test #'string-equal)))))
+ (getf (request-reply-plist request) 'bknr-parsed-parameters))
(defun query-param (request param-name)
(let ((value (cdr (assoc param-name (all-request-params request) :test #'string-equal))))
1
0
[bknr-cvs] r2026 - branches/xml-class-rework/thirdparty/cffi/uffi-compat
by bknr＠bknr.net 22 Oct '06
by bknr＠bknr.net 22 Oct '06
22 Oct '06
Author: hhubner
Date: 2006-10-22 12:43:35 -0400 (Sun, 22 Oct 2006)
New Revision: 2026
Modified:
branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp
Log:
We currently use both uffi and cffi, so cffi can't create an uffi nickname
for the cffi-uffi-compat package.
Modified: branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp 2006-10-22 16:42:37 UTC (rev 2025)
+++ branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp 2006-10-22 16:43:35 UTC (rev 2026)
@@ -28,7 +28,7 @@
;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg.
(defpackage #:cffi-uffi-compat
- (:nicknames #:uffi) ;; is this a good idea?
+ #+(or) (:nicknames #:uffi) ;; is this a good idea?
(:use #:cl)
(:export
1
0
[bknr-cvs] r2025 - in branches/xml-class-rework/thirdparty/uffi: . benchmarks doc examples src src/corman tests
by bknr＠bknr.net 22 Oct '06
by bknr＠bknr.net 22 Oct '06
22 Oct '06
Author: hhubner
Date: 2006-10-22 12:42:37 -0400 (Sun, 22 Oct 2006)
New Revision: 2025
Added:
branches/xml-class-rework/thirdparty/uffi/doc/catalog-darwin.xml
branches/xml-class-rework/thirdparty/uffi/doc/catalog-mandrake.xml
branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse90.xml
branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse91.xml
branches/xml-class-rework/thirdparty/uffi/doc/catalog-ubuntu.xml
branches/xml-class-rework/thirdparty/uffi/tests/objects.lisp
Removed:
branches/xml-class-rework/thirdparty/uffi/doc/html.tar.gz
Modified:
branches/xml-class-rework/thirdparty/uffi/ChangeLog
branches/xml-class-rework/thirdparty/uffi/Makefile
branches/xml-class-rework/thirdparty/uffi/NEWS
branches/xml-class-rework/thirdparty/uffi/README
branches/xml-class-rework/thirdparty/uffi/TODO
branches/xml-class-rework/thirdparty/uffi/benchmarks/allocation.lisp
branches/xml-class-rework/thirdparty/uffi/doc/Makefile
branches/xml-class-rework/thirdparty/uffi/doc/bookinfo.xml
branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse.xml
branches/xml-class-rework/thirdparty/uffi/doc/ref_aggregate.xml
branches/xml-class-rework/thirdparty/uffi/doc/ref_declare.xml
branches/xml-class-rework/thirdparty/uffi/doc/ref_func_libr.xml
branches/xml-class-rework/thirdparty/uffi/doc/ref_object.xml
branches/xml-class-rework/thirdparty/uffi/doc/ref_string.xml
branches/xml-class-rework/thirdparty/uffi/doc/uffi.pdf
branches/xml-class-rework/thirdparty/uffi/examples/Makefile
branches/xml-class-rework/thirdparty/uffi/examples/Makefile.msvc
branches/xml-class-rework/thirdparty/uffi/examples/acl-compat-tester.lisp
branches/xml-class-rework/thirdparty/uffi/examples/arrays.lisp
branches/xml-class-rework/thirdparty/uffi/examples/atoifl.lisp
branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.c
branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.lisp
branches/xml-class-rework/thirdparty/uffi/examples/compress.lisp
branches/xml-class-rework/thirdparty/uffi/examples/file-socket.lisp
branches/xml-class-rework/thirdparty/uffi/examples/getenv.lisp
branches/xml-class-rework/thirdparty/uffi/examples/gethostname.lisp
branches/xml-class-rework/thirdparty/uffi/examples/getshells.lisp
branches/xml-class-rework/thirdparty/uffi/examples/gettime.lisp
branches/xml-class-rework/thirdparty/uffi/examples/run-examples.lisp
branches/xml-class-rework/thirdparty/uffi/examples/strtol.lisp
branches/xml-class-rework/thirdparty/uffi/examples/test-examples.lisp
branches/xml-class-rework/thirdparty/uffi/examples/union.lisp
branches/xml-class-rework/thirdparty/uffi/src/aggregates.lisp
branches/xml-class-rework/thirdparty/uffi/src/corman/getenv-ccl.lisp
branches/xml-class-rework/thirdparty/uffi/src/functions.lisp
branches/xml-class-rework/thirdparty/uffi/src/libraries.lisp
branches/xml-class-rework/thirdparty/uffi/src/objects.lisp
branches/xml-class-rework/thirdparty/uffi/src/os.lisp
branches/xml-class-rework/thirdparty/uffi/src/package.lisp
branches/xml-class-rework/thirdparty/uffi/src/primitives.lisp
branches/xml-class-rework/thirdparty/uffi/src/readmacros-mcl.lisp
branches/xml-class-rework/thirdparty/uffi/src/strings.lisp
branches/xml-class-rework/thirdparty/uffi/tests/Makefile
branches/xml-class-rework/thirdparty/uffi/tests/Makefile.msvc
branches/xml-class-rework/thirdparty/uffi/tests/arrays.lisp
branches/xml-class-rework/thirdparty/uffi/tests/atoifl.lisp
branches/xml-class-rework/thirdparty/uffi/tests/casts.lisp
branches/xml-class-rework/thirdparty/uffi/tests/compress.lisp
branches/xml-class-rework/thirdparty/uffi/tests/foreign-loader.lisp
branches/xml-class-rework/thirdparty/uffi/tests/foreign-var.lisp
branches/xml-class-rework/thirdparty/uffi/tests/getenv.lisp
branches/xml-class-rework/thirdparty/uffi/tests/gethostname.lisp
branches/xml-class-rework/thirdparty/uffi/tests/make.sh
branches/xml-class-rework/thirdparty/uffi/tests/package.lisp
branches/xml-class-rework/thirdparty/uffi/tests/strtol.lisp
branches/xml-class-rework/thirdparty/uffi/tests/structs.lisp
branches/xml-class-rework/thirdparty/uffi/tests/time.lisp
branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test-lib.lisp
branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test.c
branches/xml-class-rework/thirdparty/uffi/tests/union.lisp
branches/xml-class-rework/thirdparty/uffi/uffi-tests.asd
branches/xml-class-rework/thirdparty/uffi/uffi.asd
Log:
current uffi release, does not fix memory leakage with pointers to
pointers on freebsd. it seems that cffi is the way to go.
Modified: branches/xml-class-rework/thirdparty/uffi/ChangeLog
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/ChangeLog 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/ChangeLog 2006-10-22 16:42:37 UTC (rev 2025)
@@ -1,3 +1,116 @@
+2006-10-10 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.17
+ * src/functions.lisp: Patch from Edi Weitz for Lispworks 5/Linux
+
+2006-09-02 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.16
+ * src/libraries.lisp: Add cygwin support
+
+2006-08-13 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.15
+ * src/{objects,strings}.lisp: Add support for Lispworks 5
+ thanks to patches from Bill Atkins
+
+2006-07-04 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.14
+ * src/{objects,strings}.lisp: Apply patch from Edi Weitz
+
+2006-05-17 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.13
+ * src/libraries.lisp: Revert buggy patch from Yaroslav Kavenchuk.
+
+2006-05-17 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.12
+ * src/libraries.lisp: Patch from Yaroslav Kavenchuk to set
+ default drive letters on MS Windows.
+
+2006-05-11 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.11: Export new macro DEF-POINTER-VAR based on patch from
+ James Bielman to support defining variables on platforms which
+ support saving objects, such as openmcl
+
+2006-04-17 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.10: Commit patch from Gary King for openmcl's
+ feature list change
+
+2005-11-14 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.7
+ * src/strings.lisp: Add with-foreign-strings by James Biel
+
+2005-11-14 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.6
+ * src/os.lisp: Remove getenv setter
+
+2005-11-07 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.5
+ * src/os.lisp: Add support for getenv getter and setter
+
+2005-09-17 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.4
+ * src/objects.lisp: prepend _ character for entry
+ point on Allegro macosx, patch by Luis Oliveira
+
+2005-07-05 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.5.0
+ * Remove vestigial LLGPL license notices as UFFI as been
+ BSD-licensed for several years.
+
+2005-06-09 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.4.39
+ * tests/objects.lisp: Rename from pointers.lisp.
+ Fix test CHPTR.4 as noted by Jorg Hohle
+ * src/objects.lisp: Remove default from ensure-char-integer
+
+2005-06-09 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.4.38
+ * src/libraries.lisp: Commit patch from Edi Weitz to
+ allow plain filename library names to allow underlying
+ lisp implementation to find foreign libraries in the
+ locations known to the operating system.
+ * tests/cast.lisp: Add :module keyword as noted by Jorg Hohle.
+ * src/strings.lisp: Avoid multiple evaluation of input
+ parameters for macros as noted by Jorg Hohle.
+
+2005-04-12 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * Version 1.4.37
+ * src/strings.lisp: Fix variable name
+
+2005-04-04 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/strings.lisp, src/aggregates.lisp: Support change in SBCL copy
+ function [Thanks for Nathan Froyd and Zach Beane]
+
+2005-04-03 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/objects.lisp: Commit patch from James Bielman to add
+ def-foreign-var support for OpenMCL
+
+2005-03-03 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/primitives.lisp: Add support for :union types
+ [patch from Cyrus Harmon]
+ * tests/union.lisp, tests/structs.lisp: Tests for
+ union and structure types [from Cyrus Harmon]
+
+2005-02-22 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/primitives.lisp, src/strings.lisp: Better support
+ for sb-unicode [from Yoshinori Tahara and R. Mattes]
+
+2005-01-22 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/primitives.lisp: Better support SBCL-AMD64
+
+2004-11-08 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/strings.lisp: Better support sb-unicode
+ * tests/compress.lisp: Support sb-unicode
+
+2004-10-07 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/objects.lisp: Add new function:
+ convert-from-foreign-usb8
+
+2004-04-15 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/objects.lisp: Add new functions:
+ MAKE-POINTER and POINTER-ADDRESS
+
+2004-04-13 Kevin Rosenberg (kevin(a)rosenberg.net)
+ * src/string.lisp: Add new FOREIGN-STRING-LENGTH
+
2003-08-15 Kevin Rosenberg (kevin(a)rosenberg.net)
* Added with-cast-pointer and def-foreign-var (patches submitted
by Edi Weitz).
Modified: branches/xml-class-rework/thirdparty/uffi/Makefile
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/Makefile 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/Makefile 2006-10-22 16:42:37 UTC (rev 2025)
@@ -5,13 +5,9 @@
# Programer: Kevin M. Rosenberg, M.D.
# Date Started: Mar 2002
#
-# CVS Id: $Id: Makefile,v 1.1 2004/06/23 08:27:10 hans Exp $
+# CVS Id: $Id$
#
-# This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-#
-# UFFI users are granted the rights to distribute and use this software
-# as governed by the terms of the Lisp Lesser GNU Public License
-# (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
PKG:=uffi
DEBPKG=cl-uffi
Modified: branches/xml-class-rework/thirdparty/uffi/NEWS
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/NEWS 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/NEWS 2006-10-22 16:42:37 UTC (rev 2025)
@@ -1,3 +1 @@
-UFFI now passes all tests with SCL, SBCL, & OpenMCL in Debian.
-
-UFFI now uses ASDF system definition files.
+UFFI now supports AllegroCL AMD64
Modified: branches/xml-class-rework/thirdparty/uffi/README
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/README 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/README 2006-10-22 16:42:37 UTC (rev 2025)
@@ -1,5 +1,5 @@
Package: UFFI (Universal Foreign Language Interface)
-Web site: http://uffi.med-info.com
+Web site: http://uffi.b9.com
Author: Kevin M. Rosenberg
@@ -14,7 +14,7 @@
uffi features into the specific syntax of supported Common Lisp
implementations.
-Currently, AllegroCL v6.1 (Linux and Microsoft Windows), Lispworks
-v4.2 (Linux and Microsoft Windows), and CMUCL are supported.
+Currently, AllegroCL (Linux and Microsoft Windows), Lispworks (Linux
+and Microsoft Windows), CMUCL, SBCL, and OpenMCL are supported.
Modified: branches/xml-class-rework/thirdparty/uffi/TODO
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/TODO 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/TODO 2006-10-22 16:42:37 UTC (rev 2025)
@@ -1,5 +1,7 @@
- Run test-suite on MCL port
+- Add OpenMCL support for with-cast-pointer and def-foreign-var
+
- Add support for direct vector passing to and from foreign functions
to avoid copying elements in and out of vector.
-b
+
Modified: branches/xml-class-rework/thirdparty/uffi/benchmarks/allocation.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/benchmarks/allocation.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/benchmarks/allocation.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: allocation.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
Modified: branches/xml-class-rework/thirdparty/uffi/doc/Makefile
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/Makefile 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/Makefile 2006-10-22 16:42:37 UTC (rev 2025)
@@ -6,13 +6,9 @@
# Programer: Kevin M. Rosenberg
# Date Started: Mar 2002
#
-# CVS Id: $Id: Makefile,v 1.1 2004/06/23 08:27:10 hans Exp $
+# CVS Id: $Id$
#
-# This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
-#
-# UFFI users are granted the rights to distribute and use this software
-# as governed by the terms of the Lisp Lesser GNU Public License
-# (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
##############################################################################
DOCFILE_BASE_DEFAULT:=uffi
@@ -21,24 +17,42 @@
# Standard docfile processing
-DEBIAN=$(shell expr "`cat /etc/issue`" : '.*Debian.*')
-SUSE=$(shell expr "`cat /etc/issue`" : '.*SuSE.*')
-REDHAT=$(shell expr "`cat /etc/issue`" : '.*RedHat.*')
+DEBIAN=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Debian.*')
+UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*')
+SUSE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE.*')
+SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*')
+REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*')
+MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*')
+DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*')
-
ifneq (${DEBIAN},0)
OS:=debian
else
- ifneq (${SUSE},0)
- OS=suse
- else
- ifneq (${REDHAT},0)
- OS=redhat
+ ifneq (${SUSE91},0)
+ OS=suse91
+ else
+ ifneq (${SUSE},0)
+ OS=suse
+ else
+ ifneq (${REDHAT},0)
+ OS=redhat
+ else
+ ifneq (${MANDRAKE},0)
+ OS=mandrake
+ else
+ ifneq (${DARWIN},0)
+ OS=darwin
+ else
+ ifneq (${UBUNTU},0)
+ OS=ubuntu
+ endif
+ endif
+ endif
+ endif
endif
endif
endif
-
ifndef DOCFILE_BASE
DOCFILE_BASE=${DOCFILE_BASE_DEFAULT}
endif
Modified: branches/xml-class-rework/thirdparty/uffi/doc/bookinfo.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/bookinfo.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/bookinfo.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -24,8 +24,8 @@
</author>
<printhistory>
- <simpara>$Id: bookinfo.xml,v 1.1 2004/06/23 08:27:10 hans Exp $</simpara>
- <simpara>File $Date: 2004/06/23 08:27:10 $</simpara>
+ <simpara>$Id$</simpara>
+ <simpara>File $Date$</simpara>
</printhistory>
<copyright>
<year>2002-2003</year>
Added: branches/xml-class-rework/thirdparty/uffi/doc/catalog-darwin.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/catalog-darwin.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/catalog-darwin.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+ PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+ "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+ <!-- The directory DTD and stylesheet files are installed under -->
+ <group xml:base="file:///sw/share/xml/" >
+
+ <!-- Resolve DTD URL system ID to local file -->
+ <rewriteSystem
+ systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+ rewritePrefix="dtd/docbookx/4.2.0/" />
+ <!-- Resolve stylesheet URL to local file -->
+ <rewriteURI
+ uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+ rewritePrefix="xsl/docbook-xsl/" />
+
+ <!-- Resolve DTD PUBLIC identifiers -->
+ <nextCatalog catalog="dtd/xml/4.2/catalog.xml" />
+
+ <!-- To resolve simple DTD SYSTEM identifiers. -->
+ <!-- Note: this does not work with Java resolver -->
+ <!-- classes in Saxon or Xalan -->
+ <system
+ systemId="docbook.dtd"
+ uri="dtd/xml/4.2.0/xml/docbookx.dtd" />
+
+ <!-- To resolve short stylesheet references -->
+ <uri
+ name="docbook_html.xsl"
+ uri="xsl/docbook-xsl/xhtml/docbook.xsl" />
+ <uri
+ name="docbook_chunk.xsl"
+ uri="xsl/docbook-xsl/xhtml/chunk.xsl" />
+ <uri
+ name="docbook_fo.xsl"
+ uri="xsl/docbook-xsl/fo/docbook.xsl" />
+
+ </group>
+
+</catalog>
Added: branches/xml-class-rework/thirdparty/uffi/doc/catalog-mandrake.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/catalog-mandrake.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/catalog-mandrake.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+ PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+ "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+ <!-- The directory DTD and stylesheet files are installed under -->
+ <group xml:base="file:///usr/share/sgml/docbook/" >
+
+ <!-- Resolve DTD URL system ID to local file -->
+ <rewriteSystem
+ systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+ rewritePrefix="xml-dtd-4.2/" />
+ <!-- Resolve stylesheet URL to local file -->
+ <rewriteURI
+ uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+ rewritePrefix="xsl-stylesheets/" />
+
+ <!-- Resolve DTD PUBLIC identifiers -->
+ <nextCatalog catalog="xml-dtd-4.2/catalog.xml" />
+
+ <!-- To resolve simple DTD SYSTEM identifiers. -->
+ <!-- Note: this does not work with Java resolver -->
+ <!-- classes in Saxon or Xalan -->
+ <system
+ systemId="docbook.dtd"
+ uri="xml-dtd-4.2/docbookx.dtd" />
+
+ <!-- To resolve short stylesheet references -->
+ <uri
+ name="docbook_html.xsl"
+ uri="xsl-stylesheets/xhtml/docbook.xsl" />
+ <uri
+ name="docbook_chunk.xsl"
+ uri="xsl-stylesheets/xhtml/chunk.xsl" />
+ <uri
+ name="docbook_fo.xsl"
+ uri="xsl-stylesheets/fo/docbook.xsl" />
+
+ </group>
+
+</catalog>
Modified: branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -6,7 +6,7 @@
<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
<!-- The directory DTD and stylesheet files are installed under -->
- <group xml:base="file:///usr/share/sgml/" >
+ <group xml:base="file:///usr/share/xml/" >
<!-- Resolve DTD URL system ID to local file -->
<rewriteSystem
@@ -30,13 +30,13 @@
<!-- To resolve short stylesheet references -->
<uri
name="docbook_html.xsl"
- uri="docbook/docbook-xsl/xhtml/docbook.xsl" />
+ uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" />
<uri
name="docbook_chunk.xsl"
- uri="docbook/docbook-xsl/xhtml/chunk.xsl" />
+ uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" />
<uri
name="docbook_fo.xsl"
- uri="docbook/docbook-xsl/fo/docbook.xsl" />
+ uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" />
</group>
Added: branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse90.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse90.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse90.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+ PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+ "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+ <!-- The directory DTD and stylesheet files are installed under -->
+ <group xml:base="file:///usr/share/sgml/" >
+
+ <!-- Resolve DTD URL system ID to local file -->
+ <rewriteSystem
+ systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+ rewritePrefix="db42xml/" />
+ <!-- Resolve stylesheet URL to local file -->
+ <rewriteURI
+ uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+ rewritePrefix="docbook/docbook-xsl/" />
+
+ <!-- Resolve DTD PUBLIC identifiers -->
+ <nextCatalog catalog="db42xml/catalog.xml" />
+
+ <!-- To resolve simple DTD SYSTEM identifiers. -->
+ <!-- Note: this does not work with Java resolver -->
+ <!-- classes in Saxon or Xalan -->
+ <system
+ systemId="docbook.dtd"
+ uri="db42xml/docbookx.dtd" />
+
+ <!-- To resolve short stylesheet references -->
+ <uri
+ name="docbook_html.xsl"
+ uri="docbook/docbook-xsl/xhtml/docbook.xsl" />
+ <uri
+ name="docbook_chunk.xsl"
+ uri="docbook/docbook-xsl/xhtml/chunk.xsl" />
+ <uri
+ name="docbook_fo.xsl"
+ uri="docbook/docbook-xsl/fo/docbook.xsl" />
+
+ </group>
+
+</catalog>
Added: branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse91.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse91.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/catalog-suse91.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -0,0 +1,48 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+ PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+ "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+ <!-- The directory DTD and stylesheet files are installed under -->
+ <group xml:base="file:///usr/share/xml/" >
+
+ <!-- Resolve DTD URL system ID to local file -->
+ <rewriteSystem
+ systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+ rewritePrefix="docbook/schema/dtd/4.2/" />
+ <!-- Resolve stylesheet URL to local file -->
+ <rewriteURI
+ uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+ rewritePrefix="docbook/stylesheet/nwalsh/current/" />
+
+ <!-- Resolve DTD PUBLIC identifiers -->
+ <nextCatalog catalog="docbook/schema/dtd/4.2/catalog.xml" />
+
+ <!-- To resolve simple DTD SYSTEM identifiers. -->
+ <!-- Note: this does not work with Java resolver -->
+ <!-- classes in Saxon or Xalan -->
+ <system
+ systemId="docbook.dtd"
+ uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+ <uri
+ name="docbookx.dtd"
+ uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+ <system
+ systemId="docbookx.dtd"
+ uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+ <!-- To resolve short stylesheet references -->
+ <uri
+ name="docbook_html.xsl"
+ uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" />
+ <uri
+ name="docbook_chunk.xsl"
+ uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" />
+ <uri
+ name="docbook_fo.xsl"
+ uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" />
+
+ </group>
+
+</catalog>
Added: branches/xml-class-rework/thirdparty/uffi/doc/catalog-ubuntu.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/catalog-ubuntu.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/catalog-ubuntu.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+ PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+ "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+ <!-- The directory DTD and stylesheet files are installed under -->
+ <group xml:base="file:///usr/share/sgml/docbook/" >
+
+ <!-- Resolve DTD URL system ID to local file -->
+ <rewriteSystem
+ systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+ rewritePrefix="dtd/xml/4.2/" />
+ <!-- Resolve stylesheet URL to local file -->
+ <rewriteURI
+ uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+ rewritePrefix="stylesheet/xsl/nwalsh/" />
+
+ <!-- Resolve DTD PUBLIC identifiers -->
+ <nextCatalog catalog="dtd/xml/4.2/catalog.xml" />
+
+ <!-- To resolve simple DTD SYSTEM identifiers. -->
+ <!-- Note: this does not work with Java resolver -->
+ <!-- classes in Saxon or Xalan -->
+ <system
+ systemId="docbook.dtd"
+ uri="dtd/xml/4.2/xml/docbookx.dtd" />
+
+ <!-- To resolve short stylesheet references -->
+ <uri
+ name="docbook_html.xsl"
+ uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" />
+ <uri
+ name="docbook_chunk.xsl"
+ uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" />
+ <uri
+ name="docbook_fo.xsl"
+ uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" />
+
+ </group>
+
+</catalog>
Deleted: branches/xml-class-rework/thirdparty/uffi/doc/html.tar.gz
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/html.tar.gz 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/html.tar.gz 2006-10-22 16:42:37 UTC (rev 2025)
@@ -1,85 +0,0 @@
- �qZ�?�]�r�8��_�)p4u&��u�َ��ę�*�Z;;s~��H�"9�H�y�<��@�(��Y�F��X��F���� 8 FV��nj�V��n��Z�ۮ鿣��n�S���N�E�^���/H��3��~@=B^|ccn/�o��?��������b��Z�՚7��v���� �7���Ԏ�?�,2f�� ��T��J�نcr�����s��}U����6����d;���No���织���A�!_���������� ͻj���[��� ?�J <j�<�V�U����DJ� p����dR�4+��X}�g� i��a�� hOV��,AˢA���os�ԯ���ӥ�͐Q�w3b%xg����m�αf凩�JĐݖ�T��W�R�g��.�j�&���z_䔹��?%}��@8��f
O#��1�8�7���r L-� |�z�Ө�a��߈�,�3����m��&{3�DD[����'�d��H1,C!t7{ V�1wB3*63�x�8�iBwC���^�|��$hU��� sڻ1���a�m:�o� о�Ȅ���V�o��p4������#Er$�߃C�w)�|�D�� �c��$�;���όi`��
J 5 �����'|$:����w�h
-��F-��l;�I�?�'ը=_ҽO0ضlZ��*���r٦����(. ��t���J�,ҥ�L^V�6R� !q3!�C�bQՄ�~��= ��i�#j 1�ox��| }���BE�����)!78�;�u-n�&�o�� R��p��z��7U�pSś�_B ���� T^�z���m��r:�lBG0�a�v��;Dz� ���M��R��|&ԁ ��FB ���q� B[܂�2�(- �l�?�����&�
��e� ���G��F0 ĥ��2� }0���H���X`�#梚"��������ƒ��DKF�^�G,��meiY�s2V�[��m#k�w����a -��4O��lI9˧Z��% ���g������sB�� Xb����N��oպ�������O�Bp9| ����lFO�~躎0�����}� y��
�=����'��+����պ "oHրhwַ "`��Z��5�;�0�6&���0��NB~�qJ��4��eJ��$��l :���9�@a�;��]�"&1�� ��*Z��Q�3_��>Sd����
���3JX�� �!�x��w��O�{���^E�,mD�cOG��0��}��Նn�MfM/�`�8 c �U�� �G?P��r����'�z�5 T`2z\|s��31E�yE�\�^��Ђ��({UQ#�jc�M@@`1">�8`8�~؇M9�L�`J�,�0)�#�� M�A�*�����e9TL���pX:x����[Ojňu�� �Z�Ǡ��`�5d:.��e܈��m��Ƃ���
�[��qQ�����t�bƣʤL�y&�- ��c.��4 3�1�@�f���a�FB��]ϟZ� l.�w�Ü3d7��E7����}s��s�ѳu*�_�l��u��F�u��#�;����f�O�3ޣ�Zb~��K��
-��P:��ފk{z�FyCȗ�ھ�.�Cz��J��CU(��� �+��|$�6rbκ` ��m�4�wM�P�؈� 3-�"� `��-��l�3DP�⑨��\���I|�ۛ��k�b��w "~ƝJ��<y�� ��ǧ�����]��c���[Ҫ�/Ƚ� �ȸQ��"��M��b� �P9����"�^�o�-≉�}�cn[��>3w �&b�_�y|\��\EB�m���7 +�J�r�����:^��v��gP��z����1ǹ�ř0��]�x5����we�8�Y�
-MfJ@��I
��oJgą:7�f�F!����|�g���.�=�.�VW�����a������?Ϗ�����$�w1�ﶻ�l�g��:��#�?\� /}?�_?T��m��|���_<�ѣ�Ɗ>�{��#�!��ud��k�p��_�U�GC��g�ml�l3?�����V�]oH�>�$Pஹ<�|��!�U�)�1D0`�_�İOO���*!���r���C�lkM/NO ������g�'* iV���M��.�%a"��D�$V��J�@��I�oqtS�O<9�ǐa4�#�#s_��`脏Ë��Sn�ڗqzn��o@.
-B��v�l�����e�E� �3���=�i��E���Mn�A��S.v<Xd�!�D���^��+��M� �^� ��;�V�1Ð`@::�y0��Ϙ�lY���;8�=�4Bz?v �7F�9�p�#f{S�
-yo2�H_I���[�Y3��T���
-�;��$�,D҆�c ��� �-���uzBp{�i�9��"g��*vL��_f�? �AP�v�?�#ݝ���! ?} �N�*�B�i��.z$�u2#j�m���*��13E$�3%��\Gt^xv���)�?J��g`�d�T�>����`��13��n�
>��% �$�Cz+eY�*�a� z����� 5">�o��G�T�|��!�tɈ�[�F�qCg�c��ͅUi��|��b��k���U�;�_O��옼-/��2:6��: _W!��P�]K,ɕ�]s�����A� � &�?3������L��{��=���3 ������1�/Q��\oϪ�"���,��l��II��
-�g�e��xTa�.ʁ��G�ٹ�_��8����{BC�RTs ��~OBN0��
�7 ��c%�↞ �FP~��Th�-#93 3�
-+�5dĬH>Č�nY�|q6�i����wY�Ћ�"�G$C�j
-Sߌ?�ӝ�p�D�T�PeIM�6!����0���B����]1� ��>�Q�.�iR!�ȫ���� 8[���`��ҿ&S{���l �1am����
k^�c��>�:\�� ��}�v�u��>��QL쳘:���� ��L^�����:���p3j:VTn]�5M�s|]�~���vy��qu�C�ֵ���,���a:����^'
���W�2Ǣn ���`��6 �9�2 O"�7� �x6�. ɞ-�w*�"���vq�5M�K�Fl�xS��
"�|'�s��e.��$ 1y4���g�N��~�F"��D�X��eQ1���7dd`J�H-vBd
-�VR��r�1(�"*.d8�� K�MS-��h-��(@����|XN�<�Jq/����X�^j�/�yP?H� N\HA� �܂P^1�܆Ŏ�@�,�Γe�� = �^��y�kBO
��'�b��\>a�I��7e�M�'�WéB�"�}�Bʶ�i[��o9$��;4oM�V:�D#��y�¹N��m�ӊ��kU6��{o��#�� �Kk����v3��UoՎ����-\�~*ė�<��5��@���� �O��eJēo����Æ�/W������`<V*S{�� Nfy�Ӿ� kV(ٗ��< ��2��| ,����� �>J�;=9ò�2����F�~ed$0PL*ƻ'���|��I�E͏���?��p_� �i�*�R����H� ����kx\ID�U�B����!7��t엁:v
-{��ԱYd��g��tQ2O��e:A���1�c�&�KM�Q!�;L���燥m2�j0"��c�9"DG��@i���@�zr1a" �TEG0�R�O����k�w��e
-kԂ'e�|����|J�GϹO\���_��� �[���5��k�XX��aӁɋ��t+P{*�H[N�6r�*+u���Z��ph��וE֎����PqU�\]vU&�H�� �g-u�h��� �-���Xwr,ȅ�c{B1r��'�[F��H� �T�6��J�U])�H�M�G���`D�͐Y����YW�6�B�Vo$\���c���2��`2�=IZ��=�9c^ݾ�/$�H,S�
�(��`�Y�rn�y��+*��|U��}�8� %Y� �6�r?Yx�Kv��-�B�c�\8o� �Wu�':]��P!��ݐ��'>
-G���J\�����h� �9uz��^�,.K�ސ�����e�"{����b9;�e%4�-9���@�Y��Z[^fI��� �Ժ>�h5K]<�Ȃ�o9AyL����3C���e�2˸%@�(�釄 b�H1�~����f�J.ʢ����H������D[v�Ʋ� ��z��ׄ'����������xT~�"�%G6�I�ؚ�p���]i���R���V �o� T��آ���#���d���Ժ��`����[q�f�� :��n=��VL����}��4�ѫ]]""W�����ˤ����swV�z���/r�9��6~�\���wE��QU^� �C.���.dv� +ZJ�=�b��|9a�� ;m��$�� 7�^,�N�Ar��Q�������ջrh���v�ޫX
-�'+� ���w��
-��;�<�� �SpG.�e���jf���9��#�?\� M����+��̇�k��? �c9�& }�� �}|md7�s��+����y]���� �tv�MX]� �R�ʂZd�-���*N*��S���DG�>ڍG����e��xE�� 9]e�;[�/!��G ��?������>�������T�Z�M�WBoN A9IR��I�E
�bG� z�U�yS�Z��cs�\���W�����k�1 ���� �l
-/i
��Ǒ?u_ ��w�Wq�\�WX
�t�}��3���k�OG}���3z?��;�/�����r�Xt|N��8�P�cU
-�,���;�P��{q�4P���^՛�v'ݷ� 798��͟ �O1،��.���̕�ج�;�����@�?;#�w�F�s���#/��F�����J�"n �"g���i �>K?�_�G�7'�G]mN���
�
��0;l6�,J��t�^ ��lG�W5m�\�s�"N?�q�����>�sU�}t̥?������u�� �#�"v ;ar�P;cd ����զ�;���������� ��������e?E����Q�9Ƥb���<d�F�;� ���^� �Xj�e���_a��A�|z���F\��G�O �[ 7*�x��'�ŝl�3o�X ��'
-k�#( �|�yRڑ�k:y������H E^!w���Cx(�HE/,;=Q�����
-�lo�4b��A�z�=at����s ���"�j�W�S?���:e �])������gD{�\ȵ���1ȸt-�{�q������1�
-i.�� ?��� ����w��l�w��<������є9|��J�uѡ��Pɂ���+ ����9�
���g��+��Y��&�pV���'��3ă����.�ǣ #� |%���� �t�@dX�B�JG�+X3�v*��7.���
�HmT��� ��:!�� �|" ���q*���JP� ڔ��(�p����^ļ�x��z+�8�]�����Ց��� ��%������#ٍ�Fsa$[ic15����˨H����>�*�}"P
-��0��� �莊:Z�\��J�/����� ����q�x�sy����4���y�h���M�Z^&��z���U��8�}�1)���Q��T�Mnw���g�[CK�� ?n��\Y�O3Ct+Κb�̊o8H�[�ѻ�]�M��g$�|����? ������ �gf�O��q��{l �wءeɗĺ��/� �3�qIwVb���3��5�O9s���
�d�����0������K��4�w?AF%��E��j�~�,��[ � ���2���EŞd�,�rk�F�{Y0C|Vv[����G\ܦ��hZV��r�*�k��<v�y�� -�N:X X�ĵ�W��q�/��iT��VI���h���,�վ��~|t\`?? |\h�_ �]�;.ֺwLb������<o�w�Ykg���n������p�z��i�����|}|��#�y �����k�ӣ�@��zON���w��]:���Z[1�`>�R1���(A�����A�3��. ` ���Hk�b��CWr��c�*�>�� �l��R��e$>s�����y�ĂT�s�{�"�!� �� b).j��8��>BæHaǗ.O2�]Lew�7hu�"[�78=yM@9���u��
-v~RA�%y�� ��>.=&� K q�{� ��xw �M"�ZO� �����ԋY��'�=�� W�Q�/ �9� �;�l"#���"���k�^2/�=�V J�C[��/��d��O��-�r�致c��+t�W�/���3���h� �ɖ �} �֒G���8G�ja[��r�~+��-,v��`g��G�9�:��q���tj��� oN��0<:El�� :z�����@��c�Y�?M}������ϙ�6G����s���Y@�� ���j~�G�����|r=,��}�u�lZ���O���?�;6���R��]��/�N�J[�QB�V�_/v�8!I�D�|�#%Xl�ʅ�N�ۆ�L=�C����/> Z�^'R�����Z�J��߁(_�Z2q<3���=�� _yf*WKh VA���%�e�y��:���2 �*��r��{$_�kB{ϛ)��
-o�w��]�D�ec���Mӈ���b�B���S��Vx�OV\xw^���iE �{_�ܶ���9�]v�DJD�;)e�uٞq]�N���N��R I�_���L�������{No� � ԌCa����<}5����>,�$��0U � �䮍���N��U�@� K!gq��da�%{��HY�
&�������ܮ]�VD��[\53��gG�gD6L���Di�ʘ��)���4c�H
-{�U��D���jZ���i�JJ��t�F���� �3D՚� .q�.�Mju�<˚�t��"���_� w��Yd `Ғ1b%�)��lQU�D�~�{>���:Y<&l���NvR�9e�䄄i���A�϶�"]���L�q&u��͒Th����Vg��K��j$����v4D6����x�Lʾ�>d��߹i�Z�s!�军{<�_l����v����
i��Ac���5���!S�/��U<�_*a����~�f_�9��"gt������!4�*�c�z��J�� �]� ?���ID<Gv�Bb�P������ƴ��/��*F0���K
��)(A��B(�ŷ�:�ޠ�E~e-&��b`P�w�-�]�Қݱt�"3�wj�$X�e��7�.���|�����6`u�5 �ӷ����2s���9� �\�m6I���z4`�Y�<�+��r�Jmc���ԇeK��C��`(�`��jX�3�܃:�]_>U �X�S�O�~�Ia6��t�#��Qq]#s�k*,�-�,���s��Ȩ�st�رi�ьf�=�օ�Uz��PP��i1z��G�ӵz���t�aJ8���]�*��0��{L�ؽ�.
-��r` �P"�Jd�K�l�G 3zz e� >`'-"�O�'�Tk�2M�� rl+ 4k���1���"�6;�acG�櫅��}�7T�U[�p�6����ǭdZ�<.�j��0��V2�+�5���K�\N������~���@A��[O-r�==�?������S*On[� ЩG���D�� 8�Lm�Rh)e�i�K����H���� ��p���\��\fL��ia�� =��#���_����R).f� .:����0_�PgҒ9��
-�G�nꋓ~g���R��>th$�B8�40��
�Z��������<���Ѩ? ���j�����5�'�W�j�{G��x�0Y�_��6Z����� @ٞh����4���$ �qˠYV{��ӭgWK�� �
�TŠ�O���S��OT��^fc%F��,"��N�QK��],�{F;8�������~?���\I���b��XJˢ�� �rVA5)�C�#�{�qׁ� �fc&�Om�����z�/�LVV���
�:��:P\�nn��OW�`P�)���B�'�N���)�cJ�P�G�̻ �[�M�����$-lq� h ��2���
-r�?#DŽ
I=8����ܚSX�� �v�! (�7��T������;n�����#����2����Ʌ� �O+�"m[ ���U3Z ��;����$7���x����E�����ɪ�"�.�p��f���쮝x�<oA`@ �RyH����@ �mc�������=�s�w<[h 8�C���sJ�Qj���¤�:�)��`��I%;���i #4k�sE�3��)4͡.�������(�6���Pg�şQ1R�( �w;��'n2j��S� �q>�}}�>�a�t��6Jy��;�A���N�����0ʿ
- �a~�)��a2�&h����| `�+424D)��h��H�M��xVkb �ǡd�Œ�QC4�@�{Օ 詁�c�~�w��¢�(+��� �|M]̠�h�ډ�98��*L����c� �7,wm3�8¡7��E8��%��G+�>�>��9�X]�0BЪٸhi��� ��Q��Gw�����s�����#<�~]Pv-�8H���?�A�!�.���w!�q?!� �8D��ʰѣ�DMET���Ss��j-C��.w���WЩ�Q��\���>"w�1l��K�����rL��I?%�73�ݜ�rc�9jj��HL��#N�C�Эp�� �&�N�0܅Hk�W;�˃ɠ7|D�C�*Z�!�"� ���_�AV�� *��{i�� ��A��Cw��4����_�����Z�
- �zf�$AoW��Ն-���t�P���"�����9>���* �
r���j�J��Q�ܷ`E� ��S�r(�@T� ��a�i���g/\�&�Y�cb>nv�}�t�
-���JMT���G���aٳ�چ,\��
-dG��qvD��ɉ����X�NQ�p�) $������]r,�&�ᅢ����Hac ���]��g7��@v�����7�X�.t�#�]-���^�9'�o��ݒ{��ƙ�o�'����~}�� �� �?�{������ �||�:~}����W��3�����W�:��RH� �f0GT������(�Q��q��d�F�G�&e��۶G�}-mh
>�%�?�+9�Og� ����h���4�O��?��?�5̌��*�;v�b-ьs=ᣞ�X M��V�`t]� 4'�����y���;U���bt1� ���te��C���%�O��0�� .���
-��[�O�'e�7V�ђz�<=m nb �Hb��R�� AJ2���{C�..��{�[��)9�����)s4"���'kϽ�2w�'���z6�*�ȷi�3
�y�܀¥����OWōq��(P�QgR� �Ũ�y �<mɯ"O����֕#q��lO��� W2� ��H��a����5��Q�Vs`���,�r<H��H�!R
`D߇�A�c�<P�C��� @�D�^.X82P�����<6�H��u#�?�3� 7<7�AR���=kw"=ҽ���c�'�����.� ��y�Iw�� ���T����<��K���� ����ugO�3��#
� ��|�x�n�{F��zN�
-��Jf�9���mN
hIM��N�hH v�@����5>+� -�a%�]61F9�N� V>!�%�&2
-CM�H$nЉ2�Y=�SH�Pc
-L,B����O���6�r��<��BlJ�kqv��7��.��L�S�?F��G�~��
��/��2�ǁ����/ǧ*�3�z�*���-{ $�Y�\p0�9����p��Q ��8�I _��~8�\���"��$9�&�+�h�x�������rS�H�u���E �B�P��ۜ"..�s��O����6
-
-��?��ZƬR4Q+
� 3�Ǟ��*09�&��-�%��N攭dic�L��F� �e�i>>U7�rh ��8f 2�y����
-f���e������-�)
m�N��r�na�������<F��b��'�Q�y:TF
yL瑐�ztē��@;��'��{�}�=Ń�\��\d ��UN�j�p2_'���K:� uU�g�� ��Q��4�O}� ���x��$�X&���!4pLL��B�ܐ���E[6O� ��L�9"�Z���^�3 �������|���QpҦn�T��S&�D9kl0���76P+���1��� �I ��F�TZ�u>,+�4N�t���S0ѕ�CL(�$� YM��͐��#���֊��\�I. #��q���5����5RI��F�Q��z�������G���{ �q ����� ��3�Q!�3����/�d.��7�1a� � ���W�Z������-��`'�7`������7����9�:e��&�OvM�q�fw
- ;��5 �4�� 3`�8�� 烥�*�hz��]P�x���S+�� �<� �8�[��0%��f�J��9���w,&����^/ �ԓ��?�r�� �kſ���������Ð�`���
K��f�Ct�}s�� �#��ɏ�;X ?ëw�=c�����d��G�m-��;2�7��G�x3EV9,��� lW���Gk���=?����R��� � ��.M�� �ߞ\2= s@�\87���s��d�V
-�Ӧ����c�J����)O��"��F'a���ux��<h^Vz%��Src9 ���caA9��AYA9��aIA9���#�H�}GYn(߮39d�C�Đ���3C���m�r�����0�3�7� ����O�`~���'�f��z��|x!T���
-i��f>���?)��1��1) #�wl�ǔ�$}T,�ڢ�:���#�����5�U�j0�g&�>7� �E�t�Mkr�l�^^��0�3�w��6 � Y��.��r7�Y��9���48 ,���`1 ����tX�1 #Pwc^�[c���@7��o��6L������ztD�/;�����Qn�惋r�0d�Z� CN����ٗ����Kq. lA�88T���r�S�+��߸7��S4��������I��B��5���k��(�ʣ
-��}�� dwɠ� �cB�0�sl� ����3z^+$Q��������Z2�"54`9�
j��o����
J��Nz�Fh4xdi�e����T�`��j#���X-��h9P�� /.�%��a����r�%��9�2� .�$P��JE�F�<�[X�e� �F�� ���5������A�x�_�Z3�3F��3�Rip8��D�f��d�� �
���㇋SrSCƉ��5}�Ε
-���-
���� B}������<� ?��ڈ�X��P����f��R��땒��AwSq(��QA(t��0
���ٝ��N����O�:�f��$���v,���N�����G^���cz�q����w�Xt]��� Q](��� �D�6����T��P:(#�:�~C .>c(��4������Ҵ�z�ܹ[ro�h�Y�&a�?�q��m���� �Ѿ������o?�|��0Gx����W��3�����W�:/R�ۿ�vˡ4 �^�Jr�� >��m�U6#�,�B儆���@u�����;�����N��4�O}���9���@���9 ~���*����@ �tpQ! �5�19 3�wl.� \pB/�S��@[�6
Hs������ H��2�F�4�e�`٬�Q���̒�/"���_,�tQ��@��.�C��Ҷ��}��̢`����r(ѣ��H;� �xΠ�O�p�A$�7��Ӎ嬘�B0�P^��6�����hV��� �,��Eh�
��0��>�4��ɉ0�߸ac~f�oIS}� F��'�_YP�&�E7~�=�dM
:�^ILȠ3�Ä :ìL� {mS� d�Ɛ�wv�� �>����^��,:���^>���_��}j ��k������ ��v�
-�c~"����4�g���Ԓ�ɲy������E�h�����9��Q{kI�?�^��è��i�������eR�1�AK�ݦ����R�qM����䁒�|J�b��,6HP}erA��I��zAAo-��t�v�y��7,PH̉�&���yq1ؓJ���t(VD V������t��G�9��� �Po\���I�?)���3�4\NM��<�p:96I� �*gv"�mx�G���{vY�_�θ ���a��4�O}� ���u�?�w�̏*��ZOIV!�cj� �T�d����${�\ޱ��H����lk�jF����7o4�Y �c��$N> 1jXU(�3�v˷K���Ya�"� �R���b)�jh1���Q.,x�� ��tG�T��+?��b�E�[ֹt�[���c���D]�:�� '�Xğu���s T���6H�+���~^����x ��9
�
�o�}�d�|��/=��?c�d�Ծ7��}�4@����N�`�-qL D� �г� �G��(>`����B!suT@�� ��iw,�
-衽D�\ń"f��z�c���u6$p��n���A��t�W�y��6�N �:��O<Q��2�y96�P�Ѡ �Y��� w�i2z��=��Uܞyq˅�#R� ��wLY1|��L�*�
zÁ�����������Ŏ�Njs�ښ
H�ν��/�B���"@#�\2��i��c��4���m(��ڴM.O"r*|��MG�9��C��[��=g�Yd����͂"��;����O��a9 E@����u�4�j�o�1*smZ��W�c�T�9p������J:��v���1��썛�������4�=����6q1��0+_��C9�a� ���E����T�� mpL �w�� ���W�Z#��
-u��b���(pꅚ��_��|7�D��$�M j��F�B����Z�`��*�)`g2nb
-41�v�Q��!/�g[TE���!-�Ë=�u��Tи�AG��ď�߾x�����W?�Dܻ��/���iui"��{g����v5�I��&�;2�z"��M ��H F]އ�AN�$"���]*+3MV�+>�i�����;���rr�O?35T����y��-�� }��Ĺr��8���?�n7,�{�\���E��}zI�$��3�W�a�x����`+�oAID����+!���Z`��e6V��b��f���X���� rŹ�h�r�9 ����=���ٝ�`�� d�?�W�ޱ�3�$s� �,�/y���|��~ɭܗ���v���u &}ʭ���+r��.a >��0KkC��S��&�W�=�|��B��O��Ὗ^��������%B�=��,�6 ��d��q �y]�E�?���RD���n�%�'N��>��~���C�`=�\��2v+1/·'���PY�sʮV!K�`� K
-�y1��(��|4�<�C� {�Z��̈r��fhX���Ze�R�����{i����p� �0������� �3<{<^�o�3{3���P)>���F� �� _�I^��&����� ��G���^�}㬨��[N����'�|����K
-X��_��@ý/Y���y�X,��vpI�qr�~�V�y�Y1
-�ZW��(�ļ��l'��ݿe��Z �#�b��%r�`(��P�� jsN���&@E����y���]�U�~��7�gO?����)�GK��zm{8)pV�P��n;+ߦ ��e
-�����������
K���K�� GqJh���1=(
-;��p!�V5LDʡ*4�8�3�b��Q�L6W1be_��� �?�Ƃ�T<ۇ�ه�?''�q�1
��}�O�J��U�n"Nc�N�+�zC�dzrkoh?�}�{K���lQ��x��D{������״��d�L�tJI�� �o�����_a:���m�h��K��@��-Jd��م�؛���O���7� 2蝑�y������!%wr�3`} B�M��2�"X����O����ƹ��� ��27���mw������},I�F�B*���_��d?."�f��� } �E�?��@�<����w�4�h2)��'�;\ �f C[4cȁ���[�g5����p��B�����=��d�)�Q����Q̊,j@'���\4b��3� �>h��j� !��� ��0����F����j���L�y�����ioW�Q==z;�� ��C��zB1/UH j��a�^5���<��K��d �1��-��d`�?w]��9� w�ȦL��)��Bf� �J,�ո w��`�������b�
-2����X���0��� ��E��ϘKB����N���g�[ �cX��yK����ٓ���HG�r>����<�����<EI�6��Ч<Z�3ND4�8ɢ�lp�s5<�9��'�ж�"�G�B�T�$�|��fnP����̙�(�=<C�)�-44շ�5M��@퓶`J�p��az� �`V��v9e��,HT]��6̔K/�t�.����s�^��]C�� �b*���Q��!� ?%��X1��iIah��0ω�НC��Q= J8�8
O�4o�
--��k�� {��i�����7!���J2q6�l� �7iM�H7�g�v�2���7�y�vM���f{�9�;� �)�k�h �B��S��N9c���WNaĮ�A�Wd�)"Y�x�RL���u�Q�/�N��4�O}� Ӑ�?��~���Te� y��"S�>���i� �$��0�K�����`&1 ]#̔i�=� 't�N��X*R���s�E���*5����Y0�2V�E|W�g�3�J� ���I$z���B���y��鈺<��D�b�#��J�X�7��Q�y.��0�� �ֽ�ŋQI��k��8�](������`��c"���8Wd)�R��~w< ��v��
���#p��������yV�\(�/ޕc�hx�\&� %����Q��Ӱ�k������I���X�0�5�� �C]cB�pZ ��K�lZ *�2��)��4�`4+� H��.�Ad���0p���'�8v�3��3�\�Nda��| `�N�b�*.$gg<L�����Q����M��&=����ýk Ɂ���
y�b�gB�ug�Y��8��S+*��{��I)�A�7T�C� r��5 ������*�B�a
����R�?���_��Q���__� � ?��y���Ŕ���B� jւ�~�h�d� �1ѾF� 站I��v�,@(�KH�AG?�� � �' '���ꮆc4BgfXb��+ϵ���t�S�K��|4�9�@P@���FO��݊�����M�x����f�y`Yu�%��Qo�x�o�Q�ma� �կI��� |��?U�q7�s� 7�������� �����fF�'����*
-���c����J��jf�C�g������ �=�
�0��N��'�F�?��?8 �{�8�M:�z�Dn �/4����-Z6�aoAg�� ��"��r����6g���M1�z��r�G�G s<�
]g���.�"oKUFrd�4������B�.Hr�ݸK��g4l�
E�X�����4Tt<�����C��\ �B;��p���6��Р,'�m�%��P��?Z4�튰�� ��2KU�k�� �]ᘖ��g�Y���7ġNg�͢ٿ;"Z�?��ٳ�� ���dԒ!Yx3b��^ ��d�s"�K��h�a��~^h�]�ˡ@ƽ�N9���S���g�%��p �N*�ʡ6f��6�����Г���D�?���&�K��<���l�x� '����A���� ��D��3�2�y �w����M&¶Y ͮJw$��F �7S8�p�1>4������^G}�!)�������G36��J'� �M
bR ��#���M
-�Pc��p�~�¾�� �eI��]m�E����'=V��E"������p.�?u݅
��,�[�OTS(1��#S��= l��}�
-���1�gr��xR�s�h
-uKq ¯��Y�H�I�L)��X�I�kk�r�W �_�f���x�t�$���qI�t!+U
阁/:�����x(�P�M� Q0jF E*�B��C��O���^_��u���t�
��0�?|E�Oa�<C����y� �"�f��ϘJ&���$ D��3y����$���(�l2�� gP8�Ӄ-E����0�q ���@��Ѥ��0����HG�oO$ފ*⯾P� ��EY0;�nI0;�^�9�ȴ$րȽl��.Bϡ~&��v�?�w���q� ���h0n�?4����?~Z�*\A쯺�vw�-���'��o�|v&
�ɩ{xۯ�Ƿ|q�"��CMrLl G� ���+q}�:��œ����ɾ%0�d��籅��ve���Ǫ]EY� ��b��H��/��Q��Y�ț��=D��(��u� ?3m�Т�"�D.E)itK��+�=���3�#wP�-��Bq.]����d��R$�\��!�o4���!�Q�,6d2�ĆL&��[�C�B2l,��R3�#v�Z �������G2����A��M��������x������Z�z��H�0Հ}
F ����sA�?���Q�'H�uR7Z|a���?w]��9�$w��vL��)8��
��M(x�Tb�p 9���| ���ű�K��
��U�c�� gf�=���^�� �W{� ��_�� Q�s#�H7�.
E�П�pMaB{�.א-�7/�%I(������Ox�W?�3<'��`M�f�;tW��^�H��"��c�����9ym��bD���ĨÃ�vC`��\ �]=�����@K%m���� ������ ч �#�0 ��K�ƅo�y�ѥ�?������L���2���P�&O�Bo��]Vlon�ˣ��X�ڕ�������XA��b+�+�{|X�� ���B� x��9 1lX�{k���n����>!��/���U�_���e�n��Q�4bx��W�M��Ŝ��=D�H/�Mg [g��ըi �16�ĂC�ㆻ,O"�q#�1�D-�!����7�/�.+��ff���;�S\�5���^�KXO�
�C�=� �H��D�2�Y/K�&��N�V#���
G�@�P,+L�s��F�;�'�~P6����s�DIEyY� � T2*I������(߮`c�'����<��F<9%7����� ��W�ȴ��V��t����w�ܬ�VBa�������u���t��Z�/!r�;�H�3ѕ����բc�ζ���¨�s8��'�����i@�C��z �t,Y�G�{gH06�3k(�z��������� "¿ULj� D)�bH<�t�k~ֶ�av F�>��ڼLA�|��16���o�r�NC]������iZ��w�ݞ�*_T��}V�-��'���G�I�e9~��a�8��ҷ����s��)�1���">�M�����a��cp ��T�igq� I�`^�;�I���L��Z��vXT�ϓ�&���Ԗ�9
-��!Y�-������ 9ש]��؇�W �b][��;$�z�����[Q�_]�+��= uC������������!S�C����|� ��z"�p��\��
-OB
�?��Yx�����}
-���
-��P�����Z���/=�W12^>�V 1+��:Y�2 eo,�� 7-��v!�;=<t!�y��@�+ڈ�^�6���`�g3� ��1�s��Ď���§��@)�ܾ�
- }qS���̞~�
��Om�f'�q�]�m�=C�ǁ����ʷ�:�� )�'��b���C��^��U* �+?�j1�P�y ��߰��3*4�Dw�R#���V�m�t3�VdN�"��������t�0�H�Skyy*��>�4ė��?�nl�e�J1ꞏ��y�{�?�~0U���,�{��x� b3ݻ�g�t�Ke҈W�TZ$��m�Nʘ�l+:������0uW��ddˉ�+h;~ i��T;��d�V���'��~p�j!���N<Zi' )�Ŭ$P�ި$���E\�n��b0yn�S6���T�4���mXsQU����I+S��#�(�+�R�?;�Q��s4�O��ԗ���_�u�Pg�>�B���
-ٟ�f/B9T�c�DP|� �2�}�&�L�Jb��t��^�B�C�$O��e�?�F�~W���#�t�d>�Ɓ�?�0��oר�+O z�ef�1���(IpY�� N��$@f�A�������RkksGe͢�ѣnh������;c/��Ն�NІ� "��I�2��x�N� � ��a�F���{�!�d�J%B�6"πj���浼㡮Ti�B�,9�Q9~0"*u.��ژ:~6
-K(n)q
-����n�] U��P��\������+d��j�·�Wxx�v���2E[�=�������bG?@���E�8Y�Z@�%:vw��ߣ]�t�-�[�Є�x�Š�ГB �W��E��� �N�(��Xu'��ȋ�K�������EuеP'��M�+� ��
-:�OPG��~��t����A��O��4E��0�qM`�Q� ��~��R�����bX7�x��uC�̴�x�f�۳��=��������� d�ڜ�n@ș�K��=�m�'Ƶ�[��9Z��{�Z,���]�� =���Ɏj+Sm�����z��3Hd������P�[lD����{w���� ��`>��_w���r�T�� ��bEV�7��"�߰����5��bF���� ��e� �(/V�P�����;��yu��k�
-���.p �p�U9'm�cr�F���\�)S���� !��v�G�a���ڟ����e>�; 5>E �z��s���7�dmͳS�H5����F�JT��\:i
-)� ��ĝ�6��~��ׁ��ҀX��;Fi��UTy1M":,r�ŗ[ ��K��Q�E%/����㧐M4��ł[q ׁ�Ձ�S�f?�z���,v�ۮh)u��p�O�����a1�{7�v5�k�D�2��1��q�MV&�[a�;�ۖ7�c����-��˩�����}t�!O�s�M�[RH"*(U���KW
G�a.55�Z+8*�%�|����X���=sכg�)���/�k�Á���g��Az����%s�"r�\ ��|���R_1�G��7/��^J��-�O�o]~�DK����'(�E��| ���i� JzE��a�5=�i���\�P �.��E̙DP9AYke]��?��K���������q���l���I��W���X�f0�Ja5�_
-�v���%�4_����c����ϡ^"C %4T~ϑ{y�1R7��M�,O#NT�yf=?�|��bԿN�٩�:d�vRhQ�S�:l���ݲd��v�1�|� ��nb� s�ϵ����� ����������w���
������H=~�p��v�v��~Dk���n����}��خ\;�i�
�.�=6�ik���o�ar�Q�� ��.��j�$H��͂�l67�W7�j�ޯ�;��f�?�M'�>�xŏ�Έ��];�h�t����w�i#�sg�ʩU���Qm6Z*�����7��ao�E۳o ����c��,�
�zvn�[���
-[h����3t�3z�ȵ����c�-4�����<?�5q�8���[��=�\���S%��t�2��a�\D�=c�O��E��U9�k�W.��?ҏJ������04������?a[�U��X��;��� ��^�8 y�}���x��4�_� @���) H
A��|[���}�|�ꐢ��,���O�x���E�&�
-i����7��<�TF�*lTK'+]$\���ĵ�P�hȅ�p`����-�j| B(r>�8�������7�� �Fg�������` *�sZkỲ64��S�zG#ye�T�S��� �2"]��Y��9�f��\�*.����f6�c�����<[{.Ʒ�� �UX�q}��ꭐ���9A��i�h֖T�UA8��@Oظ����� ����Ϯ���Dl�ŏ�bv봧���t���7��3ĝ� �~��x���!xZ#wo���O�R�\ �T��j�@ �R��a������8|�3�6���5�
-}�Uཚ�3�
-��<��UfP%f�C����"�R:P�:L2�6lh�JW��U�5
-�ƚ�Ɛ�3�]�O���4�=�R�C͕CB�V����R�JlZ���J0Ω�2~-4���
-�!]����)��-v�<����`���]��u�������x�g�B�u/��찯�VO�gv��}\�8���N�kbۃ(�B{ D���;��x4�w�c�lg�9���9�vs�ҽV?rK͘Z 3���|*��^�>�K?�����{WS� b�������u�d�K� ��m�?\�l�r�o�{���3s�:e��Wӝ�=�$� _j}�Б��r���e��A��xk�^�u�y���6>yn��͉&�̗��B����3���b�����o�_
-�?�9�W������Ozc������Ixy�������d����W��W�����u�����Qy-~��Kz�ch�?}B{��(�` �C���X�gf��
#'9�s�d�����d��xN�p��? �$]0�Hԯ��|��s6�P������ �
-���l{K�z�D��V�
;>@)��9*}9���|z�z��ӹ�1�swF}�`B[Xa�_ t�� �� �����f�7 Εo���
��]LC��v0ߡ� �\��v
-B���� Q���fsoy��#���@���W.@L���ڐ6��9cϨ�`_}8sӾvQ}�#L�����~Y�O���+y���A�z��=
-mv�jp �%�hЉ=�\����?�����TM{��0�x��n��#�"���,�5:=��c��l���O� &?� �W���z��m���k�e|��pA!S;�����v&��a�ca����/7x�q< s����&w�����l�H�芳7��`�� ��� �� I��w-@��{n��e��92@�n4�y֓�P�O�[V����G�#�) z,�Ѕ��Gy�sP9�u�y��y� �M�Z֗;y��d_�?r��gN�)�� ��v� ̀x���l �M&�Ig�]�qa���fՄ��+����l�\�s���B�����⣽�W��Sl��� ���l��G~���P����+�o��s6@(�q���7�)���:Ф��B�� M�&ew��mφv+�!g��>P��r��|���� 1�z���- [��0U�m� u nV��ؐ�<Xk�F� u>�-~S���m �P����sl��c��~��j2!�>��q���l猛f������7Ί�7_��%�4�k��>'��O�i��=� .���q��7�G�-c酣0���ŏ�ƙ�F��+� p�X�z;"�@PaNm���j�XШ��5O]���h�� �RZ� 7�����/oވ��7�u{ {'k�4�ĕ���%��v� ���#��mϒ�h��a�
;
-%-vÐ{��lcZ����/�M�I�����i��aso����L�:
�I�f�j�ҳ�pf��!;�$o�(��](�����D�t �W����9#O$)��w��9� ��W��Jw�@���Q �T/[�.�V6ٿ�y�W�l�:bbϒ��<啹�Oэ)�YC�Ж���9�6�jx"�9��,�%��imX�^Z'�|��f��ۜ�� ��W�Z��<Cl8Cm�{P�A��@��X ���n��Y��([�:�� �����@�;l���x�H�b� 1mN �2����O��0� cၬ� �3?%A��ua+�\9x��g<�P<Z��\��r�p���(�?�5�?٫L��6&����n�U�l�>�����\��$^�c}�7C˷��C�w\�3��#T��MϾ��հ �k���yf��u+r_���el]PE��-.�JXW����� �+�˳m+��-QE��B!]��A,�jp���
�ח�
-���F�e����K�h-����~����Rd1uX"Q1�7nLN��h>J�|_ �]v� �[�$V 1ϊ�b����iI��B�x�T H���yB�5I�%���R\Z4�Q��I,@�y����/�d?I1O#[��3;��0�o������G�8��ە:�I���'ϯ�#Vm���kame���ki�����x�
-T3)��y��F��D.�Ģ�JU��4
-���\��\��\��\��\��\��\��\��\��\��\��\��\��\��\��\��\��\��\��\�U����e��
\ No newline at end of file
Modified: branches/xml-class-rework/thirdparty/uffi/doc/ref_aggregate.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/ref_aggregate.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/ref_aggregate.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -209,13 +209,15 @@
<refsect1>
<title>Description</title>
<para>
- Accesses a slot value from a structure.
+ Accesses a slot value from a structure. This is generalized
+ and can be used with <function>setf</function>.
</para>
</refsect1>
<refsect1>
<title>Examples</title>
<screen>
(get-slot-value foo-ptr 'foo-structure 'field-name)
+(setf (get-slot-value foo-ptr 'foo-structure 'field-name) 10)
</screen>
</refsect1>
<refsect1>
@@ -375,7 +377,7 @@
<refsynopsisdiv>
<title>Syntax</title>
<synopsis>
- <function>deref-array</function> <replaceable>array type positon</replaceable> => <returnvalue>value</returnvalue>
+ <function>deref-array</function> <replaceable>array type position</replaceable> => <returnvalue>value</returnvalue>
</synopsis>
</refsynopsisdiv>
<refsect1>
Modified: branches/xml-class-rework/thirdparty/uffi/doc/ref_declare.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/ref_declare.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/ref_declare.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -44,7 +44,7 @@
<varlistentry>
<term><parameter>type</parameter></term>
<listitem>
- <para>A form that is evaluated that specifies the &uffi; type.
+ <para>A form that specifies the &uffi; type. It is not evaluated.
</para>
</listitem>
</varlistentry>
Modified: branches/xml-class-rework/thirdparty/uffi/doc/ref_func_libr.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/ref_func_libr.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/ref_func_libr.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -103,7 +103,10 @@
<listitem>
<para>A string or pathname specifying the library location
in the filesystem. At least one implementation (&lw;) can not
-accept a logical pathname.
+accept a logical pathname. If this parameter denotes a pathname without a
+directory component then most of the supported Lisp implementations will be
+able to find the library themselves if it is located in one of the standard
+locations as defined by the underlying operating system.
</para>
</listitem>
</varlistentry>
Modified: branches/xml-class-rework/thirdparty/uffi/doc/ref_object.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/ref_object.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/ref_object.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -668,6 +668,13 @@
<title>Arguments and Values</title>
<variablelist>
<varlistentry>
+ <term><parameter>binding-name</parameter></term>
+ <listitem>
+ <para>A symbol which will be bound to the casted object.
+ </para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
<term><parameter>ptr</parameter></term>
<listitem>
<para>A pointer to a foreign object.
@@ -693,12 +700,9 @@
<refsect1>
<title>Description</title>
<para>
- Executes BODY with POINTER cast to be a pointer to type TYPE. If
- BINDING-NAME is provided the cast pointer will be bound to this
- name during the execution of BODY. If BINDING-NAME is not provided
- POINTER must be a name bound to the pointer which should be
- cast. This name will be bound to the cast pointer during the
- execution of BODY.
+ Executes BODY with POINTER cast to be a pointer to type TYPE.
+ BINDING-NAME is will be bound to this value during the execution of
+ BODY.
This is a no-op in AllegroCL but will wrap BODY in a LET form if
BINDING-NAME is provided.
Modified: branches/xml-class-rework/thirdparty/uffi/doc/ref_string.xml
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/ref_string.xml 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/ref_string.xml 2006-10-22 16:42:37 UTC (rev 2025)
@@ -52,7 +52,9 @@
(result-code (c-gethostname name 256))
(hostname (when (zerop result-code)
(uffi:convert-from-foreign-string name))))
- (uffi:free-foreign-object name)
+ ;; UFFI does not yet provide a universal way to free
+ ;; memory allocated by C's malloc. At this point, a program
+ ;; needs to call C's free function to free such memory.
(unless (zerop result-code)
(error "gethostname() failed."))))
</screen>
Modified: branches/xml-class-rework/thirdparty/uffi/doc/uffi.pdf
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/doc/uffi.pdf 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/doc/uffi.pdf 2006-10-22 16:42:37 UTC (rev 2025)
@@ -5,10 +5,10 @@
/Producer (FOP 0.20.5) >>
endobj
5 0 obj
-<< /Length 190 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 201 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gaqcn4V*,u'LhcqMEBhUo<jf\<YI3&>Y(EEMsqht@Y3"bDuEANSaIB@=U)8^;]&0aV[0D6@Y@o>3i0Z4)MTJ1iB1&t1P?-rae:7E1X&Rb8&g6M;FrC6%(/e!qVF.CSIi6uP0V2E=6OS3NXG+2X=('n8&(6X5Q!p;[Rg*K\^g@"_cb"IX'Pu&"K-/idJ~>
+GaqdX]*cD?&;B(lTAl),iOH@5G$De=MG72'Yq]!?$6qt2q-EJV_Gi>/s/i"t<YjDPpBIl;OsFK],W_VAdjSmtNX!d%$GJd<iKP@`C7F7B\4aN'o`*!Hd\`C527G^=cu>#!0$EmK_'.Pqq^YH!<Kd&3bW6*^_c]c9kmt5c=$QVU6<Rh(R]Z8]_8CuImRsaYGQS>T2*q~>
endstream
endobj
6 0 obj
@@ -20,10 +20,10 @@
>>
endobj
7 0 obj
-<< /Length 971 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 965 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gau0B95iQ=%)1n+kh#rrlA'1'fW"8(U0G6"kACCQ*>D^tKK<!X.ESl&5P^F49'p"L'EJ8u&jMPO7*:k\i-^-,O!"MgCuBkRhucdTI,G5NoK_Dq?kE)U?%AOp&!P,[.JO(ppY%.QHgNtj#`cqMfB8aLL`e5nVdL>e#oo"8+.QT>BMS7t&b)i'2H1\Z*c&Qe"o:L8PZ8i'[<-EoNI9%u@8eA-(@_B9KFH!<?Z$$!k/qp5#*Ei2_"3/OrX4_M"d,ih7\-AD(a)i0nkPJgrB6lNu;)j#/ZW/.(VUDP39qE*m04CB/H3/V".--i*$5tpD[/<,f+8IJ".A&6Ae2M*DI/./9/Qa$Y)%gE1kl/C\Z&IU'7jV;ln&.Fa.S5<p8KtpC48afB2gKLHbqogtZ<%:23.n+9TY4\:mgTo`tSS]D*\JmWnfkNg?Z>D+X'B(u4EKmWJ!TC@0]<=F_f]kj9BDHD6!*0=Eh9t7*gL3p`*JSOG@lko/P+!<FZeFX_&Nd-7K+EC*1upJKAm;$p=:o=cI>G169hQu!bo&C9WTDu;gaKc9)so/JW=9X:3nO;\e\3cX%97JE0lH%k[`3pYk(Ho3P#^r@XO#eGVZQ1Y0o2L;UN%J;;o:-"Y$#FVI7jL;3_!a42$$p`::QQBFbb-,=UfL^`9M4ZXhIB/gf2ZN-*<6^(oZ!YP\&r+\(fd-A9D]>Tg0-<Drf>dHnHRj6fS0W0)L[Y#LbIToP5*59Sn\5,_`Hn]XlYB4RT?f)c;\`a49XA<Orf&-OVJs\lkTf@Ir*L2_=8i2]DS,KDq1ZjbA[@q-$Ah^^QQ6q*/R?W-@sld7eMY)pmMjV_%##=3J3#@XmN;@cl</k+D::[G#7CSDN;WdSfR^Q!*Vo?4a^i@J,T.;+Jfnh9e:8h3OnS%O%1hXBJh:kIf<JMqi=C/fjk-51c7L1o,&\DTYTFZm5pE%DE6'e&.0MIO4jar<)F'@o`~>
+Gau0B9lo#B&A@ZcFA-9Z`S\\a;j*G?g8#gidrqVQ6.j%f@O*E0./ih(NJo,:9QS9/_s"58Dg.h\CL?1UMbsWT#Y#r/$p7>qI,Lur&,a4q*_<sf$j%O31[t"sEAY6i"i!>%??q6/YH:;7_^lb<4qDmi3MlsD"m81?_JGV7i8eK99"_!XJ`"DOWS69%V?g*poDpTOD+NYulf9+Uo`GkpN\R^oiss6d1+_$n^?25[9&oja`4eNgk6:&60/TOB6uH`Wp6H>(0FlQ+&l1e).un/XO\^rLae!\j^aO6ZSR^<5QNT"!'A$fUMJ#msPP>Ik"%k+87<*#mLg"3*M3QXj@(^rV33`Ef<,$'],bHf`&KqG70S_>U@rObfN@Ksee2_<.A2Ype;4lNrOpK1OGTj>/<Ma"UDHg_S,a5W'4EY/#XB<\#Q*tNq9?^Zh-]V.`3@&E]jQW.pO#@ttltjGe#p?dRd2aYi(&2T@n`H,_@0j27nSae5"nl@;-taXu2Una?K]q-E23QVF?gdO1(ZUs?WBMSE*'5u_fc"boeG(P`a;*_&1JCBr(B2<3YDA_&QnfW:dO!lUkp,NHERE-hZXZ*Z)7m1"cDWk?B$3Z%5/i-kqOQV+rZcQeSgNd?[R`o&f2ntr]+CO8V6X:ldO^l'Dih\DmCK?o"nh#P(^%#I!hi&r..)RnpUE=DYekJfLX#V!.mH5&_CU=G)RqESAlT(X@",'+9\;Qo0'aEWgsY]g:/1P[^K>$4**4VkH='g?99)V,6i=K%e<(Y:Igs&e7=Vacjr\mMg^u8J1&`_1/&r`fU3\Ej-d+>-1m@B"_3n-uBP>*n>-c\ZV;2gTE8kkP7[onB-ZrdueerP,n!LL?kH%o&<]GtKfIhq`rShqJdHX,L[,-5?>m[u-Lj:e[Q<)WeX49j5FHX;[#JW4TE1:c)ofX(CW*Oab`A*_g^'q18h$9,LL52At#8'F<d/~>
endstream
endobj
8 0 obj
@@ -38,7 +38,7 @@
<< /Length 71 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Garg^iGoCd.c`?]8EV`b1=.gR0K1`91K?+0ZOMGdU/Zh'Y!=Te%#&:?HH*JE!<E/X&V'~>
+Garg^iGoCd.c`?]8EV`b1=.gR0K1l>1K?+0ZOMGdU/Zh'Y!=Te%#&:?HH*JE!<<-b&VU~>
endstream
endobj
10 0 obj
@@ -50,10 +50,10 @@
>>
endobj
11 0 obj
-<< /Length 1935 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1932 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gb"/l95iQS'SZ;X'jS`aUiIN(/T%Bi>bk*JaP@P90_C00,E_8Q;NUhQE_&qbP"#L^e>=8l#)l=gN^uG0nBRR\=#\UU:Nt#+_1[QgF>e01F@7+XrZb0'-a)M,d3R_C1L2ti]pcq_kMjW%dib#G*oYDF@^bgr[`Bt]=65_=[kmuZ*nk[k>E;[CX@FR94lQ!O63>RFqd,._S>_",X$6.*UdiZ6JO#l:M>4g%Fk19\QB&5Cf.j#V:YS8*o1BdZX/*mq>R?n_%t,TD&EqW"E3>:=X&&>o:OOIG>01>Q2H`uj%Xm%R&En6#Yj;q)Q^sU*q4,T:Ps;8L#j-%Jd"TqWol,2[*ZnG+AK`Rt`'_k@(<a6jLqJVqgo7A^?mHTcMEmh5V1[1Z7BDQi2knOE]KV#GLc>qOoSiY,X"&f>dU%F[XbC"mildTZ#,"4(d$`<j9aHQc31L^=X"pA\!Zki=T/d/[H<+%=etlEnGC*>_lKqlni4U[>)(ub.T(YtZ<`H21TQU;:SHF$"_!H1P*qeg&=[MIDiPSP=fdod>AV+F'!<O8OZo0pWL3)s44r:1LDVncoAdAI/#osc]C02P7B'&SV+[<#S.#%$o"?J1s/-Wu]+5["nd,Y5/4lSFr*s;YYX>I<UES'[chA&qq`e&*^rU/]1,,tFZIu'p8jmIdbc4+:1FcqQdnH3bV)PH-e^@TEb[CodFfcp=%;38LD*_$+mU"jn_iU6,?IBb5uclg[GLL?=*nrU\R%K`1/*KKj/0TOu3U+F@^Q@6@!Z$t9!80:,fo5/Bh%GWln:\U(P]DG&Co2pJ!$Gd#W:`p>5ajejRmB]p@n5qi2fspmiChBe5DODUYkfM>N5JB;Z@A\Cpb^\Km3d%X3[8B#TesZ_W-O=h1eB(9i:Le(JRDpNFm&>k`[Gh=e-O=haeEKJ:f+/L1lGou3^t-sX`h=Oucrj5D#a&C)>f5flYNGFrngTmbV%NkU'Hkc!'CBtM]@I#gM`e>]@9,@jdo;2]Xt1:t`o1,%J^0.[:tYYbZ&im!4[d"f-n2q=$j[!i0.8o!1Km'NfVY=+Q!?3'HUnJL"?IYSgb(%i@D,?'2(n&\2.">pQ"WW16_?OJ"F=BgnEeT]&W8IsM_)&bXH2KPRtF#"1E\7P4-$IE#l'^L1mTorC+')j#/:3N#kYL&[i;LfNQe>f3pp"\HdU4'%K_3A6U0qW.n6t+S#a4!rD`.A#(]$d'nu'1?FY`ToD[(uJG.X(#>qh,2B)K;5TnE6OHq-']n8e/O#3HSM^5IDGC+V/gS43Dkme!k6Et9L:=.AWCsJi\`2SMeKHSY3OcF7)ZUPiM-He&Fok?@j)9"og#]t0a,MR*1U;#T0/@08(>jUh6j=YalJNu^l3hYkp,3g%P_p1D!NZT?SgBsH,Ds6ctJO'7-%bU_JP`orsJ`/'e#=!PH#kV"5@<WejAp=eS?EU);gGGjYEROXm)14std"'MZDm;W#A<1&>QVZAgV>ein!!7`F6oNfii3\X6)QpeCr)nuJ%SD0K:'9:86(jDa*U@m$$]0J;7VTGIVg>1ZNcH-GFJbk1_="3EU#CEHh)8+]/",LueqhrN(ogNgd9I4gFRGrWeo$`rJ[]3U8`J1Rd>onH+OJ5mNdA<sLA9Q\!.>kHlYWl(K0\Tb=pOE/b="J1:1nI9qp=EkN<=sR-jp*-SlqcR*<QR+r..G%YD''t1Kc8ND;e)];6[\5!ZaWFF8HRn@:V<UX259S3.4)cdi][tHe&J%]="oP%s&ecHS>_IOecPucha=SD(e>*QOW6?8(^)"M^0knp(be"gf#?BCDsmB?s*R7qN6lGDqYX&lXYH'i&l5h5bM`q9`$Hri)'0Y^=7nA"G'lCB_AgbT;SH68$8&9g/[ouPDSJlL>A;oE+Ym&7lSoa2u7p=XRFUf^g&oD`:;K5#H\>Dli&^?"*UmU5l~>
+Gb"/l?'!]/(kqGS'u%mAJpP0/ELGX)V6//mD+JTF?9$fXE<A*>)kuEFa($pq!!CYMh)2E,/$0jVCi"rL4>ZHrbOouLdk1/^32)HnSW/"M)\LD7reMB=M=1U64GgW<V@2jr(XqI*>[D\c)MXGX&FR4[B3Pmbb+b1j?!V`*Hdc>j>ml_gc!Hi%S%TH7T*TZu+X-)nqbG79P3O&D?[q3r8V=kbJO#l:M$/CLFh[CQ*?Sd"mpec#T6?^\'t#O[=)"4lKf1h$%"0<B&Eqo*E3:qNFeABlJ-ORQC8I5-eW-B@B^!><JO&Bka)-TfhKH&coQ-nP<H53d5VRZiJY"kBG7U>?mdYb6>aDCUg-!U'BsF2OKe2LWc^h)u"\-A&cNjY7=$!?N&[Pf'Y@Wu37C*:2TK!JgoSEJ[kZ%s%dGBB0Y,,=bo#m:>%)@EZTF7UVSe)OH31Q<bYB-[U!eR\NNuS9(4fU##c;L\Kr8&0eIf!`ni12>RPq3\rOnDNL<n<gO@-mps\cg`s6gS."i,S2qgIm(a)9.D0$11nWmo^.iQ?2aF%r6L+j=bXuceRa5QBb*t=k=>L)2/qf6(!4=#3Dt7Z=V,X)[23];."9MjE*Oc)ZjUZ9YrQpQ,=LZ7`*'OW2H<P+Jk2X1@&\K]\m",D1C%pACs2_S8+9*LN8lkg&p8"pE6*J^9<c&n6A"Wi`Xm\?4X]4'0AXtLFDd*Ut2s%a>++:)r?MnbhH`+X2'N8ZVkeRmJ8#&1ULo#_hQU8aC*a6Cb)c]qhpe]XVF#c/)$B!dek[_EPD7G-%<oiL_dXQIJbB0>S+1FRUJcHJj"?JlVEuIC#1K@lFW:&b`>^p%f1Xc>j71]as+HrMenI2ba=S@:-SSH1(FhY:"_krCo+fbnN4VKU-_;#,,)Jp!]dUqoG-\\]>+f>VJ4Y&:"_;/]h_JQWHFgYg;X'm!&!<SfD)>OZLr-^)H<ikHTEV_+]j/#d?L'f'MF!ouiJTIB6`PPrZYSScqAXS]a;EGXD(e:.t"M-!:7cEd!`?N#Zc]H+\Tre;p'+bFkfMM:q=`fB2Z>Dt.C:.e4nZW]=#^"]sW:.0Z^ktNlZ6!*=Z6$35q+A)B+[[>8#R#HYCN,'CQlllS=I+509@[k')/e.3JM)J3&aT\-3[<QEl-DbsjK%AF/0+Qr5TnF';nY7j`Fs(g?5_R7]o..!@g@QMVr8`cPSGE)Oj$h1q-?qS=UbF`%Qhgai.Z+22XgW]2s@^;H3:Q6]>fJq":,.A">Y/]Nd&k&b)n%BH'p"er/i9Y9tN/%A%2UB4cre$aU&kgRE_._%\3rK#R#]RO,UC#9b_;TKe1""or!4L1Q"LF#]t*o;)WJcPA"@#*NT+-*1)#]C2tE0X[&Nm+X:ZETSNq*CUcqHN0F-ce[=W'9FQ@I+;!c:o)X',LiTej/?i$+dGRM*!eHrc,M_N.b,ig\/?4tu?(2&s01e+56\ZQn#W/3#h(;YUM;@II=8ArH/e*P!#7q/_8D/>-S5.bOQ0MR!TB3TMT[]%[Bo$O[#]phm[-eF6O>u$0P\(]uFK[OHZ!7M8>ppS+E9Cq+A7aY)G"i[O>3/1b4Q9qY&)A]%A53C5\o]^%F[p"6.!D=?Bi<W.oV7<U#]t6s;*B-DBLoqph9OVD>Alkk*<`qV1-XXqGpOZ931YKhh"u9MhBm2$K!HL1k`Hn.h(aG!.j(.E`EK9f4B((a)YX=[]A.143*+OE^$fNf[HN9n`t/o;1FkmIQ`#8scgW"DpWkJl4^juc--?kDO)P-KuKog:t#/OfTA%3".pfKc*B8]E[D(!JWuYWuT2)SM!#X8rAc5]X_I5)_hkA:@m)!ndSckRiL4^7.;KepX].C4e''TViU..Dl*I*W8(j]kl1uiBnb8_W*6F%4UPd7_b"eVn6jUpk1ZbB3]u_F@(d2JdDrL(Wb5,B7:*P7ep$~>
endstream
endobj
12 0 obj
@@ -653,10 +653,10 @@
>>
endobj
120 0 obj
-<< /Length 506 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 536 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gb"/i9i$Bq(ru)mMOr%8!*f:$**ne?Aeto&0ck9a9+rig2N?VN(9g2Z)IjsG52l(ml20H>DkEnbbWAQ[+um(a)d.m/c6*^SG+"Hh%8,8(2+6J4N5R9d"J3V#OTj0SBN2g\QhAdBCd\5mfr?7T__RH_SACtl*(#RG)n$5p1ki]4S=g%h<82BH;doY-TE?h?+_3p+i>EsDaJqL,P<7_M,6fQfngj]fKuC8lC10AG=_\b1o+l88PB!PQl:-f]N5&uXnZkqP>V,+3`d5X7RV.@\%QG+6GY&NaQr[+2dS/)BR`ZHW1ZIMfn=%0Qh+/^ND9V[4D)cT/,![*9-dkIF46Q2.0XmM(2%r[`KV!DGH`=<%2h]sDPYL`Qg-k[t[[V)FQ"Mcl?GdrZB@Pjta9%0Qh+TBOh)7.4)fRJ5(AWT`2:0G8?C>/l;3M$i^g>@c%-6@f4ORu5++9qNj,C"&n0A1dID%\_uMD<:PCJd(eqnL17]c=t)jd2n('?3$!?l%/~>
+Gb"/i5u3+e(l%MWMOr%8J@24*E-+sCR9_Z5`H]2#/0n=AC`<>e/RZ[I-5ql2pk?nTYIp]n]J"XAo>I'9*"hOGP[k7n>DF?&%tY'E`ILdG"=SO\\!*;X2ao@\VETk2C;%e`<VN>R*`r/cPubFPUJ+IW91IYG!W`=]7?fNZgn1<&P[*j0Ds@?Mf'aQG\QNQdj's-h]lkM@T\n'&2OG4'_DWp%1>THC=il&lgnK)k^GM>jNdVF'5X:*R(;kS2,4"DC=$qG6+r^>"J:N/6Ecu]om&#[W,.,WZD,,#793(H/U.DmLHlBfT)@-W49:6G&InfFJB$OQTXA"DrSN)O]h/]ls:e-a0:gM-3dOP#R"XW0l14S>h!!*-!5_(OsS\<J1OfPV3#hXh6!Wr4)`3arTcY^TOMR'D>>n3LsZ.BEf"SA=b9.GM)UcM;Aa7b:Ip.#NSbRnV-CT8Z&S4dLd%!GR68"T4X./\0G'f%F'&7!=N<`6']eF",)pA%/fY>6ju+'d[W"ao\&3Yrk'k'uYDH3Niu!,2~>
endstream
endobj
121 0 obj
@@ -733,7 +733,7 @@
133 0 obj
<< /Type /Annot
/Subtype /Link
-/Rect [ 144.0 664.0 209.83 654.0 ]
+/Rect [ 144.0 664.0 210.93 654.0 ]
/C [ 0 0 0 ]
/Border [ 0 0 0 ]
/A 134 0 R
@@ -761,10 +761,10 @@
>>
endobj
139 0 obj
-<< /Length 565 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 566 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat$u9i%iE']&@2]$uF^'M<qYM3I-q'3ps7W1@.i#m8hGd@Y=^Ao*AYj"kLt:[bh9LO4C&,_%^4asaEm*&TKC;4A,]\rWL>_^T%pN>X<FZUZZMNuB8[E/jjkk.rb[6rN4.G\7N.NW<Q'PHnLcbta[BFH[H`h-@JrTV4RS3CE20[Xksm,IDcNJ7Nl?rFC-lR(V=&6NX`\%]P*YWg8(62Q$sb79o9PAoiHq_43MKZC$5l\gFLX.W)7G`K#upZj0&`**heVCaQ+Y!;`AH4cj)3't.#PaF,Xu<-_g.U9<fsQ;b2>N*R-OPRNm]'o2`R'iNYNegh5jPAZ,X)r=TP`j"9=)^A[e!1[[MU948##:k<6#ci\[s)M41k?Sl+P?A^;K`GW4CUZnYVgcp!IO"CRhe;``!^#;FN%)s&V;^(O"s6A!\*CjUi]'TNgGX.T]s4_iIZiq8jKqsGbC8ec&&"O)DTiAQ8`B-5[7c!S4'K/Uq,R=Ac"-L\rRq4R8`#bWCK@j=";cm>kL?%Z+IP><\'<XSD/fJM^TUX5>rI;i8>"eSKCV#e!Dg<dDu~>
+Gat$u9lHOU&A@ZcHqY#iq(N#UOh+G;8gJG7H>pN,ee/A?2Oj^DcGFI8P:C:b`Uc314ruMoDj,+OK&hmAF[92rUngX=P2_gj.]4`SF[J0i8:)W.2\-+WODmjAOnL.X99Q.8K=i]^bKg1ON+Q(rP1kPs\)].p3SrP!">DO"K3Y*ff)*8<K9\p@5X9@Fi-r,/$VW;A]qI^$fn@jP]iE85<Eh.PlS:*eBt+!06%]>24n=t,IC_><<,#j52s!>!%ZCW>1S1gn)`A@/IKFT=n/BA%?4,Gc>o(/?<N;cAC"Y=;]u[1b+iZ\[-*'#-ni@9XM(2ZW:tBGB1etV$qgNqC6PmZ.+C'kMSH<buTnp/A1E<Ir[NM+^2uTds'4(6Y%*Wm!J<1DFeM$kJJXV??KDg\Gl[NF?rsOe"<>AH`YtN!>>7<5\0^SHSO3$oD=`:q!>n>Lps5G6O299@2<gVjr_\!*^38N6oUfPq$7r+H?\ot0njnVgO$tlkphu;X8]hNsZn(+4J<T64cCcSD<1-eh0R,#/T8)3%^T71^ZSmo-ei9jn.^Q\@OrrQ'q2g>~>
endstream
endobj
140 0 obj
@@ -779,7 +779,7 @@
<< /Length 1955 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GatlQ?#SIUn3+NQDbC+d(%n]B/abB98D=PmciWMS(n%gh8>8RFp<m<_P=UP+/]HsTk_461I34Mo]O"mV^%!*r5Y9rsX3H@aCbN$Q_M=]76`q(K.>i`0=V]5SQcgDK)CjT'='clA1i_!c\\uRDhj9>\lS`Mq0Aea=3NM&6$l?m3eB+rjLEU\j7.S*.7E'%';M>U(i?*[VHQ==$?'L#V,[0S;%2o@%7Y,V0k_9FJAlPP6/R'1PRb!m7O0ftI6mlHVcp^5;fn(8_DVi.$RMYkBo8[K"=t\4GMI]LnCZs:787QHD^'Bqh8_Ql-]"VWBQ.(>N%?YNLG$,.AfauX1NSoLgqoF[TeVYu);=of.dp;/-QIV7T)Qq]8X.5F/<pHl-))!Jdj=rT43I;H.0Nt7C=V*oc`L\GW\H_M="`MTWfgH+@&;?^uc<p<F4G/#G85\YcM\N6D;UC7&'n/Yf%1p3(BX?`7%<&a1Qmo5FEiY>9cN[ZKT.-;l1PIp\fo`gRTZpd0B\g9^:67[g=DJ$O`\-.*[+$4s>L9eJmu(g%7=h)`_JcrWChn"&BhNU.#L%%'bHj[Nf=<m\f"cui7^fD%QZ2H.^-S4:6OE1!g6+9LIpNt(S\!lsg6$riq+Ipe(lke@\X+crkQ&XW2dc\)[B1C-Yg]OWkac>;)Jgoip[FMAOPp^b8.s/'jVpRg_$CGs.VC$(Y=^$85#"I6_m20J@bMj:VqhBa.O0^T8.%e@Z)0T]*cV`7m+Wdi!^71/S,B4c)+6-anb>_dDBEZJBNY+$Xu@j+8C!Z:NII\JJPq-@nqcI*&gVQ5bEpE`TO+JZGM+'IYhucY%Y@[QF@9A8s4571c3lADL1:o[3_$s!A(:A-0a`>:bt^X-q8m$j%jpaXnA[[2-KSD5`\jSH"bGE"K8h!bSIYmI6G7QK@Ah7CH_b`YkRf5Q`f25SOojp+Ao,@?"/Cipa35Fpg8[53Z50J;mDYQ6-:s5>N=rAZ4#m$rY>h)\0oaU<9cs^'DBi>[o9h#ED?NZP[X"K\8UNMrcs0^1c&l,7AMDYu3FZB^2E9Pna)lTE@n>AD!o0''>h2fd[3PPnYn0PTCfJF+7mCk_ARcT5*K2]'``&&fVDFph7<K+&11RaXbk<oF(F(#jia2>lag(/u@lK;(>-ti3m<JaLK'M(a)#$./NKJedRj<<n0-Q3"nnSMRL%_[8><@CW$"F(UWaLME,a>GX,9l2*3PM+n&Rb0Q9Vo>-@F?XGrL"N<'\Rf/E4'\^LeX]BTe+jYtIEJWN"7n*p^[uV&<Dcta3A`6*TH@>fg,G53CB]u&*mE#d_logRaApjK,F_s/r>oNC(Q"th&keGnI(CqUfiLJ.u/NRk@A?$7>&"A'=dP1=;.D>ZK?j6oblgN>In`h6"p7+MZ!]I0nS'EL5Ir4H\VnD'[S_fqLkp=Ha8BY3C^)nORMJ"5aWbD4E[M/Q<3N;(QUjtOUT]0iLXV183UIs.F+du*Tr1WTu6"FPm[qi<bad[&Eiq*itfs8n/S"Yn+fI#!gnAkeN=C1Aqqm`%U(a)n.lT8G;<IbPCH-_t`PXD+<=lA0VP<GUKC75+EHYnd,N_4eme=I6NB@+8F56qtq!k$+"=U6q/lpqRgsSWJY)E0mAI\c9-4X]>jb2ImJc39#*l]2TG59=dd1.`4Thc"n2=B"^&F"k4+RG['$)*W>S]FH.b&@':FNIjWE0sfe$(i"DVV4YTAHCX9QXmI52'W(;ukqUjB.HpbgKu>P:GqXJQAb._-^_%^.EUHI]6OI2cNjPTKC<6iuXn90n;D\lGAA8!7V*S3GL("8ecc@C2k^@;0+k4%SBq_sl?I@k`RhlS<4K;9b-1gRWo"Q+8[4%J<*WP3I1G3&-Bg2DfekGn=T4/,/t@=1@Aalg!JJq)U#D"Y`D4HeGN0;KN%a2A^jJ>d'0;Mur'9r\pD[BZ*4B.c0[9Mm^KQ!<g#4SH~>
+Gatm<968iG&AJ$Cn5a0k7ehH)<\&;?*@GjIng$"c%kn/Y(fLPFP#@iXh^&:8$]26\2T#oG_0p`6//Ga%>eI`V*'Y]_)E<Z*L$Pfn4NE0%EtY+T:7PoA%MNK[FoK%DDeRZTq8Tu9PD!JGS&N[L7r8$MfgrAao7i1oNUrLCpg)Ql8J8t4%9n;r&N<CKrju33U1T$WjEN<TK4I*ZA&NpkdO7pYM[cl+K@'9^kZg`g@Zm!:1TY`BQ\\nP3g]c,eUs:b`/GeK,`H3ed)4,Qq\NN/PCWH-Oj)&%V.NiWr/%S=:X+VPBNg96\6P*;k#0_%(#N$qgTn,Y$Kf5W04B90'SjGd@]S<K6IEu8UN<]rp56H.?0CdEf9N$J(a)E.o>JsP_'q6,(SfN-qP(a)tAk.J!<oQ<g3,X&4)U.^9:eP#'AEo[,pjp,"-E=,%#!GY<+)'_0ur-,]cXIRar'bl3'AshpC'ge-rgffncJu=$e*B)KfAh%C=+Ai![Ouo.8*Bmf]tlE21d5]@a@!LHA(!E,`$>$nBZ+=>d0:,e1Ht9D%\2HQaVBOP7]mKOfIi1u>U9hXLirD'-s-@D"P03Ou5b$O[m-[_?(b`r#Ue(ekMe^u)LFD-6<j6XcNPE]">;(`<2Y[D7F^lWikBbF7/&2CoD6+f!V2@i0A-eMB#1Cg*XCP&(AQkla$E_2otbm9-\\As"8CSEcVASA$H^3lSTCPmu'oK$&'m!oLco\Z/\j]T<h2cL["MRI]Qq1%><LA5*(,fu"NB?-T$SQk.qQd<5=gZc:?!+#RBhjJ)lsSdkRZ21*?)Nqng_6V1,(d9=6uIL,TrbJ#M+aFj89>@]C$<KF>>l^H]LFi*s:7m$p5V?^Kch#jFma1uB^Si7TUn`D3p?L4rbB0bK!6dp'i#]raScBc?3AB76gZ7ZUjG/V(;[Gn+0N[)t<4s0n1(S+*3,AEmT=O'u17iW1q4(QWFY-#8UV.u\fhd/DO-^*Q3f/PY%^4Vt`Le?hj'[o%bZ4n'_,A]i-3hMNim)IDJH+*-^/P,rS+.=]QVE$Di>6aGcaq;R[gZ3<S*Qo1Oc(Su![K'B($WTjEe;!CObedP(BsVib4Sic'%N?p[n\p:s'0N&cAipa<>h&XY.PiCZ`+33gq?[J$.IM'1@uXd/S@EP?a.f^/CsNd+Yc+]`1]bV29(K)JEV7=Z[2$Jcqb@;s_.JCbFc0Ykqjbd(%%s&#T'asoS.("&Gc<7rXietbCDQu._d?c!56Al7jk)4T_4XGkh\ojG1%EZNU-8F74`ZGDh`a6:^#`g`Wksa+m/$^P@6b&Q1Xs*g_il<QG!8K1'@;3d?'c$aQXP=)j\kH-r0P%cg(?S)S-Z[+7!g)LYSZ9u#l2O:$s0#,TB@:;n.L$2niPZu]m>O:E)+slQ>>9"2k0C:rYiBY41nM^SQLqTo[@p1U4j>5mtVa=P:;-V.TV#&U\'0<S5AKKUkq1<BC]q(mLaPGK1FOpTgh^Wqa8Io/',oHBU?58WAA;caRiCDgU>BJQr-,s`"k'Bn0eLNWk9*IH`,hjTbUL)2#h[tjnu[K_7eG@qMVr"M%)3]XEJn>'#8D4,+mej]]3gX[__^2^5##Pap('S:qUV44]MlWFq*<6pJ`eRcbZs;$n'mk%^YBY4FJtR&P3!Ib8YP=<N>Pj<H2>f8Hn_gB`B[?`9@!;E`UdgIe;`$ECJQ'59l$G6*EMO;4"^j57m&5MPA?)8C@9gfT/gG5["=[nrM"RFmm$iL3:\3fUg]2Altlpk1JX<79cr6^?+7,k7d6<H59A2Iauj\MTk_V,B0HH60%U&"r,]CA=@!P%8ioEC3,3iI>1s=(Cj=K$.ib<bcmOqB\+3AYar<k(Cg=1&'=U!6^"1:^)]8JTfbkNo#dMJlJ:k#r49E5><U.Z7?H+5oTe5LY)&*KcKaDMMsJ@PO)[^BdJnqA!ZbD(6np^7mO#s5^BrIgG5~>
endstream
endobj
142 0 obj
@@ -791,10 +791,10 @@
>>
endobj
143 0 obj
-<< /Length 1082 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1080 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GasIg997gc&AJ$Cka2?Q<\I'cO"%ZU"t5Q5lDa0%Q=ubD74KSEL&:1'Od%hIZsG;rQl40/Rg4`Hh!TW</s<;*H'>VU?(.:,=d#5g/?*]T-?Y2C;rOMmP(,ZCPtX`G)-%cBs-!)6Z,K;#)Du$9Qt?(EW1"^V7HWsj1]<\'j`pdoTr3d=Gi6P\F]SJ+XKGF2O1kMjr;?+.I\%J6.Q1]B`+PVfReB$f\-6&'W'^2W`^kZP!h/.QRGU07]5lg\T_UOmYqaKYBD[JJJYu'oIX4tU3NjcQphiM=PiC>+R$7fCNDu@8"@4E2Un,5Map??MEk)<B:#dX4<)GQ4(HPB1$I&]TBY,T[qIWH*o%g"U-o9iY.l"b55id9#kr@C\)JR6PX96V?Acqp["gc9WH>54GI0pV9<XGM517tN,\Bk4S+;N@hoaM=>5D7oqTYPUPZ9=T&#?f]JfHr8qMTedKCu&5B$@:5ui1h'=^6%d[p2EOp!aXmuk-?Nf<7Gn[n'#@"pF%P%PO25`qrZ.#q's@K\J%r=CM+WdCf(;\\>Jgf3ZrGXEHG![oJ3$B'kHd(a!*0ufhsQCG7lQ$N:uA(%14iE1BRp\DRk<T^t0YAe(_tdQk%>/]Xh,*ZT]$43U#EEY&n_iEDm+P@H5VJMl]2>$J]\q9[A;Q]EB\pKX2o29?Bg:2eX^:OpltYN>J2.eb3V6D(?D)U4B,TN>/Vg+Kp[>%Rgp?h?-5>En`39?%laTCP!VPO*:ei>:2;FAn+Zk4,@5$c_%$]7FrF1s15S^k.kOJVGg[8C##)WeFYH4Z.Z0'j6/-O)u2J`cCSkQeYTspoXA5D\M/J,=IO7f8c$r-M7!:RVdU;*EN=*p%bRG8\Ig4@$?JHT:)%5gh#`!_B/OXGRN-2,>=/n!XbRlunkS[)jifOmB_ib8\HDUN-N-Qil"oh$jng!<K$06moX["Z52WqFgc^D[[P5?q]BH6PP?bOPf[QH+8j1-P$M6*47Wc/eA_[4;mXD[TT3\pKR@0"+9;dN-1cb!<m68!f3h'r71"KoGQCl(a)fKki.6WH5>Qgf>^N*dTEd_T6_J9(+PHNd_$I$'t;~>
+GasIgh/Ac:&:`#5_.+uI*oE&BG$:_;RaapqC"n7B-F"J*C7@WXYFiX]cRE^1V7JbVj*)S/qk;YiIZ1o^6XfBtou?_9S&"Xg?f5K=o"E7C:nB"?d<NFpSd"5-.SAd8pX^q0CYQc8I''8?B<r^#"DJpO/..>AE?t;82GAi9G8684^b!gt`EE&g=dGb+kBd$uq"XJIr6X',WG=gHLegZt're9Fhcj8MW*E:i\4D1B"Ie^UR4f5\X)]J:7Iql8'5a0Ve$$CcN]KbbiC6,=h">lt+;+/Xf;.Z,!f=<Qk`T%6ab:k63e>.ecn]u0=[mRObCrkkg9`6U&>nbe3Kn-i,a&+58IGANK%ZtKf?pTSeufKJA3+.42qV0>Unfk"JT@f)6iS`?B),@oF<^Z2/(%'++NfD,4:T?@!gkMfWTlt1^sMb,fl[=iYlMTM9^)@VR$rssSs^JL1r$897kP*]<RlY]MHfq1bEqnLG3T7"b!$Zc3!rKH\LH>Ob;b>U&A':TPEP;'pEo!)n1urb-f:V.C5a=t=B!CAVMM0j#t1X5L9AUcS;*4MXmFVQN&87&8mI$.nr@1-*;qB,A7HBF$4omhV$C^bYHJsHlcJUpZHS/4bT<7Z5%4^Vk[Df`A9D(>4L9"o\f6/iEJi0Jpr(E3-Pkbt8YC*V)6M#jOs\;bLUR+'E7:3*9Yr#<O1gtWZ'DWrQ9\CA/HP2la,;,`LVaBPWrO@ImamAZV7%6;NZbb/Yu1ZZgLQ(+]eB_k%)b_FVTmJY,g2/5hQH2j7%p6bED!25*64==^XMqeCNL/uD,'Uri4<F[Gd7?JPP'm_bQEAU1XjnqBu4C.aL43?1&f(eJl,!uCP>CpM[fM"qJ\,0dKmel-aL$"]qpedW*7Id$:F.L<fdDub8CPNXQ8_A(tJQeRe)7kg`Ck%S[oAY31:4nqVGQ_>YAAk]-[+P@De@'q:.jrC'VXL[<173F->!i#(*oq>fs0qT0P&(X$un!R<S&-(a)e4?kIH.WXi`IjcGbfa^$0'L)T::VQ:0AVHYJi'<;372fSsU/'l:M_*c#"AokX2P9I\l8)R%eirR9N2]!C@Wj4o~>
endstream
endobj
144 0 obj
@@ -809,7 +809,7 @@
<< /Length 2312 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gasar968lH%)2U?kZ2?9B(^W6Q=T8P3bd&$Ro@dg/9+a-oSO]5gg=Dd!(B_bNFS#^LlVZEJfshcIXSa&q(?XaOJQ[L*0++'F1Uo^=8mM@i\T2Cdu;7SiZ&m"n*;o4hG8NDiS=9$_Qq\9@cuHX[f"1mSVFdk7!l4$Id\UI^2X'k%_ol^/k^duc"bQA7Ec3>R.4J2f=^)0PY\#h[CsM<'Bf4%cO4_,KoKt_nIju^kEC-6MtA9ulC+?"m`g)XZURDU`&ou2Omg9A5Bar2EHbq)YujN][nj'8n#SCj!Z&?ZkhL:_(T5M%5MZ:^Moj!<ir-[5rLi4gB`kPrJr_6$OlNum(a)cE4,.j0d,k'Q%-U#H/U<aq,8dNfR)a3Frb/m:$5mtWMK.M[Dlbp+lu1=7-7+q/QM!<Acs(-fMYF-'_U:Ab7JLutacg6l@(=3o'1=<_8AD0?X=';]JT)W#SRe'4VNY]pU9$DuLYgBR66)@W^fc:FZ]lFFj3/]]WT\!(Jbd=:HCH"$u>HUR4c&%To='7maToB(i:,B]7[*1t6-2u@S$P;Orr"?,dPjBS$,H]I[#/[tiY:2ST:)FS3fFRqfdIRAF:+b([[B!IXD`Dh!OA,n'=A@ggV(@#iMQ%=FU`Ls7E==*f>4]0NWbG:os7ae,b]GHtY?6^]$9INF%>,hb?a*al[^k[g1V*UE"JaF+hq2eD-+:ot9`i0nJ+*`PBfkB3Tjp_@s3hGJnp?cPIk(%1C<oLUB?b@JK`@nJg-(JOLl<Mq'+#f;:FW4G@nVrMqMAfWi.#Ms_.(Z8l2;_)X\S;*WE&q?1MtYA&\Num_)0qGCVF0N2Zf/NAODYRf4"K!BXh;&`Ce598;93#<UUQ<*(_["u>!RgNp)?E,l9)3c%-\UGRFac3oeLn@ZTAZOWCnsLL$Gtg1Tu/`'K4UfOA(ts`nPM$DtcW`#&>XaHDr``_Ul=acuB)c].hI/2WnR/8HBsjD$Ie%Lk7++m!/XE,QVs"A1&IF\[19[6G.gM]YUs4aJ\QEd&4LfGL+^7+S8g4VgFsN?fXeLQ/BolMnmM<(a@9d//096j5oFN":rD*E0WY,,F.8u`,@EX`/CW1?Y<,u-=XH:=:c^L--"\DFbW,q0X)](a)=q`fK)2.KH%4t"Z-`mG/2%*^Q;gN>u;JS/j<hb-8HI8E;Ni#P=:d'+I[]s)dDR_Yk^mbB/88R\3nZkN6fGfB]o9)jp@>:<C:-2!qQC&fZZboK-+0'V!=`Z&Vc`&a/6"$1ede>j5ICV#9X^Uh=$\oAi/[T41k[S?:?,M`E@jR"iP_$"9Begm0phloOeX,ZY0T"%Hn?F-Tl',aUp[F;3TmOM<90*@$,sf7aNl7$0-7B#@2mW"hgsommqR1b3%rgP@<(oMn%$Jf'UA;f=l\s6%pWL8m7j`,BU<=pe:FRX3(`eht\QB!Pm]dEa%jXH"ckE1dgGMd5ZTJ[Z=_8r`Yl$%t;(j<q@X88Vbd,IDOo]B0!?f\G%J'[>KRr32?>LR.$-U!F6l:^MV7c>(#@JBuE9bN&jAPnm"HF;l;dT-/Y%a9R[TpP*jAR\:F`MMLSNGjXapD9>qBEE/]2*2!&'iZWSDt_G6e8FK$Q[H=;h1NHFKIYcnB:n9=9c.7ncTMA3!d)fTNHC,iWQ7J-JCm_4;gF*2X4%o/-:0ZUqN?21p\/SAcT6i$X;on-6soX:`/X-;j//_ch0\Peb=kkrdCuEX-]TD/39j?0t`mFTgE'$0e^HH4ETV.]Dnu_P(PSI_iABNP,IZY0p8AedmP'9C?pSQU.?^C+F0Y#0lgXaPIa;N#U4HL/aGo`J*UlILrgd.)1Z6^!t[l[XUUHP]f[*M%A5H8]j\a%_r*$<hp>]rR35>c,7i#pnN[J>/AjUQ^nL&U;e>$h&k'482If0[Lb2.4YC!!q8V7Y(U0])ol5^k`p,\cg.:M;B30%eql?UKA8KKlp3Wp;Rn:>*Ljli])eg>N!gj&X0VQ!r3+2P#f#On;n0O'M$($W)43XDml,A+0@>Sa[:L2*_M/mk4OJ0H`(nT0q!>aP=?2L0Qk$:.,_].>YD+)j.CKA0q&*0Gc=G9AHg!'EME,^f+?<*M4j5M["uXWZo_8G>MR,p5#'!Oll@NRe.&Ed^?WNpOeR&uIN-QbI=s:s&"STl4q=ndQVC08'>>LRL.$QE,mV!;pA['%t)ieqFF+L/1fN'$L"hb6Ed/:;QuQEC;\a-CVJ"^etnc`O7m=Y:^(W[o!p)F!L?aii$2o='sq$--NM<<$)7\V<uFV^n'N9T3&3,gOYM4"hWeq.d*hL*(a=as%3R@N;j!6GtHu~>
+Gasar968lH%)2U?kZ2?9B(^W6Q=T8P3bd&$Ro@dg/9+a-oSO]5gg=Dd!(B_bNFS#^LlVZEJfshcIXSa&q(?XaOJQ[L*0++'F1Uo^=8mM@i\T2Cdu;7SiZ&m"n*;o4hG8NDiS=9$_Qq\9@cuHX[f"1mSVFdk7!l4$Id\UI^2X'k%_ol^/k^duc"bQA7Ec3>R.4J2f=^)0PY\#h[CsM<'Bf4%cO4_,KoKt_nIju^kEC-6MtA9ulC+?"m`g)XZURDU`&ou2Omg9A5Bar2EHbq)YujN][nj'8n#SCj!Z&?ZkhL:_(T5M%5MZ:^Moj!<ir-[5rLi4gB`kPrJr_6$OlNum(a)cE4,.j0d,k'Q%-U#H/U<aq,8dNfR)a3Frb/m:$5mtWMK.M[Dlbp+lu1=7-7+q/QM!<Acs(-fMYF-'_U:Ab7JLutacg6l@(=3o'1=<_8AD0?X=';]JT)W#SRe'4VNY]pU9$DuLYgBR66)@W^fc:FZ]lFFj3/]]WT\!(Jbd=:HCH"$u>HUR4c&%To='7maToB(i:,B]7[*1t6-2u@S$P;Orr"?,dPjBS$,H]I[#/[tiY:2ST:)FS3fFRqfdIRAF:+b([[B!IXD`Dh!OA,n'=A@ggV(@#iMQ%=FU`Ls7E==*f>4]0NWbG:os7ae,b]GHtY?6^]$9INF%>,hb?a*al[^k[g1V*UE"JaF+hq2eD-+:ot9`i0nJ+*`PBfkB3Tjp_@s3hGJnp?cPIk(%1C<oLUB?b@JK`@nJg-(JOLl<Mq'+#f;:FW4G@nVrMqMAfWi.#Ms_.(Z8l2;_)X\S;*WE&q?1MtYA&\Num_)0qGCVF0N2Zf/NAODYRf4"K!BXh;&`Ce598;93#<UUQ<*(_["u>!RgNp)?E,l9)3c%-\UGRFac3oeLn@ZTAZOWCnsLL$Gtg1Tu/`'K4UfOA(ts`nPM$DtcW`#&>XaHDr``_Ul=acuB)c].hI/2WnR/8HBsjD$Ie%Lk7++m!/XE,QVs"A1&IF\[19[6G.gM]YUs4aJ\QEd&4LfGL+^7+S8g4VgFsN?fXeLQ/BolMnmM<(a@9d//096j5oFN":rD*E0WY,,F.8u`,@EX`/CW1?Y<,u-=XH:=:c^L--"\DFbW,q0X)](a)=q`fK)2.KH%4t"Z-`mG/2%*^Q;gN>u;JS/j<hb-8HI8E;Ni#P=:d'+I[]s)dDR_Yk^mbB/88R\3nZkN6fGfB]o9)jp@>:<C:-2!qQC&fZZboK-+0'V!=`Z&Vc`&a/6"$1ede>j5ICV#9X^Uh=$\oAi/[T41k[S?:?,M`E@jR"iP_$"9Begm0phloOeX,ZY0T"%Hn?F-Tl',aUp[F;3TmOM<90*@$,sf7aNl7$0-7B#@2mW"hgsommqR1b3%rgP@<(oMn%$Jf'UA;f=l\s6%pWL8m7j`,BU<=pe:FRX3(`eht\QB!Pm]dEa%jXH"ckE1dgGMd5ZTJ[Z=_8r`Yl$%t;(j<q@X88Vbd,IDOo]B0!?f\G%J'[>KRr32?>LR.$-U!F6l:^MV7c>(#@JBuE9bN&jAPnm"HF;l;dT-/Y%a9R[TpP*jAR\:F`MMLSNGjXapD9>qBEE/]2*2!&'iZWSDt_G6e8FK$Q[H=;h1NHFKIYcnB:n9=9c.7ncTMA3!d)fTNHC,iWQ7J-JCm_4;gF*2X4%o/-:0ZUqN?21p\/SAcT6i$X;on-6soX:`/X-;j//_ch0\Peb=kkrdCuEX-]TD/39j?0t`mFTgE'$0e^HH4ETV.]Dnu_P(PSI_iABNP,IZY0p8AedmP'9C?pSQU.?^C+F0Y#0lgXaPIa;N#U4HL/aGo`J*UlILrgd.)1Z6^!t[l[XUUHP]f[*M%A5H8]j\a%_r*$<hp>]rR35>c,7i#pnN[J>/AjUQ^nL&U;e>$h&k'482If0[Lb2.4YC!!q8V7Y(U0])ol5^k`p,\cg.:M;B30%eql?UKA8KKlp3Wp;Rn:>*Ljli])eg>N!gj&X0VQ!r3+2P#f#On;n0O'M$($W)43XDml,A+0@>Sa[:L2*_M/mk4OJ0H`(nT0q!>aP=?2L0Qk$:.,_].>YD+)j.CKA0q&*0Gc=G9AHg!'EME,^f+?<*M4j5M["uXWZo_8G>MR,p5#'!Oll@NRe.&Ed^?WNpOeR&uIN-QbI=s:s&"STl4q=ndQVC08'>>LRL.$QE,mV!;pA['%t)ieqFF+L/1fN'$L"hb6Ed/:;QuQEC;\a-CVJ"^etnc`O7m=Y:^(W[o!p)F!L?aii$2o='sq$--NM<P,DTWH.@(LCZ*M.lHcN_L[@@KOb2D//!Y2+@?u:9s3i8M1]@o?mn*!~>
endstream
endobj
146 0 obj
@@ -824,7 +824,7 @@
<< /Length 365 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Garo>9i$Er&;KZOMVa"RCHj3h*]MK!#GVSanPGQ$@L=Lt'E>`L@2Eq*>UD7jpN`[-6fq\3V2.u8;5QL68rk.\Jg&.S@[(nr8<hZgg!BU_lft>INU?HF":.M>SFPtci8/Xpd7t/;-?bl(&>0i(h/>:[-Y^/2%+qmOmQt@<G#4IK/@FmqA(m]`E#NFthdJZgp!:Jl>8r0T2I\t>=DS[j1oc1VV8&L;:$s_[6$U$r9!GfaXi4Yi%'VCnDdq8E'po%]WeT&Y\!d!dqm4aE`uuZ?Ki:`PecF4UPBRis6(T];Z-4FaUcX)d9F.+^5B^nsWOf7$d]p?QfFP*<r\?28M7<gr+G'r%Q\'lH+Zp/2!+N+6W;~>
+Garo>92C6q&;BlVMXH-dCEJdrbF@_4L!bRE\>Y`C@L=Lt'E>`LiEjGqB%-BGc?H.V6fq\3V2.u8;5QL68rk.\MBU![b:)HtOXR9XZ_.,If%!Iq)Va]k#S<$[f]1^F^qK,iUR_PS3d/J)#g`t%m^J^>P;HQ)#41"cGGVN]4/g;6[T]`SR.dI0S6FXuG?D=ZrJNA\2MU."N*$W<Q5BcFNTsp/l0kG&OF)pW&0<K`&hNHFC[m`H"72NELKH":!`S#HeZbM32Y0+^Is-/&3"1X3iH1sbe,e"SPBRj&6(TuCM9I29Ug&(a)/9F.+T5B^nsWOf7$d]p?QfFP*<r\?28M7<gr+G)AHabYU+J^LgQ%hdU!eG~>
endstream
endobj
148 0 obj
@@ -836,10 +836,10 @@
>>
endobj
149 0 obj
-<< /Length 463 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 462 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GarVKb>,r/&A70VHn802r.pR/8.-D6;2#]ZLdPjb_'4kkS[=Wba*kb7--Be31:*2#lm.Xpmj/Q#bq_l]<Q%EGEPhXkM,9(%8Wo%[EMc:@-81!U=B'u+>&A"u7:&RbE,<='.[,:5?ZR\F,>"D%R3bAhHinPe@Ja\9KJP7g9O-q@6jUrU]J"4LKqb(G$4@,##>7Ie_7J-c5hE^T?t%WGY.u5kRT?Wb\#rBbFM0GQI7Omchb;WGoErrVn(a)m^9i$dT!B._VM[2T<YFgX:_iaR/XEVSeYo5s+h,*W#V^i`@]D!R0c#2>hBcYKV#WX;@6_ELE%6nm)mfc'bHL<00b3C!jWN<SK?^YgX]c:e9.4$Zb3%<g5c04QuF?51q=0-d1CiC!.T`rD+=T;PTM%J#_^/rr2W[sSHQ@nmbq%lNsD"gX#WU.Ke_9O]JuFa_jkRIhCDBq-6n'rM!2f\=[F~>
+GarVKb>,r/&A70VHn802r.pR/8.-D6;2#]ZLdPjb_'4_gS[=Wba*kb7V93@^1:*2#lm.Xpmj/Q#bq_l]<Q%EGEPhXkM,9(%8Wo%[EMc95PF'*;/?6Q&SMlJ>,-N8A3&G#"Q-$2FY;m>^OX*]#b`[U$^';4#YkbUS_O22D-8'I0+p@";IOT4]Kqb(G$4@,c#>7IU_7J.^5hE[S?t&>$=(%.FD5V1JXd]q`h5lR;pZY!=S*<"f?3.VGhKR]i*(<!WXbEXQ[_j5hWOBi9S.3e)%R5AhT$Fu?ACA42\@ug>m2Rn)?oo(eH%Yca<C(=nfV`DK#\Meu)e2+f&37KS#70:h[G]j1(S!n2M(&FR#Dbuc^lC%nb8AO*(Ibadb=F%is%pA5nc*+hkGcsFKD_[_bG3D$/al'TSWq(iReb)-=[c-6,X3(l0pNPtQ`a=DmKo0*3'F'YNq#?4JBfG~>
endstream
endobj
150 0 obj
@@ -851,10 +851,10 @@
>>
endobj
151 0 obj
-<< /Length 808 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 831 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GatU29on!^&A@ZcHn/0R)h5lqNU;>)<OG^.mA9G_^gSIMKI3BurdC>u`==-r[Gp1#IPYo^1XC>KN]tYn5Q^di)30*K)^4./*s)`FAi&oo_uU+d)#P48X&r05:U'b5:^eJ]7^Wh5?mp"(f]pg6:'Uml0J!/CH_+M-l7bhPDE!ecIS/W[9s":>aq*&QIDU`\7<FPNU,S;C0P:I(4%L"f"!MI8ifk/Boo,'cM=RrY9F=]:g(Oki="oU',qQ#Fl>cioefA9='i506H^JEWA#tlg.Us#T)>H<JV+e>bNULV3/8O';YAoRNj?gBKqCeAd9>o=d;LXMTl/(.6=d89C975.S)]^7q-*a.IO?R\:KL7@cZe2+K$>W(*9BtE3DQ;(<^;Kb4Dk\q+gUKkWiPi!F&^po8[u#O&c_#*N6Hk-.Eh,A+UKJuiOKkG_4mIEY7>E':7r)Lm.@-'7r!*(k;74tYj_cMQR(?-N/1?aW9kgP<Aco@tjPH=;.3U%:#0gISI+UNUe"I"(MDH*B7OhKBp,1mDGu9uR-o/F+DDcl]XcMRpeRUQ%<&VT1'Wc9b(a)CQ.Hb+OtOLLXcqKP>1\e_!^_Mab-i3609UY;5KSLGGoXpNag7^*tt(>;p#O)p)TL5"Ai5(:RE`l:mBOp,$@uE]Mq'M>h"El1<p!?QQ)6q%s]OXC3ldf]rp]?CqGN609U>]Qm,@e)[[Yjl;%$H#)i-Y2hk8gX-g7@:[^^0jI[GNR/;Xc!n+$rMi(2l;%_D?oa>1g,H'+K5gI*oWYtja=/C*kK^F$)bgE(fP%$qgd_2L^Xi::~>
+GatU29lJc?%)(h*kdGRu3(]EHH+.m4JIYn8,2"Tl%]Ub_#3(]smah=5aWHB#33J/K\VN!_q+++R\QmHEgj"YM5UBT(1Q3Af"C^mHaJXQN#WPAkd5jQXk'&<&([*5MIl8^8#W<.sF8ukUD[8qNpIL4pl=a&^F+[Xm?@SMa..s]bV5$$#V;4skq'et"/@G2<\BM'T7ti0*IuK=^5iRgJ<tuM(&`QdGYLm>-LhIs4I9NV:,:48)&[KDa$:N7iRQD5"!uRm,'UCZ%>mPg/DiuU5*-gDNpgs!jSER=pRd'\\E5G:5dr!G1Y'/-6^W3=]NT5a9':qj6I.!Mq,*mCKjZ[t2G1JRfiq1V9jHK"-oaTt9Z)N&2;0";++W"]Yi_iX=6Tit/*6%@1Cq+Yf`,MYe*1l'6p$Lo(p(_aM@M!?X&D3M^%].h:P%MuErS,Or<I,%:LP?*>KZc:*PqKrucE"IhBG22O0`m`J"7UdmY-f<MWOLH#@Ht7$9*Tt6;jqC-B/V1,6i%u^g+hT<:P'@&rM#I&k?O]:RaAFbP6C)83B+)RG#peR;T0i`$G5nI1Oj>FO0umf@WTqn3XK_hNSuKP!1\6G"?:H_4Jt)'P\&FubRKiB>b$>+:7-!u$LM<#.ViLS75kmBFAU*S4K*OhkWtm%XmQMNFVO)E.OS"J25/)7b%mn8eUO[*]Na4kgC#lB$tH12mY+h&jE4h8+841&d!@t56ZABgDobQQ#+hWG6QPG]"OsT@H50LN<QtGa5D_C]PfY)&lh0UGqnJlqoBS=CZ"B!?WmE/_h9R_*ViF6D]X*(-$Z/;\.(]K1'i(]%q%m+5qqM~>
endstream
endobj
152 0 obj
@@ -866,10 +866,10 @@
>>
endobj
153 0 obj
-<< /Length 1188 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1190 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gau`T95g:b&AJ$CE(m:#^b5([;mhB1C/^Cfg)_q!p,7/8GrYB00+0a$Md[2lUFM/.YA`TnDh_]iD7I1QLc&`-Sqj^->oD@>ASO^+B5.^!\q+/3nI47JCb=FXhllGU\u-9+P&"oo>drB?Hq1dU:Bsd(CHo5rPJFerm^S;>+AXpjZbq8QP2]$S;h+N'UTKr=DK+?CS;I#m@j'U4n>0-DRLS0K4mf97XMUf>1cuJoduq"R2E5`9ZC8EHgq=roi#$$F<[WO=GS_)l>`ka#>eoY'k&N=gM7dfK.H>)I?4M2?1dDgDa0KO>g1e;C`1YT-p._7B-I926aQ>RD:L`+h/1-G=oTU/K=?&_=A$dQY\-9na(4IB:5KDBjN%_VpLk)P)8dWPgD&KVpbeDIV,Clc&hU&8;ZsS&*L'];"gAJ8o,'s.4Y')N3$O*NpJcXOK+PUrA9Lsg7V:%Us:p[J#D`sj-671:i@Y$uZr@K[#BgCd&j>+EFE^<*t3E9TRP9ArDAl<:An"eoT[o:.G^:R2Y#pFmZUJR:I')'lHkk2l7SY]d]6r<=BU/IhMMn)@iUIZWY3GUH@e[CfBKa8ja*+sqLl:YMr@+D?`[?NO:"ASNQ:MH;N&>>1%,8F&h0-pr;6=)NZAD3P.KIXr@ElL:HaB:h4=jFI^2,JlQeJ7*a4IhEX`nZign?G1hQ;C?9]Mp!DWD;K879,cmq["iZF/]od+lYF*8lt^3lq@EZY:TCqL.ai9BpM9\"\uq9LY43?m;8"rD(VBQNg;Rk&gBm;HBTf8nZL3KU[_+#Z!P<'=PB<:L`e=NJuTnfcdB#bb;`6=2qRlmgNCpg17Icd>T*G7iU0I+pR$Hd3ARIW$h#O&W]&g__e8,pH!S;C[!`/TaWW-,l"pCMdnRE_]!O+SU5&BW_@s%pi(A\52TE>sgTjWD<MHsr6EoWECDKu.BB+8f(AAUX+un^ARB=hLU:gh@R><aIDm)D\9#7AA[bnTf97&'q261cM==#ea?t37)U2'>KZUgb/jTP3k/-i[;mRhM08hY(C,Xg!<Q0T=,]D"7QBTDNV-0;XA^l9pSUnBGu`T@tn-V=\Kgd+Mf2lcMTGk"6:mF-1<',"s6cO?/S>r:`-#&NLEcgF01qVD+KeGAN8D-tnTNFl-$/R<d1h1ih"Nhtd`F(Z;oJ_RA6h/YR^?"*76\._Q5~>
+Gau`T966RV&AJ$CE(i;M6'?NMP"p)^FS_Af;qhBYfiE`ZbJP4tq]`8>Q#+Cc1t0QW7P+DChgW0gMsoZYbrr?$_@?WV`N,D:X_5^qg-9+V'%d]a/MD)00Q=.=CONto;R.mTfq)MSF6rek%4CeLX8&ooe[>)!MEaYE^T]lYZTK5[#b`=>Gu)UHUJJqD2tsJ/*8;(>:H4#]_/ljJ/]bJ(K%h5Q(^APkh0XjQ9qlPueB<a>FfoT7-[A):C1hHuV/9^)c'qB_VOOATd[HJeFoZHhbB%I91Y&][(`-ji29-Y^d#b(F=Is<%*O^#@#JHF@Lnp?[+r?\V=57M"P3Y#:H1=E9:IU[C__+M&P;Ta$Hgi$>i<RBjF+2$ur/rj(,ZHUcKSODGL!1jLDf!ZI?lI7UXR63S)K+XlUEs3Rs#c!kU]9LRqj^2E8aE875dgg:p07V#dZAFJ1_:6V]^"LGO(a3/-T$EWT[C[IPS^<p;0a1m:bYm%Lkq@PRZ:G^K`'RslM^aR1h,p"8=2j0:D?8aaQ/=/eCTh7IC2+^4gBBQW`TfE<L]_aNF`e0OW_Y?7`[Z*FG[$`:8J:0;Tpl@(lQgD^rF<]=d-g(edrG$fe^b9Fu9O;#'gM5&Og4[;2C>)RMk/:i2TVK\44ah`"P-]LaXqOHF*o,&>QgW?%@^Z>KF2XjXklHGEc`6O>rYs>qn0Mm.-rY($0U($Qi*n![;1S7RZLqSq7tSi;](]SN:^=LhN%ia`rG:0QXpRj`Pd9&m3c/#H6[^"-J1kZD(La`clh-iSgf03D@dm\3!We'*SuE<F%BO_\ofr(h+4-kS#VV;*X:%R_4Alf[s-mT,p1F1qjiTS"N$cZu=qUj%8&A4`Gk-!8<l6hmMa@$"2C3<HX$XILSk9s2I:X-U4mhERB_@XPRW.%!oI;fO:_5rm$b#/uohL8#qBB2(SI`P/3>P&Hrd6$^Qc1F$).5`3?!^b=YH;TPpsJ9tBUSLVZ7M:r1.Q(N9T%=IR#CY21Gs`C!EFJTb-l0\Z$ui;,2_P.RO^j@Ms07*#+E5,*<%WlG3_e/**qF]g=.`gUpOZ4uA/q2;*P>mF.H[M6Y!@l]H2Ns@#6iQPpkc21inc=8r*itW$5*qPNMqfqhHs8ApTfl-P##HDYnoId,NRXLa_`VN&B@?ZWH:*C5Tg#D`1Hf=]"+sL=l!<PSfpA~>
endstream
endobj
154 0 obj
@@ -881,10 +881,10 @@
>>
endobj
155 0 obj
-<< /Length 960 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 975 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gasao995Pr&AI=/E2kfrENtL_kq1Y-V6-b_W^Z<Kl+nOg"td"[l#-KK%@FPS!)]Q5@qIjpI@c44K@S#GfRaMk<cD/$f$at0Nr20N,"HNs%KXYG<fgFuD]X-If%(onpa3,!"eF5EDa>6B5&(Q#ia@OE>#mbfes;:dX`.e)H@6a/qbi>W0?\FBb@3&)fgW=:Gb>*W"@M-90F@ulUn3A+"WS?\O85pFj#O7:l^O/(`_L:VM9dGOmYjBoN(f@,LSecQZq[(qi]eKV%.W/[3,;*uk#l[5*o\rj(iC@1MPjAsd]0"to769ie<@PBqu4U]g3#Cl]fI.EJ21_+5Fj-c%P9Rpf7)dMlF]NinSKY4F`qMP+(n5h2"V\A_(m4da#ZD,!t13:-C\!3'X^*-KG!)b/!;?C;)o*/K[LNKd]\5`+W]ScG:%<t2SY7rSZ;i7!R1Be_41aup-\ch1Cu4Ge,nn)>@bjo1#])[K\;E,*^91nR_<Sd0_Juto2@c]T1K)h!WaTq5S*VHY:*3`,=%(:RX>]Y=@@ELAa*[EFWJRI<F%4:2T0"A!)Y#@2:p%:(o:D^.<qGB_U'jfXIB?L>Zn^ghm&tkeEt6fA%=>$"PWHqV:T#'Qk55&@@#tO/F4j$ZD,f]W^R4s_]Os"ZZ0`D.](7@\2ZORn*(C=?"kY!F>b`-32R`^(q)'b??q^S@P5-S'un%AC*[_Q1KKKh4@36(hRqGA16o<6mJ8SaKE3;*::da;YP+ii:L3SV2QF5WjsZE<'"G6]g8Q(Z7=SY"*=a9pb/KOCmg?$lqcjDlA`MB2.UJ(]P`%6T7Mbp^7DsDT!7tI6P5c)opV`qc;[fPjm^sAroEk"moh9VOd];pI;?@]R?(Qa:eOABm@oUQjP96+TK<B$2OH$$F$W_c3=(M2SP^9VO2JYgc$=OrU5?>80:m&<h?dsGg)\/22"9V`])Ufc-!tNM"3<~>
+Gasao997d\&AI`dEiPG*\?Y'REGoYdV6/I:Wf>_"l+mM/7%76uZO?fIc3l]?+UAC"SG>9'TBG21@.s,k@mLVJh[4N_gNoGWb>pi@GmN%<Te>hkCB]RfkO+HYHuAnjJo;"X>0p:W$If,".Q<0EJEO]dZ/rSdR&,LIWLR0#jH^^.CP4f%h+-_<cm$r^ifn8b=N`J3W7DjeBA^?Vh`M0l]CG7n$Uo5n(aO20E%iDre<$S,.bX?NTgLWS0/5?dOJ#5\1e;9jTEp`F1p-OZ&A&;(a)Q,NtqI.tKR>2mRb'65iHf6)X;^&%N#GWmB8Pnj+d#H/$8+u\8#jBnb:igT$f[k9uI'?B`m4AuOM,F2E6IF!l5H&H.lgP-[5lqmRCbSI`JoI;'$%2%8iqq&&:'p8l+VV3@MnP!u@^Ki1LYoofN4=i:QN_kmf6Wi!M[?)2kPJq7YtU[2P\D3.;YV>dH]oJc:ET+^Sc[%]%"GaHDZq_LiETlps,E?eBGA?Fpl<qPo;'+n"14-iqtS5deg25`ZH5-]8XJ#=-nE!FL'`MC=fgQ;4kn>lGu':qa&GEKC^dL8&;)oMY+P<(h.]jZ+-3VPnQR1dm!s=/9->MPNP1)g^kLNBRtgb7@LSgR9ia0Kt7pP".66aJd7<<hl[[7`[(Y=<*rl;l`;89J5&1m]gM*m:*gX>tHZ>9,%'ep^h\3eco/FQK0d8Q<1Iu%]066'7&E+Yg#/K,G^%dh0U^r;e\C%cS*<+3##bI_FRmOMjph_ku6>]g'r?$A=P?L3fDm#aA]J-SN4+3m<C%;a^RPh!mb`gqIdX6"<0NT;Z::PUn!2P1D8W2M26"X%]8\4@5[6%=3%UePBU[+jtuH`/?caTglGTa6[h<.!H$^,X(05?C?V%6MPR7,[6Mo@q7,sW5BL<Kbl6-ga%FZ.*uT3T>II]ADXD%#BD4]!O^R*Pe2oSs2,;[u,lflT6`a#]#J3?GfD~>
endstream
endobj
156 0 obj
@@ -896,10 +896,10 @@
>>
endobj
157 0 obj
-<< /Length 731 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 740 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GauHIbDr&G']&?q?;<!'p&!-B7[#I9(o\G':"'7P-A)FJ-"K(4qjKbOj(a)(o*.Q5<?nN$@?hW)X1q#$BXU(IT<&n%pN#f-EaJ5GS['c)TT$,R\[I!CZl3s!)]ps#Q:+Lj]H&Q2P<BEO'-!gB@cl,phW\+X3#7D7pd_J]9^PLS8[2\C1"BE*'<m8;\-I3r\DSZ%Y2L5Ikl#5hfHjFn]n5t[UNs0?]GoR92ro>"q.5@Lop'd)B[p^Bn45)$UsVP1rK0^fQ)\40Z.k(IHZg?-sdqm7i,N5AKge@KlanKZ2bFmcHVCC_d48Zhm\Xqu[P6VP*bg[+K"OnGk:b#>e7?0\KhaSk#Cc40*(][[%DMB>*\!ss6[C/f>*Bs31qd9Eh4B2mRZ)DXMDJ.Li$H?F2CO:\FKkfI_.A\,%m_MpH1VZnkI&&<\BX1*1+@h<4ITpr_cq)[ilkCr&6:f8E)>+_6j17kq@nf:t<B?PB'f1"sS>BXdhg)9ZdV"&hQd9)bI8;fQc+rD-N7:otk(&PU,OS#HSO`5l1\V"Gg)O58IojX:QI-P_%lgr5\j]:6;O[rs/>$`-%Thimq`%J+8BXLZ*&L[UZ==C*(1g?TDmNpR#K3R]^2:q;hDQWZDE-G.mm3r0"eEPEL].(mWln<)745V]MB9#N;PgJSCAmt2@H((3MR1gin=4UmJ8#6A\n3)"):H(n+fYr7D?A?->!:L<.[0>#6rWPU)kFh~>
+GauHIbDr&G']&?q?7(qVD;tkCQdMUe8falLeBOcs#>>=.9M3BJo(P#F@$2Y,;,q1;?f/a]pR-f`q>AbF=?tku0Q@ZV3>`n1_a"ch!"Tq=3<N\"?5?<l=%i#jK\m2q!K;ti!VHFdC'42:'HV-(YtEfI-rmk-DKXYPZqFNg[Fc$7L>/Iq;QUF]5n6DerX>.](a)tUKS.QiV%;kaDL53bOaQVgnU+]e6qa?9kjjt5ZiUau7i`WXmMgoiGg5g7>Lll@">.l\.)'!@^7],[BZS<_;8K.IQcIT>fr\^FKA<$>Yb0K".+n`]sNB#ct$e'cqQ1.!,FSh4fj&,6lK2&,Crb-sfOPum+IhH:#1<?J:?[!%*--#[qAoAXW.C*Xt3V93P_V,mKY_Ko$9VlWi[Ko@[ss2-jal3tfa`6</[GuTQt9_VOjkh0[I'LP9%&,\@b3iNa=:uIum>JJ@/T38jQA*=hfSrY&Z=4HB`b3<Ld5IikP<LH>E^.<CCb2M_\B5ugd1u9cFdL.8*6n#X!8@ie\gh+]'ZD+=>:L]fk82u?_hE_dfb0o*I<XbJ:-]>$Sh^m))dolE!KgF</cY9IMqdH$@.]NubI6n"A?n)+?I6pUd1YQ^;<MNBMf@opTYF*nkm$?a3U$pqtRDOdPr>DSHL1E3:ISMCLm)D5]1`RVTE;s+Y3coh[s2BtiW:r?Gbo)pJWBfJ@E#ukh8!=bXVI.[8RD!4@)i(d.*4(4e0/GiPf`~>
endstream
endobj
158 0 obj
@@ -911,10 +911,10 @@
>>
endobj
159 0 obj
-<< /Length 1093 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1111 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gatm:>AqtE'RoMSLj3?TM"0:U&kErM#rGXK$bS/7][lHo[7Ns<Z2K%9`2i:49ntuZEDH(qn(`<9\]cF>5*5tZ!%.MN!gD^K-."b&5o:N6J.,i%PC/r!31HqU5#6VSq%nZm$%b;i7dpfgM0hLu?*2Q.]rKQ+H'2WK^Rq@%5NfUl)ulr9dA#-le[62FWd;]<pXh3a5gkI;qX+-*`*SsR5\%`b>&?-9R"8Ta*VR\@-].Xn&:P`G"9FY,*d[EW[d%kN&&`<?R*87Zl#A`ep\ge)LpWh[R#*uE]D!Z1*-M?9Rab6M^dU^KOCb4hED\BuCL-Xj'`po,\M2,WkHWsW%<aPiO].8gi)t6=UB<A%n.9Ro>#\L@0$73JFU_*86m_@+__<+;.KTcSh,VutX"l*qQ!/oCc&8!)M_^MK(a)]+f2nT?m]H=HfnG\kicqa.4]A,qH=bZKQq7K?qm7t&n3X=cDJ;3`O+$,t>s@NRI:2'ln)>'Fu6?IYE]dYGpN\hL\$o#IsCS>Ze?Xpb@t1DWN7!C89Fo2HtAho>^mR,<+%I(&sUBs#("W4`_sSem<=Y&ubRTb"tb]if&r+dEL]F0N8R1BM`cr4Y,T/3Y;/->-&\%c1sVDX5`cNtiOe&g5;+m6UB*[q75m,VcIj+9--jTc@GqY\BHpj!g2S$B)SW\Y/](EtbuG'<V[<>@T<"_`66E@DiW[#pAS&8-c\Z_Z.3HXKV:iXt2<0)ACW\Xr`i[UTp<H:m:s2gr=;K@^8O)?)smQ1&LJr;uZ]<>;jI+eFRS'h4>^1KFe2?[SslfX]KIWSja=,c`6P%f595BWS&8ud@QeRe7Zf"oLdrQ\imOKOH4D)LC'&_a7nNSQ)BH4S"7'iKALAs%ZPfU\djemRk]Z=NrQkuiSNI%&Vef=Hf6G.rHpa2&A+iJ8HF7bG5d)f_NY(WR9PE'\W1lc/(;YP:3U.s?ou*X^+lb4(QBO_+lLf9@2BrH*ipW2:FDPBkC>kpQdiJ&$hA\1B"FI[C)+)4'^[gDd3D\ZWImUIDoG^?q:4s(rVfP(Y]IgUTfLXa=\QP)0(\%_S-!a#^KgqpaDP%UUU_P.TVq\iCh:rZ~>
+Gatm:9lJcG&A@sB#e`&TLugS7!\KN%Aq;P^!(GCDl5ge1Fp-H\=-D%phj5$gOcjR\Md>O5;LFunDe@)dO=oDf73WuW:82jDJC.t[,%s.S#n14[,m+Hd;7_\"?/;QP^5fotkspA8&V=VI!?D1HgBF0V+:*"Diiq7YforGqrH/faAiEsH0c#5(lFNtn<;E6,WN=L4?Wrdr:I(K_^mnLk"q9q7gtb\D`eah-"F4&&K*FJ0>]NddOMD@t8S(oT6NT]3C(^k5iXYPK;Dd\%KKFu;('?9V*1tWb"!W!T'np.n"\hQ9:(ZmN)r3MjFjKC+R\"Y`0a=!ZmXUdAF4f`o799a;)58In`G.+,C=TJb]Q%sJMui&$N&PB)d?+_I2j8Me#33@0oL;p?2^guQ%?)UEa=7;rX<,Q*X&TbmqGqH"<i\>]9jWKgl_.7nT4(/o$p-1m,^d[IVIBfGJ;bVGMRerlPZ**7i\5lI3ihh"PF'8TSO+b,&6#bM@0EguC1$4+(%%>+F.G:Q\qO1\DQNai9S./]%)uQc":OmeN!KN;fT>9dNeF$6J2`iZ[6Zo1J#jU42csgd!k28,HEA]'A30?+)"70&D2V7o_2l<h<$osJq=/!UZhT1R;l+WI$YGZA%TVKN;^mHp"A&+Bl%/\tY@]Be,X\*64T7,a692hl`2O:CjcE&t`Ss:`:3:,lARokEkd#0!%@&8.(_=sk@tFr<";!I9kpWu2qQ9YCqHD,[/<L2D,TZ1DVm8lN<<peb@1qL.c`f6`XCG71l6YlbqI_*QIf/n9eG5ugX7gsG?Cu@m:^JQ:O5B0A+0[TZ\dmn+=Zl#MM467YNIs-ea/4`!>e3Y5eDmUk[Je,=(q93p"H<'JT"DJSRi"%CrGnA2c>107P'\4\%PQSW'(D^+s1_[RcJM8%Rm]h%4)G#ds1TESM![uoWGd'@Ful*j[R]Z3n0)0'5q?nim]cDBRs>K[H\6Uq7bsEMD`g28gsD4.c.Ym-7h>KYa-Tr@.'_K^Iq.)P;f-Aq'pRtV_,K*>l%co3%.<3`$76ofP+5F[9c*i>p:]90Ca0_CFpuWoda<C2H1<$uD_t6F3P2K0oZT[@\eYchk;_JXj=eGpbln~>
endstream
endobj
160 0 obj
@@ -926,10 +926,10 @@
>>
endobj
161 0 obj
-<< /Length 287 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 288 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GarVI]5GM?%,CLj*1`c3WOKnP8;8`c!Gt8\TTorsN`3o9d(cb(a06-Y>#)^l*m%\!gOfR,d<c%j&d5UMT_oY&/<R"9lNp4&+LLW@][h4_os'PsG`g9_Jk?D>pcHO>#/24m/UjVF3X\u7AEM#65/]97nTrf)%gJD_`pDC!E\(=UBXN/LC.>euVo8CX9IoPCCX8uj`1NmU<@`H#BtLb1[Tdst/_[(?L<!-'cb9qLG<4An@&FkOkSpCX;M7YiLg>6>>)hgHDE`RpcC@b1h6]B;')<&Ik[Ua~>
+GarVI]5GM?%,CLj*1`c3oqLNP!Ks-L;*\@5+_YH)KB#oc*;&\Ma"_B5JX-u<N^n++`:fii)>%6&W!#C<,Z&q&PU_gJ!IM]3>6lg.(9_kO@X[V'#%!O8R@o_:#_2#^ft\DW\&IeEZ=@;(;+`kEhhRSR-=6/pmD4B"UbR5i8Mq9N'XH+^;XI!krKK9kO(lR]GO7CJQh[nO\nZpp.rCUggii!9\OG9Fc0uR-pY#:,r([L/%IC/b$g*0mUD0C7+(?$-KksRMe]e?G,Vs'NNLSLcDMe8rAS,Gb~>
endstream
endobj
162 0 obj
@@ -941,10 +941,10 @@
>>
endobj
163 0 obj
-<< /Length 1693 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1740 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GatTIbAQ)nn@i6Q3'^oI?<2I<iLHFV"kl=oU5N@C*jf,=>3K.1,cqa[I>/rB+gmL"VU1#QjD`rdlGI6,bHF%$#ml7/IME'B'b*M)BL#]+a>fE;`DNjb%0"!=S3<mQi1FEK4&F%LL5*jKL_<0TAdEQp^K0I\nL@WsWAcK^CKu?eqk@%!,-p1uo^$T&#g'a65;($oBM(Vk\/%K_=^+iOZ'6KT,<@!YA\eI.'D#m(@89CaUk\<`Qa4lM/a,J6NK@iUAed,7BR$Zj(LsbVo>Wfu459-1Fkeh[s7EL@6)[XV)5plll_^eBo'cjkUe"%>E5V"M5(N1G[W>IhP;EcE(`ZTEI)KCFnYA</YDBl^$5+YAX2qq(=Z!"c`L(@G*k0Z3iV"F1&^j`>m\W<Y+s%LF(+DcQ]s1q,fq[eB:1D(mb@Ar,#ZZ4VG8DL6di"k`C^;6RZM\-QUsN`cQY-f4<Og=nM0?4'e<@r87;]e?#cOM%O)iC3!"s6)5o2gj'@+C]!@3ShTg?U_[0U;;;]JE;F"k+Oeq&Q`-^\0Y-X.]XeMV;g&Cmar<K2g<%n1,,$T;j&[uO!?RV%adE_]NZcI4Or4YC3$a%[%`$/$)!(1ggQ51(p!qm%=FL\_u;_S;6d8AK?h`QT^^GM]h,P_h%$25b;d^7;86/["[a6,[]eVDZ*hqKTHA(Tb<mNiLcS$q2=sWWVfq#@:#Z(c'eFqk?!rC;?aI)%shp3aPaLQjj8.Kl-+Nat%]-5;;>3[bn,*Ia(R_L_Nk@kqH&Z4942I&K>p11SRAJ).=,=Khfm/P]KmK4<'31GKn^&RJsi1MaG?MN!S-m_I;;hln-bU-'"PYRb_dD]$tV9Z/jBIj\S+@\t&(=ON1KG(C"B,B5dAS$B;0B;dP&La\G?]>L>!)5)/pOI6B4>>qDC-%F6HD)l<\.,Xff-&:@AM?5HC,bu_nO*XT\.ee@2dXR8,*LDYi67m@n\KYu="?*Q6ad9)Q";P1aCpH;k^\]joC8q"JiC[`"3^)$)<6I;=S_6al.Gd\8^&)5NI!*^BO!'PD%oEJg:f[NbCqm]*tb=[dup?F@=&J9aO!Y99.+I]"k3_1KnK4r;9J7qENhE3uF0S+iYDi[G3IWWij60_Kp-Gt6"9/oM9Q$EQ6O`ItAb[-,uTjo<AHt&S>o/:Q>B\F8SiGEo9]QO[^?^@36gMS93ndF"Gp=N?>3\u(M%6%:pnpAC"P>bt-,YqDnD^:sR\jB"5dW9Pt%%b9#C..'I6mLIaW'qSd_C*)Ib'&?2jO"jeRq`qI@[n?g]5QB_dnq\s?UMflKZ)BSPjdG+YC2%7gDkeAbF8p6S#s$Bn#u/_-DQJf0I9<6ir+5"q)AM.7C[IJftY^8!U0L4[D0Ct\(THC-U--;%_H$E>%#rHl_cRi3A4)S1bd>/^L`21m<;:[>3H$@\SsGW>]60C:3;GJi$nZSR.?Kq=-_qu7=C7@841u?2p/JMc1rbC.'^LRo.isqTKhXO/c+0;fCuU3^q9d.`!Pk&TKhRUR_l;u5J?GGisj:?8o5K%KLXDhX!r3tai!!PGPf(rgSK\=]gbO8Z%L+a!B*h-Q=Hg#m)K(CgaVc9eL1hhh#<&>m1`Em^GF/.E_\E8N^Ub`@/=,n_sDf\=a`$>#L.0Q6&C9Z;6N>heLK4Tr`FU$N">2+4*_;XYS?f(#n(NEb)k_/n;tSd~>
+Gat<AbAQ>unF!IkZ9XPF0e:!1aI]]j'^,U(TNItU\d)E9*MJLXQ/k(,^-e"q8Qh4_$XGa0)9mM_jJUPf\)1nM(a)mlJf[9J=#IY!+_4rhKDKgCrDPXIW94U1pkIMIq7.ekr)I/trAi"-0EWFN_3+ejX_Qt"=FQ+NkDNfR8XP&RgU\L&T1ctBo4$X$\ekl79Hr1@@(](c?pB(R7"+?H/sb/d13H!-f324cQL`[D-&kFWs!b+?TBRI;fO:kU(<o'NPm`9W@N3,-?b"Q>.F4_D3CG\S'$)6aimBU2NJH?#:p_m[#C0E9-Q$e=f>J.'M7=Z9>em*?Th3Cc2k[A;Pl%k]E%2J@)h;N;X5Xk7shhr8TSELf!S]9ksE=@?F>B&X[;3Gr]re8LD;nmLG=5r9?T^TQBeBn=[%R+=78<ds5qF#poqXj0LsBQ/7<lc)9QcE>nD>B$Y.6n)4_MnBkZ_gj"61_uDa#M;SZ(3XEjB!eL+aei'T?:kUHK3T==pb#rgBO0!IO0XEO.$jo@7HmWQ`*P>;&9XQ4$b:C6G583Pc%<',B!$]%JF$B<+OrcBa.e]]7D(bDXZm7s2kk%,PuKY9(,Dd%V+KZN)4o(\(8mI'QOr6b8qP7!a=>l.RDEasAi-/(7q':4?fDq4-jI"ei\TrTkSneFkEgbbj//."O2cqZf>\8&`#m:%EPD^hHo@XaXI[InWF@uFU;X(3'(T3P?4+*j=0r0TH)7iIK26(7(P]r:ZGnk@2/(Y7[4t:AQ1!cF#jHB<gFF:iogJWFfUAtc@A9*6J.7Q*XP@)c&KRUL#_RXWFF%ON*SRB\a[JZ*8r9`-rcKP()$A"^6h?C$_HWA?UH:7M3I[D8FHcC]EkAZsY`I+rIJGFp@VWJ>*K)O'1e'FMcK>?f)Uf/9U'-`*NX&'X?I*m<ju)Akfl?Q@@a=YnZ%a7^m"p7i.De3pjI^"S<V_h:o$$?[`o(LH3l^M/Wcg!naFJO7pkPUMd?saEQok?,(s]9(q[EJ.n)WcJV:U&s-j!JP5"ZU`OuEmeK&J9THC/BaZT8&-Y\C0W0V)&C0JWGgY;(?XNKIu3LE46V2WE<1c9/re+2T]W2QM-lh%*crWV(?Ec&`AGo`3OQa2dm+E,ZBU!NW5\G-j>%2<[eWR%A[3>ROr$Gn'h>1AGi4c=A5Z(nta(1ReH:p48Dqj0@Odr_4CrYMD,%2^N+[$la*1n2%cUp/%*./i1".om\GAktd8I-`=kL9HNM*hLU'Mk;'OaYk6H#3JSt!V#qLB+_oi1%pG>Cc@#>T]P(n&EbK;WQ?RF1(^Mik2>R3OG^MQn\^%5X:Jup<G?nOef3`Un&t@)HlcU5UTpq%JcIQ(_X3o]H#t$7#,!LI_4El2\(kgYOXS<=C<<05+Y5RaI]1l&/4nYf&Z/9E)f)XRn@R"HjbTJ#Q(?jQ>m]_,jG.TeN%<MWn>WA4L?#L]<-T;6%5WU0$-;nkcQ<pL8p-E.R*4h0?Oe,ot:6-R3&^-*3-o6V+kU3.,<+#LeqJk'h`$5OX.&]XeIkKH>,<V9q58%ft)".b(FCF2T;=-V5d,`rig\&l.pUd!?R^ig>2@@@3@%hl.\XVis>,BnIljSF3n2\]U*hK]r-K&P.=EWBP+oO>;kPdGT(KP6_?@'>OKfh")mep#W$?cB;an?]&%\Da"H#mf"A`qbDe`+2iCi%)1l@CBlm5fo#-%k%5YJmEiOAJ[;;7b-oDMS>0iF$F0_MK$-5;LO<3W~>
endstream
endobj
164 0 obj
@@ -956,10 +956,10 @@
>>
endobj
165 0 obj
-<< /Length 231 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 168 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gas3-]aDV1&-1WO:N9l+oXm"pP-0L"3!`tOE@@8J_7'?Mi8^;qU'MsP*;B'\'p^G;!`D?:'\JidS/;M%_1DJ=JL5pnEj..^U@N;CQ_EZUl5W0SC5obNV'4PN_cTWmHOP8*/'hhCVgXVTK1[(>;?h*rG7Nf$d^!Y5+<6[e1Q\f1I!0R-ZOJGOgImOsOrlO%FmtEo:0]`d^I]_Kr"TBThoc/Fg#M':4TR<$6?E~>
+Gas3+0akiP&-_"jI`37Kn@VCIBj;$,3!_i/EAMTLMh:udBVd=*[lj(A^+RfZkFobE<(LsSL"'&"HTbSQX=[>2e)E%kR?olXm:i'R2U/.f)11!t925/>6:^=hbdeQM=rkW9]B$9?_k[6+#34jLfSJ,(#I]\kS$2Ge9].L@~>
endstream
endobj
166 0 obj
@@ -971,10 +971,10 @@
>>
endobj
167 0 obj
-<< /Length 1042 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1056 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GatU295iQ=%)1n+pp;m\XB?(KH;!!$kRIcN#.lEJ.#sf'E9,5D]&qmGQ5*&9A%083MaWIF5EQZ%]@H962se?`"PtW#"l=,$]g."mK.'R53!]PB,B%_oIbd-6".OYP^"%>''m_QI[JCe=Jj>2sKe:LH>#qOpc938'c0lV/\*F9bF2;TATH/FV"s,3ZLjJjj'5S4R6-qjQ;E7_c(qftA#[V([9OLYeMK*b"ar#^i8R'I&Z]Og%iZ9df"C[`Ia-';80R.ph&e,S0Neeb\g3]GA<_L'L3@hQ2#Pa'"!D.lIa@3Ku*LMpL.WGmF3/D#Y)6rQ:Ia[5ol7'FO*"if/M9C**K;*%XZ*;>IT+@EsY^<pY:0og)[JQ.JR_up:n0KNled!fIA),P\N2$q4+2-$YdnRZ[7%=`+<nVnhgU/qO\(g%b87%/l=Q,ETqnWm$S?XhUgGQC^K'Uo?]1enJ!>iB6<#e?mF`RY2ct`Lae@IrZ[E]5p!-D9ugTi6M^W_gVc?@HDm2iAHh[([7kG&^1nY@K7JM<$e1(UJ3.Xl1sohGN4WZ'k&>njVs<][L)J,sOnA!V"9?"=?+pQ9$W(08dY[la#0^//.'9Y#sKC_ijh0SG(mGI4cq*EnME`3<Mg99jBU2`j8S#JV9R=ZRtJV;u!cXsAh*>AHf!k2]%%HWOPA;)quCYIs%=,C>ZIl[F:B\Pu@IPQZUUp6j_T2u#6\nqgVfW`]aQ5E_=7<D\?WX0?uJLL\/t3#XBs0K!]lh=%D2C1!9MZds[bS(j-QloW%l^:N!D5)9]#c-sWKK-]dlCg<nl%TKm7eTsC`JhTaE%O?*]DJ<+uZ\-2M6QQHlTW/qrgjoh+lKIo8jZlL.!(@%/,W+>GDcsiY/b>KDEjFi:0LUmF#3ER.<"A&Xs"7^(]L/?[.MeHf)t`'cC;*%K-4rMaN!iFXplK2,.aP$fP,&uEPuF#)a8.TY-`S-8q^g6MPbcE*(<b7p:HNa.j!K="oS?g(pNdSGo%B)Wh.h12`=QB>f=fK12PUBZ`3]M8XN>s`JVV\~>
+GatU2gQ'uA&:N^lo$f:WE.(<JADc$F.W)#b<.XmDqI"mWQ@_I;ZX*RENcVH=2GgA>6Cs%[bjh+kj^C%Br.TAD"?>sQklc=E$1abg+YUb6H8H*s6j%@Mn:'6-YQLMD^V&)uN=%cNo`P_=!=2a:)IX0i<$Sh6SX$37-#2_iE):tt>@SXVl\VN+o$TR$QQa)aJ.^1FqC*Jh0Z"Y/172Ft3>ENU^i4*=+T`6lE8Obqj;l1dXKNH1!CaAM/C.5![k$c1O\#X05SRQTf&.+P>aS<B5\Z*3UX5t7U#;cQAh&&6/T7p*JcGpn=9k?4]@2=(ASMm5+:aL:b9OJZqZk;>]Y)7lehYUKn0r@fN].TI6c@b<89mC8o$#g&c^aF'6C7+1mN=/U5L(&hRscF:-t=''(t/J<hVB\4"P[JBHK==piJ"]2e;d6YCMp0^U-pV,@%@[klj$HW295P]BueF-1L]"3YnA'W4+uD&:W3?<eXI;XK7On3qD.h#Znh7\cn2@So.8)bE6#:FgTaSO414!U-_8,GO%pS5)VP]-5XA@JH/`C5Lh!R9NDn%KqB,Sd0ZdF*g58,s81dLkFIT<'c(30NSd:Wb7n)3:_@?@a7+V!%lPdm5jiWE'S`kD*D<,kR4fa^`G'M5RZ^K,*!\uY.ll]<r7$0*ufs!>K=]'!H/JXJ+diESo]sDX<>(#T$nXeg$mob&iqq^4Q;L.Y)M$OAaT@nW;_lVp%HDO[K72OV29hF=O("^nNDsVGepbdf6F<lYCDK"NWs(6+Dq)l.+g6B!"mSA/(mj-f9oX`W&6#A<U[Oq#Zi571``XVU_$'jj[Z(?sZ+Ya9#/kFt+\S"@Ic;#W.*V'Jr#K8Ej;&<4&2[@s8PnRV3s/P(W\M]^_bBs!:,#*?WY+G<`**AOPNgbn*Z/A:b*\m\?EaaRmR[^e,glUOoS$tF/Dio]Q24FF?-("Xn([8CAp2SiW#rh%D3P]IrV,/OOm\H<dOOa`Sk`Wel2>LOm2pK">H?shM)+-P:\<ft):EEQSM:C,^b^8rm9rW&>I2>i//f[6Jnh4K=Ktd~>
endstream
endobj
168 0 obj
@@ -986,10 +986,10 @@
>>
endobj
169 0 obj
-<< /Length 755 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 870 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gatm:]5H@W']&EsgmSX\8PskKBE8?\LCO@=#[*T+MG1Q1CrrO;+TD79U29,Z#>fXgYOCF5pVB3[`88P<"CM6BLbfQm[>+c<57DL]N0,=l"3s0E"[DGsPHDJ&^Hh_ATI@UsUA>-B!Z2(VYa4"H2Pp-)P0MiKrIEHOGJ<Os5GV>jI$9gO-#P^CAuaW]qUJHuY0<c6[+_F(Y9[qj(bfTIQ?erV!QL<:2N]o6OGh2ST+6QMhG:(`>UiSiBI$8k_m9q0)M%uS!gg*?9UZAIC$NT2\m:WFc0>]P_FCGOqX!.lk"e>FKcp)>Kj*rSZHu<A3JS2:N13i^X1mQ'5.iqCCO8#N+VUT6lhh="&RaQE?ruKEQHC(efbpqjaa@BaR?o]D_hbgY[K@=*p(/7)7<?YL7TobWs,/H>>jVHCbgPlFDPt+0<NbD__r!pHDY)kRe-=T&m&1p>!t,amfXT+6+=Hd"SL<%\S#H/\'aZULP]BFgMl]gAmrVkO(F>=P%LHp9Bp#9uWb1=t08!>ak:KgJb$dQ>-*qtp[_#8s$;X3`70Ng7gqG!dj+lSA<b:OaZuUm3[H5?1CTfh\f>I?'Ig'V_D3+n-Q03N@qa.[617@Fm@OLGmiE#"\bMoOR"ZV*2e@l?L-BK52i9T?2A/nGp:j?2XbU@"l*.*snB&8\F5Pe<]pIY>(jns+S@E?ET`A7/dg<U$$fjO_+#b*\,.j[LDIJ4fBTd)@1RIiR(:C,Qu:/"b/'iPq>+8]^TJ,~>
+Gatm:9okbt&A@Zc\97NWf/@$STp;ouHDo>Yg7Vc(a)*XFKW.fu\)gSDTuk1^"E)ekRq4dsF():,t;PAe,6Cmg(\m$`B65]^id'<3-0.0e-ESc`6WR/YM2q=#@Dfq\AdoY2f=@j7ik'W;$T>Sr9T!OYaXfJC(Zi`%O:JiHia"a16FLCM81]7"<iE;%/Sc4kB@.qg3Vj/?;sVn8eQ\<@VP.!*3iRg>QWKHf?k3g$U3.+/m*<NKOZb6A*3$F7Ak1,u`[D]$JG_a"VA_;k3gYm:iTQk$prp:!YY^bSc43O.ufE>J"\:pJ+"CEG``n33>@llF+IN^kVp;XF!"94[jqPQK/s[X*d@f=V&25+LHOZ[)ua@pfsCbB(6&aT/R3hZ&i26o*.-A?*%<.N%%j2nNXi,",_TWqpcVFbIah.E?8+Ol_/-&R/K4?5pN6*E.',OSe;1=N1O!C&G$1c'9[NUir#_j)rii]g/`h7YUMX(0=s#?/0.74hm,J:Q:.3=qWi57Ih,86GZH\Voc$7>+PsA[d1ec+j7.tWU*:9X+aKqTs=CuY(b6KH^6>t`;H8,QM"KaQS?dd[FH,TR?%*djl(q>fsYWS\"A&fA9=SO2R*LKq00*.c;We(m]1DJ4N3a7NQ?;9.$b*WZPYX=7Fqf`RP%?5FG>!nV6.7F003uJ%+F?Y[)jo$RN/aJX'.@L[qF'T&T%8:f+>!Zn(&4\o,[.Rr$mS+.'qSja(gJ\XLIA6R_3+,YbbmEg!Rtu%dS&#m:AI6/=r$]',S1bGg3*jSO6FQEY.t3YIVl0_EOU'dKSQ<G=Z0()h4l;AYgJ#<if2^iXF@/0JbJu),L7>URD=$e?@^'CAFeC7"APjN_pV`5Ai#Q63~>
endstream
endobj
170 0 obj
@@ -1001,10 +1001,10 @@
>>
endobj
171 0 obj
-<< /Length 817 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 835 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gatm:bDr&G']%q&]^'*ZM_T[bBVgYKQ.j2Jm@\>X>qh+,>Qm[7R83aq2C?6O+Gj'/A)H)%F7-rtgrHbqT.rSNqB/OG5$6,BnF[:m'_pD'HiaC>6(ELuGE5<Bk27&3^M4G`aLA*#K(8n2JH`-/nu?Q#]Nl\%--A7;!b.\f4Ki%?(TN_Z<E-(LBpWJZZn/LK:W(]MMKIKBQ2@E3QNB(-o[HerTtUgR"7=8c*=*]2aEV7c:PW1$D^SM+ShP$j,iUl(i<<!;T>:W#koRK^q5m#\IN>FLlpSHYV:_pt`*db3g4t_@r;%CpO@.<u4^q9kpR0*&?!G<V`-f^L61S%-n0?WS9`p>EgDl5?83(mg*H+FeO:,/a[$<,2(+W!#fD.hd9LoR:gbRS%>gV+h3#_Db^'us,g5,d*<\$.LGC*k"Xp_dGmRgHa'Iu\gANapBIS4@fBF&@L3@2\0)0G61GVq's9mXkAFo2HL5(6'iKHMG^$N26MALVgq(AYr>ME-<V2A7Rs87uVIlUkc0S+PE]Hk8a#J@]Bc-;fu);-eKQS:P*Ar'_&FgfJA(r8!16]M?sjFSO$0h\'unY:187$jIR%i#^a<Cq"PaeNcGQ._q.>k4*g?H4>qA\L>+]EX_Dqjj[+e4Zdo39i;nukP5k09lY,;RKlEe7!Iu]Uo@Irl=/A5FJ3<B58O&p3=AXdUSrGG(H%?=:&UEr7:m5GaSkTdC.&B($m3[#'_U9S[U&SSWV22Ej)Y&G6ni0L>fB&mqdVj[m,sQ*,9X)>^0['+UpG!Gqmc)cF]eqI:=$2+bj0s?X^sr.V>LRb:d;/~>
+Gatm:bAQ&g&A7ljG\_=R/$;9<4L@A*VEbMG5T:l5\d-3OC_i>t8ou!OIAquJaqh)^."!0S45/?mGC1@ShLG52i>=lq,r6(6B*<MB7h>pl+XSTI)+@D[IU:jNWOt^8;"W;2-mG7&0VBY@5\4=H@.'3_Z'K]BDK(a)tujXS`b\41P4Q.OOfJG6Mp;AVqhbHa(GrUC;d'R;b)=iKZEGr"f`Mu?QB$]2K+\18FlE9O^OI#F=[hEe6C%4gQGQk@n7*Y+Tu?TO-*%hmN&4MZW$X(ErPG\:t$i=qkJrALW1Y>/(>G-\k/8o@]HaS>]"CEGb6n5DNR$;a>L'tj@X9sNQQ1=LAY3QH`7^iUf*%IT;IG$d,aSS?O`$@i6@>FE(#Z/K-oDD$m4cE6WZ$`V_1`JJS5oLL(/WW*Z&)e!a1lK:&`b^(N6'AL=H?Pe&K+"k,,aP5s^A>opHZM6@UO&qU[-+/qQW9C3`/bU'cd#lT5\Ji$1Ph/WJi&=PVf)l?':_F[)1dB*&=f@llGrE3;I3Gg"5m*'(b$(/*\Q#Q^`[A[k?9uFFaRIs?%Vi'*j97Y*"62T7(Hp&_?eQ1_G9^Bn^!J(gg/kIWOm6p]2p4,m^kl`&]6fC`h:C:Z,NW`&jU2Jeh->p'i,L.-q0](l_n4(>%?k@!&+em0/h6>/od"Ac7YY+Z;Cac[[Wb:eQb&\,2dc\cek4VDT"Uk%&:hm7(!N..NZ>4uVo*U]+ts&sQFK="Ta!K"Bdr?Q'lO>N+-bX&Q$k]9_EuJ`n=7@$2#Gc"9re/:V01od=(fjL$Ajr!pXsD*lGs%nO8="YCK/)_!Q.3m3'\SV+3Hi0JH~>
endstream
endobj
172 0 obj
@@ -1016,10 +1016,10 @@
>>
endobj
173 0 obj
-<< /Length 668 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 678 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat=)966RV&AI`dFGpa/H9Z^s-I*cib]L_ode'3b_I:G"0#lB8h\Qh6%tc#G/h:X#mC2t,Qhr3+p.,3b&:l5>&D.1(T]3ih'3&d?`$(6E7!nFhmb-so!rN8M;h<p.,EM+6KHa5+&(oMo1g+G9i?:p#DR0KP#qs![_Q^9eCn*J3Cc4ss?30Y>d'!f*/CV+_3$0]QH2"fUI#Dd2.0YF3UgbHJMP4#'?gr)Z\bZ"gl0J2EEeA.-<0U)\`TRY)Pj7:7V+<#]B;.1aF/GU.eDILS[\pf]Gu]8ATpA6jU7?,Mh=t]-Vc'7/HM-Be6(q8IhY;`^XH-IAZIQJp$2WL>E;"4VLssQp>;rY^%G"5%L-qktA#qbJW(gre_i.!00A,]/V$ife.,u"^/j5U-HX(4*+\tupfrU-G8-QO(a4mhf6Z2I,Oo/#8\hA9qXo,0LOAP;m=FHS8@Foh+".eXQJjYC\g%IHdXQmfO46LeRm/+mF$b>XO>eccpFYSY((6B/8O,[[[]</N!A%U$IPN!0K+K!WAIAK<N8X"0ql?_#5.uLbo,Mp_pS>h/Ke^NhEFn7pE$&,/kH.TKNgh,/trfZ=i;]\V6%P%mS<7`[%;=MX+"o[>>@E=?R.;`$dR0@U",Iig2Ne0PXk]_kV&M?RZ):h<sZ3g=;*Z_qA~>
+Gat=)9okbt&A@ZcI,#]\rGC"f<gt-[FepRdQY$b7@^8O]8I87\Ip_f0!!sFq'c5WKA)>H$)]n%tb;Td4KLCAN%1q.q(a/Q\+:1G$6l[\m6$r[I+.i/A/AMXL^H3,7(qBVO\c=F`%tl-';VWJ)-4P)pkUJ^WR4V.<!$U<DfY`FTg$bM+RTX^s%s5S!K9l=D>a),Dk32kC*=]YZQTj[I6\RSd5BKfa=3.%)j8MjZ"Vr\#?.i,j?STrV)V(WL"Ca[0*U;Q"h;O2g[s6Y@&di`_F-\WF*:cY/pgp]l+,he@ek6;oNgX[Zh2_3Do_r*rj/:IOO:q\`TL3Jnlb_=,@bE9_eMX2bgYdcCJ,;s/(FIm>TBq$X#ko<./bH=i,2sc>8IcgjjQ?$%]kLGsZYD83+Qf]#nmkKeOWDUr\$JP8$q!G8"mG^<\:RVFr?hE#A*kWpl`D4,-um`PZ$P#Wj*krC-QLd':)/NE1=\:H;lVY'CK2;1]<>joE`/BDR(VZmZ^<%3h6?*Z\'DEojKMXQR\W'jW^\^t>_m[Url5m?_F--1Vf!V0)hqre(ga7G`pNp?PHO?:gjUM%V,.bE;)L)QNRmu(l?-.!FaZI21uaOL;YLl+EU]n)kr!IdSrA1WCZJNM!GV$ZG`6PCS`f3Iga+Ur"2^$(!EiJ`Tmb(50:]NF~>
endstream
endobj
174 0 obj
@@ -1031,10 +1031,10 @@
>>
endobj
175 0 obj
-<< /Length 1103 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1126 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gatm:h/Ac:&:`#5JbHD3!>jL<Qq<d3[T(FLF^9k_<QcH=`$@kV1*C<&hp2K?3ttR6-=2(Tn*YD_qmm,)QabUt"B\,1N(a)\QsJqh6/BL$*JVIqmhH*.`sN8GHGFMl,<+!^^'V&TS@[FD1/9+^Si/[/bGMbKT&oIr0sjG<gPVQ%j"/E0aZ"]Ht@C1e[rUreo?(Nu:1n?Ba4H._KaL`u8D?].)hdZV<cV>Ret&]&F6_S]dURtK928`ZPQA.o:$Wn]*8>Ge?9<lAR8T#$"a\#o2l(StM8P8tSR!66F:&6p`QjK%*kV.CgEmWlVB/CtQ=YWQLp'Zu>Tr^u;!"th&Hrq9u`8(o.#p%hOOZZt#e%VIKJ5#r$V+MS$;6m>mB1EbbR8LfY*5J#WXX<(9*Wt^At*9bAB92.6bEE]X_b8$f)Z:,`RicN]Q<7sD5cI=jeAKJ1k*frM=%.UmiV?7Q@RA_HUYq>$3!oEikn<a%RQF_^$r>>AhrKUhZ#TUmc;;\TeOiQ5NhPV")_unX\NF:VM\O(k7+(JO!a#u[lZ-XM;dj>gO&gf)SLkF@M!5bt[)8+DB2URDpUDqc^#QkU[TeP[.:j,3IRu.'d<D-LlFoJaMdp0E:OWG?K5b+UhKU#/IcG-=)ks^p+=^IP.B$0[$$QdG?`T<p,o_HCP/AAPU/F!IE)#4*XhHi*!AKoqVM(&Fo>Fg1'cm2g#pJL\;lEX2R%nF>C+?nNZ0@iteDbl#uZ.0uKVoJ]-XtrIn_uRDpjD[@:+liV23HA-@8hH2%aol\iboj$U!9W=mi>pnA+]&l<1J2ZH69DAKfch\okCb%^n$JQ.]nIX[MHEf>nZ(&Kb&p]iP+!X&>NOQ2*DjC_Us=a3Vhc.h_lPnu4>1BArLodC"GqVeLT2YV/Jg[OXW_B3J3Nt8#?+"X$D%#N%DS@`PK2$tpccA%K@u+<'l3&[M9E:rh?:1C[[&b^Jb,kj!"W\.p&3!K2L-4hKcj_n>eet5i[$Zl4b>(kMt6g_K#e.VAN'p_Z6?Z%+_%Y.KdoHk[J;pD)b^g'rmiT?]c,XQ3#Hg](2oWt,9$Lt?%q[(/iV1'YKIYs6*V&2@*>eWM),)AcQfrO~>
+Gatm:?#Q2d'Re<25^cf,J;\9[0PQa!2Usj2?'h9[eZoFHQkV!#b`K4-pTq\DPCt7n;l%LdptRNpH[RQB_8Qkl+9<mpU1E1ao)Z3<nUhTC^p3ga"+foDdF.l>ISZ;HB`531Y6*fgck-KcVu]./2uEXVJmjY+1!UE$E_a)2b=8'cE'?^HB^(s3i_UCH]gX_e/[:tV9)>V%#QdM!rC1:g[h'dsDJ7Z+54iX3j#/FP>Dig^blj:L#6F%`"2QE/FS:g;6bCDd+hgmo=Dh269<5]rb;@Q%E<_UiQ(L6U%3)l\Z_R&;Sd2oieF4'BYEpdj$^l9,5j1L8?Grois-/D!pO]Mc_a=^>54/R.:E'r56:UhNPFSt$hG8rV*uq3oeep[6Jr,:ifK2j,)cKY+(gftlWP5rq>cm,$qsX-cK,PWaV-1q&N9cI4`Sr`-VV/W&;/NZ<SEi%F,u<469F/t2Vo64]VAF!&'hN6nlVQM#$#`!crg2UGAnHQ@a)UD#oMp_uGR;'VpA(-l0i(lkDPmgWLEUVugAlNJjpIjq[[A_E_]Ca\11>pDf-[oH(/.d#naNdHRfnJRQfC$9>V1m95L9W#fPh*mo.!F&,?/O,?KI>s>dpGplLi3mKlS'p!GZ!fW8Y*%(Tc,rWV@cn.E?_B@D&tjgfC7c(F"tV^"&f4qKt1Ab29?b/8GL.&9r).Dke5?2Nb*X$X5Z.YKZD%K;Q(Ok<>7F4,</-^9m?^^^jWGs2>nVj6arB&pt+L\,TXehqfAI&ILi92O>C(AJ0#<:i*nm97oW\"bOZWnpRk#@aWRcd0cHd``f,%C!o(W@BAX[l4%Jq&4-b+GK*4rD5i?6qDD75U>QGRq,.rnP"(?5S+HRC%d:U\7'F)q=pqO`FL,_UC)td?pd,MKO;$o4kXpHZnGuVS)M)L[fBqbt8SZ1d@7n:PUG)>kkV9@b^>Id;j%2c0SF,Nd:!4>?]H0kg2`9#IkW'%RmJ2!I;$0:Oalqu6$\H;/4B&$0@le+jO^jn,/2!!i$+`OORkt8lfEm99:lHF[rN,@im_&/hmbC^n%10g9Y]"\)%K=r=FENP`@7r^0E\/`UR?\20$ne=2K>%`__/o#1-`.S4X8'J1_'2sMr!1R5^>J~>
endstream
endobj
176 0 obj
@@ -1046,10 +1046,10 @@
>>
endobj
177 0 obj
-<< /Length 246 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 236 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gas2C3t&nj&;9rX'jI+NleWl>>UsJr+c+a,7F6qqe7_h.J+(?IJe)C]@<^jDG3$S\P(4f'E.oFe$4.D9JlL!X8YK[6HWUbie\P_u.r`t!dLZhgdjFg\8Qd3NgP3_W[6J!?lB(HYL_V^LVNbMn-nj2b3Li0A?fV<&(c,[9>E#+4[ADW`7UcG]W@=e"6QtT$j>rmT1pTi-1[EoOpt?O(?J##O2`<Ols&(_rE(`$V(K/tYoDfa?:6>~>
+Gas3,\I-2=&-h'AT41DE1@FLkfsCc3/-KrSYm@q'J4>M*qY"e:[1ShhB9$nN0.&Ia`2F[N;FoFJ!Z?oH'hVkJdA7WV&_<`A@iN_&l;SRT0dMVo1J7pAX6Oj]gAZ4')t<H4=s+^/,PgIm[>iZbA50bH37S%bPGo@brdD8r`h3LaAJnD[TG1%]qi@YF7a>i*F@b2>]?l3d.@R,Yrao)]qQHnF`L0HJ%&C19klo286XK~>
endstream
endobj
178 0 obj
@@ -1061,10 +1061,10 @@
>>
endobj
179 0 obj
-<< /Length 888 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 901 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gatm:a_oie&A@rk";GP0(1Oh4%+#%cOreoT:rMRol9V[(7tiM)>2&'+6]&*?/RAp<!.imoH*`YmbLu&s`'XSkD]-lo\!\BMl48.G6bO=%#&qAkjjs<OFWYJNh#$Ij^M=PT&2^=LJdVu42Lr2mrAmUBD!q+d27lr(Do]=::,5i'Kuaba]MQ_i!=n0i009=u1'7Rt9bHT&'2K\W#bN57&.!qG^k\8XMOk>,3Asnp$VUop*dUKtJg284,(a)&g2e`X.om!YSMb"gtbV<d[RqMYb(">M):`MVLlXD3/&"@*0Q#MQrG]"d_j8o%FuinFc0'Q>4#^;n]Qo-%ROj45+&c19MDk``?8WW*cgrWHj`M.JA[j"]+JN5I\Ng6bR<h?uM_;/6<E+HVg"^fXu(go>Bp,eM4DWah;aYloa?4n*<'lP*8A-,9X$Km1kjG*b831f6%5`>JqXf2BIlO6CVudM:-0Uk8Z!)Zblu_%$MjJ+XKj(4G"4_tc-R1*EEIAq#n'`HJ@riI$SA]J6mt0YC#C!t=j(]@/0&o2Sa=^[nk*5Q4M1#P#VK3Mk--73#.iWDZa$X(.nS^J+7As4:5Th5Md03/bfC7]@-ra\Fg:2a08Agl=,L%I[fN+kJ`%@(n/^%2p:`<$0&A")\48ZEc)^)pn9pXX[>`NQo1/M_SYX6Z=0hJO`tDj.WNO%<%Fu-]%2mSX_??/a-IW/hSP$N!$iulRnlAXnr"m/rhfSPC:Z2JHQO0^(^.mm&2L@g':G>!+qe578$Je/t0hIZ^_Vm!:oPQ][*q-<9pH?,\5ea<iU#%;;0Y$OApAPCn16iUfrltPIOiBrgNSDGo'<\R-qK/)!Xtl]Qj-[G-`/0j:m]tF*k:tU?9$4J9ELd6`]bm=<KV9~>
+Gatm:>Aoub'RnB3YV^'02W8(S)lU,8WS0L/>,A4G?H+$70e!ceN6BfMq\^?W#uL1h7>cJ/Im2c#F0f/#r8I_;6L98?]X#A&Kn(b(#e1`*JGBn*N.UEtr4KTO%t"h8JaHNiU&`m+JcKonKUWG5@H]aC+a,uVl7C&`26\cONirMC>qOn'36?EE2aY3:o7A?:"+'Z=FZOQqo5Wsg\-RD(bNE(H'mU<E$m-DT&BGD]OG?b8L!Mp%+04q-)B2&^nAsr3L?oK^P7]F2%^q`Vm<`(,ZI33Pn8q_aP,FO2lFZ>t9sLl44KG91>o3>O&`Mbd2irNBC!Fhf\11QXN$2Via`Tcb(ct6(FQcmq>:GVmTKX4u)?4nho]J6h82E5Hi@JaXA$A]A)35*Th8>-d8L*/&&.'Qm;,8pVj^hC:a3)W(\`tCB5oZ!tpfbWob7cn_7D;ZDpDb67WKB^b[3A1'*eLn;.`%cL[(0M"bTBe\s+&RsF[Sq;]71s1U8P6Bkj(\Hf$dHM+=.qp=\33>fsQonoba`S$g2iGa/7Vl#3&^R@[O$<'NX"(4`0;A^Nj?4hJ"441b,pDK"gqXafF(DZ0.BPVKlbOD(8Y[e<='p9kALC<'U(B$]LMZmu7FHf9ijupDe6Oq+-;)=QFgNIZ]`S,/OoWJFKYA$SDN2s2(_o`Tu/mWO*KU<]ibpG.aD:>k%R9e^K8r,f)[!ZqHQXT/Gh,&8W*i8pEZ*]U_1,NXu!Y>oX4j0D7%f629<SCq0i\qWk()>h/t<pd1X`SZa!SO:TCTj(XW1EZ=2N6gHq^0$u13AUCq&4V="i1/%qQ+-NW6S,Hor+Y66FG[h))gXRD=@3k<Pc$T[_Y&1En3/CYn=#\n*MkYnePP7,ONYjQ]fJ#j"__KUirrXU>2_b~>
endstream
endobj
180 0 obj
@@ -1079,7 +1079,7 @@
<< /Length 301 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GarnQb>,r/&A7ljp/iTmqJC;U6k<N6P&H//PAEif8\h`kpj8/^Q(n]IbO!O@Nd!C4Xg\Y57dh(FQ>tP3!IT7rUt;QH"7%u(HNW4/?<0kP44X.G"0W7WMpuIJc@V<&Kb1T_8EndSpT.Y=%1%uAZFS0c3Ai@SBXPE,\<CMK=#!Q$W6\c;BL1gjQqLH"IPJCj%s?+Ggm29@Q;XGhZ!\uiqC22\kk\!;YS`CKo8cnZpg]eL)P"![#jglIlKM9G"WG`8bX[m'>5$/uiEBp8m/PR@U/P<US5H6@3B/IFjY'6RCRb~>
+GarnQb>,r/&A7ljp/iTmqJC;U6k<N6P&H//PAEif8\h`kpj8/^Q(n]IbO!O@Nd!C4Xg\Y57dh(FQ>tP3!IT7rUt;QH"7%u(HNW4/?<0kP44X.G"0W7WMpuIJc@V<&Kb1T_8EndSpT.Y=%1%uAZFS0c3Ai@SBXPE,\<CMK=#!Q$W6\c;BL1gjQqLH"IPJCj%s?+Ggm29@Q;XGhZ!\uiqC22\kk\!;YS`CKo8cnZpg]eL)P"![#jglIlKM8\$l[J?bX[m'>5$/uiEBp8m/PR@U/P<US?]$K3B68\jY'>(CT7~>
endstream
endobj
182 0 obj
@@ -1091,10 +1091,10 @@
>>
endobj
183 0 obj
-<< /Length 962 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 973 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gau0B997OU&AIm?6pcL-7#[bCZ\"IR@Zcto8n]G%P_7^Oh4QYTWJe4_HCVnm46[tY!qkPJk2C7@o?>u:UN`>$J-:BgP)`qS*2*A$*srR67`Z_TQq'HJ%_c43aL)okhh1!rZ!m`cNE+RS&fAQs0p&G90pc'tBi1mHR>8cJLRROK&7S])?A5(7:TX-<M.H&"=h`EAT.;9<;GYa^D(JJd%LVRIHaf!]n80ad&f;9WU*H$3!aN['S&]r[j`>2P+6H-o!Yu0-=aF4a":r-V9`&/gIT*'jJi2oH`C=K//ltfTc$l]L(SgW<jbFdf^!YpF\R8A:+\6*,.@7ZSb&pugc9]Z_`2gI%\q7,+[AsXa)Qn4C.#<QGiLZnkUOA']aeOpAee'[.@$##)Gg*Lj"&>(CAKH[eZ8D#>X4$%6pK@GMfT#h2%)\ttEF:iH49`K00khb-^`eBP^iBSJUlA_gdRDN?oomm2M8e$EpTaPbqm7/[UZP^JWQ!Vp>]s;&'0#Q'Jl:i=R3-,8rg0J:pC`RZb;hou`%gT?n06:XdfZ/[9:FS_T..*\%H]fqlj)g7+U=rYZ<$:Z.QrrsML>6G#hn=7l(DnO\j_8hMn&3=?Ap)O3t_B<V#=pdd([i6*f:P;N&Oi6W4):QWu4)\ZUi:@M<l)Ss)[BmE:<>6Vf:PBjiP+s=!Zc*'@]:]H^=!Bb%nd_L/qeQ#iNe,"4O<)9#Ib`GBIi2;aSdbH!6uIJ$'6:l.H%"BjNHMh/&pbj%A>;b6TF[YVu"8`PVIu,A3o:+_"c#F?&,`]f5;k\KH#S1*ZrX470A.lHZ]I1c8@f%[%<##cK>j6]nEBWeQK`bjD,ZW<9-V.%T`1,9md$.-TQB7a,sA7U??V=5NFcd2t/]HA2/KN#u%m',-/1\4]:URoQgu6)f.[k&"14BMPB2da=E/D:2KBAKaS:g6Du=C*OjOg)bgM$i(#=6'Jn~>
+Gau0BheUt#&:Vr4@2Nee/=IhWQ;t@[au\`oKi,1CAIjYCV]L\c.EZ?#f2&gi>B]!eK+5RdkPLtAmaI_EU=$SK^5!Q@Tbf""kcI=qKB>NB_Z4u`V]ZDH(N$hRj*S%n'CU\mI5Y-U6dR4uUS@k,KcgXU?p:SA`-Rup6Ha)+/"*QGBtj?k@m0@ZQkmj)3QA/Rc)gcE&W*SlVqFh'/=)8@:E7VkBqm\7AQVbNT(O+q+V6tepb*glH#;POWLY3)J,fb<aho:Nii0BFVd[Ft%)`,LGT]N-$%aO2Hq_+XoO1tb-%I;ufD/IFGp_+%BU:p+(CipUM9?F]NV->Q_+[Zt!TgC<SuL7h,;WVkOtja$,"4AUXo12`hA=`1LK`5^@LPfc]28B=84hDWH?;,V1NeF<4g]3&F,+YACnMA/O/^%PX\e/oBW2sQ429lqKAG05_$0<OC;@1`faH]FQrT4R?k=5sNu`7#d`SaDBd9RqqGHIb`8[fk/iHd[QZPQ3AXk*H>eY'u7B6qUiefmY5Y8XjfniaBYEV"g&s0bjF,DC(S@3K`&a9RVNl<_IFm36]ZY9dJCYKBL)++U)a(-DR$`P,/Xn-B%cNr7e,RJ]/\82[SN'gp[E@45IAuu@,("2NX*:2@,D27n`B@3qEa@Ee!<Ees?E)I9]:5atB,QE2a*!LNr.pN."4^FYj9/G[b#Va1I^pd*KZX#Z;pWTike)V/PnF6f=+"q1\h.a8MqkBVk@aV:?,mLul1(`R]pSXd3[ESB'[@C#"NAD"7ID[a@#O[(7=FY8-U<aM8J.d/hem?$Kbe5&k*&_^RDAi/0/nJgQh'Rt=`bplUQuW`NqbXfK1HA\oCoC'bI?)Oo33k\4(PgtZYXg#9S%-Pt71^Pt&kckFe=ds^D;'W)%mr;-'C[,,4i2%mqGf[>90H=g+?WQ)Tiii/-)7Z=S#EA)&E'22X'\DpGFL#u!+LN>YR1+14#W$+~>
endstream
endobj
184 0 obj
@@ -1106,10 +1106,10 @@
>>
endobj
185 0 obj
-<< /Length 591 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 605 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat$ua_nsL&A@6WI"Xjl4'lt2'b3B+Webu#H3iHU<$\?WW:9P(QBI5j<0<o"1<Z.GD`eQ#LEut'63Mn]6"&k`JF%mhp5h-=`1SJ;#SQVbGn(KF"n*RYZ;D$<<(=8?\FcH_PlXaZPT/j\`OjXMlVFoC;rDsQpRA[1rOoRua821%6t_k_Cd,^*i-3gm%JP4_$'!Zi-<m_E^Lb`Be:tBV&](KD:)b21Dkj%X!:)6C^Hi"=:e8>pZ+?_X4C=l]5'\nB0OJ"pl#9daH5R"RAN6&n"AhQ6P`h7SZYXhX<,)btKn-m&>Z_onD;4OumSEZ"rl.k_`tWPCqfm#BLWXMMX<,qYa/MpqaVrtLL`2FEHh:Su2O!78_\'OY5p9a47/EjBRk-aj=Jpd%6>[a[.rf^-hs.#L#H)(<WV,@:!<n^'_pPub.#Ahl^3t>2=8IrdW\'<$'\Pmp5r+8B+X4Z[N(ul?:H3tj@[0KA8ua,_S=QA%e8?]6B4[#F'@g,:c5TcB4P[E(Y@;Q&"u+iI-NtcYp/*@BkGu7XbF@.9AHh<Vg4!T?7*^]H&%[dk6?:PY^*ms7B*?XT],mqErW"f=B;b~>
+Gat$ua_oie&A@B[GYATZ\W]'$LiXuk!_%cKg)apqE`?/8/(820pE_9-g60O20'$^&/8sD75"e(&;Lg&=$=lSW^b3G'q%!R!+9EbK:^IW;$N.F0W[i,uIY$jl7ra'AGOV8,!%,N)'S2G,(/Zp.X:!^LE`]I2k-rIg/Q`T+*,g9=,5^,iG<PZOb#Gf0pNQA5#LL53i2ZNuRqlZF]ud/lr#aTZ.D9/"6V['uQ$fbcM4m7A='p(+fF)4Thj?IITYR:U4Ip8c?S7^fSjp[ULd3N4#NU".0UbG'BGTRbR`.$BkE)UI"l(uI;e9\[fp*2I*&CAu]cGqDlhr9VlMXmidPrD3#s,9O%IGi,"l/cL3nU`]Ah[+qLWV;D=r>S5Wl&8L^c>Z\N%#5k=)FK=k*S*h_3MH8>Ri)CS?Nbg;>dARWVfQ4@8!*]a6goF0'sG+X[5\((!V)29:U1:0"5GgNHJ+n.*#mG0SWiG4tO.VJp"(q1e2Q(1hNi45g)Jt.PSe7r)[&oTjljCY?u;`8$2N\e5)o&7Ga@mVqrteS<pJ*P!A=A*;sDM9YfX*q,:cgOaKgiZ`0^-OM9u2^C3(QQ[l0\9%#ob5F'K&9`~>
endstream
endobj
186 0 obj
@@ -1121,10 +1121,10 @@
>>
endobj
187 0 obj
-<< /Length 1255 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1273 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%#>BAg]'RnB3nFQb8)([>\f?V0*]9EP4G8]$5%tk2<Q4pN`'kFl2o';Da3KbCA.?bR?,FtmLF34B,p$If"J2rF;FhNZam0X&[qS<0+827G!!@UTnofi0BqBO\BS)CJXrKEC:!Z2fSWC31":`q"PbiCCX\Y*cnLA^R[>0<<W7*0E:3Xjj=++bIn8'2ip"DJc\'$5CaGeEaqh5<-lh4*(CK(j,i./V)dQXp7FY:-VpcXKW-q,hL:E1j@H3*jT@L*4YIUZ0`q/'4-Q<,nAcHse3gY21G<C_fJf)K9em@<;B8KSh[I9^Z6tFE?L+YA@Z!BrG)rN%pdes6b4]XW6/PK$%E,Db*V9k9/*U;0++nrLUGq_^*DjO[Wu]?I1g4A,K)jSp':;@$SVHUj6jBlO:E9llqu.XF5aOBgs-_O43Ad3Pq220Onr'/peBNfGPX"jJ$u7M2?RKHjSIBlc&VRf&9F4,AXu&?I^*Q:gm!H*6URD:[2MUI'm3PEJC"`':a`S^kjf/`?ApH2f^o2CPoOS=\h%Z(cdEDW>?5LTB7.EXNs>N)dkhY8<RLQi!7u$JfRO3]?j_kjWdOJpr#5((h/$F9D34:>GU@CgQlSGdo%dV>3\&,3?V73bi>)EZ:%,C.JfGESb2H\kKOT?j#rAPi#"\*L[RG)p?ql0<o:7O&2)rG(R[q91DcZ@eFGpNYp".<ON4XO`=NOAL1];]:6P1S,=g6bNhnQoK%;e0)/[P5i0a7rhX/G'Vf'PII<UK[s/p)"<cFU`0a&tB"A?#_WJc2^QTMCc:cYMj@6QYC"XdH`1gAi=>b%Si@;*kKHm/ASj)s(0EFkpW!Z=\P@8g$W<AtMu<:4uYLPCX*GB5p+TP<J5Z=&JRSlfQ*^Zl<VH,E:iZ6_uR=3I$V[AO^/[sI_-\'+Zkd3m]!/cGA)qN_CQ]]"+i\"+/.<ES\eR>R/LF)r6s*32HWg]58_5?R;Wr0Ib>n/5g$--SU#rXW$sm8GEYGi5Y\=Ko7=)1T$.i`8*VK.+cXnJg$Mp5'+oeq3@OBi86Qo\#Xp-(PnXYsSR-JpZ?[H'+Nh5Agp`2/6r4%F080T7\U[.^ph2HPNUFF@g_UC\>-l`Jt=a!fRN.8)D\'<!c5+O;<#9]@2MuCe&b52cd#G2uuSbs%h)t!B@u,JX09](",dXIq#_821IXc!WnbNVbT@U=9"Y;$g(e_$pbNEqE%S^Jd1o5Qdu%\IPHf_?G,I@0H=+FKbHNi;=%!U#=ZE8=9~>
+Gat%#h/D%+&:aF]+lm'QJ;Fq2I8Br&+R-1eU$^4Wm2kCQ0J[3TPspb.P,<_W.?Y;m>E2nj#]_:6mruh0IH5:Rq"]+R^^M=uXNEsGC_nd]e.2sC"JR$`'0stk=RC`jQ>c#Z>mLB6X$;hK'#7$Y:e$'<7(jcj#\4bjMl028_NG:-D4?VOr5T.i*J>j*%kcH>APW)+cpR+e\RSC-Fj1:D/)E6+0>6iB:[?4dGN>"rhDLd*gBYH<Sp+$#%0L,(ft#Hc#Y8JnImXU[7h[Pre,82BUbFYQn"1Oj5E@_uW>hSf6jURB]oZZL!K9ck^sU75lfB?+.b$:1M17^nosL!5YZ\6*Oj5/00fm&KQX?;k!kJmGPFZA>VC"kIOQ;h?jAp*/4_pj*8="fhJ['M_o8oaFOk(Og?]*`'<.Y[;;f&Vfd(a)Ve/SfSiPHtk.sME]O]VU8C!nsFe%WgXCl#':H!cMH_6%*uDM^bb+oPeL6J5&skXI16UbeZSJcog"3<>;G/:rb(r'?:NV/iD1\Y'sC.*'97_oa,+g!`?A@<eT*i+l`+^.8'U+kU*(R*;\Tn:TB7.ESfaGPMj063$t)EGn_[GQM!ABZg4cCBpV0Qf4KqR4L);'+Na5T9c=f(2[ZanBFAaX!:AU/Qp:OB#nhd5JXKZ-8']"lbSataHLLt)IE)*_H35qNHa&d1C]R#"Glg(Q6K_'#:EgM_4/j=!DO^.L^VQqS2Vm;N)#`dt8Y.TChUr=]/%\2E9Q+GWTX=UEH@SQA$SFTFs]02]mC3TTtLI46)[ros(K'Orr+Y[=LR#)jH`5TIZMOi@)R%2Z558fueJs01h2c;<X(2"6#?uDLkJ#<*1m<.*M0kI"e!mn/4X;-X-;r&_O1:cGIm$f;Ag@_`n4k$q67);EZBOid.qFc$fef.fhNNFniHSp9d,Tqq6=IjcWS,"pQ`+1s@Q%*$lDl=5s)i?R[dje;)$&b?=92UkTY>6C#iuWtj3[kqd<2K'R$PWHr.uM\HR/]J4n%FGo;^cp9i)O9S?r-GRr^]6U.ok(+O<PN-e+=?eH"96rV;V5*9r]S.*dcsYmS6)6m[1eCi#]H[0/E.uj0h4R>)eKA*ioVA4AetW]!C.gWXYHa#5;].T!c8aC(\Z)D='gdQ8e/NID?i&q!?j]X8T9e@e0$:/2;VN<"Y@CQerV][@%GG=YN!4BK^A6^65%io?3gp<>q6d;[E,u`W,(M"+;ff2`!7RJk5hd=AUX,/acZ[#LaOJflM'%_L?o)6#6YDO`U=5'[6b7~>
endstream
endobj
188 0 obj
@@ -1136,10 +1136,10 @@
>>
endobj
189 0 obj
-<< /Length 823 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 840 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%!>AqtE'RoMSn/L+LN:1qO5jH:45\Lc]ie?oa[8%[j-7*Z/Q!]T9\?hB21ak$&n[X&1nf?U5Mmo<,^^;9IA.&Mu$Oi-q0YdfoTgTk5.6t0D5HaG&]tO\861W]4EI^o)27*pP^mO`uFoFm$AJSigV=RCnRH)+EL^7o6YG0+1^M2.r7I:7j)e^#3r_Zbr^WcV$SXS(.4W]Rm]JR$&LR7u[fJmu(qo<&iAHFCu2KXe:OqmaYZE@@F=FEc[7(k"';T6>1qdX'_k812o]Z-rdn6"AHYShF83cdTL(q[k$(a)c^9LV.aeSX>\=0(T&^lPVACo86a_U4VW9>G>6hUf+C%+QpIFq'V^Fe'5&Z8IroclGkFA+ngrB-oWi"s#BOrW.m*&DS@S,m5M;Q)UXsHSd?nI+F4l3DW9[HK+&#uV(R`3X0Ikk"H%Jl2+@QQu'1i8A$W-t.8!`)j&LNU08/$e!E<]%Qs,dh!nhB]m80R,e9VKPX5/^Q`!>X_;:L:,Gc$GV(>)Z:,am6i@;Oasa2gUY4N5iTkjccjU3h=l4'LP3,Dg;/LmLQp;j<nWr=]*#/`,<+LS.YRnH3/4fpT>r[/(a*cD:lc!A."QBW4;Hpre%]"e*;n031^T<c2JPgKK9+\PJ&HHDVr)2L'ib$'GuL8<0bB'$H1b8be%HlMrck?/;!^BO,,'C\_c,,Kq?ai_MDKYDC[BP5^Kfh>!cJOgchfsrEj6>C^<d3ZaA0:[RbV[kkDWm)ou>jc6!E$-!07XDNi'.rlsohHA3RJX?.YRW\hd4?PbZC=A`0U:$VO%#.N?T6KZi?iBH=0,"qb\~>
+Gat%!bDt%*']&L6Z=@JYj*)+]O?0*e&<$aOfME?TenKc*#DlARq0JQ4mA/uW:cJ*mI@PY3cg=*0Gl*=Wa91(=_Irt@r;nuUs,c8L!$*+7i,e%6M=^?,;'b_hq;m:%FVJm.e.+O<%m[W_E$#1CTJiO's%55.gaF[`]MDgUc?0=-ZeG"gK<]',hkd?1Znqu0Y^FnLH'3llB9>4CKG*G@FB6i4;O)98Il(dgVSd&CJ,1b+b/0m(K1k[iXkl2DI+\,k<G[T[&n6tc,a_ED&T:%fk>[<$92';1`c'!b$kUH4;;>_Jn1"TmI%2B!`8!]%(]u>Yg5omNY7d8'L1nm8!CKgBRdLCS+6$DQDfH^jb8\>9:emn79T0k($<b+4P/ED4F1I:*=;J^)_F&.a9.gQ7k/s8Qqm/ELSqN7g0M<8U)*lDa+b#[;[YSu>BBcLN.+dFF[Xgm`"B%K-KXdA'A[oh!Z8E9"m[[$&9.q%'eB):[1q\li(rG[g]mOY?Xb:Lha1RBd)Zr^=;4]c'*in+qJ!#afIYl6qBIQq^Lj_Kj,K:TVN+XM@*2Ii($Y'6#'XV;LB9D7FCYU;ugCtkr!k@-eRk"MH\Dsf]\9CqVC:i93olG!<-Q=1So2+*$I/h#NUM4q4!2H`Pn0U0-#f6drHd\OlU=h?3^h>X:56V8.=\]9t+Qu5"Ngk5N$Y:&A\p?B;+<9T69Y7G'R&+j&/MX/lP&>IsRlYT"c"\EGeYVppGlLcFpPU0^B4rfb*?gGqdd($"V5*GLXePlJJG[q0<oN%6qZl$RH1a5M'3q0'4r)M&(>fl<iRh$!672ZT574D,1'b1%S01c$+6S.Fg]~>
endstream
endobj
190 0 obj
@@ -1151,10 +1151,10 @@
>>
endobj
191 0 obj
-<< /Length 605 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 618 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%!]5H@W']&EsgmSYcjngbXJ:k@!LB;=G/3sN[VGn9bjiB3=r-^#PNF''S^^Em-giLbh:j6pOoc$7d"%I8K@?a1`@K.R.;!^+U(-n-QnJ48nrCFBj)Z<.qGE3Ami!._%856qI#-]Uu=4qVVCc8-Gn#t,jMYbWK(a)aV?.g$2DFc=-Cd[XUcn,4-AYb<Q4sha!ANk;<E-%/Hr]aV0[O!MrKmIs?0;o(IVij"0D?6Q#4^`ht6l*he"b8*HtCTOW47GB<*!,&ohqZRuF5TJ^LO/BdCa[B;RQ>q%H79BDqZ9n21XGraMK6QnGJ+LN703mgBR%KXaMR6/YkS8<tf-uGQd:>7o2[He1^V/jIWk$e,3amFYF*SO\6f%"!YSWDu5S%J#\b6O)8p7j'e$gPe:"!LVgjkfFWA\P59_T`QCVZrLs;tA&(9Y0O=qj1%GPWrag:e&;Yjr<(DaAn]*3_reX$)7W2pA\POS@s`JF"g^L1*;qN?m;3"kGde:jE&Pp?k=g#6*%K&4k;H8l'"?meKLn&k5A4-JS(a);KZ&5=.k!RLC!&t#<H_Xno$)k3ZNIF?@naN:6^eWa%?Reqa2?P"hPKK3^+/U'/Sc~>
+Gat$ub>-hH']%q&]IPPCp%:+DJ2E'j;5oga+u[e:QuUPR9JZ9O,l%6t%jhdS9L.:`NfVMsk<?'/i9MsBW.BXJ:'4+o!"!ci'$Yq>'hJ[r,k6UOSGbu:k+)>rnMc5d"KB#k5]6X5ommGfBT=ZR>NS@clp\3d>I3(TP7&`'94s<El$iBM<-qho^T0Srhi,?^lM^(9*>ohBl7%Q.+f([In&`_<#DhQ^cj)0gTkY`pY=4_h*&,d-->[?D"&s*RM%5JdKP"DId$6a[a6AEJo#gd&kg7)4(o<H>,MbPfYh=J8MQ3peCPX5CpJeC=m-g/$]f?s(laUI6K];$"N`8lV`<Rq`3VFr!4B`,,Bhb06?HkV226.'J+I-E^r8,"V\NX]cdFN%g?`u=kpS'H%0=$F\mpc4#)mo[ik"mH,.)T*,NS1FM^9-t3Qu-%N&1A2Dn<<g<q!1kpJ$a2CUI,M0UTP!r[2B\=1/2&3:F<+KPt)O!pbpUD_TW[7`LGm7]a]r=2T!r/4KY9,6@F_,)2+_'<6LVnBl]V(&#esfC7j#=o9$@5!_r>i_D2W#[DTbiVs?o>7'h&C&SjoUr!]agpD7,CnY>jTd=cXh-kICLB0G@+m:Uf5~>
endstream
endobj
192 0 obj
@@ -1166,10 +1166,10 @@
>>
endobj
193 0 obj
-<< /Length 1028 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1067 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat=*>Aoub'RnB3i%]YqoaNU=2CWLBeu@rG'Q'k94j_+YVA(d.9CqUb^gKONV3>86NmHP=3VJ_&]"B<n@K7<q3.aUV63\,3)$iUGFJ&fA@iPEJnT4U>]^cHjQf3E+>*a_IXjtt+)$V^r'c&plTt*qYUu9p[@:H:%(n7DVhsaGJ-$,Y.?D+`)(J)"u=#N,#8d7iq+m9Ja+A@B;_q\GkBpTOM>H?lRVoD>`jYB[AHH[OaHb.k,IGK$C<l9YlMT'JXO16Oej`K!:IT"mLK@P^KOfq1k@#WS>-<[^$j[i>"gi7l15hcln:DR6UpX4;8/3.Da;.)2W-$L1Op7B-3n%'7/8-`Q8VAYGi6o!,VhgAa\e"K[+.*nI4+,[J$0f]k6D68dGe4u=B+0)&BGaq2#&hNYf%&9FU=N)Rp?m8'4[#KLi@rqG%aL4`mnH6(D2cVSQE!@"*_8*(a)H3q+)[ca.k%`+a74Zr"gDZ":gKH*PJSr6/,^*,V&4I!KP^r(g5/&Ih?/*Lld=]WP=>k6t%K>"dY:KB.9JNE<bhSNRWZG[Kd,@'rVi6,?8%5-rL4ML5sRZ\rks0dDQ.r*]r"eb[I7&aJNUo3*2WUSqHH)Sned7$G6#lYN,g&aBbP'!4Pa15N;hmttSi*-S_KCGlYYI^i^\dG]COpOek;BQHE7fL>9<9OMUlR;9pb1G(FK*.g/i#h\]JWdC+hVoKDZrVYk..Zaa;ET16X7u9c\Tbnu#79n_cOsNdp6UBCURYb!cPGV80K1&S#eVZk"H@6;<mk.T:?+NnO2UK@CqG?VC6*?a]_\XH<eC6i/!YK)J,crplO>K84a7V]8aA&g95OSHqk4RfW2]ofk4o!m@@lNC1>MHYiC?1@5oknP>F"hRo\o$B^oWjdT9W+*;F/B8L>qmOmhatK=h07N[6\47GBL2cN`23tD'7Q6c,he#15D@5nn,3W#FsgS-#XH9#4a[1l:]8V@s-FFVbGWn)KL*V;E:e!hjnAqt-]/>T[JqM.b)Z],<5'p9;(hkL344Sm~>
+Gat%"gMWKG&:O:SnE<!=(a)5$Cc[1Z&eROV$1)mtRg4qPA7.L[r2lhKq\>^+$:Nb-=AQ9B;$L,6/_j%Z]FYl[XM/B%uERM&>fU@B=)9E[2kY]X=k]&KiW?dgBP9s9f=MYDh"F9QE,!sc46Lron=6GUOD7P&7K6ZnU3.AQ^(U*@;+10l#5$L<_,Hs7N96EL"BYsF#&ff[8j6==L:o2e/tZOS1UfM<"k?pLKAbkERXh`?^E87PXV)?S8NUBrhTW#]9.6&+#$.na>b<L.I9TdQcn["e(2T*5"_T5<cFCis"g\o$#;-]b]OR^/sWV?q&Z&mk<Sfs?0mNf-hme[=!@!lVlP@`N%h)uuL]Y:UMl2QDWgb@qrm@Ng*s6N[PL&ZQ$=F0Fq#A!IYOM&9uG>stCYAjqKK$N$+.Bf%BW;D(8)<^.87p"77683hkE/sS?fAB+?)V31.G>i/'F*djr%T`A_:8-fDr\*C3dBG'=qL;d;AG-mA%+-@I$UMQEt`B+`q<O>uL_<TOK\ND0So:ZEV3\pHS?Z-RVCITXBPn3"&W#`%!BgS6OkQV!+mZ"m=-V5*KN2hm,e1SpVb6O&0>a<'t?>pW*iHim4^4NXeG!?ttc&7#b22/9.G)QiF5URT*-I3kqgdk&6@U9G[l8Dr_`L&_nCC>:Q_OM[N=6Xh>?M4'O]Bo7gaQ"%NB,+:hHdj#d:DoAGE(o)D5QG"Zh7]17\B\=Sjk1B7h[FD-&f8u;Pk&@O@Y*\pN8$j:B.;9WO^C#=j<EWT,[o?J:PImU$'"NBp(<+gLJU,%Z`Pp)^)Ub8K?\Jq(Xa7P[/>_1W%3Z8"N6`0@,nCIr3VHpHX4tWf%_%Hp%-#sXPQ!Z:OW69nDq-dT&5>6I-kCOP0?"3k2+]\FZa\XMoa`-FU`;%1[!lt/:f^o`h;H41QRm0G9FM+a<c4?:!g+h=.-/j;u-u5/jO51[gT+nU&E`]li'""^Si8a?,CCK/gIlsSH5i&"$c$)cXXD#F]u=s]uf1.\m!LMjjg4l+I#c%3E<r<pW8CRgrS4_O7!r[$1ieA+9)Nf9d)5,o`"rEEh$8~>
endstream
endobj
194 0 obj
@@ -1181,10 +1181,10 @@
>>
endobj
195 0 obj
-<< /Length 235 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 173 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gas3-bmK%f&-1Yc5/eN7i&'c&NdDN-cln5=(*04%&5(1UHMl?Y,)DW00L+GgDT-(a+=:WaJuo0l8OssG&u7/o0I\8Y^g:Cb'T[n4L:V6EEsPXeN.rcm#e'DF0?;'aKK[tQB+pBe^.5rSPV^OjT"oL'31O%W/$@>'dpXg_!WC0_B>&piCd`0u?H`V5T?C(%`#W.PWi0_!AoR]e2V"c*Wf!V@,ms=(`n<k.!i3IsC]~>
+Gas3+0ae%;$jGQP^ETE_`hZ>4hKkiIK-4\<2d::k:5f,oX!d'SP3%i#pc=&h-D3%I=pDu&#]`'oENa"c7hX4PGaRlQ51(@2BNnRXgrK4M;l,$@c<O:>QsgMr9q7+n[<8sI\5Ok+05e\(J#)Y)D3Xs*e[*aX1o)5ClW8B6C;hi4~>
endstream
endobj
196 0 obj
@@ -1196,10 +1196,10 @@
>>
endobj
197 0 obj
-<< /Length 1072 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1092 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%">Aoub'RnB35i#'_%1ceG1MN%V/X<c"8Q2t//:2>m8XU4/J8FVfT5S,1,c!c/I%58*0)j.?I(N^t]>G\c+Rmt8,4Ka`kQUO0*^kS7N.V\73:bW*n)s6l47I%SQacr<X[3O&`bK0!;$7MB%(N6s(&-0I<p>)bD0U3jq']429AasZPub$C7e=\>-S`*cnqq)N:S`Bm7?bB?#%KWMk.M,\9`-le+<4LJ74ncVkOi@V?#IG!5:T5-k=T39_O`T?EAUNnR8-EhF3+<dB\:e%j<7MB@7');O\6\3i+4nk)P9khr8q^7Y37#HgO/cElP'M.SM%u@,SX(4NVuSZ4!(nFFQMO",]OC7ZMJ#lh"\_Z7tmSa$/*3>!>2/l#u+egMT.QT]QrjR@L<?XX-hI;\D$WKlB8&jp7.&sV'i1[Q;?P#,hRfdC@3;b-d(`:$u4,E#mk0aKX!Q/'<fk70:TTcZ[>#7!cV\tn%'JP.%@@+E[rm'f&g`4r^OeGTmFH/H$FLJ`sTD2V\+eq&<h&MeiY`R!2H6I#2j2SWnMFYjs]MB-WBMIr"4cHJqq@3Mg>P8(%2HH\^0S^)AeS"]CT?Oqj>Nd`mA&O'0DHU?E[)mO0Kl3`6]!Tc#V,L7g0k-AT_?T$h9QbNSbG!<`E<>b-.;W1k\l?@TT%7oo7G<MQ/?WJ;0W,Z7:$:X@O$i@73ADFGcun<#:tBQLBQZrLk=I7aP+F`ZY`k`1=fIik3I>V'(!IFGcrirGgV*ei0'-]AO`-'Pd90.?\WFO@*)PApS?lVi_%L4lpH&pa$J<&-;q#!5$X=pkZde5L4S/1^45Jf=?WE%"\VkkY8U"0")jJ^X&Ao;a8LhYOG!pg6,md`R`r]b790]nlQ[E8TJ&q+]ke@jr#uAg$Y>TAqb`''l=N0`+4UQP%Y]PpUe&`k9pa3hFlk%%=]kXID>0iWh27O3j>t@qVngp'U.boFpYZ9Y:;^0g75J_`@)f*8XMjJ?')KX-=1)SR!p4(N+"ep>NDm:Ma-@cCL4ZB7#>4TE`I*4>C9Z1Y/cD3!I.MG.s[doTQ4o_4#Tsq>lFuErNOc~>
+Gat%">AqtE'RoMSLu>+nLl$&\+G$nV:'-8DBS@8FK9nW):n%S8L%X?`>N-o$)l@;6O6>PEqp'D5ZX1;X`?'s<MS4/@#e\spH@c!e(Ej?7@7!7";K%!QIOss?JR<[e^%H$;76ML/"&c*uJ4OO10`hrA7Y;NM;/eaJA4$=#[,L#eo+=tmQQ(T%-a!%"g2/[-XDnkob:OMmPCH$D\",n.1P[Y2!0a*Hn!"b-K"te#ifQu9k/G.)]Uj5GM\'t7U2sIp+G^,HrtguYZ;^"Q@os'U9aF+]EdoPWp2hI$(i(o.!\d"YMd`f>_=Lns1qo`4pr1_E;U-^/lb*6?;\TFAMIn*0PQI:A7f-BUNX&lI3os3A&djK>HEeL3hqA"-TQ<:6PBVlq+<d<bAcg?m$mV<ChE:M*0NES2<DK/cE8(!2eJ1mOm$&<us1LEE\%IFJ.)Z*HG>5f"'M"#.]"SI$F7gY!!Kb=``fIc-7:%is=j1me+V4d4fZ\L*NTE(cg=o6$E,/C>]"cXs]MQl0mQ@#pg<kIHi-B.5#Xj=Uh3o\o.%rcQdHEZ17cbPKboDX&hoQH-)1+b\No6V:-(nR2R,C-D/baNr9qm6t^tnaJg<36O?t)e(`"(>3f4Pc0UTNK/!2pnWS)p5#NWM-0bNcg3QGjpu)S[a"X;"p:afcXlR_^%k`EmDae2IjI.jqTT1^Q3aPpgiqI#oa__B],GF9g-OVp7)X/Dp!4rC>anNLqZGN'Wm*0^]?]K(CV7Q@@Vkdik0=b24&`kD]7`ZXL1?7'Z)d9?6f&Q4LKHQ"?iIB"Al%U*d,c5^-eUkL"o9QJpRQGHL9%+`XPHT!Jf)d@uu[KeWdfTGFpaf6kR2"4R!iF(B$85'/2?LI&t2'ed!"Sf#HIHHTeu(/C#+_?md<(cB*rU!.];9JA!pePp4Q#U]h]HnCG!kf1*dgJ=/\$VRdh6Zf!=T.3k+2go'+A&_+Go+H'&aU*j=F9]>WgmSVE7pR'TFs\*gK0P318.t*]m>?b0<`)W,#A5Be*OdV:<pR_Co?u0t,PBd[LgE`IH%LCrip5T94[(9l+J(^IV-Hc%3I`?)>HhT%9`>,IK;r5~>
endstream
endobj
198 0 obj
@@ -1211,10 +1211,10 @@
>>
endobj
199 0 obj
-<< /Length 1013 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1023 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat=*?#Q2d'Re<25^c8$iSdT%UePU3<8&B?9hkAfm_L1rAP.IRfp[CT)`nlBKks)<Crb0%guEb-p$I(qp'uF'!eIgU(4ir#5VGqUoH4Lj@Mhpl6KYEEhY6+JZ'X)!%r_DL=]#\6`i<sn+p9k\"u<4hV=`e\;>P!-bH3>!4WdP7Ds@.:]P9?*DP;Lp[@7I]grNA?lBfJ1dph9K=>3&AiZ=J2)TDo-9F5*TP9SVW4.+J,7$2WC9lRlh5@B/\BgsX!m&B@qAg<gT#f;Ce,OUUq/RBc5LQPo94An+.k2!o4S;Q7kK`()4N9_q4#o_O1s.C3<_24in!i7.D;1sr)9t<FRAQCa[LEYSa^d?<CVSDUpljc(#?B<,J%b1_Qd:bWeg!&*qAsLrnh/);NV.NcH]j/\"GFm>N<QI-oNbPr8o]/!haRN4S*':Y>jh=?&U5a%s:Y2Qb+VY#N6Z_6W=iFrUe7kN!l2X*i?tRl:Y.d!M:)DsQ[7E*aE@Xi*0f^*A2^&V5@,Ap_Y71n.".T<*LFKYdk5\q(8UD'H@b8`gO]",=P_'HMOa^R'AF8[M;12$dS]?$L>F)[(kC/S\1>QPk<L8G(]BMpm4^RGmQt0=N3$o>-ZuoH7q%aH!2E?OI"e<%@a1FWqX1:j[Z"j=&Jo@f+%$tshR*to`>uF;J7bD<QHg5j+L/5lqe*Dl.B,B?sZ32>E<ijc0m&SYd8JI>&[XJcVWpjibbqjW:qB4>]#df$>VK!jd@]>8u`\Z*_Nl\uGL.o9(3'Lnk//sic]>"%:Zp"coa*dfH?r_6p8U(T1D+ot!oicq'nka!33mEmC]1K$G7X#>NPj5Vn3es:(Bb\X?@-878+c$Ei_g&]'q_Y,^3!:B8q_n#Ad.dL9MmZCh455\'be)?!RoCk[)[b="gfTkRdpZ!+-a/Vo5P_'GY%tQOfpCKsOCe7_4)CeQ%5`"2?MlR^9Co//&5]4#H5rk\.D99^F`G#7DIcA>8,'Q\$Ii?""(GIK%\1_Wh`-L-~>
+Gat=*gQ%aW&:Ml+=Sn>JMX*?#WKhYWXOKjJWS4^49cmJHZ;_-,6e^A2YAGlr6:+nM8;uU!S2iAh_sMd?qMkXD6P=olZ9Vg,^]<U(".qg]7*&dZ3*79<\)i$[OOrDP=F\h,*+5R$BW'D^'=/e_!e#rA&"/\Q-,'(&;I5elE[TBpn-CrlQQ&8=B<COOdOeEo;<=n#]l'[0M>h(kgidYR'0)4qaS[3Q2[7BX'I`]a3:\M=K=lt$m=C5%hKk_8m*>@O;<24(T]Z#F;69?6V,rR`*@QOAMq[:O-**d'$`W1%L-YrO5qZ-23<5gQ,1+F<q;Vu'=-j2*AF/p]SYeoMQCcbd3TlLi!a+V)[6#F?<a!"^>o8Ti@=1/@^IJ*qBq+_)e>..P+;8iPQ\f#a@dLEnX/CCcoK(F))T@=Uaes?S>_98CELOP9g$WcSNq9AhHYeoj_@E`FgS:8nj)f@A:X<$n#mN*plLWlU10/*dV0Ou"!K:HC#]"[S\_'&UD-<B77;4*XDWUD"8dEB&?-i]YBfO$iY6b77,G5"fKX4on$@NmPPW_Nl@c-M:M(<J#VHQP^/'j^H?<6L.D=j$VI65`\?W'm1Q$Z**A(a)fssZ;NQ*c).Q*C3+6`EJ%*jOp^#QW!c\*I##`]D8/r.+_TWNkqUQDZA%ojVp-<3n?tkd\E\%E2BqA%,tc<4_lfoK;l:;1q4q2^#sT0.:s;t%kY[0Uh0V]%EhH=2,ge$_fpb?N6,TACq>3:<o:86*"X7WWac29)LD";Rc!4L_$Kh@]>T>Li(hl&iQ<"s!r?1`"=reio5+ameWFOGW9d-i[h3o#_&;0)L0ZqjJ>)Sr6RbM:@79%H/]3`g@`qXC^VZ@r9Y;t11B4;/,bMD!09@?(Rkj*4Gn<)%N.J9`*<\"]?Ff5PZ1LHYLlAi7\FpY[&WK\DQD9g6@1@dqRZF@)(%cgH!qs'I.dpHB:1N"I[X7bIbrAA;!qduu5B&A`";\C(a)6c\pQNGb^iiFE4#N0YqAL$.q-d'e\PhPmrCf~>
endstream
endobj
200 0 obj
@@ -1226,10 +1226,10 @@
>>
endobj
201 0 obj
-<< /Length 687 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 698 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%!9lHLd&A@Zcp6Zheme=bqQ'0]]<)KG@UmJ(dJsVkU`\(XVrqB\,#qSnl`FW0Fc("HNG.<N`GFo`s)DI&s!2J_-+RC/$#fU[Y@0'>!'^a9AX8@-SYL*jpI;pZd#]<I&6>?j^2Lo*2bD,h4]+#;J/?`l0NC#,[>utIe`?,I,=13I:haktIKJEY"GV&TMGBYiS;(9<ULpe48;$-i^bR%s.(il)\P7n-S!_Sq/_8@_*ig1NG7+Vg`BP0,.+shK8:?s(;3Z[Pq,9nGOq[^u"M9k<+W_5_eY!HjS^i,+nj3Hde=Wa>8?kepL*FlhW(V[lCUFkZY[)iUZWV(q5M5Cr6Lq)\1W<'cJmF,D>o[>-eDs+ims(nuOe,-N:jVTjq@8gBpYcN^$f%&Dsq-TjY5dZq@;kb[Ji?K,@"`Xto#*=tW^16"c9Qd'`@$mR*iUEdX,7%Q$I9\I-]4q><Cmc!jU!!*)ic*o,!0cg3DT5Fsg"[`G*G9hQ-&8lfX6W,b*KIb94P1oP1V<AZ^Vh+($rBFIq3.q_IgK1jl5IEB[#-:5R(Z8oI=<%mk?qO>2YZ^bA-YK[l*O,iV^MMb9FV3"g8V]18aNu2iiQ#UOB'?2riiJr8dS2_E>>N&ptbisRm//Gi3(HfFsWfuU,;W`gd]2(a)Ooq3/pGSBnWCIg.hKCe%*T^W99XfW~>
+Gat%!bAs(+']&?q=saX7l7K8SB9LhOFOJBT6G$sD+BZRh2Gh3<q!T^S2TXP/N]3,KO,hMr&+0Pgbt!ME!if*/HPjG@"C_0P85[/nq?"#<.+k9_2ilqKgnLDhpgd5'&SqP#kPua45*24b@\cG/_r#'gmP^P'SgA)^MHdH\U(4g26)j-nmgBe0VVd/!*e2*q\Rc=)dGri6LP_p+klX)"F>&4j9O1Pl#\`"e5)3!t*?bON>h^)#8Rr3Sg8@sG3['=CL'CR!P$TuJK+g@JVtDLQg?3("Oc^78m5sXJ`/XY><Qn&L6@eQ*$be,tG$C/2AXu,`^__[Y,c3))s"3$m9KArF2-`rb>d?.Xc4li-Vhht!N*>^ZQc4UMo.LbWK?1-$s'7#"HLTO4E6"o;$PT#(KI^#1d_Becn3p2A5d6j&-`L#g>f9</&7:&LJW.MV*HMj5XpTjn5'&BI8KQDu"G,7Kj,sKV\de[Ib,(a)l%.`p,ldDS$G9R."^-VesCa<=S'BC5qErb>;GF!-\GLAeF%9pESQ=h3s-@1?Y<Lu6IJA7_;1>K3qMq/Y%6k$nu!0_D^D$=Y>bF56Cp6Y"p.J)8N#EX[WEs.UeR2"*p*nhi0s+bUeiqC/Ce@=:>CS8',[<oYPY"7K%_F_p&:4o>k0f%)?N(_h=(]_gVDd$?.C)g@gj[e=R=9Agg@;a'5,+kj5`~>
endstream
endobj
202 0 obj
@@ -1241,10 +1241,10 @@
>>
endobj
203 0 obj
-<< /Length 652 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 667 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%!9lHLd&A@Zcp6ZiPme=bqOV62-<)KG@[$ReJ[Cq[(0MoPbo'a1-'"m.18%u'[IIh(-]Rd[?qXg$SX<7R9)Bk22(a/jr!#+FG&ogI<!6G`K\p?%lHOYFVjI8YZJ5M(a)7&OI).8Im6CGog%`.p?/teMW-hn#fp7nT[fFdl-5n1EHeZ(eDjHNF'rpM',XcJH+TKrV](!6to1Y`'9IS/K?I.`WUb"Z%7K.IoB6b65>BO<4YRa^(d\p?>'MC0#4mcg9X4;N94Ef)7XDtL!siFpjD+%([.O'CZ:BPJgNKV:at+r\?3+9c5-@pV1`"r+oQeHD&E'$.GcU51aL*M$DlkoSM6c`;o!8.,3uOD%$^'BG14`aGM33odkU0X1bfT$*SgR'a$f7!bcNm78op34$\W&\6I'.<o#3MVg/Y7*MmLUILk\lj=jL)b[r,^0UZ,IlGHT$,J4hQM6?ff=:F9?&pH9jW0.a3nb]ZlPTUJ,toitCVC;8I:&,YLt2Dj5>:&W/&Z[,Nk+el0D^TtA.gKQrg4q-DcA1+6]^RV4idc6BC'9+-$_cpaG]Wh^nQolXDFR@q,&'joFKHH[mo.!d4oXFj*oUcGE+nqbscFsEX>ED>3UUt&_;(tO:hA`AQ]A9<F%JH]1V#1ag/:kq~>
+Gat%!bAQ&g&A7<ZGYAV$nkJAq!X\-5MDRR1[?n<,g85i*ZD:*5Oo0X,LTQn[V9hY9E&bJI)<j?UhL/jh.%gTu@Lo6)7hBhS6&G_51)(9jJYG=(EV$.'jqdn^d:\4ILg[^.JW9^sl[fNn-q7B.H:SZ5cYQdQ_U!._:IVt[jsR"*?U^inb'p>ef+-LNiiG+^&C*>0;?@?K/NeK/Gdu0Y%4R)>jKD;g##6:`Bi7AB^`DQqhA"WL16?T/-fZ>+C`uTXBr,1>N'i2O##cY-SencO&j.70c+nUI<P4Dh!Ui64jX"f/\#!Gq09.H6E.Y+`J@f97fUK7]?)8YXKY%Ue\"iWj>4;%90Wj8b;W*__LH4D6[[//qDWE!OGA1F*f"]J,RecC8JOpfJoV\9knYtT^EV$O$%pEUK@e>1":@o#37HBU6&OB([d?L-;k*=3>`Un.F!)l(N3%rM,DKIaLX`CDIl)l\lph^nUK<.9&EH!SC91`N3gttFTRBp?VJP;e`;*Vo_Og*#sh3sJ`<cRJD]3H&6Kc!3sr:jjf)i0nm9t?D$TeU&\Y@!W13<m@^J'elV(%4=TX-\f[gnKuEoolKf\um\^:4j)l<q@)-OnYdP9/QNF*HoAjGGc0*%#Va%hL.6:kkrZMmcuNqeBsGp4'!-hPlC^ukC-q~>
endstream
endobj
204 0 obj
@@ -1256,10 +1256,10 @@
>>
endobj
205 0 obj
-<< /Length 422 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 432 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%_]l(\@'SZ9D`>q5mY(%(RN1dUHKoddp;q3%e%ZLT$Fe#.D?agN4";HNp**`0mn+o"Mb37fP!LY/@ZA^JR,6HMG":2ta;rA?e_*RMJIBq/mC'l%*?^rVMK"\5Ri,ac2l4#Q*mWNTt=B"I$I&JQ4Q'k>iVWhIP,`[L`"Bj6cZ+7:j<d)<RS0Q1'Yk?ac2)62s-k^qu2cp'(';DYSi*`)14BP*di#I@=/*Sa>`'!Ws*`Z.+l<pYrhi8EZP\,b2/k2!I1dclglYf0Y;A\K216Tn%7t+I_fqmdk/2f!A[S`Z*<RrKJXD2P^;O'Q2B>')<(hHpHchhU/Xuaa,(I$^iU)=7j&M=-6=*Q/@(RF(loH^2Ms/>j*8mEejru*t1'U7!\[$8HpSfi3amKdA6MBQOZ&Y@'G5lLiM+l5?~>
+Gat$tbAMqd&A7TLHV>-Y[10S'R.PBsU.CR5WU575P9M;""`rnbQ\5nP8VnoLZe!FIGh+DikO-Fo.ZjlGV%/'96\3`/"j)jV#WW*(a)6aVKTaXZ/H.==DQ>dHCd;E*+$Q9a-^5QhLl7iTHA=50jHPbuOo`nfgG2QE-=_.EPk4*bI4g1kM6P3^Q7g779A$TTP#'RdOBlZ,!pOG*aMT5h/KKhic[4@]<m:J!8`V_Rp5]:DXmH$VX].N6lj.[)(2Rk31#A#0n<J2P:@81^!Z-s==b7P9o5A-9tF0^VI(Q'Io"`S))CAT:_M:KsZ@@1/i&dhBi$MrW+LTp\68WmKS4l^t6%[*hO0mocA)$."qN\bK6NSBqX9qg';.kI^PfN]WJq,7"7)8W=&\WUo+#U1'hddC\,aML)ZYJU21IC_XS09)\mqQeWY~>
endstream
endobj
206 0 obj
@@ -1271,10 +1271,10 @@
>>
endobj
207 0 obj
-<< /Length 1678 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1572 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%$=``U]%"@rSd-O,h4GX_p1HXu_dl8@l2YK'%CaW0U6*]ZV]/mScf'E>3nrc6YG#J2(a)J-ce^!.pk^=-K9E*<V)<102#DA\:^@@BhIDY\c+'@!Tg'Ht/E[IpXe%P[5=/(ouP^Q=jSuC3;E3cpks>$HK[1S"$@XbX3Fa'eQQte+WR:/(4XtY9H#l^d^RQkM$Yhq$uU_^88X8NCF?cp>t-2=662\)*M_M:'ZYUfY(+0Hmr"uP[gr:J`DeVj^8dU6lPjlPZ?-*<f7CF%Cs8!+\RW<*ade;?E^P9;qN#@ZAI>Foc.W!3.!A9OlXO+U!dat,hCS_rrAie</3OSM.[9@s7mJXrY?e;I04kg)ko$.Uk*7M;Pu@P6lcF3,(\h\/?.=2/,7&BQ^=pR`j(I"0U0Q\$Kpa3+"0f9<8a15gZ8Tu?S\b;T0Le!KjJuR,nB:cF7cK9*KB:e+/H<Lo2k<nhc9'r;H?A;#dubsis3^9D"()_JVcaLQcmoOhm*"Is*AkDdt4/o433WtPirRQkW1Wm]KeN,8'=U=+0%<H?L=&]'dC\"4_48WDX*,%<_0_*\')B2i7]e2\<"i/@PrK86/1+L<b=b^"6^"]4lCldRsMoQSj(F2Yk+FJj*Yi*?i4LgV@PJE``a(3,6&Es<<80spQ5Mr8-!V-G[/fO6JYcj36"MkS-ZBno3*,\`JUT4H7p7:SEb6SgX_'0gNK^m,8Ia$.;_JIkS28TKn,`[5BZKndZ,8l23(/i!u`0k>ndkDknZQ89P[W6X[Emhb=>i=iLh\L#W7_o%cI(E*PItHiGfrXp0CP+cg,+gfg23Ve.o+ZWhqDYX_QjI@27E3g49KBb?tDWH#94;Bb$Ql[#h,WXe@IT]nVbB2D.Q[25JkO?HMGR"D!gfq*A5]R@Y`3I4=_o5Cht.epMD?;B21B\up.WNWJ:S!#YIPFaSYJ5Km0DYU_"'0&?Wb58S''$$9,:#Xf"6`MLtZaN&F%)J'YfQ*sAp$;&jG3)PZd%-UEWIBKnNF6'/oG2P)+49r+#Rm#'b9fST%(F#4-\c>ndR6Ef07EUm;ScPtA#6L#Y7E_u7bWB-pmsnJr<Euo1l6o5!RWA$hdlo&)7UtJ[n)S`+Xpspd9h=-Pg*PI4o[TG\_)AS>gg#Y4H:YD_D.G+3>':IO!39bT>0b*%Qnd>-TUh%bpg7mV]jXEu:UT",*W@=iI5YM[b3]$"TQ@kQ![Gi_d1MHo9Jll"-RC3T<>V'>(deBa$<QiJEdft8+3P<@D:f0^KXk]M+O,h.0&,JJYT/Gk2?3BPHbA'LQQYVpW-autVU@MR:?YM5i7".^&9p/!a@2PUl8!7K)SDC<Hdksc--M>i@'phlrOGhQW71jNpA04KZ\RZ&;fB]sgjbe9(Q\>uC%t-N:/OkV)Ub@`/%X"u<X5AF2".2<7F1=Y#ob/%Km`<>f?`kZZ]WAs%hfV6Ufmos:bpe<MGm^DAn.CbZ>k.KgjJGk%6#Ojq\9cr6:]eWj=+T<B5c%WG%urE+V"g*Y^qu,U'G[&r#aNl2n^M)7+sFIlb<2/TeU!,c<St"O7cWSqZ-*-fl"jA9_mthO)5ulb/tpSkZ`?WnI`e+Dh=t@L\>&^ccpNX[[MT/J)eVbDd:L=E*(C%UC(c&-@\^,=8djN.N_qT(5ZO0-=Ad(X'RoK$et[dkl49F~>
+Gat=,=`<%a&:W67+S*n%&)*1>E_/<*!P+L((U947640LQ"%B=C-9Mt`ER\?f]uX=tZJ*/K1TR)4RtJ&]=\jLXZOP)FfJhCYM.o(J/Al"JQJl7_)C09a:L%D#)LkJJ@7m_^^Q%pT9Zf4DP?hQ_NIZ`Y!V%o8CeIC5`7893Kk3,'k&FGLil[WsQX?5"0_U%oZNuU<YT]+_I!5WEhZFn\3slrd26(%lRJR(kQ&eOKoL6B53`=Hsm[]9kZ]K+*a</9taBK5ci\%mPK8;sla<.=]$GWu(_9e,oba95M"J5pdQkJ=kX3*1&\o?U"F`$/T(MD(#9Vf3rF0%3h*/MiSn36oPo$lXD7cKj=lTbCNdU0nfVAI'i>o1&&-cP8fF.La\&k1l,-u^bn,rFA!plA["q&1k@PqL(t+nca*B?MBd\1]jt&h6]A2G^]#4iG`6YMM\EED-!$Y@S9_EifhY>Lc]bQu>4:W'^M.<mq,27CFk'W!ggVBs][u[Ef4!5A1#6<JNFsCRNf67:/+ho2g=$g;_-+#A*/"Sgd\XI0_muC;T7)iWe>-.X+ql2K+N<>.</^pg6123REAL\N@ls3%31nQ?-/N>HTX8^85C?`5a@QZ\r/o3s^q)*@\Mn7\dPhU/cVn4C`]D\pXX_)<I$.^UddT(QWO^b\tVF,*TD#)bGfMC>fY6R`%j:rUbPi1r&IF\+e)'B$:"f!`%cRpJj->ciM\,,K[EC+2AH%fPHd44@qlIigS(AG#oKcf%S=$O&S@o1=7(u8l7Fc(BM/9f[8ppa=NtF8*uV>HCcDS\]B8K#=mO[!_.ahE9u?9F_+fn3"?]ChCVju(2J*N(a)G`\5oPb.B]Ec$7[cU$coWcKP`]Lb!E25`r>UmMGA$RNmZO5>W]-d*PkdhI\TM^dO*TbtP3f?tKe=eGi0`VI[!,`U6Mn9k6K^JU[f*0Olb5CdLY#6lImk^V:qVXUbdauZ70Q23>]`GiAXPgsoWl$)BBu8hA:&:61OiGCDhoYD5=Z*SVC<`s%S2RddO^8l12YN5F"jI/Wdpo+h![GmSE!EZI(H;6[7]ot\gG*IkDS'kQnNYaiFNpZm?^A8Xg-/U(Z\g],g:(udk&.R.7MMDf6Qk@BeJph/WKVp7Fcjdc0iW+o:n<#>h;=7ikHWR[Bu<\Z-d3$8JM]#TqUn'YJ`Sk-Y4u@2]1]YWiZd@aW!AdUWmWra-?L[%nW+o,e`#O#j?h*[2+O,FQB-N'?aLMqcLR;3YZ_IG^',<0/9QKDK5U-dnZ[=el<,[YrHDK\O:hLC%DP`G'Ga-9+YBS&U?emkFWdPTZZ_rjHH**^OC`SCq:rTUTAAhQd#@94-H6in`<9TtR9a.<.4o\MZ-M^gG-W2.+7#Sn_14I$[Ks0ec/=PYN2<,Jl6F1\M^J`f$$%a+#qpT9pV[#N1VN3^)'[N&XK;<]n)(a)HT8AOLn4TK!fTP^;OMuB5AR.B6[AN>E$P^5eOo8HusLR&Z/o[IAn0'psQ>A8GqBK+iupP*8rlcBt=^BAQ$it"#U4*'%c<'cNBjMU%jh7lK#A<5S_bhDFJ_&a^%2-(_29R[4`i9R?~>
endstream
endobj
208 0 obj
@@ -1286,10 +1286,10 @@
>>
endobj
209 0 obj
-<< /Length 250 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 241 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gas2C3t&nj&;9rX'jE"Rf"FSZg'Y*h&B*nQ,(r>dReSkiTC9`iJe)C]@<^jDG&#!0(5!kXYb`Jp$45c`JlM-#8YK\!#?V4hVCjQU%G83eC%)>X8Xk(Q,cm+"U^O$n]K!L&WO%!YO^c<:;o0*I.X0.k_kfj576Z6VEGWjCMq!V_=1Tnt,fX5`R_1Zt:l;*:g7G3EHBL4Iqlan&gI6C2ERD%jC0-pTZP.uf03XS3[ofDNJTX):*Y6t$_Z~>
+Gas3,4V*,u&-h(+^Z%^&3.%L`l:QY\K8Hk&E?GCL6ij,RJ%eAL=H'fPc$_^@3AI'P5`Ej;gBe155p/N,YX/XI%GK<^42E8dmq(&F\o!>b"Cf?/1IE(TFmZBOd-i?d"h+c7!KuD(ODg0/cq(9*:2'9cD,]EZ,^861^45RUen@<5ZOH(r_+q("k!#AG6EA"u7H2_,ec$,H7IT9>XW(VQIbUjAj=d&p$8[m?I_hJedK>;X7?I~>
endstream
endobj
210 0 obj
@@ -1301,10 +1301,10 @@
>>
endobj
211 0 obj
-<< /Length 1348 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1395 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%#9on$e&A@sB#j@sg@)\"t5$R*PBi:Tm;'<!g93h\+9Wa0*P!_j2Fc61lO<UZtA8/`20/I+PiUHAW8A3i\^AEb33(&8+WE+TE\ADPpJ(VYI+G4A>UG,ETc,oiurEF99GM_66jqil34WJ.b(m/>Pb!QWje&nj4:>'.E58F+Ao>=[i=o1D8mqB[T.NhQ<.5%N(Es2MBPe7%+FmPhRWL2!UVe3p980PibYYBZ[.%@nUk%&04?='(oKm7WO8s1'$#Y&NoC\T!<\h0KY<.7PRV?1b/8c#3KVo6Cd>&N"-?2'iO-\5mtEd#)oZgWqH'l/W#$tU=()'AW`GG967PFeX":P0pX`7Om+i6UE8WVp*Tf-JBK9!ZYmG?J]Q1.==(=Yl#@PYK>(r<Rki_*0X%3[;tXA/-UJU[d`&3^X)\C;8BY[fQW2<!;X8("g`uME-c->3ij`H-qY9MhT:Xjc6aKW<ii,@h1h3AKIPtdqiai=!l5N)4_U?(Tm(fe"W[c#ja0O\%JZYZ"OT-3r$sCqp?;0N;i@`1Qo;o=uQ$ejl<.SRdPR#gb0&oQ97r6P_VM[6MRVtZkf`S:C9f?g$&\rN5n]V,?5YK$YsL.i1GIbmASU@"kX!G8p0mdl>8@Q`OKkC[.JGrhk4rSpH$$I@f7Qn9M"gb9O)_TlXjiG@J["\/(9"Zc9Hp'm;i3Ui]$SsqR^DG"jK_KKaMCbgKc*t!a)RBHT/OY#k@E$7:DX`nX=3dlpZfZln&m5*2^39fuKsil[%!A#-@9.^r1%4]e^oirminqm2al?(]:SP><ogDkQ<'+oFXh%gRG7V&$Qt_e,<$+Fc>W%U1=&(CKkYZ5Hi]n"%ka9r#_W4]Qm_D/44EIC=kTt9$Y`I*8c.]O<d.<#qaN<:Ip@?('K1OMVnt*G%10Iie0K;=Eta=b+]p^G'*(pU?B^V[$.T/bK#HVf8m;0%'(b$"E"%\G#KJ0ZTkG$HQ;<n^.a6U$7EtCX'E0G2#B!.p=3X]]k4H8JjP&Hkl#Rr)Rj[)=@t-VL5#2!81j0uqehPbMU=5!p45\"KpTJ>68Y:a/\J'+`P:?D!L*F8?*m?@"e\lG=QF6.5k:jtV3ChlBoXT>3J_KVq-5Z#=-IBLj<,ZOY\uS9D$G&a-r^hAgD,3hiDn?Se7HqcE/me/(C5Ya-g?1g`SQQ>Cs=B@GPFQL3+!H`QGSR%*&4`1E45*34M8`iQJV\!>s>0'a6V-E0,+sjj^TG#Q7ObN&]Wr=fPBsU.8t\M-*_0PgN?Rtm!JC+0kFH"0Z<gHml.:CqEn)/!(N,4fmo>>($]f(<N?Y2\!uVIeM:dXc*^[e@.cu8-o.<S"K)2+kYYs-~>
+Gat%#9on$e&A@sB#j@sg@*OQC77eqKfJG&(+t\o-kbTm5=f0b<D93COc+6@CHh\lr,tmP>^<DQ3L,4n.iTSO4n_K7'J.k?!?sPD%i,O=#;#P?p&/5="Mc%XV@!rI_>lL06q-EJkYl7e!iW+aKJHBro9XKAI"=4YgL`J-MA_h=q=KS1cjt9bu=>*iq#Y@:.b=b]P$&0EfGr]d."6de<BPL@J:X4lMb@rVEF-1AO*%[fcfnB]dU>A25a]t\L7VV'ArPaNQ+<I@H3[9M!Aest7V/#Vb*g9lJPF?>TJhSE*KK:dsYL"P'@ru8lE5b.:h<!^3a*Mqnn=(<6EK&m.Z2Pf5a7GEpXl2B6:_mQ@BWlR]rK$kqeqZ=/WoZ#`"Aos1U!D7.(a)q3H0hDE1WX.!`A;*BM;2]s2qCqZ)]?AMJnQbiNAcb1WQ!F":ni3s=-3`H7I:F4*!gIc^PHlVIc^NnZGS]dGBqQ_t8NMsZ1W9L>>7%$md#F6ql^)->CR]@$ufq>HP1d#^P%Lh)"aDI,BnrU>@7r/$7Zh`f:W<`I)5][Z]mBrmn-f,9&qJOTV'5po?0)^lE#Z50i';?'h;+Y(cd>B<2NbFAB:PR?:nT<^#_Gt&f,n^&b::XTZHEmZ6#>nRY4fJ&kSPk>7qArgh]]lW'n4kobHl:S\-50)"1]o)->2OJ#lmfk0<I7cLqsM.I,Zi%JrFq2IaoAKRbI4UIM%.$_Ks8qkY!Q7ug"Ma9UT4e7%kkR.Y(8X9/n`%mV&52Q`s,3NfY6[o/*tusN@,Un5c=K:i+u[A7d6I(IH)6@eIH'CjNV7W2hUhQ0SVli(e_cCfXZ4](ds)Um=+)fcD%Qq`7jQh\$A3SeTAc"$n1pV2h+I@jc,TVateY1e:QOt=Z#-6Dt2'Y-INDPTcL?V9d92aLLGB=61(`*ZZTc8BDT7W`I;JMnnMjjntCMuL+Ua"NkG'QO([2u+*fqO<fR#JhO:55?11:q5O"M]BJNRO:PDj`SlL`TS9_Uqq^_sFoc/^(T6-<j"D8M@mQ&ln>P]b*kVYmO5)\2Ep-UdCU^W<]^PT3HdWgpc-tEf@WYQq\D>k%oY<e,]+"(kF`>OO]K*J/a492?RIP*bGs,MM(WdR^odaP1'T!(&[J1*dD35D[\gEUd,b=nQS6V3X7(Kb"pog]t`$r.Jg,m]FB6$1GVCp+'mG9S@-*hS7=nn!,cS:r@8;oGV"5hR^5?$MKA4cRoCrJ%fEVAc!#9E9o!ZOfZS\L=^tFK-;6e_P<@s6:5Pl4YCb/iLmo=c-;WX'n]+b.kD[A?0=APk8:R!V]3kfQZ3r-D`,#4m(a4CkZ`oHJlF.ifj>p1m^DR?PNT!Ei>dg#Nas_ilue^OAQ]dY+'1h;2Fo'Vqqn"'IC!^=,hHOp&~>
endstream
endobj
212 0 obj
@@ -1316,10 +1316,10 @@
>>
endobj
213 0 obj
-<< /Length 603 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 571 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat$uh/Ac:&:`lHYkga;jbeKcJ4Q`j9'O57-;EU(RAL,R$n6mr_US"WT,e2j6C(<XR'Z8UEPD$mm+jclKE`!LfQ[GMHB\R+UP*Z*K.:9%.#FS<PJ?\GB4NUsGM$85H*s*ca:Ao5rKJNO#,+$;HlV7D7D7C=eSLb3bU"_AMMK.(Qu%n"1H0HJ<*>@X5V)lW'ZF&oY^^.V+W[FJ@-W8f9!LY>Xij/4X1HN]Hoj/HS]DC2CN]/PV"ILW=aQ.+X>5HJ_J2s5Cn&b#YKMLOc2,bKgM?\5m=9ug0&i]5Oh-phqPA\U<Fq_#a7M8NDk[=KQF76pe\^+=#WZ;BB\?UY<%J^gd8oPUD3'Y)R"@]XokTj@Atj*?/G;+L0kTCn/5-'0DJuiV)H80deS3O&#:(']TleaBjPWY_%Va,XR&-sjQr<YO!i_!j1e&kC>6cFb+oVTh-qMW&Qu>Eri=^#t5o_6ADU5--+og]b/2]m(OG<d*ND]cdgR9_O'E-o[J%Zf,5A!p/FrTTPJ=Jn>Z*B0tm(G;1hYs&)f!BMeeq%+lRMbM*G9;$Rbh`Vlp0\05'f_YQ.:d/Ir1CbA:tI8l%;K<KogjQ52rI2n~>
+Gat$u9i'Ou&A@7.=IaPsG-F./LfZ&=8B[]^8enn%W`l_%2A.8HP,doQYFT2_6uc@+0(sPP]f0</cB=))6Pou!17(hC:Dff)@tZ$"7V+QTP%9X7gZ!+u3`iD,eu`1]k"S^<9<qGP"T-4q=&in._;F[H9CeWaT1;SS!bTTkQilL+8Vl<#&K(4:le476>o)ONKO5O,'+\%J>RuCHeZO>)@oT@GcIf$E&7d':Wj]m\>lEC-PAK]sIpZc6m]YdSGcL4<]SN6)]6Tm<p;]g)[s@S6hHO'pFeZb%%d&sYG^*1e!+W^./u>LUBa!q!;P,R3A;jti/O8;=^S8qXUhhb$,s^]TMhn_7k*olTU;PTXU',61O*YeuKPB@YfS;hm%["W(J;7F?/TtR(\CR7:$*r2CBCk9ILa%mQ2:X._oX,W1r1tkpS0f#C7&W<1WoL@r$2OOle%ApNb4nJOd:eV`keQ>)DP+egD]^=U[meb`KDfoWkQ_,Gc6[;4jLP<bFFMrQ;L61<9`:s!`$JcSlg0GJI1^lnZq,`WqIV5k6hV1IDZV.ph;j,(?j2Q]rrCIk/^j~>
endstream
endobj
214 0 obj
@@ -1331,10 +1331,10 @@
>>
endobj
215 0 obj
-<< /Length 1998 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 2102 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GauHL95iiK&AI=/(ccjX0j!g6Na"?U(5jg!\u3+E7]%APA^QbkHdc?ZTh(#-=jdL;'EJ9\R.KBX5)qhpmlil0)_W=*ic"PdS[3UPF#OU,\Jm2YM&Wso-uheHKU_pSo>gP`d?O;sqel#gB)e(J)@%OFUJ9eq`-#@noui%HQ]bYIh@EE0`c[(^bm\Wq-Q/',OXT^aeF-1/T14\,<[*?U'?7IS6,B7c&'!YS2Xfp)Pe9I:_9r+:M:XONqfk;.:2_\1;*r,B[4VE_ii5\pNPI1,V_](LF2a*o<[IEY,u]8[&0I-=atb9Qie*l!6lmM;U@iNF:uK-gqi_0G]OBnp]j`DZ;rYE?/Z.PP-;s4cauO<8,.a)Bq52:\9O2.[f@B2%\N!EQ[YQE!+G?<?1Mu?4$.^5jWYW#1F#=MS_bZ(,lAQS:VqS4VIU\$]:ZmV+==r`=S(`HsNlO-eTm\d7ZU3^"N:'&-)sXsIPImiY#a]k]84,h^)Caa%,YHNB!At%e)5#+GCibQIL0'7u<B7=P?YZ(m\)tsN'bJNe[Fs%VZWWLX1,Z\d'!ZUZ(!igd8"5K9Bp]^&$/XHRS7[AJM`Ah#PbK+$5f%$;hIMMV:i=qRqc%>TkMY,q"fYXQJ9jq*ZY&*nX=D,LrG,MZXec,*4O*-6>d'dY6k%VO^?S4HLhN1>)WUrWb6tF57TLG+:5<X"Skd=7gZ<_VG\$Vf\5&\NEdEFpmJRDtc2)I!GhGis%e$:*p(OF\K6A&jaq*6qp6STK5O'd>hCZj]E)r!bIoO7a1u;o54mO4b'p:'D&6FVg3k]:sEK"8Xl\mW+Y7.iJRC`F+GG[6l'PRcBA]&<:?OZNmS!!iu4;_++[sJ#EVpC)GF0nCtNgq8VWWrtk^Qkq2TD'=oMee=r.p2LfVu)XCL9M,lPZ+D0G)5V>"`l7aYqsW)-Z`?VLV;?+DD_ZMe/UIo#].a'YMn.YG-]`G=ibK@d+FRoKh?+rO&VO_Is3<)*]!jN,QX,gY=1f_nR,Ir.;=OIaI8e6F<IS6IDnFRBGt*EVYg'AGVV0,_n-[q<Z&-8(M*<Z::tkkNp%NWk&6-@RM>+HY*C1-OAT(<p"ZEOH"SpJVV8N<.,6`Qi.9,nrEPI9GW"#W9[o#\&FoT,BX@IZ$u2!k/0DS>lD\QQc%1)eWa:?h;e*/3iMVMm%BJHg.t?=@p!ri0;2erl6\khZ%<p?=Qkc,XfGehRO(+8?Do\u3[mHh8'YFYL6;Nd5I)fAXYf$/t!i)o9+U.5BPIGZEeG9IL!"RVf\V_P;+3Rj3U7pqd5%(+OXJ'&U4^V&=9M<bG&u%MHfTuGS?oW*@JPb/s9q\l>B_%hA':]F"hQhWpmJ`K.7^CK#\!t6d(IiI;N9,V:8HRB4BX2&`<sb5qO-Ufe1_ASKe>eoRqPea@c"6WQ0WRhG@1>F?#4h-#L*rm:R"/,p74WVnPTNoo(-(#JmtL7KRp^X#0U$MUr"jn6<9(Wo+GI)Tkc-/a[f8("2sfRZ-Ym7QO>RJr8)_Xo8pL+WVe$&,GQ6fL!AnO(%#=V2#!8H1P7JUi,ml+1AM?^'B+FZW(i@fPNmpAQKpmr7_jZGs$VfrU;=L_T)bOZ/L"38uQ!k(Gl`>0F5k6V`5$YTT(a)j_$i[Vsb=+B^bmrL/R,2B_ERi_m[1jp4DEY.79!GpDNo23EKGQ-BjRZ%c8;[M,XKb6j^p)9%>teAha2OTRQ,lNo9Tb)X$:O`hm93lr07[[U'?*1OmM!-81EKZ_/9'^,\!FkqKgA)/7SY4G,AD&ANZfDmue(OC`"a2A>s\t1)2B@L!`-U`e6Xqqb$%23T3?34^RXqR"4&L3'-Y\N:fJnlet:_67I,9@Vu_\VN8Wpk`W6@[r/1+GdG6V3&VlrXVjp7'+T,UTK^n^=5!mA?jiMQLg50t`C,(#7([k1KNKo/G;i#P-pSmVhdG]0DE;E1o2orRug&_`%>H06\N4du@3ir7QM)+(60kITu;5&??*7`0gQ@7EN7@~>
+GauHM997gc&AIV:0_SBl=>P7f2Q%nc!\&^*D;A.H"4sDO6=eK?-p-k#mnfguTe%_K9<l9ao.B.IiQP-q@=@n<.9lufag,ljhVWU:QTK]U_2l>:ZBY-H^IU,@jB9,t*u9>YJ!Zn2?^`p3^D?.-mFF*<8X_2n+="Vhl`FMh9Un^u2LF=E,n&TTSl4&/q1/S[0-Eh#C9BdmSj!T'nMNh$&2-daSq;P[Wt:MnMrh[T\$G'PJg<kP1F=_ELA(09TK0d8*$cDYUYODtEQ1rmPUhL=Q62,dQHp;PH5dmSa-fJPECN8+iX":R`Yf`4/19]g0c-s91Q!@e:-BR#Gg?OD?g8Lt;4*QoO'FU'(U9PMMc%]t5_3Sf2J8LSQT4`A$=6f#flZa,0jPQc/5Zg;QU`OhJOq1"VR&^p]3+aE?LS&kqE,u<qc)<m_[jshjl'=H"03^gEmn^+bMbDc-FBu=Eft,rR_aBmBhLUuEcbAW&E-Lt&J7tX9IM5P-:sfl)2K`/$[aRrUPi5q/QU#K<I<_W?YYqifBSA2Q/KfYEFJ-qgI[\%4>f4$'QJ:q(#Mp2FtS_?Bu(J;8hR8)N[)Bf73"`WajH)"+Q9aYhc,D`=D_0C]20GUcb[,tG1&XHK4[hn]4Ts!asmdtqUMe(`fYg)SjBqE2sY*9&PG!_bPFLL+p=+35UK=>4OL0?A>XmGE2Z)8QuHl-m=&D+mb!!=?RHDPGb)Xpo)8fqApq8"fQO*bc'r^S_b:@IT\LiGnBJ89h'Fo5O!Y4'2n/R13%N>E5AFhR(p>2YSop:\\s$n-i)bgV3a@X:fZ12^11<l'$%jgXV!``uN+jgn7?TrK.<qu[MZlmUPSEu<K8$nL2="U5IC;PS7r'A[`u.dSCJ_5+>M7*pC!33[q">Q5"l"K3RCZq=_/2j#MQ%AWH6i.<KK5C)=P7/6K=S"U_Ob",f92n"8PVA\7BY]'Y@270.oko51i0@Ud-=SEKi2]l+6bV5hgV1E?-e=YQpd%m]U".-o"dZ$-lKg,A-;$*g(W#)?LT%L,RpTpcs?J2/K"n\`Qgo_/M(&O'2j3c#;.X]&6!)\oM+jr)hN4[2Tk+m,3kYl^3AfLDdB#J\pR^MpMERt(:`R9k6u">X0M##,\AHX#jWt5$h9>ue0Xcj5((E$6eb-JJN7FF0'ZtWAWs#(k*\@AVr6kkIpMHdebGcK(r[D>(]1Achc79sP&]9o?J2g),UHUaqS#u!7]Pl4DI,JTUF)s#ht(`/Yg)_jC.<'r5R?"[V/GTu;sQOS,</q4jsl+%I4T.ofaUsC%A>-Rfj$K&\>M.*LY#FEWtV3e@,GkTiPFQi]@dJ_h)#6Aqh1aFniXg`ODc0<=4-Gr\M#3YPB3dE>6s5!.Yt&bclgNiofT/eXD'0kYJ?^(a%6`iE#i[o9a^RCN`B$*4Vu>adXRYB7ggH_Y&jg3eI=1iS-6r-^Ut:'SaT<pFL+/e@;bC,q#,Q_WP8YM@N)d26lZ@pPrQS/0&%:*[:j5b+m>:AS%)bm"_6$T7QETu-gVkb9<T2G1^s#8rqu9kjNjOS9J#\.`(=:0X[`j[mpXX/nGNOI[*rX)m%%Z#AufOt9ZLNK<o#H3LM*9_$K6+ULOlYr"plYj=*&sO)(,1g4W!C@29:INPf8+,AMMF(\]nS1"J1Kjl.-#Pn:6f>9JcFHT(79=P!doK6I5:c`1tXX)Nk8hQEh0YVRnYQ5?-kF*/Od<$iSB$JFge2&Gl*0J:b6Fg/&u90<Ac[]-R[F5<qm\f0:o1-C]RYTE<tuOm&6P!-:^qmc4R?T8jJo;,`3W/iX7TL9A'[+1[L*\JfJP990'5@M>hPZl*kO`'qc2@GUgV58>>0I6Jf[4sA:u9LCAd\`nj,F;->#D)E@/344=0)7'[;q'p$'6B7)g/sEd%T:#O!-"6MiM+KD$/9&Y+*k]lXHp8osJ7^++I>9$sR^;I22%TIg8s3^s_K"b@>@U^sDO-GJ\i'!LSm][og)H?S0Eu-4jIs(GUM<$]ZmP8<#XWgq'iM'gc'D63Xk9e@C67lhVOuF`J*VRdFC(e`%/2jKefLmq>O:g-^&,#TDbM>f:@=VL/FE7$I2O8,Wa1Q-X8ZIqoCl2~>
endstream
endobj
216 0 obj
@@ -1346,10 +1346,10 @@
>>
endobj
217 0 obj
-<< /Length 276 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 343 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GarW44`A1k&;GE/MAs[!_fd#L0I"o<982F9\e*OlO@Y$2l//]#O@5hj/bef#H1,WhanEUPUI`4I6D5_7BFG*hkh&k!ULIVLE8$g@O$7*99:FqHXL`RoU!J/NDRo4fC[*g=R\m2'=d;&2/4Bd#?p>G4R2i$]W6<<Al$]o0_7>uc?*:?qs7+ZCR\MS^leV5AaaH:5-]SfJ9+ZS5NEL5YacYr=6d#3J':rur4Dq-O7]&Y-YB]rk\=[oX'NhHr-Y,MGS<X88(U#M#kneH9@#G~>
+GarWu9i&YL(^KOlT7Z*<!qKB*4YG-7(Ltm_oq3=)bgoP-mHY/I=LE"U^dInqJS/2<gP6D>JdJLe+Ku"`Ot\;[S;![]$nD[c"+8eOS$Vc0W;6/4G&7GG,k5-<2sBK%_pM8fEF!2pI"g,2K]Y&Vb*(^-:Zu-^S%i(d6H"B2l*oL*G'^0cbW8t*PXS7p(bX!r1)KiUUn("&(s)>EgU9K@LCO!6r\?bL$&W68;o4SMp<GY"Y?q8.W>iVAeh+uu;kl3G]s#6'fGbSH,m;Me)!3*fS;%51K5KsdIdL_+=WoL-^TBnTkp>7:]_uC6H/4ego2Ru:SC"JV=t)(qa=$3g'b-5@~>
endstream
endobj
218 0 obj
@@ -1361,10 +1361,10 @@
>>
endobj
219 0 obj
-<< /Length 715 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 726 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%!9okbt&A@ZcI,$m'od@0Y?"pcB%olW/>-sWr#>.[APX&tW]DM&4@M3,m+fel7ah2mTj#=kS&q0OA!L=:J,``L=7i3BC_Z1A2Mumui6k#5!pj)Tsh<B:U$RB("M?Af".R_4<5XddXX3/32fL9\Xh'/o%.E_<H=:j=MhCTNAq31QSHV<'77n?iYqL'mZI=Li2fHiXN1<)+AG#_Guqur'-lD,7(WI0Zf\'h.W-^5PD7^`N(V!BA>JJY(S+f'c"+%$H5(O:^fS9LWe&&X]XT3/s4FZqa.JR\j4U)ru@f$-sVrY:-;8t]:r(FiL[i?d;<]"VA6+ZPZ*(a)O.jeS^<uO6dXja7+6Hi1$_-=g(\6GSk$=<Z"nbsKY$H&-hse/bS5D.<9<I+;5Kf,3iS]F$$CmB&44<2^tH+gn]Z#'kfe2eTeOPV&J6D`fZ>M^Ac=iKTOSfIBp27GW+L;3<OE8f<GlpsR[RE`6Hd-gct@9s9\8sI',qr1N38Z;YfTmo[HVsJFKmGG`C8V(T'FXk1@l$+>%X8Rp,Aa`A'1j!n.r]7m\ZE4DEAR`*DYNJcZNjcH1b#=)*b;(WmitI,6fUUh#nddoO%e!I[d/\DC]/l5%_YG<3"]pbL]E0Ah;bmjNiNsde8atq?c+W+u[_UR7)Q&kL+i,)2?oUH$`$KA2MB&+44"BFEDka:APuV.DkIUV3#iCJt\e,5H1Ks[f~>
+Gat%!995Pr&AI`dI,$m'p"OG!V;4$m<,JIH;(lbsPaDS&J^g'1pYXS1#T,mA'e/^4k*p;G4N>4<pCq!A8I4<,5[Y[AJF!dK8K\'Yi\2&d`$b'AmW3DHpYZ:45?JU)(g-qKl2d8/$5!n!.<^NS/:K*d2OQ0nS$Xq30D>-J6[3*dpRMjU88k&92/&033Q%<VWnk_.3Y.AU_+W!m.;"EFLq8s<-)iLMOAU#q_GCF?((Tp-;OHP@Jr/VH@7u4Y`.Hbo:$2PP"W'9FOJ:UN"LZ1kD+b`35d0'ep(JC7Q*kZk'>I0ti']h`V8GFZI=5"Il^sCqigAEM'K]+iRN-*Ch9<4m#d\f2+haK1Q-jC-nN[VkiITIr*E1Ga*]-Pn6lM+r0=OGeWCG+W$(%?,s%ZRncHdgjMq't"(u(oB#9<+873"(9ljU7B58(R.8"*(3,@.o@^6?P++V[;[R30Uu2i+8N)"_P&6U&V(.\Fl+pmNroWpj#2V09T8cXCR0en(k]C0laLneG>.ol40r1:p]]XOJ`W(Y;.bTcsH;/lL<rb6^6UArsAT[4Z?'^\)<9[doeTh,VUAb$2SsQDrA5X.r0(<n&5iZ;CQdCtGLJ">,Q&p\s(a)!.P$?"aG'C2<au)ckjJ0<3E>H],tF$m.5uCtkgpIq/:s81GmN.apuO]"Xe"MmEkpBfZ7i=F(46E0j/J_[OC#?\Gq$VT+Vg)]X@s%eIf[5@]hA~>
endstream
endobj
220 0 obj
@@ -1376,10 +1376,10 @@
>>
endobj
221 0 obj
-<< /Length 712 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 733 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gatm9ac=h8&A@rkqD]^^VYB0PdL:d26A*We>S%.$dnVH>$+9r"^Sa6N'<cD-KH`jU:;-D%b-/t^@IWt("^"%n_B_BS)dn3_#6RY]]p+=?+pA6nnDiXSb0;O5$,Y"(`;rF<2+.^=TI(-[Qc3lA263TZ`H>+U`V((K#]IUu<ibZd_8Xs\:"12uV"MJ!25Y*1=ceu&52B(n!\^G7/#9sM9.FOgU_l_#*Q-pBBVOZ'8l,=.g@fQhCa[n)<K,38-j:L^"=)8r;5k]$*qSgu\/R'?ILH+Cf[W.C=@7tEKABP^6Z*8*"JpcT+sH=U.5o)%mnn6^ojY$Vj@jQLOd`Cp`d!Z*0mCh?RJ-juXCLH3QH?R2IEmtgQMSN*[FIo?qU*f4Q0t-K/1qDFe_6J9g[tM?aB?OpU*-:"fs)Qp\Is`G.+ei\40p33.AZ69,q5*UNDT;N4CjpVpW7O?Ub\hAf:TG'/`ahUJJ8XJ>DC7m:(q-+9q^*?KF/.la*sST)`&J&Fcr-%W@o3FEQGZIeR+6+,Kd[NN\oX+VB+6d[:0$2kEK9+1K\ZG@V=2SHa9`3UW2qXEg)j?nZ!cfLQlaBShDCXd<9aq?EB9&%'a/#%qT1P;'l?1Xo5\75KDntrh=3Wrg5SKf9+6J:]V;?dk''YnB8L5h92!jaK;/i1U<q$J0an*gkXoT]6EITgr]*m[k!e3jqe?AS`F.SM90E~>
+Gatm9bDt%*']%q&]UY+_n_;=jU_tQg"G9/WYlPW.e7g/h;3DWjIub8Tc)YPD6J^;^4nmaP\Ms86p\Fsq=@/`I&:4\!4UdGJ@3>kE5kl<K_*O06D`828VJj9]&:?;_%PTXB#'9oSdQ@e(TVU3aU*BW6bBd/)X/N&A,i@I1(#b/.c$)KbGC*sSX6q;#Nh;JLhqc;4lJa#/&]/V-E\:gXTgCBkcXBcgB1T3__m3)C"VqmEFNj(?jc&`-1dX&:6m*7U^+^%Xd>S1q'1e7,0ETL]EmkK;*9PLMB0W[V.2b2`fZ<Sf"ZR)*@;/#Ojn=f#gicIck]=sA0CmBGr\[@[]"4>CgCIoe</P#+o7H8]E!D]AlcOe=.Tk7k"XagDYqk"^W:+dOXLT6(UCo2EFno?F;46e:UrX?bLgb,2`[pWZ9ua88#Z6]3+miA;do_Gp',9d=K:T_Gku1.'^J[rZ9p:=1C0)D'9um.4]5q4lh>?M^;X^d,`/#9b4S7KTR#L5c0]o\JFBK_c0o2gtek!*oK6^V?Z&\*a;(YaTLlgB=?h0d.MQBm;,ho6.RF8=e@.gNIP?lU8=+&(6X4"=rd^4hI>5*t2SJC8V0/B=;SsDd6NZRVAkMpT/k*ZUdCEJF=0=)9[+VAUeY?rL0Na8"^W1T7L?q[aA!YG]I,,ZTc"7N/dBXW)IF3'?"R^3;=PT%KsUN[f=%>@[&7D#nQ&T3o9JBY8Rfhq_L=&6_a~>
endstream
endobj
222 0 obj
@@ -1391,10 +1391,10 @@
>>
endobj
223 0 obj
-<< /Length 648 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 666 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat$ua_oie&A(a)B[G]\J)j\G*.+O6Z/=qhQp$$oEYb#P+R($QqAqbe2>C(a)P?g_P(T(4jL^.LEu`o6ig="JL$9ffL-Q!pL/RYEgIDY8>H5W"^Vu%dRrDJ?Qf1(U,]reNuCLo7:8gcJ@sEYR2O`pp#Z`8$1AiLb@NXt3KIQJ\n]rIY]iR?KCq;#j-)f*B0noB1DDrq$Cm`aiWOUcTi?"Rqn0+LqL4B\k:[TViHVG/NS"CsN+Sc:M.u2@/3-X*.GBR5\!p["CMUNH8-rd_KER4??B6agVWCRB9:UBMbb.et1oD!mQXh"VJ$r.>*lTCWSBF+8UGc7ZCi.SL<u&aq'G\@>SY3Pd:a@1JWj!#R;-r,92T?H7jkqI;b9fmL6$<1,;r(RW&1&K.A5".^lG'p<9A(a)[D0Rj.`q)e`fnDEPN2GH,[+')6U9AMJ^e]<+V]HJ98n<9m"2uj^@[-VXBCp<9p_0g\`bViSP\Lsu2AU[RY;%*cMI`dPU*\2Auk;os3C?);Q&CHR#eC==1Cs!WS&bem\+R."D$sJ)qR_&.d5EQP0>l*9^HI)4LhJ"tSIkL(?4nS@r$+H9F<G]riPsg,uA_o([L*6fgE-;p\X$Ig*L`V_YUL91ToK0&fiGR9sA:@8k$'>/eL#$g9~>
+Gat$ubAQ&g&A7<ZG]\J)jdXaS6(LBj#Drf#Zoofmjf6\F($QqAqi[*n8sUL,n3p"=E+X<,q2e!_+"=u<&d=F\6=:U<JD:Y;8K\'Yk"l?oOpZS@I7c#<#C_3a]gHdiO\9Yd'*&\q+;BBiiZ=5k>-B_lgS3Q\JMlCMA+cB()59Wf';A*#9m[<=_<>`lSgXOHf>:CI]V\5/W6h4$A"'gM#apo@0:O^FYim6+a4dCD,:6aF#j!ds5V1!Q_?V>U$RfHC*.!XVVNGp0Gq=<hIChR?]!fWQ7nOV>beP^1\$PjF=rt%r9i'Y$:'bB^?Ij1+n@bDBkl-i->q:^[%P_&`"n/h?g1"uYVS6b)-6/P[*pE"P]0ML/`4+YAK$dgj]Pi`XT$,5I>*_mKg<OcWOn[Y]d1bV6@:Uu6C[+-q[;4MJ/?g[V\d_m!!!E2_3ddF:0An9/WdUlFcs;^VRn4(JF&%5923%cI@D]g/*K1GirAiQV%u&\lk^9QACNQ!E_k7<i'$%n5'jEgWkpF`!B$K_B,6YP<4\\YQD\H&@]Aq21*K?XDaCNlRBW8$I1\"hZDDMtG*h^bNVE8"[jc'&8Y_TS)j\6%,NhJj].:JE.^\]t&bEMpZE8C6FY#h:H+HO6)&'9*k@$"^=)bl3ohf&VL^rfWLr!Oq9E6/~>
endstream
endobj
224 0 obj
@@ -1406,10 +1406,10 @@
>>
endobj
225 0 obj
-<< /Length 1036 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1061 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%">Aoub'RnB35^c8$iF-PDl!(01d\a%men?_[*ZSW%<%o2W[aDJ^5(b":"HlHkfZ/B[kP?4V04u@k,7=^kZ'Oq(Z*lH%3V%e<F<)h&*<KL'Z^.$PF8eQ`G&.&^Q<tqq=O9pD5/I\4&@r5<QAD(PQ(ghEp=?NT;ZAG[D8!YZpnlPFWgB6hV$F\n$:Y3R(]pNLZj$tunDJs3XnBbus7s_TYoc9i#GK!u+1S!47oX`uZWDpBKRo'p5'%ffVP$3T0PmG`\IOqg1iB>ll;gRWXRj]qmhME*'EZ<D9(eq2<Z0ql$+B;Td!%TZ#+TW.JfchO=F&J8V;/m0E!)qakj:oXq!J^#d((\<ffDoggs`?+0k/0u&oX<&HG*o<,m,b]K*.q:]$cod`pi(E.JJR06X+b6khTI+VW5+CK(:\a=1mcFSSWt#DL/HD\ZV[M:7@!8R0<c_G'Rm`[:9BP2L!U^=Q^DXE]7:dfQD`]qT?fRXGi$I09Vi4A1Ak:Q8gHh9G>gX37"M]$tI7FSf,R/Iq;(%(ciF%3\2JJ"cH"6)&5_2;j/HdK!B>-q+9_c4p!LG]c^SJ@fjaYlC&tA8Tr11$LmO[Z[HSmbQtC%PUlQ]GTAe^=DZ"mO&U9a5$Z?N[S/CSHD>&6X[G$bp;[988JaZ$_XOLJ<>,kkke!d'h'p",M@d2j]7Pm>i'#ZB)Fhc2)\>U;VI,VIO>>X6n:_lP/?'T<oa)aHKPnL_QBW:[%CK)H;WPJ3!a>@kMhJ63p-FW-6Ed#q4R,WR)f%g]->1>`4?&;QHW#`jEQ^Khg\)J:BZHh`>9*?+*i.P#K5aL%+Ws$?AV52^)95\GBQ,]/[:1?#U,K:@=CKg04JoeB\t3ZkW$S41cLhMQ4[9(s^-IhjlVH`"3+e:$0@F(Li2D(E4QW)=e#!\g^a1RGd9OTo%tsW/WM-]Kmn"&ihpm:j!MPMr,1^]m:&C8A-_d@.60J6bEqW^#>Ldd06U9^#W7R&7(!MPJhe)W+iK##aB_9%oYE/jUk7k`!Pefmtrt!^IV^;~>
+Gat%"995Pr&AI=/TU`;cj5Ll9]k,`re>cfRh5H[;#D\ZL/WUUimRC4VHOY_^&-uK[Ym5d=q.@X=ICGf]s+i8j!p!MME+W>O)745U6-D^4[N(n@c_8oNZ$n;H=Mf!X?e5([6r=?GEe+A$!/N+Wj!!>iW":VE3%T\KjAEM'Z'L2H.i'(W>Wo]WdTrQE9Fk)$&teeQa>jo]B,HkCE/r$\Mog[gZ^[>rZ67K=&;,@s3$uFlNe0Bb;Sc\c)#nUqa/^mP!mj5#e/K[?8"e@%!8@s)Zd:.Bm$arCDf2rDcSjOKr_E$WKZ\>Fb4-t=QO-GVSSm$_5(uC:4Pb/B5?M1]ibH\[<[gGPZ*A?*B0+B\.NT81d^:W$aYo':g9[U(1ZH2'$?,jeoQ\P4=p@Za+[4Cq]obqm@rV5V'h<mZ5LooMHM.ujnSmh=B5%s%45T&?XrN+7R]`b[Xu^6bUkr3C<D`1.QA#OB"4-dICH%i9D-!N'mD`>"?jr.cW<b`X,06OSLpD,#We`K!LFD)j%/!irH4d=D<L@EUnN0C9H!]!O%OI81>6no[WYAUQ6kllX<6-cV]]eI*<3qC=X))sB0R\g-U_fuo&n-&7Ggog<mpB4<N"(IYd*oQiR+QrAZk^P#&!p^m#-,,6%W3'R4Vp5/SnhQ7<2N8@lTNOBE@&%1gHb%5lZZ9a%G0guTN0`$]St/+)Z4Ht7@C%o[FQDqGf<=Ynf<oqBb419RfoAYBcrQgY=L,SCbmpJ?:Rn,-o9XNT2D2VQ2GFX1Wq#ONVPYQb&TXoq".!NU<j_r5'@f&[S/L;(OqDO0cuG2K)k-S":#u1/]Hsfe3VM(\c@MUanm**B4nnZLRH1Uo3cSFWOt8':o$I[c`:/KVg-:0gN4If9;@i4IMtF"#SPf0c*JYKn]oC,+,2lh`MB_(fbPWD]KB^RT0At>0MA^r'5:J8_n46HmFAg8m7XH?\Grt?jD0+@<JH%Ud`pdserPqA=_45&m`V@o]ZUTKf<aB"H!;qC.0\3FoiR*&Q#eIGI@K&pq[6t=nDLm$>AV4B=lTM1n0Ym+nfL#$X53~>
endstream
endobj
226 0 obj
@@ -1421,10 +1421,10 @@
>>
endobj
227 0 obj
-<< /Length 175 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1000 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gas3+]aDVA&-Up?T41DE>^,YW>TM2.64gR=.nO1W,K>8;mqF%*,23Mf_cIa.2\(a)MjYaP\(.3tNPh<S4"@kD()*+lfu=7I8#fTt)X[rFUWJoX8(B?@-V:t)".RlHb!PE1!W-LfCmkJc[LoPN4XG#s7n?e1.t/p\!L1PDt("G\`cBE~>
+Gat%">AqtE'RoMSa:m8QC4&V>j8l&n$u'BKJd$B!*k^!:,>r/60!,'oVb(VbCRS"HWDEG_lZ\B8ANG20JHUc0*!^1AK>DS_!bd$2?l6\0-4u&J'Vt'Qa4VJ?Mt>k.OFB$b-pZ-a0VBJ;E$M#1#)o2jO]CtU:jS_6C-Bln-&SOhf3/o0Gok1Le,[dC@a+3'WeJr'_X65UKbY#='iJ*<OgddX3.uj20Pi9WL-Q0Z?p=*S<I9Oc2*YRr";K6!Ekdm.5OC2IF#,Xj0G"=SnHh5A'HoH1.7u9:Yg`4qi=t^SJ+[#^mAUe?WE8dE2e>#$6ELX;[91Wp-f'hWaht>=qY"3=IrNFRa4tJ!%&+V4AV;L_Lp`TX[G7j;Cl,tF80Sb:$Hn-Irl3-@W/p(T=4km\.?;O/4H2*9'0O3>9Tg'Zi(ZSF?=R?'.5+q"\h]7*-\MMb,Y@>:eWEkBJ(?uK%DWSDal=Qqs4gHepsNeM/O[lCV=oU34lOr5Tm3[)P!l!<dVr6'Ub58X=H)ej`t<jO=*OE3p@_%B#XTXP5dD,+4>X\4$nQ&<.D`?U=I_\pP$"jH%6M]Q(Z$j5TX[eZ6WKD'94+'QI-F<''l?[HK_n9;fN.dVBhr*cP]AVL,V^RBe9<l8&mknVJ77dH^9>Ht*j%?[og#l&3+e"cAM%'P\Kegj*+g:QXV1fF[H@>-;5dY?V&okQ%XRsul%]9[5[Hpp!TP:acq/5/Rm>dYGl46U)tekM&@&`Fs'F3C.NW_0aiS[XKZq(l@12uWoL?s?X2?*qS-kY(p*CX_E#'5WI+=+t]&YqBoWjDPX.(%u\TGPKR%@=4U%\>9KUM$98\-dS=:"@5]ZtS\l$>+33+2g(I_DeXQo9n;!r=9iB1;SKnABG'C.QT_UbB$2&qF]*Lg<5V@`JsbHD^-=^#=ru3cL=NNl(.n$eOY0:V-i"m]e/AOm/V&^L:fK7$,_YcS!]*72c5JnD:l&S&l@4'SN%-#[3Gl!JPEq6N~>
endstream
endobj
228 0 obj
@@ -1436,10 +1436,10 @@
>>
endobj
229 0 obj
-<< /Length 988 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 652 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat%"95iQ=%)1n+pb]@nXQa08nmMXSXog^!"h&a3@G!k?jM[E1GIH9Ys*f"T7$dDJMZA;rlQ[kL,H:!Np?iS#&-jm[ZPa1;1DE+G6NP'N#\-C+N`hIHK:`qj@P'6c?U=PATP/j`LN3ucA!#UY0JCt7XE9h0jZ:W.9'/b]f"0#SnhLJ*D9lRBTj?PtJD*VK?1nW,^t4f$>olGkkOl.l"8tqVmhqSVI3/V*(g'JaOZ3mT(a)\.\A*]H]LIsY.8(d$<GJ0s&>4.:%._,Hd^#8-5Y*CQL8D'7^5Q5dFdUg!&Kh5dD$67o6\Y(W+!n9NgfQifs-U[LGB!Ue7#J!T_>-3oa/";"*be5`nmel$WAM.;XcOMrR(C>fN6MkZ@,fiW*V8"9V`q=.RXA32-ja'OaG'hn+O798G$-Y$Hk1$QgpBh1c':m*)OOP#,cbhTo*61t?^iLW;%AEiN/g&b?%i7()*U+*H"bj,kE-==`#?6:FbClnSGd3tP%:@C0aF_jqcRB,c7g\q)=/.mO8ocWjkW5RK@f:[U&qHbJeHmKS-#\.b]f6Y#A:NC(RD])6m2!@=&<0i4Paq\NB=Ls[1H']0p&ajh(Cb'mIbL736WB;&BOs%OXEue$%gb46b^kfUQ+"QU37ot[tl\SZ6A!ZmjereMNHfE5fEV<gOSab:_RG2kE]W1X-qD!M0=5PG)0OPs_FnG8BB*Q:_-1M,I(EI\8F*%(\]-fEi9g%hPI$F<:b+Ef_WmSil+k-qVIXZd3\uF3L\&:#I#!"@^pGG_X0R1Ei_,jnK<>T,fM4O"un`K7WTNhr?4di=P2SSm2;TR'LND\1i2tDZEBAm]nagnQE",Jr=&`(.p8gUCf`Y8H*C#;7cQD?HtT/P`,Z"`1XFd>nAJ>p6mFSfu/[kn\NC]#p=NG(P8h]KfSE#9UAELY8QFRS8X>o]8mDCVYl6aNe'ONkM`Y#G@nREXaU\UAJ+>q.Ol+mSkE;/>_ej[lt*~>
+GauHIbDr&G']&?q?Ht+]qYaO';Pm/)<Mr_PBJs]DKU<0JJu:lfakt^#'4)i(2AHk10DD!sq_EA(nE(r!=@/`IQim\2!t:9<0TZD]+>ejGE"MHR\!o%uhV<])+T1:s*+7hI*9[O@UbW3ETVT(``&@L0no@U]7:L>%DR2c/k%V9;"Ui0tpRCW)aEI<l!>MX^C6tRAijmkSM+W+,jE65;GRd,:"X5[#a9Q`-`OS-!3Z76rM_Z]bBHRi+XGgK2(d4/sWkok[YopCKnh_1Xn8M)E7@n,l)JbPjd)3MEkPYXuY+CStT8>p0jb$L`4]42jA\L=o:"Ifp8uOa^Y#<rM[ss?[#?+k:\#p3bBp4K^%!UKq"LB7`H+gE>0H%8J;n-BUFYqVS<t*8RFPg'_(h8Y)eL5i"7@^:%ASSR)q-sQ>R^*.m5KE#!\2Sc(+$0s.p9<;YqmG[mji2C+rCP21.o"3KEgKWf_M[;7.sCm?`9!6uEC*,'o<k6[6ERX;lZ?W_*P4oV-X+_0L.]t+8o82>6'tNjrH5EIAP@SWf#N&=pLZh+7[CQ/1%@3[l6S?2k=*"SoKue'U<5YA3>!0E--&MXKu'tTT2YVYc67DNWRf.mEW_K_CN(("*<h)fU>JP/eq;$IA6tP]<q7oa:RrU~>
endstream
endobj
230 0 obj
@@ -1451,10 +1451,10 @@
>>
endobj
231 0 obj
-<< /Length 633 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 901 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GauHI9lHLd&A@Zcp6Zheme=bqQ(6Dg<,JH].$pq=CbH9`%4U3nrqFCu3gbt;EiHQ"_n>_eB&Bh:;=N]m6UV#G;%d9D%1'iD6P,s$%Os#[.Z'l_qL8#nhV29,"%AhsPX#@5<#6]8"[a;<SS,]S;2&!k-@'%KD&/F;O_3?P'N/qn^'V]#rSFB;D'X"cT@<A1II#?]q'a=bp2T#kkj;W<3BR!.1K8u@P9V)U"I(g)kl-rLnad.2%(di^bnik$IHGUi$2ta%f"d.*l%+TCZjCh.Dr:57j*6gn+ahS94!LU(,+1eOMX=hj1O%&8JPfOLqUDfF2t.CI%^qlY\KU-jK9:JejIo-oiI/pZg195UiJP#O"*68NabaF\gPSqsj,AP$b%Z:.jgn!TW\i&)c6C:5,kmW(T@7omI'NR]3*mjmk(hciI:(Y8[_gaV:OggXEPf:,CXB@kiJHN)@e/&F]<3Ja,UaZebW--0$j]2tGc)M8[I#_@C>JIGfe=S"On52&cg33".Y)3kIG61'hUnoif;12+@pZ','a?6PB_f<LN<A3H=8Y7a%e8f$p%g,(+=/,t@Mo?ageHjI+AP0EhQ1_1.P+2DDo#`/:QujOB\lmY2)?ZuE'Hs"[ZZ+@Q=$IO~>
+Gau0B997OU&AIm?pk3f:C>r=]+G&#Wb5l=>cphsS%W:Pg@FKJCKAH+aE?;6QVJ4t=HLX\lS&[JJEGiY4X7l`>%^?"B]^W^[JUhB^#]L28i!0YtT7Lqd^0Z5P4*;"HKCFLZ0n;Ar?pFqs_MuDK(ik3hKZl1la\"-p?)Vk70?^@doBeD;@b)B'ID_FVC"8]><`M?+86O@8Z%<tZ)ugDN%0VaVnu6^kK#6j&]ou<eNt@)5+X_q0+8Hr<I\0^4q1o?s@=6I14:I@5B3=Dh+E-=p+FNIN9Re.q0oX'Q%#NS?]m*A#_i!ojXOMN0ii11VHniO:52Nq8+3/Jldb\T1PUR([0lt<ZLKtYLHDg>6D*-o7@#19>k*pr"=_;e4):KjR*G'sN:<A<fF!HST4[k$\1N"62+R.OMX+ArC81SQ'CI`m<qo5X6B4TV@1\l"(5UqjiGLY$>+pY'3M+U/9M2A6TVIXQZE@/.qH:k6V9%"b>.[G3X=iISA5?;UARN+*""3;<"-5BjcJI".<5TB)`U7;jrU/iqL\<Fm!l27#1Bg1f=Y>jJFkZBaM9OF$E<pnXo?6?b`N"T8uC.TOCZ1.CGFhOZ'2&RuC&pUA2S$S%"b"kSI-!!^8ZY\s_F>_>!!KFI[a';=uH_m]E;3ZkheT\$PMY+/GF[#\3Zt+NjT?R?)"<8,"C8[!'A!#n8gRQ$ZEM6VU\n`u_cb_V:_Q]3C_f<T[oa_d;(T:_R6(`IjkFD;Q#!pU#7Hm8N2WeirS"Skj",Ln;H(D"N#`K=*r=c\U_l2P&?LMOE@Ncl5rkF-*VI"rQfD>2$;XK.ZC_6G,X_QPQk:=TkJ-6slE#UEYG$dV=*G9!_!8=#-F".l[(S;I%iMiMHc/(EmGFXok`\JXa4t=H.j<%a?2TP~>
endstream
endobj
232 0 obj
@@ -1466,10 +1466,10 @@
>>
endobj
233 0 obj
-<< /Length 882 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 198 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gau0B997OU&AIm?pk3f:C>u^^"OaGT%S._9NSo=H\>dr19p6k6G0@)0H*hbCk8mGQ1Xhcfk3^rYZSrs45S=8DN+W/nbn(0I%fq=c.hi#:=E"hS_2kWMH>Th$:Cqu\<XbXo[i/IiM4qf"J^1PFd^>L`7;:1M5-O6,bu`M)N`iE024lu,Al,Y#W-ZsUENJim(d4%khEAI\"qIn5ioB6MHp`ns=;+!qJLh+Z6E8ner?e`@o?Ktq=,+0fAkLc\d`\:\Yig]_4S;UKJ'Bgn*_T*rd@g0t_/*q-GgI2'aX`9^Q7(\2$r;;aH[cl&8BBGVoAV5TX<?Mu\%X:mc._6$f7+s:&cifWchVT4pnkBp*KoH:lCCjBU#L*r:kqLV,<E4<'6!Gfo.=%^Niklej*@a77k["#[eEEB9"jIpD!VeM$PF/lKtGseUIk;_2\qZL"c5Z"MTk;>$0"X^*;>]KM;trfQR:9X<]e-i[QfdhMfj-gLeuq&N.MC4j?P!F2h2D*HXaW%lEW.J*P9na6fn99G[WcOBjR:W9@;4)bAqu5qQb/.!d_KG`]Qk8H)`/_:2LMK/P;.(ft4+L"fOMVB5aO)T9;$'*1LX1mP_WCC7>#%)AT\CFueLbCJAY&P))<S&#P6,oW_/Lr9W0(m$;]R*9[@l*c)"Pc+5;^SjH=3g%+X@`hi25d4`B,M3]-%1sVoiYe0MGig5Me';]+19M[fV;KY;0A-`W?;S"^FZ[!A-(:Q?^"&'h'gD@WGbpD"E&Vq\O)V6.#ak:!:c9c%<UaYn&A0R^XK@/LrA@b@]fbjWNXW-*qEBaDGSN3VF;;?l3hu+?hs(,_"Ooa:aJYbs@in;r:D)bPVe=MahHFo=(QBr1SLR"RM62gtML-A9~>
+GarW2]aDVA&;9q/MQ%j:?M8jAma;;5+Z@2[@\I6VKb:)o^Sa@cO_n]CLRkVD<&PN3W>I3b98k*0E#oJ+7VNA%O]<,"l%F3,h#%&P487>UAgW1Yi6%g^I':_22f+9;OAd*o"jI]d`nuLc,D[b!HYLc?32!)_e`f$VS[*`dAL#Pt4#=Ws/aI5/="]H5@R'MrK>KA`~>
endstream
endobj
234 0 obj
@@ -1481,10 +1481,10 @@
>>
endobj
235 0 obj
-<< /Length 198 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1417 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GarW2]aDVA&;9q/MQ%j:DYF'MQSr4YYn=,P$^E!50OiQ+pG@[SZH_b&Yk(kWo%H?5%`'9r,j7cbdO8eVXMgk>_I[\B-Z$-c4reM>H+;/)d,([QPQeAGpU]c'j*p?aPhI:`BGp%irRSgeD\Y@dQ^4Ge"ta\jMSI!EZMC!5CBsO>'D%^FLe<CXD#M:e_l*J7JTW^b~>
+Gat%#95iiK&AJ$C#[<rmMO5,-;30M<fG)tI2aA=WQ`;GNRBh[jP*_uNl[N8>U-qnFm1d-N7N;p$RjUG'(;Kha"Y^*.$Wbe%$oSJ1K^+1UMEi"(3<iW<K@MULqrWb%k\]fbYkhWsi;eUIK+](*+OZ2o6Qh@r0<qD)Z8sh=A8QB,/.pGpD@2%p97<OG9fNlR6gSh)#,C&ISDFs3/2V[fP*3;LLh!)r>SMen-G@LlZ'"+f.$L:'aZ;:&!\co]jr$`-SqnS\9gtN]b@M=[(A!NieBb>jBW5:L51Ika:?@$cXP$jd%q?#eT(WL5pu\fUNU1UZ;ikK+/&fceU]2P26+c-h/Nqf)+V6#`CWlO`aPs2;K2NWH#UI6GOM%o2TNc<c2&"Ek\YgaS=F'Q4b:U,T'5N>tmfk?=\[$#5SBZ^mPNh2s>\un*LPp4TBfTao+Y4sB5\REA6G/M9H(JZb#a$:F0X:@4-A!5_BS<'P:5Pc^TD<O"BurpkC*G7.k/U7dnaC"(Ha7/GF8BjeTWN%"2p+p]9ohL)pQR>o_,G&%Jl`SY5sST,H*OVirFa4j5o[WcHZO?J-jQ0r^8<qGLj"@Mp.lJT__12TKj>A(eA6HDaZ^OM;)']Y'-uC>4`=#QJ_nk$5iO>=!+D/7%oYd=4\RjVJoY%%/]WOp:l>/H0QWJOb*UE"*[.k]0BV9(HYI8NQ:'<L.2^iNY6D)\V)ZRJ(4B2r;O9MT00efI2dQ!G&%8M+T2[4jgq_ENLq[Z_!9!+B75e)rA#mMj./7,lL,A'LI-.c5qkR;+TWe.SqEN=i9Cg9e".H$)MHF*,5X'9kJa[ksZ=4oU?P.lML`CE(a)S/Zj.8?lA1Wh"5WX2UW<8GA`_L+[b(4pdC1>fea.u'IOo@gb9/oFNi^L5JRK]\*&[Dn2'$\)R"_b%X17thIQK5YSW)lLX-5*l>Q-,Ejo!#B>f528k"H>dog`1gLKb`G+S)8[1-P+8Y;b&Eb*GCHSY*s9o=)o83AHH?^i8#$@9q*P36=IX7D=KMD_51##TTp)a,)J1,g_K3U-(JrbQ7\dG>,,RSQaZum8d3,D/XaU!`oW;#U]W3XOmE-MNY<Z2fkQ0`hOp`+c6N@97urKcL?kKKc$U>n!-$7+M+8(97q>12&1?9%53WKqGK#RmY;7:gK$jNrBF!3&o$GU;/Q]\@uAB9?/5?eM>Mpo"Z?fq0?Ys+`U.BB7!_TuC(.rKG[sO>$f/-Yc3e`=M:L[R)8UYYb<5$iJAODPd(C$`<IsWdoZ*u+V7bI43ddX<2p]_.k,E4S&S=k9>EYC%e3g-hqTf7LEj"Xq)SPeCkfjck@Pl#!8\<V%[AWhga[=rnc#JfF`OGi[g8Rg>>=[4;]aiSMe"BnBZ1thtDG4M>;Wd\t[bMGZM,X'`@h=[&qYpPAm?oO~>
endstream
endobj
236 0 obj
@@ -1496,10 +1496,10 @@
>>
endobj
237 0 obj
-<< /Length 1375 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 173 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gasap=c_;q&:XAW&5o1j(2Hr5FR@fef`EUS!,[_0e4$'r.@XG-E_(Kis8,\<,uTL/k_1hP2o?NY`K0?(YJ9#rVB?;ujWY+V$Q+QnK)nB6AgUph:_F$!6h&FmCOVoe_8!h_GE%I](`Lm8&Z5nFa8iZU>a6[C-s#qp@"k=e_fE/*lVFmdE^?P^jDNX:JQ4a/'Z1<9lj7[)pE_ej3?s8$8Mc"tlc`B.UISlo]@)EGAZ>A+\Y9Uh'.Aad0pK.B>fEDA<pZWWIX\&)7igm^WUf`iW_S.%^:V;"Lnl.fYu1<JG,GH(WqCCqJ1M#e7-j!i+li%(3]0uYfcDX`&eLt?DpRO<8BD_=XL7$nK/ct*-!GXV\e]0h0r_gV7p<-[($ED^[AT&S,0b.sZN3RF0&;tAZC,h#I!iFo?X'[f_W@Vhe:OtH+31MR7>RKf]F]"d0[$aYkZq`@02*FB*#h<fV`2K@KqPuNgEH1]4J\7`\ZBi5S8*QO[+Y@9g0.9qXG.].:KOn<21MN5Wba6_F?EI+RWT[nOE4`jbJji::"ih4DVb4n0eOoA9X/e[QZZkp3?0R'Udj3GJctL;)_9_sjfP@`kAJrUl_>\!0Nb&[6M_</4ku:R-UpTJkllj<cuTICD1:+EC<p>3Bc!#oqW^$uXL_;G$H.lO8bHA85E1HbHG5cioAR*[4Bcl92lE=\-?h"[].T4*FM9GoogW4*+J,^I_nPhHW\3*g\$a_*[VZBk##Jt7k[I3$L]A+ueURPqjiVj'5nh23e&M0K'ft6KA(bVI;q)EY`EOR%+3J@@RD4$oS=b4B>R3rb\Pq5=F3jfYeA8`aGO#H]9QPh@dWNK$TT3pea*GJt^1YFAOfmR[H=PZkV(20gEcKqu30s5V:O-'/CE:='giE&:_mWN>L)XV<9Uo7Tje)2"M$`HY>[(FGAGKPi2q]0gAl?KKm"BX_K^SfK;:bT'O;QnA1csj8H'W*e[=l!M<%7;!q<7coo4JQq][S[KG%b#[o8(=&aRkiUYjgnjB%nhe'86R&iBr]n5Vq#CdqBYfSbp%SZ*gV*C8#XU?W"LPHZ-nUE5sYf8Hbb91"nih=U90j9V.S_EJu$U1$X;@7dWj^iL]Y7$j)*U;=j?'Djm]=2Gb>lP^inV?&4Qu$?kS1YbPr?9@\-7&*'_,W"DB0O@HpNc"OoL/:VZXdn.jf4&38c@\8S'__b_>1Tr%)8)gTd=]+WQ:Q2>W@!`YpN$,RE-U6&akW<#VP8#8fZ7cnt-\di]93K\0?0uQ"9LO!`f`"e?]:oc"hF+#b*'Lcgkie_e'VATu[D<-2WToiCigY4,RKk0j5e".E*U8o_6+Qc#nSp_K(_^0ak4\Hg15*noN<-;P68GJ0Il>2uao~>
+Gas3+0aki`$jGQP^ETE_`oMG[D_BPU5nL>YPMV-`Y:0)DHWmD,8<ud&j(f+T)b"1EZil=(&EIk`ia0rc*D(n7j'f23Ehk!&dC.C>gnsm(o:?Zp4*+!fL^Ee%g<@)MjFW\/R)*i;X7XK2nN,agDXFG"b>p0je!g3T<;fEbHo!EN~>
endstream
endobj
238 0 obj
@@ -1511,10 +1511,10 @@
>>
endobj
239 0 obj
-<< /Length 235 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1791 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gas3-]aDV1&-1WO:N9l+oXm"PPHKU#3!`tOE@<]0K!tZci8^;qU'MsP*;B'\'p^G;!`D?:19_343&2!)K*1jZ!_i_fjC$<<MonQW/jnB;eL?4ueJ`L'R>,D0%V%@RmP4(EXurb8:\u43"uC,C8/]3ch`73.9$=BrJT+_3<$5O.q<[7:@2i8"\!J"nWDS,m+P-WV\0bq0Y+C+<m:I!M?WIa44XEqMVP9.D"No[k;u~>
+Gat<A?&tL6nGRe>\k;@\P]a5+Nmp[foHGTm7V]9s9<SjWQocfL-5^dVIp[g;*j`X_eS6DVfJB,f)=r$$p%lAbi!>Itfb[_mo5o[,=8oE;&`bu]&th2mSGgk2qrUh'UpnW6cMjT7$68ET"-R=C^naJR0gUqW'h-6nHroflZDVG=Z9sg6Vd!e(K)XiU,9`2#*opI4^sjnm","sjcm2;l-;9(iltTtcG?*3L?;4BaEEd/'7j/?We`Tl]VV`bijSYm"\B-$&LLa%pblPFh/3Gk]ZRApIX23Z)clJAMnI%JtkfE@u"M:D/CYlG"HI<Tb.a5&[-)8(YX:7Tbim4Irq%n9CQ;JeX=t^-`j9LfVE7[3p7p<<QA"s;U!VW@.X5&=,9$<6P/IO"O"s-&On`CTjNCXd:(=etgfF*+\P9c!];JdXQB&e,G_faZsCKEdDRV&W\SPclBZ\'Uk+d-K;MFE>4eHK9mcJg*QH5pFEVCKDIe[?jF(kqNERL0&cMAh!cl]Us:RNtf+a.!;\l5/<)&WaC*SYb7<`<"Ri#"T23E'Jh]=]u_3Dq*UK%ap9!%_^[q:R+Hm\un\rRh(2^\'Ib#Qo](0=\B\QSPpshSXiL<UrM!jqnh'"hR/i;3GW<ZEogtecM2B^9g;4.R^I6.eak/FfB8TEHtArq(LW:?ei<ir&jUMjl5aO\gX3lS]We[uciNW0%jca0^8spH_mCDHgC'g';ZnTNAAY^#'X[e8S>'u(!:(E%_3lHn.(D_mN`tc$ej-JaMeHZ68t4UJ]&G2BW$_Hie*/aoeiB#</+Y:0!Aln*.Ksoo:7G,t%uoU,D:7!%fr;\_)#YR6&rs*Q6<U[/L9_XD_kg:'<,bTdCh'5N)Q@SQJ2(IHUeJLAChd,5-9(7tY05;b<h\9V0ITsRqoKA!T2\rQRi&$]j5pmK[?F/ir)F0%J"0#:n[mubffQ+4Q[A6KG<cYO4,BCWL87\gY99,.C98I%$pseVLQ@%0aGkSk<1m(t0S$%YOJ)HU_(a)$c_OSNV$.J_UPROspJVTHI-rd=J0?S"CjfW"))cSoW_[clTBF<F8Y,jj:<)-X,4S56R%S/dER?9c>JEM+#iZunaN1#@cXA4o2Z\Q-':&V^mqB<rVED$TgB6Un\.OB%L^JTEgR<&V$1e#-7d';:3C>T.&JY5O*34VAlrA",_`FE=K8$3gP-JjI*ZV?.%ZMBF--drEZW0V=?RQ7BJOS6`)54p1Og01<,_]!07l7D]#pp+$\mP'ur="Pn$Zn&HgdCoKUHGhDMJ+,4DBki,PpO!7YOFu]IO'j8FhlS5g@*[GdOM.9m):2dcJ,HTdIC'dLi6GSJ\0R'fmkk]Ek54o[#l^"=i<S$e2TUfaq5Me,6of,sRaDkRDY(:W#cY:!>'o3-L?t(jWM&`08)tE2U-pUI*)$mdcCTIjH*mI#@\Ps5a]Xs/"<C?^!Wb1)6\HK-?GJ^rJ8r#@0.$$ppL:nRB,fD*e&nR+#mqG"pMQI])2c,V>@1nN9B'%KoIa%df?bc"so3-&(s5Q[u/Me8M<Jq!pSgT!>5E#nD&/d]d]U?OLY6PgnP\u)#GGO#CWW2U8F.HT$hG,YA;UY#:a`ej7r8@Kq^;">]*"\@u"THX9_,Jejr4XT?lXaj(;3?a4O^gVGAb1NJcbA(C49sWB;E;9Q3PJX^8)RD7>TsWP^\$:jg/.Yk_r5]7];YJQpuUMN9%Li[T%dDYVRV#JO5f$bYJ.#TC5RENTKj!5rS!O;L-!<(moOH%o7Jf5]Z"sSK2LOdjT+abBnOc;q(IC@^bl~>
endstream
endobj
240 0 obj
@@ -1526,10 +1526,10 @@
>>
endobj
241 0 obj
-<< /Length 1516 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 245 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gat=,D3(GM&H88.JPrJl8f'/CSWd5+GMSIcg7EE<ZsT8N+N,PV&n!G90E8aEG4:k1&lkutm(r;mGfGpXle1;Gf>8-*X`ZP.Xo/Z42ZLZ1G&0n^D'(cH@',L@hhs/0OZZbG=R4j(QZ$;:Eg[n5jIk.f%!e9-Q<@?(\hB@0h:>/GHE`]q0+KV#9>,f:-^ig<HE#OS6-2F8P(E<,hpAOMG:e8-FFt/1>`?NJQ88G!'i"84kDCp`NWd1Z,9A3#%_^N/&E2?Z:ddco;KU;m#'T2&O"]RiGK4aUk27b*X/`6?>3qM@8soV#D+ViIQo3hni-7U>If9Lc85mCX*V&b"#_ej#7BGd&HR)&/jYdNE*83^"o3:QT_I#mk&iLIN-(J3(HdON>="u-Y@rSQ[AiK2jNoN+YN\r[)Rn5,GF'g6<6)=[(<[=Npl%6N-$k@%56XlH1%4qsO8rFXoK[9#')KHg(!9G\RJZFc<`Y\ka+%[=%Q3GYTHE;-2daVJHl'oXJA^t!f^Tbt8-Dq/0;j9O^_Eh)94j[R(Bq"+O+G.0EpVD$[%jLH*2DDcLCS(.j\,ctiVh7DPG?F;W+nn(8pf1'-K;^OM2eR*N?("tYemI2'a&9+)Wle,tT<bmr7:MW2$(QrBc3nLV;0/D'V!>72VJI%*aD4FaZ88L4.*=7>2\Y,g>4m,'\s3aR6);EW[FH"XGJI4j0">XJ'?)eZk<UFdm:Gp:3P$sq;@N]#3(h7g]NgR&\e5^+d?Tr/DPTE7$i:^H`K.e6q=49`LuT&r_TNjI29q<PPMcNs;-k`rE,dA!Os#BAG&l6j.6'm<]fm],fp32rfW1J=9?WX_-dr.&)t3H;*'hHArj9VPD.CE:h.YP1JZPBrZK*mI0Srr(m,(NZ72PRP*+DjuH6U;1j!0L-PG&?gd&MtT-@cT"M/Q[u!$U%X"$Tj6J<*(.?2.*^MH&0hq*:WiH[7?h*^R+Oq67q6U#:E3q]3Hk(LOpS7OD$oGnGp]e#G'nT-n[?"i1?I]&RA^H9U>T7l(!7=Ba0G2U!+Y@b8H;ER_>%J*P#j@J/-892JS5!S2'Y=n+,<.bFoOhd+`<2'oYoKhWut%7QE9-uTne[E(a)em4.Zf1f$KH>O>N_5!DH#cA`L7fLTZ\8=^8fFTV=sXk]Uf[e0m"40TL5B-Ko`U$*_Qb9b1:<Y0##l=Kbq@W&H?IHWZT[7/i@a#Ap3?fJ/ZmH2=+g2]A0S6sN6$H+`R8#I_mb#u!MIJ#MLj/ZTuh#P!:+Z.D,"paR3#b5(Pt#@]r;g]3%1aaZOF6fsqq/"DX0F_B"aM<1Y[@\1k(%t,D`Sb+s?]ILsAE&jbrmt`J(658(dRd]I#R$5TiQBAPBHEASMT$*&.i(B%qi*q.0b8p@O$[FHs35tIs@+fes:HHQe!%1_Jm&G,^%*#F:l)&siSJeCmE4)N&D#i^lbpKqphtaKs[eOQ"H^-fLa<)0[rq<e5DU%(?<_]Z3p3$(;4Zpfjj,T_[j0RtC50nt`bWaT-rr_n/#^Q~>
+Gas3,4V*,u&-h(+^Z%^"3.%LhiG,*>K8Hk&EBj[pJtRpVrd2hD\eoM3S,7GJk/:dB"#6eY>V7:l"G-26^^;Bl1mhAImL7iXr]"GT[]$76$mANm3&RKTfG*^9mJ=:'G2S\C1dKK]Hh,FDl5DQXa>".\Wie)s:ZbDWL\L`gCQ/O?T;>=X#.[ioRJV6O>#\G8QltqWQ$%D3o")r#;\bS:^.FgWDr,5fs6?j75;O)JBH-qC08.tIZ2~>
endstream
endobj
242 0 obj
@@ -1541,10 +1541,10 @@
>>
endobj
243 0 obj
-<< /Length 243 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1321 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gas3-bmK%f&-1Yc5/eN5i&(>kY$M8nF9nVS70fkn"Of,YHMc9X,)DW00L+GgC>!tX5nFs6_%r!&A/rYq#O]b<L*VpU^n+pqbO,UZm]3e<lMs7[$mp_9J_?pcDu%bi#-\3AoP=YXf_=SgW(i5U;Br\d)i)m7B%^aC?p(MM7\F'Jq5eX6YVf)@gCmbc8GlkSgl,Rqk/X]>4'.\A=BGAPmiK5hX\f#I-#qh#,c\tH`(,+T2?cT5~>
+Gau`S?]Us?&:`$(5[15DPo9lHN6Oqr[+F-!Y,YN>2sO&b#EkIm&qQR(p@@TdK>BGKE[RE"RtnuCq>6ZOGl3$(=M4hY,QL\[SM#<YY^i;uJ']DGpg+YE5U5Wt:Yt"'YK;VaGlN$S?_nJ1TJ%1Y:aZ7*,"*+G'#7NljnX@n(4u'D^<H@Q,i\CQ/J2$RpD\dA=hRA_dOZ('W>-8e85mYe#("nBP\UC'l>,!Xl?l\',4D?Z(gI>u&4A3eV;<hMQ$hk.iisf`=Rm&S&XiefCOlCT7Gp[''tH_=@2&H2\9fj\XssR`M;MP7K)a#[)6556/<9"9<W\K!j)AQ(Vk8tD3N8#tdD?J"+XX>`UH$aNQ<-da#luc8U!.>eGLh6i=`*tW"d(]k3'\TOJV2$S0d<5"7351:Pa12&_5n#Q(KXaB46]SaWmP)qX+BGoWp7[L@[iV5.W<VY29h0.NU!+T#=9**;^/\IZ3@uD8tE/PY7*r=q\C=BRCE9S,Piu7;;PKVqkIt2in"AbMG;$,VjIV/(26&YZGHB$Ee*Fhg?3q@"(jO@CKa>s2up.[G;/Xl(&<AK`\h[SUr::%d0s:.'2+NM)oTX,gF\@M(fM6jf+5X@i/Rmp(?puD8.MMOj[2)h#EkW_hJ\Fi]Gi97,DdL:`Vmi`bcGQk"^8D3h?'dnT%qo-[uOBN;=D,##^OC"<lKtXGE3M(SMR,qU.!i46bIO>95+31g8f*_I%m:@)h?f@giMhfVa[0F/YLUEQqU/'0d)VEf6ga'&cjhNi*UTL=?0'VDNbme+:)q-&.$h5!,:c<'.\9YT:L7CC4K8\:`AUJXW%U=!;ngBV;IT#=^&_:+^2]"ic_OY=X&#ZSNB3ANhWH_a'#0_IG-I8db7H*f&rbYq6n8lnuUJ$79BVXr[4a]OdAF:#1?d;9j8WpUg0iNH_o^(3NDa;2d)]_1o>:5";G5V[i1i&-0glBFZaMBcF4AL2oTCoNM)'P+#`k;P'FR&+1#7mjVbcgS,LXgk$]*9(eP8PWtV1$.93G.>cep,Q'Bg+[`2<QMNpe3b:qck&reZCHI<BDJ^E#/][PK5*Fi7)>5-]l8Fh#`YgYE`kpqb.fF"8;`O"&Wf&#Hl71k>(*Y8;.rI4M5DBo1MGh%QX=oFO]lW(7nPj:79#>&E%5;D$iSiQ7jk;8Iai8"+Tq?geSA#^V_Y=8F."UjG*),^>6Hu/.'pG&tegpS0%%$3-J/$F75U@+]@=ORV@bVB(9X1I[-2dMN-6_BB%G[<$e[ZC3<NQ<UQHXZO5b:g]EFRdE2rHcO%KcmnJBATGgH/*s'DG6&3rrJ'WeK4~>
endstream
endobj
244 0 obj
@@ -1556,10 +1556,10 @@
>>
endobj
245 0 obj
-<< /Length 1301 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 1048 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-Gau`S>Ar7S'Roe[&2IWdJ=.`Q8X'Qu5e<aVLETc(@kZ"HA=Kk2aHB1f>Q+#7B[J"Q=gADLB`&G3OQZ>.$P2,IB8^u`,;I'l17M]j4!Pf$+7Y/JJ]MedHkq"N^%_:"9=j9shETlfGMifkJm0jo,Dpo6pani[MTn76,o><FSr8k-jmg0Vqk6&q5G+G6GAsiCbLCoSG!d+fa[FF:[]=%67'>1:SY7*pB/I3X%OHqM8LriMZ)H,)*EP"L+BF.LM#k!A#/(-M6r4lr7219a![ki4IlB^bF^7UJ'7[C_V>-D'F'dI'=srUq5r">P*X2_c^\hj!%r&_h!O"29&IW9qs!YA$Seq&KZAbK1iJ9dAMiCC)/'T$V[L9$IiI6<o+EgR!9h-;GI?mBe1fZ+rYr1iFg)3rAekXfZZ4_:c6:QdJ&QS;0=fg&o=r!qB\g5s;RS<6#Hn[G'3b`UD-(FEdTQIX8pl,:\TG\V4gq'usM8T0Q+Ap]nU:YG(IIUNo"l6KUf^0HL+PA:t8.<HSA)@<eUM640FU+9oO^4,J\\oP6*W6C67o5fONdtKc)@&TF4<;Pb,sCcLD=X8_@^>*Y"9hB`_YE^$NsXT/b(_JGgJ8%ZU>Hu:T2!ts'8B'=1/+1rdr<+mZcT`W7%TlJA%+_hC>W-DF]Xg^3]C)"'dNOgDPVqY-FYa:2MG@=@XlJ0\r+p>Pf;`u+n-0*9RGU?).j4J])h,d>O0p)Ss<$TZ%,^U0cCfGL'VBEa0+[2:_k4ha!&1^QEand>2?&(l^edRL1,VPOPb`!G!,;0/]C$7Is$RC&WE9pT%pp1OAU[p"HpMo,."Xg6pn?:1W3:3?1CmsG<1&)>jl4VCj2(8Me9``d\X@b`2jJ\<Ja_6Wb#>D5,D\A>l$rs2mTCYVY%CE#rSl.^lf#'qWrp+VdWt`5/h[2g6d[ON*&%_Xc2ErW@G<TY1I^i$+,`abMm[2WM#$mT3h!TJ@IgETC[1XTT8KbB")jUqTsFA#a?g+ar/U,Pc.#rW#$hI"n:e1>N2BVj?eR"4YY[V'9+[lHINL\;&j=<hWQK@p9?)aWLJ:jV$NhA3D19Ypm&eTCk5CUiYc8;V73]9#pM2E4p$3.oBtkf/,Yt9<?L/)q?L?meS,7;dr.bt+2dCo#kdLUCq0?pGg8&]$`D"+<X]"p:eQ'_Mjq#<"E9J9rNLW2.H8$Ram++VZVR9DK!/+DW5>@nH<Ki<:J>h2q'T#uD3rT^T9ln1m0gUUR0PDG5c7]@:e@8>?8h[7Hb8VdMulC#T"B5u5X=6f5Z+2dG"@VhrrJ["dD#~>
+Gasao;/b2K%"?O+d+btG_Uu.?fmW1t($K'ci6Z;XYjF`!j?tpso%?dDr;2[h4,Vg`1DECU;'Pgm'Ige$c5)HQ_D*<-KU2Eb5jMR/!qR3PL*8f=8V+ki/[sruc$`_%[?A:Bd2XqHBbI3Uh;!XDT2aY9U>V$\l5'=`b<NT]!O.Bg62U_95S,;KJG8o5$I)X"ZhT,Ta=&<'j]R%YI!dtX&JPGhoskNL'f67?+]2nB<UX,J1^/JKPRo@#)XZV9M:-*\,>OBbX%4)*&;7u_FbLh_0pmT<-7-ueo!NFFo1EpAP"k>Z6+flFMW+mIo=])7<_O'^W2V*b*TGg*C:E#8R\m`%/9Z:ki?a2ZV.CHlo`)`^o9.=U>5q@?2gdiO)q?T8*?B#+&n2;*>ok$7\WcKSh`l^F:M3<j9<AF^R3)=8laIAHk"Mr(A<dnAe[]n'S324die.;DrimOd52Q;s;*':8OI5f4Y&s9YM%(*,fiIid3'aTi<@2`lXT^-#/BUTb,I41QA6Ha6/%V]!CW6:qK$t.i[ifI'#2lnSe_!h0+I@dT9_pe);$9JUdp@mD51Y_G66YZ81.)'Rl5OrlFWiOdAS7Fq-k^mrLX49[V$dS5b!tNYQtj3o`PA]r1?uDd?b`U5[[-M$W>9h0%dgjD?%Ed(?KLmYccEUfYDm.'C;DUlR!^a0P%oDf`fbN!i8MMn)c<#fZ,E-.f$C#MC?:!4h@=JActGSDjgH_#':0r$),T<+.<kGsC>Q5F2N;@u<I:Ak.s(B+F`aWWX+j8iSs0U7S4:;]n+b%@5g49h7jBce[1i+\ceR\I_Tnl-r8!i9W2ARn]Fo!_2q@HCe2'JpTU>Rnp:QRdV<GN0K6cCiCkNFJ>M*8'm/,Ri"':ILrF!,*WStISl.Lh@`&.#+>fg5E6:beVg[nG/XUDeB`JDJ59NQ)7B,QKMqtD_h\eGlt>#-uZmIc67[g/Mjd])]h=7c=Ve5\?U+2o(#otthDDtertGqejg6VO(Tfh=5%$'`d8T"S?g2prP;Mu-7(K@%%g$m0d@FWpbeS7PmD~>
endstream
endobj
246 0 obj
@@ -1568,53 +1568,71 @@
/MediaBox [ 0 0 612 792 ]
/Resources 3 0 R
/Contents 245 0 R
+/Annots 247 0 R
>>
endobj
247 0 obj
-<< /Length 182 /Filter [ /ASCII85Decode /FlateDecode ]
- >>
-stream
-Gas3+57>=^&-_S%5/iLBoXrA^FtW":+:-Z=5qseh9ei-phIr`<,.B]&4at)"e]+=;1&;07!sip15uFgubDN)aJ&B052s*@u4JL`Mg;A?-:GX5+dC_9e<!#PA6gnY_3CfXFFkP#I9_m,TZ%Ospk*jTW<$&f&B1W'a2,!><-M+LEq+=G6UG??~>
-endstream
+[
+248 0 R
+249 0 R
+250 0 R
+251 0 R
+252 0 R
+253 0 R
+254 0 R
+]
endobj
248 0 obj
-<< /Type /Page
-/Parent 1 0 R
-/MediaBox [ 0 0 612 792 ]
-/Resources 3 0 R
-/Contents 247 0 R
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 345.52 637.683 367.18 627.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://uffi.b9.com)
+/S /URI >>
+/H /I
>>
endobj
249 0 obj
-<< /Length 1022 /Filter [ /ASCII85Decode /FlateDecode ]
- >>
-stream
-Gat%"gMYb"%"6H'k\Y1A.)+nSpFU5`TL1GABXV>_qk,ohU<Sf_>=k-qT6uQuUiSEs#]qJW4=!A<2m^om4p1n<;&"Ub3qC(,j9*a+Hp@et!><A5+:;^rn9ct8F"S9gpE^X]PeoEN(a)KJ0Zd)?O$e1Ae1(.qnb="sO(3:S+#8`dm5J2-[me2Xs:4..P+32iN0e9jkrA42I?Qi$Z8K,+[*B2&&BJkA9p%n8Np1qp"b`LFdWK+#fs_BQ,KH?#U"fNn$"-Z\2q#\*#nf_'BA?%<MDJN,,>97F/m[r0Y]XXt0sZs^r;",oP\6;1\N/%+LAKL0.J)&rhM][AjUSkM%V.c<FDM-(a)Z#JkGV9=tWQR=]VPP8b.aU4$#kHo4(FD)$Sph_Fc%Mq7[)6g&og%]6i2J&,jb$c*'JdV%3KcL\Eq_F<?`q+HpWJE1@3e"2gH3HP$[72[d+(O4-nfYI`+DWSDC#K;I99#u=R+jA9k[aU@co-b>fn8]IPTkST_-i.LG!67ZbBgOb)M$[POq9'WoIOG_7O)4rTPVNKo+\ssR!/bc+(CRBr658u89WR^B>"kT*IU!ePIY>58rp1XYdmi'XY+)2NT-BJd?V9=(g/Pkr./B)idjCBe9Y1bhE8c==-MmWJa,OVtj\Ij]n\'cC4Hp=&T#e<'iY\GWjh-a#902.OBjNP9j:+'Rm@=`*(]Q9`]MADLeSS.hNZA46&JmBSrVHaST-#-,K,Ft^G*Hb5HgT6:G'dZIe-=f=iVj0bl#Usm*T:+Ec>](5sOV+mfCO_>Sc$^F2NN2!i<sb5)@+i'J92Xt`Il6k'&.aqS\7W1N&8[s.AeYKs4N-,X>k2`;fN,:rLN<oJ9PTL>EEo[Xmp37U32057+<lq@k"OnKp0g@NX4,@`pX\l3j@:a^@+o=C50JLqXhQ]<<]Mh#Xt10gDQe8l\-dJ^E\"l,*k@W\TrVk,J)mA?eIT"6YNAKXk!>+iA+EU$4gQUt84T:B2m_Os"MsTPEsJ>/?f)pWI?7lR?2ako:J":~>
-endstream
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 373.595 637.683 444.155 627.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://uffi.b9.com)
+/S /URI >>
+/H /I
+>>
endobj
250 0 obj
-<< /Type /Page
-/Parent 1 0 R
-/MediaBox [ 0 0 612 792 ]
-/Resources 3 0 R
-/Contents 249 0 R
-/Annots 251 0 R
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 582.79 626.683 614.47 616.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
>>
endobj
251 0 obj
-[
-252 0 R
-253 0 R
-254 0 R
-]
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 626.66 626.683 641.1 616.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
+>>
endobj
252 0 obj
<< /Type /Annot
/Subtype /Link
-/Rect [ 345.52 637.683 367.18 627.683 ]
+/Rect [ 120.0 615.683 280.52 605.683 ]
/C [ 0 0 0 ]
/Border [ 0 0 0 ]
-/A << /URI (http://uffi.b9.com)
+/A << /URI (http://www.sourceforge.net/projects/cclan)
/S /URI >>
/H /I
>>
@@ -1622,10 +1640,10 @@
253 0 obj
<< /Type /Annot
/Subtype /Link
-/Rect [ 628.87 626.683 660.55 616.683 ]
+/Rect [ 156.67 604.683 172.22 594.683 ]
/C [ 0 0 0 ]
/Border [ 0 0 0 ]
-/A << /URI (http://www.sourceforge.net/projects/cclan)
+/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp)
/S /URI >>
/H /I
>>
@@ -1633,7 +1651,7 @@
254 0 obj
<< /Type /Annot
/Subtype /Link
-/Rect [ 178.61 604.683 194.16 594.683 ]
+/Rect [ 178.05 604.683 440.79 594.683 ]
/C [ 0 0 0 ]
/Border [ 0 0 0 ]
/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp)
@@ -1642,10 +1660,10 @@
>>
endobj
255 0 obj
-<< /Length 286 /Filter [ /ASCII85Decode /FlateDecode ]
+<< /Length 280 /Filter [ /ASCII85Decode /FlateDecode ]
>>
stream
-GarVI4)]a*&Dm@9D@Am;T3oANU/7[j,]?6ZJfq?%\95m>IpYQp5Ua5*e(sc.]?H@t>QC*I8HbEL0Xq\t(()5IP^uS-WauU9L%FH5EVFh=s!%4Bo+e&.O9JMn:*Sad6Rt__:7nQAq9%R*#e#QR0\tfNY3`8p[Z4X#q77uTQhSWuMM5Dd]L47gf5dZ=@X!Gf=/3Buh5=<BAmEQ!^F`ag;tTe;/BEgaqJ\BAV&g'@ID0IO/s]$Ca:Yb/Hj)AfOj'n`@7g!T2k;*/L7&ZrqRFspj?LXV@-.~>
+GarVI]afWJ&Dm9u2p,Oq5;7s,UROh6F[-#*#uI``q">Jf5_uu4bMDo6GDSeiPQMRYME'f4&\&tk`#",h(a)0.p9YnA5D)GZ2rAY7;m]`Ycp5'X%08j(3'#8(NQ6V2iC(k5PbFbR@`!A#[Z]BLMf20j!(['ai+_Ne81r4HZkJku<mrAg7mQkK#CF_B$2mqtVhU".j/B-Z1_F'IP.em,6^\M(a)7Ln&E,lX[\B?X8;3M.Bs$'A)`V$TL;;7kW.$DaoCpd1H;(W-5@RcY/hIU!Qcp$l2~>
endstream
endobj
256 0 obj
@@ -2227,21 +2245,29 @@
/BaseFont /Courier
/Encoding /WinAnsiEncoding >>
endobj
+332 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F7
+/BaseFont /Times-Bold
+/Encoding /WinAnsiEncoding >>
+endobj
1 0 obj
<< /Type /Pages
-/Count 62
-/Kids [6 0 R 8 0 R 10 0 R 12 0 R 121 0 R 140 0 R 142 0 R 144 0 R 146 0 R 148 0 R 150 0 R 152 0 R 154 0 R 156 0 R 158 0 R 160 0 R 162 0 R 164 0 R 166 0 R 168 0 R 170 0 R 172 0 R 174 0 R 176 0 R 178 0 R 180 0 R 182 0 R 184 0 R 186 0 R 188 0 R 190 0 R 192 0 R 194 0 R 196 0 R 198 0 R 200 0 R 202 0 R 204 0 R 206 0 R 208 0 R 210 0 R 212 0 R 214 0 R 216 0 R 218 0 R 220 0 R 222 0 R 224 0 R 226 0 R 228 0 R 230 0 R 232 0 R 234 0 R 236 0 R 238 0 R 240 0 R 242 0 R 244 0 R 246 0 R 248 0 R 250 0 R 256 0 R ] >>
+/Count 60
+/Kids [6 0 R 8 0 R 10 0 R 12 0 R 121 0 R 140 0 R 142 0 R 144 0 R 146 0 R 148 0 R 150 0 R 152 0 R 154 0 R 156 0 R 158 0 R 160 0 R 162 0 R 164 0 R 166 0 R 168 0 R 170 0 R 172 0 R 174 0 R 176 0 R 178 0 R 180 0 R 182 0 R 184 0 R 186 0 R 188 0 R 190 0 R 192 0 R 194 0 R 196 0 R 198 0 R 200 0 R 202 0 R 204 0 R 206 0 R 208 0 R 210 0 R 212 0 R 214 0 R 216 0 R 218 0 R 220 0 R 222 0 R 224 0 R 226 0 R 228 0 R 230 0 R 232 0 R 234 0 R 236 0 R 238 0 R 240 0 R 242 0 R 244 0 R 246 0 R 256 0 R ] >>
endobj
2 0 obj
<< /Type /Catalog
/Pages 1 0 R
/Outlines 257 0 R
/PageMode /UseOutlines
+ /Names << /Dests << /Names [ (preface) [ 140 0 R /XYZ 115.0 725.0 null ] (introduction) [ 142 0 R /XYZ 115.0 725.0 null ] (notes) [ 146 0 R /XYZ 115.0 725.0 null ] (ref_declarations) [ 150 0 R /XYZ 115.0 725.0 null ] (primitives) [ 154 0 R /XYZ 115.0 725.0 null ] (aggregates) [ 162 0 R /XYZ 115.0 725.0 null ] (objects) [ 182 0 R /XYZ 115.0 725.0 null ] (strings) [ 216 0 R /XYZ 115.0 725.0 null ] (func_libr) [ 234 0 R /XYZ 115.0 725.0 null ] (installation) [ 246 0 R /XYZ 115.0 725.0 null ] (glossary) [ 256 0 R /XYZ 115.0 725.0 null ] (id2254977) [ 10 0 R /XYZ 115.0 725.0 null ] ] >> >>
>>
endobj
3 0 obj
<<
-/Font << /F3 325 0 R /F5 326 0 R /F10 327 0 R /F6 329 0 R /F1 328 0 R /F4 330 0 R /F9 331 0 R >>
+/Font << /F3 325 0 R /F5 326 0 R /F10 327 0 R /F6 329 0 R /F1 328 0 R /F4 330 0 R /F9 331 0 R /F7 332 0 R >>
/ProcSet [ /PDF /ImageC /Text ] >>
endobj
15 0 obj
@@ -2349,7 +2375,7 @@
49 0 obj
<<
/S /GoTo
-/D [null /XYZ 0.0 0.0 null]
+/D [150 0 R /XYZ 115.0 725.0 null]
>>
endobj
51 0 obj
@@ -2361,7 +2387,7 @@
53 0 obj
<<
/S /GoTo
-/D [154 0 R /XYZ 115.0 678.347 null]
+/D [154 0 R /XYZ 115.0 725.0 null]
>>
endobj
55 0 obj
@@ -2385,7 +2411,7 @@
61 0 obj
<<
/S /GoTo
-/D [162 0 R /XYZ 115.0 678.347 null]
+/D [162 0 R /XYZ 115.0 725.0 null]
>>
endobj
63 0 obj
@@ -2433,7 +2459,7 @@
77 0 obj
<<
/S /GoTo
-/D [182 0 R /XYZ 115.0 678.347 null]
+/D [182 0 R /XYZ 115.0 725.0 null]
>>
endobj
79 0 obj
@@ -2517,7 +2543,7 @@
105 0 obj
<<
/S /GoTo
-/D [216 0 R /XYZ 115.0 678.347 null]
+/D [216 0 R /XYZ 115.0 725.0 null]
>>
endobj
107 0 obj
@@ -2547,61 +2573,61 @@
115 0 obj
<<
/S /GoTo
-/D [230 0 R /XYZ 115.0 725.0 null]
+/D [228 0 R /XYZ 115.0 725.0 null]
>>
endobj
117 0 obj
<<
/S /GoTo
-/D [232 0 R /XYZ 115.0 725.0 null]
+/D [230 0 R /XYZ 115.0 725.0 null]
>>
endobj
119 0 obj
<<
/S /GoTo
-/D [234 0 R /XYZ 115.0 725.0 null]
+/D [232 0 R /XYZ 115.0 725.0 null]
>>
endobj
124 0 obj
<<
/S /GoTo
-/D [236 0 R /XYZ 115.0 725.0 null]
+/D [234 0 R /XYZ 115.0 725.0 null]
>>
endobj
126 0 obj
<<
/S /GoTo
-/D [238 0 R /XYZ 115.0 725.0 null]
+/D [236 0 R /XYZ 115.0 725.0 null]
>>
endobj
128 0 obj
<<
/S /GoTo
-/D [242 0 R /XYZ 115.0 725.0 null]
+/D [240 0 R /XYZ 115.0 725.0 null]
>>
endobj
130 0 obj
<<
/S /GoTo
-/D [246 0 R /XYZ 115.0 725.0 null]
+/D [244 0 R /XYZ 115.0 725.0 null]
>>
endobj
132 0 obj
<<
/S /GoTo
-/D [250 0 R /XYZ 115.0 725.0 null]
+/D [246 0 R /XYZ 115.0 725.0 null]
>>
endobj
134 0 obj
<<
/S /GoTo
-/D [250 0 R /XYZ 115.0 687.009 null]
+/D [246 0 R /XYZ 115.0 687.009 null]
>>
endobj
136 0 obj
<<
/S /GoTo
-/D [250 0 R /XYZ 115.0 599.683 null]
+/D [246 0 R /XYZ 115.0 599.683 null]
>>
endobj
138 0 obj
@@ -2634,345 +2660,346 @@
>>
endobj
xref
-0 332
+0 333
0000000000 65535 f
-0000086303 00000 n
-0000086846 00000 n
-0000086939 00000 n
+0000087336 00000 n
+0000087863 00000 n
+0000088550 00000 n
0000000015 00000 n
0000000071 00000 n
-0000000352 00000 n
-0000000458 00000 n
-0000001520 00000 n
-0000001626 00000 n
-0000001787 00000 n
-0000001894 00000 n
-0000003922 00000 n
-0000004045 00000 n
-0000004446 00000 n
-0000087092 00000 n
-0000004582 00000 n
-0000087158 00000 n
-0000004718 00000 n
-0000087224 00000 n
-0000004854 00000 n
-0000087292 00000 n
-0000004990 00000 n
-0000087360 00000 n
-0000005126 00000 n
-0000087428 00000 n
-0000005262 00000 n
-0000087496 00000 n
-0000005398 00000 n
-0000087564 00000 n
-0000005534 00000 n
-0000087630 00000 n
-0000005670 00000 n
-0000087696 00000 n
-0000005806 00000 n
-0000087764 00000 n
-0000005942 00000 n
-0000087832 00000 n
-0000006078 00000 n
-0000087900 00000 n
-0000006214 00000 n
-0000087968 00000 n
-0000006350 00000 n
-0000088036 00000 n
-0000006486 00000 n
-0000088103 00000 n
-0000006622 00000 n
-0000088171 00000 n
-0000006758 00000 n
-0000088239 00000 n
-0000006894 00000 n
-0000088298 00000 n
-0000007030 00000 n
-0000088364 00000 n
-0000007166 00000 n
-0000088432 00000 n
-0000007302 00000 n
-0000088498 00000 n
-0000007438 00000 n
-0000088564 00000 n
-0000007574 00000 n
-0000088630 00000 n
-0000007710 00000 n
-0000088698 00000 n
-0000007846 00000 n
-0000088764 00000 n
-0000007982 00000 n
-0000088830 00000 n
-0000008118 00000 n
-0000088896 00000 n
-0000008254 00000 n
-0000088962 00000 n
-0000008389 00000 n
-0000089028 00000 n
-0000008525 00000 n
-0000089094 00000 n
-0000008661 00000 n
-0000089160 00000 n
-0000008796 00000 n
-0000089228 00000 n
-0000008932 00000 n
-0000089294 00000 n
-0000009068 00000 n
-0000089360 00000 n
-0000009204 00000 n
-0000089426 00000 n
-0000009340 00000 n
-0000089492 00000 n
-0000009476 00000 n
-0000089558 00000 n
-0000009611 00000 n
-0000089624 00000 n
-0000009747 00000 n
-0000089690 00000 n
-0000009883 00000 n
-0000089756 00000 n
-0000010019 00000 n
-0000089822 00000 n
-0000010155 00000 n
-0000089888 00000 n
-0000010291 00000 n
-0000089954 00000 n
-0000010429 00000 n
-0000090021 00000 n
-0000010567 00000 n
-0000090088 00000 n
-0000010705 00000 n
-0000090157 00000 n
-0000010843 00000 n
-0000090224 00000 n
-0000010981 00000 n
-0000090291 00000 n
-0000011119 00000 n
-0000090358 00000 n
-0000011257 00000 n
-0000090425 00000 n
-0000011394 00000 n
-0000090492 00000 n
-0000011530 00000 n
-0000090559 00000 n
-0000011666 00000 n
-0000012265 00000 n
-0000012391 00000 n
-0000012476 00000 n
-0000090626 00000 n
-0000012610 00000 n
-0000090693 00000 n
-0000012744 00000 n
-0000090760 00000 n
-0000012878 00000 n
-0000090827 00000 n
-0000013012 00000 n
-0000090894 00000 n
-0000013146 00000 n
-0000090961 00000 n
-0000013280 00000 n
-0000091030 00000 n
-0000013414 00000 n
-0000091099 00000 n
-0000013548 00000 n
-0000014206 00000 n
-0000014316 00000 n
-0000016365 00000 n
-0000016475 00000 n
-0000017651 00000 n
-0000017761 00000 n
-0000020167 00000 n
-0000020277 00000 n
-0000020735 00000 n
-0000020845 00000 n
-0000021401 00000 n
-0000021511 00000 n
-0000022412 00000 n
-0000022522 00000 n
-0000023804 00000 n
-0000023914 00000 n
-0000024967 00000 n
-0000025077 00000 n
-0000025901 00000 n
-0000026011 00000 n
-0000027198 00000 n
-0000027308 00000 n
-0000027688 00000 n
-0000027798 00000 n
-0000029585 00000 n
-0000029695 00000 n
-0000030019 00000 n
-0000030129 00000 n
-0000031265 00000 n
-0000031375 00000 n
-0000032223 00000 n
-0000032333 00000 n
-0000033243 00000 n
-0000033353 00000 n
-0000034114 00000 n
-0000034224 00000 n
-0000035421 00000 n
-0000035531 00000 n
-0000035870 00000 n
-0000035980 00000 n
-0000036961 00000 n
-0000037071 00000 n
-0000037465 00000 n
-0000037575 00000 n
-0000038630 00000 n
-0000038740 00000 n
-0000039424 00000 n
-0000039534 00000 n
-0000040883 00000 n
-0000040993 00000 n
-0000041909 00000 n
-0000042019 00000 n
-0000042717 00000 n
-0000042827 00000 n
-0000043949 00000 n
-0000044059 00000 n
-0000044387 00000 n
-0000044497 00000 n
-0000045663 00000 n
-0000045773 00000 n
-0000046880 00000 n
-0000046990 00000 n
-0000047770 00000 n
-0000047880 00000 n
-0000048625 00000 n
-0000048735 00000 n
-0000049250 00000 n
-0000049360 00000 n
-0000051132 00000 n
-0000051242 00000 n
-0000051585 00000 n
-0000051695 00000 n
-0000053137 00000 n
-0000053247 00000 n
-0000053943 00000 n
-0000054053 00000 n
-0000056145 00000 n
-0000056255 00000 n
-0000056624 00000 n
-0000056734 00000 n
-0000057542 00000 n
-0000057652 00000 n
-0000058457 00000 n
-0000058567 00000 n
-0000059308 00000 n
-0000059418 00000 n
-0000060548 00000 n
-0000060658 00000 n
-0000060926 00000 n
-0000061036 00000 n
-0000062117 00000 n
-0000062227 00000 n
-0000062953 00000 n
-0000063063 00000 n
-0000064038 00000 n
-0000064148 00000 n
-0000064439 00000 n
-0000064549 00000 n
-0000066018 00000 n
-0000066128 00000 n
-0000066456 00000 n
-0000066566 00000 n
-0000068176 00000 n
-0000068286 00000 n
-0000068622 00000 n
-0000068732 00000 n
-0000070127 00000 n
-0000070237 00000 n
-0000070512 00000 n
-0000070622 00000 n
-0000071738 00000 n
-0000071864 00000 n
-0000071909 00000 n
-0000072080 00000 n
-0000072274 00000 n
-0000072494 00000 n
-0000072873 00000 n
-0000091166 00000 n
-0000091220 00000 n
+0000000363 00000 n
+0000000469 00000 n
+0000001525 00000 n
+0000001631 00000 n
+0000001792 00000 n
+0000001899 00000 n
+0000003924 00000 n
+0000004047 00000 n
+0000004448 00000 n
+0000088715 00000 n
+0000004584 00000 n
+0000088781 00000 n
+0000004720 00000 n
+0000088847 00000 n
+0000004856 00000 n
+0000088915 00000 n
+0000004992 00000 n
+0000088983 00000 n
+0000005128 00000 n
+0000089051 00000 n
+0000005264 00000 n
+0000089119 00000 n
+0000005400 00000 n
+0000089187 00000 n
+0000005536 00000 n
+0000089253 00000 n
+0000005672 00000 n
+0000089319 00000 n
+0000005808 00000 n
+0000089387 00000 n
+0000005944 00000 n
+0000089455 00000 n
+0000006080 00000 n
+0000089523 00000 n
+0000006216 00000 n
+0000089591 00000 n
+0000006352 00000 n
+0000089659 00000 n
+0000006488 00000 n
+0000089726 00000 n
+0000006624 00000 n
+0000089794 00000 n
+0000006760 00000 n
+0000089862 00000 n
+0000006896 00000 n
+0000089928 00000 n
+0000007032 00000 n
+0000089994 00000 n
+0000007168 00000 n
+0000090060 00000 n
+0000007304 00000 n
+0000090126 00000 n
+0000007440 00000 n
+0000090192 00000 n
+0000007576 00000 n
+0000090258 00000 n
+0000007712 00000 n
+0000090324 00000 n
+0000007848 00000 n
+0000090390 00000 n
+0000007984 00000 n
+0000090456 00000 n
+0000008120 00000 n
+0000090522 00000 n
+0000008256 00000 n
+0000090588 00000 n
+0000008391 00000 n
+0000090654 00000 n
+0000008527 00000 n
+0000090720 00000 n
+0000008663 00000 n
+0000090786 00000 n
+0000008798 00000 n
+0000090852 00000 n
+0000008934 00000 n
+0000090918 00000 n
+0000009070 00000 n
+0000090984 00000 n
+0000009206 00000 n
+0000091050 00000 n
+0000009342 00000 n
+0000091116 00000 n
+0000009478 00000 n
+0000091182 00000 n
+0000009613 00000 n
+0000091248 00000 n
+0000009749 00000 n
+0000091314 00000 n
+0000009885 00000 n
+0000091380 00000 n
+0000010021 00000 n
+0000091446 00000 n
+0000010157 00000 n
+0000091512 00000 n
+0000010293 00000 n
+0000091578 00000 n
+0000010431 00000 n
+0000091645 00000 n
+0000010569 00000 n
+0000091712 00000 n
+0000010707 00000 n
+0000091779 00000 n
+0000010845 00000 n
+0000091846 00000 n
+0000010983 00000 n
+0000091913 00000 n
+0000011121 00000 n
+0000091980 00000 n
+0000011259 00000 n
+0000092047 00000 n
+0000011396 00000 n
+0000092114 00000 n
+0000011532 00000 n
+0000092181 00000 n
+0000011668 00000 n
+0000012297 00000 n
+0000012423 00000 n
+0000012508 00000 n
+0000092248 00000 n
+0000012642 00000 n
+0000092315 00000 n
+0000012776 00000 n
+0000092382 00000 n
+0000012910 00000 n
+0000092449 00000 n
+0000013044 00000 n
+0000092516 00000 n
+0000013178 00000 n
+0000092583 00000 n
+0000013312 00000 n
+0000092652 00000 n
+0000013446 00000 n
+0000092721 00000 n
+0000013580 00000 n
+0000014239 00000 n
+0000014349 00000 n
+0000016398 00000 n
+0000016508 00000 n
+0000017682 00000 n
+0000017792 00000 n
+0000020198 00000 n
+0000020308 00000 n
+0000020766 00000 n
+0000020876 00000 n
+0000021431 00000 n
+0000021541 00000 n
+0000022465 00000 n
+0000022575 00000 n
+0000023859 00000 n
+0000023969 00000 n
+0000025037 00000 n
+0000025147 00000 n
+0000025980 00000 n
+0000026090 00000 n
+0000027295 00000 n
+0000027405 00000 n
+0000027786 00000 n
+0000027896 00000 n
+0000029730 00000 n
+0000029840 00000 n
+0000030101 00000 n
+0000030211 00000 n
+0000031361 00000 n
+0000031471 00000 n
+0000032434 00000 n
+0000032544 00000 n
+0000033472 00000 n
+0000033582 00000 n
+0000034353 00000 n
+0000034463 00000 n
+0000035683 00000 n
+0000035793 00000 n
+0000036122 00000 n
+0000036232 00000 n
+0000037226 00000 n
+0000037336 00000 n
+0000037730 00000 n
+0000037840 00000 n
+0000038906 00000 n
+0000039016 00000 n
+0000039714 00000 n
+0000039824 00000 n
+0000041191 00000 n
+0000041301 00000 n
+0000042234 00000 n
+0000042344 00000 n
+0000043055 00000 n
+0000043165 00000 n
+0000044326 00000 n
+0000044436 00000 n
+0000044702 00000 n
+0000044812 00000 n
+0000045998 00000 n
+0000046108 00000 n
+0000047225 00000 n
+0000047335 00000 n
+0000048126 00000 n
+0000048236 00000 n
+0000048996 00000 n
+0000049106 00000 n
+0000049631 00000 n
+0000049741 00000 n
+0000051407 00000 n
+0000051517 00000 n
+0000051851 00000 n
+0000051961 00000 n
+0000053450 00000 n
+0000053560 00000 n
+0000054224 00000 n
+0000054334 00000 n
+0000056530 00000 n
+0000056640 00000 n
+0000057076 00000 n
+0000057186 00000 n
+0000058005 00000 n
+0000058115 00000 n
+0000058941 00000 n
+0000059051 00000 n
+0000059810 00000 n
+0000059920 00000 n
+0000061075 00000 n
+0000061185 00000 n
+0000062279 00000 n
+0000062389 00000 n
+0000063134 00000 n
+0000063244 00000 n
+0000064238 00000 n
+0000064348 00000 n
+0000064639 00000 n
+0000064749 00000 n
+0000066260 00000 n
+0000066370 00000 n
+0000066636 00000 n
+0000066746 00000 n
+0000068631 00000 n
+0000068741 00000 n
+0000069079 00000 n
+0000069189 00000 n
+0000070604 00000 n
+0000070714 00000 n
+0000071856 00000 n
+0000071982 00000 n
+0000072059 00000 n
+0000072230 00000 n
+0000072403 00000 n
+0000072597 00000 n
+0000072790 00000 n
0000072983 00000 n
-0000091286 00000 n
-0000073187 00000 n
-0000073388 00000 n
-0000073530 00000 n
-0000073808 00000 n
-0000073935 00000 n
-0000074095 00000 n
-0000074344 00000 n
-0000074507 00000 n
-0000074640 00000 n
-0000074785 00000 n
-0000075092 00000 n
-0000075391 00000 n
-0000075530 00000 n
-0000075684 00000 n
-0000075799 00000 n
-0000076135 00000 n
-0000076415 00000 n
-0000076560 00000 n
-0000076841 00000 n
-0000091352 00000 n
-0000077055 00000 n
-0000077189 00000 n
-0000077321 00000 n
-0000077552 00000 n
-0000077708 00000 n
-0000077902 00000 n
-0000078051 00000 n
-0000078282 00000 n
-0000078414 00000 n
-0000078573 00000 n
-0000078755 00000 n
-0000078949 00000 n
-0000079149 00000 n
-0000079314 00000 n
-0000079452 00000 n
-0000079637 00000 n
-0000079858 00000 n
-0000080070 00000 n
-0000080282 00000 n
-0000080499 00000 n
-0000080688 00000 n
-0000080865 00000 n
-0000081089 00000 n
-0000081301 00000 n
-0000081501 00000 n
-0000081683 00000 n
-0000081911 00000 n
-0000082112 00000 n
-0000082286 00000 n
-0000082471 00000 n
-0000082675 00000 n
-0000082882 00000 n
-0000083054 00000 n
-0000083226 00000 n
-0000083486 00000 n
-0000083734 00000 n
-0000083956 00000 n
-0000084222 00000 n
-0000084379 00000 n
-0000084598 00000 n
-0000084802 00000 n
-0000085088 00000 n
-0000085251 00000 n
-0000085379 00000 n
-0000085513 00000 n
-0000085627 00000 n
-0000085738 00000 n
-0000085854 00000 n
-0000085963 00000 n
-0000086075 00000 n
-0000086196 00000 n
+0000073203 00000 n
+0000073423 00000 n
+0000073796 00000 n
+0000092788 00000 n
+0000092842 00000 n
+0000073906 00000 n
+0000092908 00000 n
+0000074110 00000 n
+0000074311 00000 n
+0000074453 00000 n
+0000074731 00000 n
+0000074858 00000 n
+0000075018 00000 n
+0000075267 00000 n
+0000075430 00000 n
+0000075563 00000 n
+0000075708 00000 n
+0000076015 00000 n
+0000076314 00000 n
+0000076453 00000 n
+0000076607 00000 n
+0000076722 00000 n
+0000077058 00000 n
+0000077338 00000 n
+0000077483 00000 n
+0000077764 00000 n
+0000092974 00000 n
+0000077978 00000 n
+0000078112 00000 n
+0000078244 00000 n
+0000078475 00000 n
+0000078631 00000 n
+0000078825 00000 n
+0000078974 00000 n
+0000079205 00000 n
+0000079337 00000 n
+0000079496 00000 n
+0000079678 00000 n
+0000079872 00000 n
+0000080072 00000 n
+0000080237 00000 n
+0000080375 00000 n
+0000080560 00000 n
+0000080781 00000 n
+0000080993 00000 n
+0000081205 00000 n
+0000081422 00000 n
+0000081611 00000 n
+0000081788 00000 n
+0000082012 00000 n
+0000082224 00000 n
+0000082424 00000 n
+0000082606 00000 n
+0000082834 00000 n
+0000083035 00000 n
+0000083209 00000 n
+0000083394 00000 n
+0000083598 00000 n
+0000083805 00000 n
+0000083977 00000 n
+0000084149 00000 n
+0000084409 00000 n
+0000084657 00000 n
+0000084879 00000 n
+0000085145 00000 n
+0000085302 00000 n
+0000085521 00000 n
+0000085725 00000 n
+0000086011 00000 n
+0000086174 00000 n
+0000086302 00000 n
+0000086436 00000 n
+0000086550 00000 n
+0000086661 00000 n
+0000086777 00000 n
+0000086886 00000 n
+0000086998 00000 n
+0000087119 00000 n
+0000087226 00000 n
trailer
<<
-/Size 332
+/Size 333
/Root 2 0 R
/Info 4 0 R
>>
startxref
-91421
+93043
%%EOF
Modified: branches/xml-class-rework/thirdparty/uffi/examples/Makefile
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/Makefile 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/Makefile 2006-10-22 16:42:37 UTC (rev 2025)
@@ -5,13 +5,10 @@
# Programer: Kevin M. Rosenberg
# Date Started: Mar 2002
#
-# CVS Id: $Id: Makefile,v 1.1 2004/06/23 08:27:10 hans Exp $
+# CVS Id: $Id$
#
-# This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
#
-# UFFI users are granted the rights to distribute and use this software
-# as governed by the terms of the Lisp Lesser GNU Public License
-# (http://opensource.franz.com/preamble.html), also known as the LLGPL.
SUBDIRS:=
Modified: branches/xml-class-rework/thirdparty/uffi/examples/Makefile.msvc
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/Makefile.msvc 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/Makefile.msvc 2006-10-22 16:42:37 UTC (rev 2025)
@@ -5,13 +5,9 @@
# Programer: Kevin M. Rosenberg
# Date Started: Mar 2002
#
-# CVS Id: $Id: Makefile.msvc,v 1.1 2004/06/23 08:27:10 hans Exp $
+# CVS Id: $Id$
#
-# This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-#
-# CLSQL users are granted the rights to distribute and use this software
-# as governed by the terms of the Lisp Lesser GNU Public License
-# (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
BASE=c-test-fns
Modified: branches/xml-class-rework/thirdparty/uffi/examples/acl-compat-tester.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/acl-compat-tester.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/acl-compat-tester.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -24,7 +24,7 @@
;; Place, Suite 330, Boston, MA 02111-1307 USA
;;
;;;; from the original ACL 6.1 sources:
-;; $Id: acl-compat-tester.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;; $Id$
(defpackage :util.test
Modified: branches/xml-class-rework/thirdparty/uffi/examples/arrays.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/arrays.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/arrays.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: arrays.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
@@ -21,7 +18,7 @@
(uffi:def-constant +column-length+ 10)
(uffi:def-constant +row-length+ 10)
-(uffi:def-foreign-type long-ptr '(* :long))
+(uffi:def-foreign-type long-ptr (* :long))
(defun test-array-1d ()
"Tests vector"
Modified: branches/xml-class-rework/thirdparty/uffi/examples/atoifl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/atoifl.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/atoifl.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: atoifl.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.c
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.c 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.c 2006-10-22 16:42:37 UTC (rev 2025)
@@ -6,14 +6,10 @@
* Programer: Kevin M. Rosenberg
* Date Started: Mar 2002
*
- * CVS Id: $Id: c-test-fns.c,v 1.1 2004/06/23 08:27:10 hans Exp $
+ * CVS Id: $Id$
*
- * This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+ * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
*
- * UFFI users are granted the rights to distribute and use this software
- * as governed by the terms of the Lisp Lesser GNU Public License
- * (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-
* These variables are correct for GCC
* you'll need to modify these for other compilers
***************************************************************************/
Modified: branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/c-test-fns.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: c-test-fns.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/compress.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/compress.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/compress.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: compress.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/file-socket.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/file-socket.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/file-socket.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Jul 2002
;;;;
-;;;; $Id: file-socket.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/getenv.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/getenv.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/getenv.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: getenv.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/gethostname.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/gethostname.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/gethostname.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: gethostname.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/getshells.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/getshells.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/getshells.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: getshells.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/gettime.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/gettime.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/gettime.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: gettime.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/run-examples.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/run-examples.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/run-examples.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: run-examples.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
#-uffi (asdf:oos 'asdf:load-op :uffi)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/strtol.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/strtol.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/strtol.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: strtol.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/test-examples.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/test-examples.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/test-examples.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: test-examples.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
#-uffi (asdf:oos 'asdf:load-op :uffi)
Modified: branches/xml-class-rework/thirdparty/uffi/examples/union.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/examples/union.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/examples/union.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: union.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
@@ -69,7 +66,7 @@
#\A
:test #'eql
:fail-info "Error with union character")
- #-(or sparc sparc-v9 mcl)
+ #-(or sparc sparc-v9 openmcl digitool)
;; (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
;; t
;; :fail-info
Modified: branches/xml-class-rework/thirdparty/uffi/src/aggregates.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/aggregates.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/aggregates.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: aggregates.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
@@ -45,7 +42,7 @@
#+lispworks `((fli:define-c-typedef ,enum-name :int))
#+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
#+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
- #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
+ #+digitool `((def-mcl-type ,enum-name :integer))
#+openmcl `((ccl::def-foreign-type ,enum-name :int))
(nreverse constants)))
cmds))
@@ -64,7 +61,7 @@
#+sbcl
`(sb-alien:define-alien-type ,name-array
(* ,(convert-from-uffi-type type :array)))
- #+(and mcl (not openmcl))
+ #+digitool
`(def-mcl-type ,name-array '(:array ,type))
#+openmcl
`(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
@@ -79,9 +76,9 @@
(if (eq type :pointer-self)
#+(or cmu scl) `((* (alien:struct ,name)))
#+sbcl `((* (sb-alien:struct ,name)))
- #+mcl `((:* (:struct ,name)))
+ #+(or openmcl digitool) `((:* (:struct ,name)))
#+lispworks `((:pointer ,name))
- #-(or cmu sbcl scl mcl lispworks) `((* ,name))
+ #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
`(,(convert-from-uffi-type type :struct))))))
(if variant
(push (list def) processed)
@@ -98,7 +95,7 @@
`(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
#+lispworks
`(fli:define-c-struct ,name ,@(process-struct-fields name fields))
- #+(and mcl (not openmcl))
+ #+digitool
`(ccl:defrecord ,name ,@(process-struct-fields name fields))
#+openmcl
`(ccl::def-foreign-type
@@ -117,15 +114,15 @@
`(alien:slot ,obj ,slot)
#+sbcl
`(sb-alien:slot ,obj ,slot)
- #+mcl
+ #+(or openmcl digitool)
`(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
)
-#+mcl
+#+(or openmcl digitool)
(defmacro set-slot-value (obj type slot value) ;use setf to set values
`(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
-#+mcl
+#+(or openmcl digitool)
(defsetf get-slot-value set-slot-value)
@@ -139,42 +136,54 @@
`(alien:slot ,obj ,slot)
#+sbcl
`(sb-alien:slot ,obj ,slot)
- #+(and mcl (not openmcl))
+ #+digitool
`(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
#+openmcl
`(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
)
-; so we could allow '(:array :long) or deref with other type like :long only
-#+mcl
-(defun array-type (type)
- (let ((result type))
- (when (listp type)
- (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
- (when (and (listp type-list) (eq (car type-list) :array))
- (setf result (cadr type-list)))))
- result))
-
-
-(defmacro deref-array (obj type i)
- "Returns a field from a row"
- #+(or lispworks cmu sbcl scl) (declare (ignore type))
- #+(or cmu scl) `(alien:deref ,obj ,i)
- #+sbcl `(sb-alien:deref ,obj ,i)
- #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)
- #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
- #+mcl
- (let* ((array-type (array-type type))
- (local-type (convert-from-uffi-type array-type :allocation))
- (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
- `(,accessor
- ,obj
- (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
- )
-
+;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8
+;; below
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; so we could allow '(:array :long) or deref with other type like :long only
+ #+(or openmcl digitool)
+ (defun array-type (type)
+ (let ((result type))
+ (when (listp type)
+ (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
+ (when (and (listp type-list) (eq (car type-list) :array))
+ (setf result (cadr type-list)))))
+ result))
+
+
+ (defmacro deref-array (obj type i)
+ "Returns a field from a row"
+ #+(or lispworks cmu sbcl scl) (declare (ignore type))
+ #+(or cmu scl) `(alien:deref ,obj ,i)
+ #+sbcl `(sb-alien:deref ,obj ,i)
+ #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)
+ #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
+ #+openmcl
+ (let* ((array-type (array-type type))
+ (local-type (convert-from-uffi-type array-type :allocation))
+ (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
+ (ccl::%foreign-access-form
+ obj
+ (ccl::%foreign-type-or-record local-type)
+ `(* ,i ,element-size-in-bits)
+ nil))
+ #+digitool
+ (let* ((array-type (array-type type))
+ (local-type (convert-from-uffi-type array-type :allocation))
+ (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
+ `(,accessor
+ ,obj
+ (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
+ ))
+
; this expands to the %set-xx functions which has different params than %put-xx
-#+mcl
+#+digitool
(defmacro deref-array-set (obj type i value)
(let* ((array-type (array-type type))
(local-type (convert-from-uffi-type array-type :allocation))
@@ -185,7 +194,7 @@
(* (the fixnum ,i) ,(size-of-foreign-type local-type))
,value)))
-#+mcl
+#+digitool
(defsetf deref-array deref-array-set)
(defmacro def-union (name &rest fields)
@@ -197,9 +206,57 @@
`(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
#+sbcl
`(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
- #+(and mcl (not openmcl))
+ #+digitool
`(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
#+openmcl
`(ccl::def-foreign-type nil
(:union ,name ,@(process-struct-fields name fields)))
)
+
+
+#-(or sbcl cmu)
+(defun convert-from-foreign-usb8 (s len)
+ (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+ (fixnum len))
+ (let ((a (make-array len :element-type '(unsigned-byte 8))))
+ (dotimes (i len a)
+ (declare (fixnum i))
+ (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (sb-ext:without-package-locks
+ (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+ (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
+ (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
+ (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+ 0))
+ (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+ sb-vm:n-byte-bits
+ 1))))
+
+
+#+sbcl
+(defun convert-from-foreign-usb8 (s len)
+ (let ((sap (sb-alien:alien-sap s)))
+ (declare (type sb-sys:system-area-pointer sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((result (make-array len :element-type '(unsigned-byte 8))))
+ (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+ (* len +system-copy-multiplier+))
+ result))))
+
+#+cmu
+(defun convert-from-foreign-usb8 (s len)
+ (let ((sap (alien:alien-sap s)))
+ (declare (type system:system-area-pointer sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((result (make-array len :element-type '(unsigned-byte 8))))
+ (kernel:copy-from-system-area sap 0
+ result (* vm:vector-data-offset
+ vm:word-bits)
+ (* len vm:byte-bits))
+ result))))
Modified: branches/xml-class-rework/thirdparty/uffi/src/corman/getenv-ccl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/corman/getenv-ccl.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/corman/getenv-ccl.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,8 @@
;;;; Programmer: "Joe Marshall" <prunesquallor(a)attbi.com>
;;;; Date Started: Feb 2002
;;;;
-`;;;; $Id: getenv-ccl.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :cl-user)
Modified: branches/xml-class-rework/thirdparty/uffi/src/functions.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/functions.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/functions.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,25 +7,22 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: functions.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
(defun process-function-args (args)
(if (null args)
- #+(or lispworks cmu sbcl scl cormanlisp (and mcl (not openmcl))) nil
+ #+(or lispworks cmu sbcl scl cormanlisp digitool) nil
#+allegro '(:void)
#+openmcl (values nil nil)
;; args not null
- #+(or lispworks allegro cmu sbcl scl (and mcl (not openmcl)) cormanlisp)
+ #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
(let (processed)
(dolist (arg args)
(push (process-one-function-arg arg) processed))
@@ -48,8 +45,9 @@
(let ((name (car arg))
(type (convert-from-uffi-type (cadr arg) :routine)))
#+(or cmu sbcl scl)
- (list name type :in)
- #+(or allegro lispworks (and mcl (not openmcl)))
+ ;(list name type :in)
+ `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
+ #+(or allegro lispworks digitool)
(if (and (listp type) (listp (car type)))
(append (list name) type)
(list name type))
@@ -63,10 +61,116 @@
(list type)
type))
+(defun funcallable-lambda-list (args)
+ (let ((ll nil))
+ (dolist (arg args)
+ (push (car arg) ll))
+ (nreverse ll)))
+
+#|
+(defmacro def-funcallable (name args &key returning)
+ (let ((result-type (convert-from-uffi-type returning :return))
+ (function-args (process-function-args args)))
+ #+lispworks
+ `(fli:define-foreign-funcallable ,name ,function-args
+ :result-type ,result-type
+ :language :ansi-c
+ :calling-convention :cdecl)
+ #+(or cmu scl sbcl)
+ ;; requires the type of the function pointer be declared correctly!
+ (let* ((ptrsym (gensym))
+ (ll (funcallable-lambda-list args)))
+ `(defun ,name ,(cons ptrsym ll)
+ (alien::alien-funcall ,ptrsym ,@ll)))
+ #+openmcl
+ (multiple-value-bind (params args) (process-function-args args)
+ (let ((ptrsym (gensym)))
+ `(defun ,name ,(cons ptrsym params)
+ (ccl::ff-call ,ptrsym ,@args ,result-type))))
+ #+allegro
+ ;; this is most definitely wrong
+ (let* ((ptrsym (gensym))
+ (ll (funcallable-lambda-list args)))
+ `(defun ,name ,(cons ptrsym ll)
+ (system::ff-funcall ,ptrsym ,@ll)))
+ ))
+|#
+
+(defun convert-lispworks-args (args)
+ (loop for arg in args
+ with processed = nil
+ do
+ (if (and (= (length arg) 3) (eq (third arg) :out))
+ (push (list (first arg)
+ (list :reference-return (second arg))) processed)
+ (push (subseq arg 0 2) processed))
+ finally (return processed)))
+
+(defun preprocess-names (names)
+ (let ((fname (gensym)))
+ (if (atom names)
+ (values (list names fname) fname (uffi::make-lisp-name names))
+ (values (list (first names) fname) fname (second names)))))
+
+(defun preprocess-args (args)
+ (loop for arg in args
+ with lisp-args = nil and out = nil and processed = nil
+ do
+ (if (= (length arg) 3)
+ (ecase (third arg)
+ (:in
+ (progn
+ (push (first arg) lisp-args)
+ (push (list (first arg) (second arg)) processed)))
+ (:out
+ (progn
+ (push (list (first arg) (second arg)) out)
+ (push (list (first arg) (list '* (second arg))) processed))))
+ (progn
+ (push (first arg) lisp-args)
+ (push arg processed)))
+ finally (return (values (nreverse lisp-args)
+ (nreverse out)
+ (nreverse processed)))))
+
+
+(defmacro def-function (names args &key module returning)
+ (multiple-value-bind (lisp-args out processed)
+ (preprocess-args args)
+ (declare (ignorable lisp-args processed))
+ (if (= (length out) 0)
+ `(%def-function ,names ,args
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+
+ #+(or cmu scl sbcl)
+ `(%def-function ,names ,args
+ ,@(if returning (list :returning returning) (values)))
+ #+lispworks
+ `(%def-function ,names ,(convert-lispworks-args args)
+ ,@(if module (list :module module) (values))
+ ,@(if returning (list :returning returning) (values)))
+ #-(or cmu scl sbcl lispworks)
+ (multiple-value-bind (name-pair fname lisp-name)
+ (preprocess-names names)
+ `(prog1
+ (%def-function ,name-pair ,processed
+ :module ,module :returning ,returning)
+ ;(declaim (inline ,fname))
+ (defun ,lisp-name ,lisp-args
+ (with-foreign-objects ,out
+ (values (,fname ,@(mapcar #'first args))
+ ,@(mapcar #'(lambda (arg)
+ (list 'deref-pointer
+ (first arg)
+ (second arg))) out))))))
+ )))
+
+
;; name is either a string representing foreign name, or a list
;; of foreign-name as a string and lisp name as a symbol
-(defmacro def-function (names args &key module returning)
- #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
+(defmacro %def-function (names args &key module returning)
+ #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))
(let* ((result-type (convert-from-uffi-type returning :return))
(function-args (process-function-args args))
@@ -94,8 +198,8 @@
,@(if module (list :module module) (values))
:result-type ,result-type
:language :ansi-c
- :calling-convention :cdecl)
- #+(and mcl (not openmcl))
+ #+:win32 :calling-convention #+:win32 :cdecl)
+ #+digitool
`(eval-when (:compile-toplevel :load-toplevel :execute)
(ccl:define-entry-point (,lisp-name ,foreign-name)
,function-args
@@ -117,10 +221,5 @@
))
-(defun make-lisp-name (name)
- (let ((converted (substitute #\- #\_ name)))
- (intern
- #+case-sensitive converted
- #-case-sensitive (string-upcase converted))))
Modified: branches/xml-class-rework/thirdparty/uffi/src/libraries.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/libraries.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/libraries.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,10 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: libraries.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
@@ -23,9 +20,9 @@
(defun default-foreign-library-type ()
"Returns string naming default library type for platform"
- #+(or win32 mswindows) "dll"
+ #+(or win32 cygwin mswindows) "dll"
#+(or macosx darwin ccl-5.0) "dylib"
- #-(or win32 mswindows macosx darwin ccl-5.0) "so"
+ #-(or win32 cygwin mswindows macosx darwin ccl-5.0) "so"
)
(defun foreign-library-types ()
@@ -35,7 +32,7 @@
#-(or win32 mswindows macosx darwin ccl-5.0) '("so" "a" "o")
)
-(defun find-foreign-library (names directories &key types drive-letters)
+(defun find-foreign-library (names directories &key types drive-letters)
"Looks for a foreign library. directories can be a single
string or a list of strings of candidate directories. Use default
library type if type is not specified."
@@ -56,21 +53,21 @@
(dolist (name names)
(dolist (dir directories)
(dolist (type types)
- (let ((path (make-pathname
+ (let ((path (make-pathname
#+lispworks :host
#+lispworks (when drive-letter drive-letter)
#-lispworks :device
#-lispworks (when drive-letter drive-letter)
- :name name
+ :name name
:type type
- :directory
+ :directory
(etypecase dir
(pathname
(pathname-directory dir))
(list
dir)
(string
- (pathname-directory
+ (pathname-directory
(parse-namestring dir)))))))
(when (probe-file path)
(return-from find-foreign-library path)))))))
@@ -79,13 +76,19 @@
(defun load-foreign-library (filename &key module supporting-libraries
force-load)
- #+(or allegro mcl) (declare (ignore module supporting-libraries))
- #+(or cmu scl sbcl) (declare (ignore module))
-
- (when (and filename (probe-file filename))
- (if (pathnamep filename) ;; ensure filename is a string to check if
- (setq filename (namestring filename))) ; already loaded
+ #+(or allegro openmcl digitool sbcl) (declare (ignore module supporting-libraries))
+ #+(or cmu scl) (declare (ignore module))
+ #+lispworks (declare (ignore supporting-libraries))
+ (when (and filename (or (null (pathname-directory filename))
+ (probe-file filename)))
+ (if (pathnamep filename) ;; ensure filename is a string to check if already loaded
+ (setq filename (namestring (if (null (pathname-directory filename))
+ filename
+ ;; lispworks treats as UNC, so use truename
+ #+(and lispworks win32) (truename filename)
+ #-(and lispworks win32) filename))))
+
(if (and (not force-load)
(find filename *loaded-libraries* :test #'string-equal))
t ;; return T, but don't reload library
@@ -94,31 +97,29 @@
(let ((type (pathname-type (parse-namestring filename))))
(if (string-equal type "so")
(sys::load-object-file filename)
- (alien:load-foreign filename
+ (alien:load-foreign filename
:libraries
(convert-supporting-libraries-to-string
supporting-libraries))))
#+scl
(let ((type (pathname-type (parse-namestring filename))))
- (alien:load-foreign filename
+ (alien:load-foreign filename
:libraries
(convert-supporting-libraries-to-string
supporting-libraries)))
#+sbcl
- (let ((type (pathname-type (parse-namestring filename))))
- (if (or (string-equal type "so")
- (string-equal type "bundle")
- (string-equal type "dylib"))
- (sb-alien::load-1-foreign filename)
- (sb-alien:load-foreign filename
- :libraries
- (convert-supporting-libraries-to-string
- supporting-libraries))))
- #+lispworks (fli:register-module module :real-name filename)
+ (handler-case (sb-alien::load-1-foreign filename)
+ (sb-int:unsupported-operator (c)
+ (if (fboundp (intern "LOAD-SHARED-OBJECT" :sb-alien))
+ (funcall (intern "LOAD-SHARED-OBJECT" :sb-alien) filename)
+ (error c))))
+
+ #+lispworks (fli:register-module module :real-name filename
+ :connection-style :immediate)
#+allegro (load filename)
#+openmcl (ccl:open-shared-library filename)
- #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t)
-
+ #+digitool (ccl:add-to-shared-library-search-path filename t)
+
(push filename *loaded-libraries*)
t))))
Modified: branches/xml-class-rework/thirdparty/uffi/src/objects.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/objects.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/objects.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,32 +7,29 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: objects.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
-(defun size-of-foreign-type (type)
- #+lispworks (fli:size-of type)
- #+allegro (ff:sizeof-fobject type)
- #+(or cmu scl) (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
- #+sbcl (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes
- #+clisp (values (ffi:size-of type))
- #+(and mcl (not openmcl))
- (let ((mcl-type (ccl:find-mactype type nil t)))
- (if mcl-type
- (ccl::mactype-record-size mcl-type)
- (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record
- #+openmcl (ccl::%foreign-type-or-record-size type :bytes)
- )
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun size-of-foreign-type (type)
+ #+lispworks (fli:size-of type)
+ #+allegro (ff:sizeof-fobject type)
+ #+(or cmu scl) (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
+ #+sbcl (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes
+ #+clisp (values (ffi:size-of type))
+ #+digitool
+ (let ((mcl-type (ccl:find-mactype type nil t)))
+ (if mcl-type
+ (ccl::mactype-record-size mcl-type)
+ (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record
+ #+openmcl (ccl::%foreign-type-or-record-size type :bytes)
+ ))
-
(defmacro allocate-foreign-object (type &optional (size :unspecified))
"Allocates an instance of TYPE. If size is specified, then allocate
an array of TYPE with size SIZE. The TYPE parameter is evaluated."
@@ -46,7 +43,7 @@
`(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
#+allegro
`(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c)
- #+mcl
+ #+(or openmcl digitool)
`(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
)
(progn
@@ -58,7 +55,7 @@
`(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size)
#+allegro
`(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c)
- #+mcl
+ #+(or openmcl digitool)
`(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
)))
@@ -71,7 +68,7 @@
`(fli:free-foreign-object ,obj)
#+allegro
`(ff:free-fobject ,obj)
- #+mcl
+ #+(or openmcl digitool)
`(dispose-ptr ,obj)
)
@@ -80,25 +77,35 @@
#+allegro `(zerop ,obj)
#+(or cmu scl) `(alien:null-alien ,obj)
#+sbcl `(sb-alien:null-alien ,obj)
- #+mcl `(ccl:%null-ptr-p ,obj)
+ #+(or openmcl digitool) `(ccl:%null-ptr-p ,obj)
)
(defmacro make-null-pointer (type)
- #+(or allegro mcl) (declare (ignore type))
+ #+(or allegro openmcl digitool) (declare (ignore type))
#+(or cmu scl) `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
#+sbcl `(sb-alien:sap-alien (sb-sys:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
#+lispworks `(fli:make-pointer :address 0 :type (quote ,(convert-from-uffi-type (eval type) :type)))
#+allegro 0
- #+mcl `(ccl:%null-ptr)
+ #+(or openmcl digitool) `(ccl:%null-ptr)
)
+(defmacro make-pointer (addr type)
+ #+(or allegro openmcl digitool) (declare (ignore type))
+ #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+ #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+ #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type)))
+ #+allegro addr
+ #+(or openmcl digitool) `(ccl:%int-to-ptr ,addr)
+ )
+
+
(defmacro char-array-to-pointer (obj)
#+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
#+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
#+lispworks `(fli:make-pointer :type '(:unsigned :char)
:address (fli:pointer-address ,obj))
#+allegro obj
- #+mcl obj
+ #+(or openmcl digitool) obj
)
(defmacro deref-pointer (ptr type)
@@ -108,35 +115,33 @@
#+sbcl `(sb-alien:deref ,ptr)
#+lispworks `(fli:dereference ,ptr)
#+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) :c ,ptr)
- #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
+ #+(or openmcl digitool) `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
)
-#+mcl
+#+digitool
(defmacro deref-pointer-set (ptr type value)
`(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
-#+mcl
+#+digitool
(defsetf deref-pointer deref-pointer-set)
-#+lispworks
(defmacro ensure-char-character (obj)
- `(if (characterp ,obj) ,obj (code-char ,obj)))
+ #+(or digitool) obj
+ #+(or allegro cmu sbcl scl openmcl) `(code-char ,obj)
+ ;; lispworks varies whether deref'ing array vs. slot access of a char
+ #+lispworks `(if (characterp ,obj) ,obj (code-char ,obj)))
-#+(and mcl (not openmcl))
-(defmacro ensure-char-character (obj)
- obj)
-
-#+(or allegro cmu sbcl scl openmcl)
-(defmacro ensure-char-character (obj)
- `(code-char ,obj))
-
-#+(or lispworks (and mcl (not openmcl)))
(defmacro ensure-char-integer (obj)
- `(char-code ,obj))
+ #+(or digitool) `(char-code ,obj)
+ #+(or allegro cmu sbcl scl openmcl) obj
+ ;; lispworks varies whether deref'ing array vs. slot access of a char
+ #+lispworks
+ `(if (integerp ,obj) ,obj (char-code ,obj)))
-#+(or allegro cmu sbcl scl openmcl)
-(defmacro ensure-char-integer (obj)
- obj)
+(defmacro ensure-char-storable (obj)
+ #+(or digitool (and lispworks (not lispworks5))) obj
+ #+(or allegro cmu lispworks5 openmcl sbcl scl)
+ `(char-code ,obj))
(defmacro pointer-address (obj)
#+(or cmu scl)
@@ -147,12 +152,12 @@
`(fli:pointer-address ,obj)
#+allegro
obj
- #+mcl
- `(ccl:%ptr-to-int ,obj)
+ #+(or openmcl digitool)
+ `(ccl:%ptr-to-int ,obj)
)
;; TYPE is evaluated.
-#-mcl
+#-(or openmcl digitool)
(defmacro with-foreign-object ((var type) &rest body)
#-(or cmu sbcl lispworks scl) ; default version
`(let ((,var (allocate-foreign-object ,type)))
@@ -160,22 +165,32 @@
(progn ,@body)
(free-foreign-object ,var)))
#+(or cmu scl)
- (let ((obj (gensym)))
- `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
- (let ((,var (alien:addr ,obj)))
- ,@body)))
+ (let ((obj (gensym))
+ (ctype (convert-from-uffi-type (eval type) :allocate)))
+ (if (and (consp ctype) (eq 'array (car ctype)))
+ `(alien:with-alien ((,obj ,ctype))
+ (let* ((,var ,obj))
+ ,@body))
+ `(alien:with-alien ((,obj ,ctype))
+ (let* ((,var (alien:addr ,obj)))
+ ,@body))))
#+sbcl
- (let ((obj (gensym)))
- `(sb-alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
- (let ((,var (sb-alien:addr ,obj)))
- ,@body)))
+ (let ((obj (gensym))
+ (ctype (convert-from-uffi-type (eval type) :allocate)))
+ (if (and (consp ctype) (eq 'array (car ctype)))
+ `(sb-alien:with-alien ((,obj ,ctype))
+ (let* ((,var ,obj))
+ ,@body))
+ `(sb-alien:with-alien ((,obj ,ctype))
+ (let* ((,var (sb-alien:addr ,obj)))
+ ,@body))))
#+lispworks
`(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
(eval type) :allocate)))
,@body)
)
-#-mcl
+#-(or openmcl digitool)
(defmacro with-foreign-objects (bindings &rest body)
(if bindings
`(with-foreign-object ,(car bindings)
@@ -183,7 +198,7 @@
,@body))
`(progn ,@body)))
-#+mcl
+#+(or openmcl digitool)
(defmacro with-foreign-objects (bindings &rest body)
(let ((params nil) type count)
(dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
@@ -195,10 +210,10 @@
(setf type (nth 1 type)))
(push (list (first spec) (* count (size-of-foreign-type type))) params))
`(ccl:%stack-block ,params ,@body)))
-
-#+mcl
+
+#+(or openmcl digitool)
(defmacro with-foreign-object ((var type) &rest body)
- `(with-foreign-objects ((,var ,type))
+ `(with-foreign-objects ((,var ,type))
,@body))
#+lispworks
@@ -216,18 +231,24 @@
,pointer (* ,(convert-from-uffi-type (eval type) :type)))))
,@body))
-#+allegro
+#+(or allegro openmcl)
(defmacro with-cast-pointer ((binding-name pointer type) &body body)
(declare (ignore type))
`(let ((,binding-name ,pointer))
,@body))
-#-(or lispworks cmu scl sbcl allegro)
+#-(or lispworks cmu scl sbcl allegro openmcl)
(defmacro with-cast-pointer ((binding-name pointer type) &body body)
- (declare (ignore binding-name pointer type))
+ (declare (ignore binding-name pointer type body))
'(error "WITH-CAST-POINTER not (yet) implemented for ~A"
(lisp-implementation-type)))
+#+(or allegro openmcl)
+(defun convert-external-name (name)
+ "Add an underscore to NAME if necessary for the ABI."
+ #+(or macosx darwinppc-target) (concatenate 'string "_" name)
+ #-(or macosx darwinppc-target) name)
+
(defmacro def-foreign-var (names type module)
#-lispworks (declare (ignore module))
(let ((foreign-name (if (atom names) names (first names)))
@@ -241,7 +262,7 @@
#+allegro
`(define-symbol-macro ,lisp-name
(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref))
- :c (ff:get-entry-point ,foreign-name)))
+ :c (ff:get-entry-point ,(convert-external-name foreign-name))))
#+lispworks
`(progn
(fli:define-foreign-variable (,lisp-name ,foreign-name)
@@ -250,7 +271,21 @@
:module ,module)
(define-symbol-macro ,lisp-name (fli:dereference (,lisp-name)
:copy-foreign-object nil)))
- #-(or allegro cmu scl sbcl lispworks)
+ #+openmcl
`(define-symbol-macro ,lisp-name
+ (deref-pointer (ccl:foreign-symbol-address
+ ,(convert-external-name foreign-name)) ,var-type))
+ #-(or allegro cmu scl sbcl lispworks openmcl)
+ `(define-symbol-macro ,lisp-name
'(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
(lisp-implementation-type)))))
+
+
+;;; Define a special variable, like DEFVAR, that will be initialized
+;;; to a pointer which may need to be reset when a saved image is
+;;; loaded. This is needed for OpenMCL, which sets pointers to "dead
+;;; macptrs" when a saved image is loaded.
+;; This may possibly be needed for sbcl's SAVE-LISP-AND-DIE
+(defmacro def-pointer-var (name value &optional doc)
+ #-openmcl `(defvar ,name ,value ,@(if doc (list doc)))
+ #+openmcl `(ccl::defloadvar ,name ,value ,doc))
Modified: branches/xml-class-rework/thirdparty/uffi/src/os.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/os.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/os.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -5,21 +5,32 @@
;;;; Name: os.lisp
;;;; Purpose: Operating system interface for UFFI
;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Sep 2002
+;;;; Date Started: Sep 2002
;;;;
-;;;; $Id: os.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg.
-;;;; Much of this code was taken from other open source project and copyright
-;;;; for that code is noted below where appropriate.
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg.
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
+
+(defun getenv (var)
+ "Return the value of the environment variable."
+ #+allegro (sys::getenv (string var))
+ #+clisp (sys::getenv (string var))
+ #+cmu (cdr (assoc (string var) ext:*environment-list* :test #'equalp
+ :key #'string))
+ #+gcl (si:getenv (string var))
+ #+lispworks (lw:environment-variable (string var))
+ #+lucid (lcl:environment-variable (string var))
+ #+(or openmcl digitool) (ccl::getenv var)
+ #+sbcl (sb-ext:posix-getenv var)
+ #-(or allegro clisp cmu gcl lispworks lucid openmcl digitool sbcl)
+ (error 'not-implemented :proc (list 'getenv var)))
+
+
;; modified from function ASDF -- Copyright Dan Barlow and Contributors
(defun run-shell-command (control-string &rest args &key output)
@@ -32,27 +43,27 @@
(let ((command (apply #'format nil control-string args)))
#+sbcl
(sb-impl::process-exit-code
- (sb-ext:run-program
+ (sb-ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output output))
-
+
#+(or cmu scl)
(ext:process-exit-code
- (ext:run-program
+ (ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output output))
#+allegro
(excl:run-shell-command command :input nil :output output)
-
+
#+lispworks
(system:call-system-showing-output
command
:shell-type "/bin/sh"
:output-stream output)
-
+
#+clisp ;XXX not exactly *trace-output*, I know
(ext:run-shell-command command :output :terminal :wait t)
@@ -64,5 +75,5 @@
:wait t)))
#-(or openmcl clisp lispworks allegro scl cmu sbcl)
- (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+ (error "RUN-SHELL-PROGRAM not implemented for this Lisp.")
))
Modified: branches/xml-class-rework/thirdparty/uffi/src/package.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/package.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/package.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,25 +7,22 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:cl-user)
(defpackage #:uffi
(:use #:cl)
- (:export
-
+ (:export
+
;; immediate types
#:def-constant
#:def-foreign-type
#:def-type
#:null-char-p
-
+
;; aggregate types
#:def-enum
#:def-struct
@@ -34,7 +31,7 @@
#:def-array-pointer
#:deref-array
#:def-union
-
+
;; objects
#:allocate-foreign-object
#:free-foreign-object
@@ -45,13 +42,18 @@
#:deref-pointer
#:ensure-char-character
#:ensure-char-integer
+ #:ensure-char-storable
#:null-pointer-p
#:make-null-pointer
+ #:make-pointer
+ #:pointer-address
#:+null-cstring-pointer+
#:char-array-to-pointer
#:with-cast-pointer
#:def-foreign-var
-
+ #:convert-from-foreign-usb8
+ #:def-pointer-var
+
;; string functions
#:convert-from-cstring
#:convert-to-cstring
@@ -62,7 +64,9 @@
#:convert-to-foreign-string
#:allocate-foreign-string
#:with-foreign-string
-
+ #:with-foreign-strings
+ #:foreign-string-length
+
;; function call
#:def-function
@@ -70,9 +74,11 @@
#:find-foreign-library
#:load-foreign-library
#:default-foreign-library-type
+ #:foreign-library-types
;; OS
#:run-shell-command
+ #:getenv
))
Modified: branches/xml-class-rework/thirdparty/uffi/src/primitives.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/primitives.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/primitives.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,21 +7,18 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: primitives.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
-#+mcl
+#+(or openmcl digitool)
(defvar *keyword-package* (find-package "KEYWORD"))
-#+mcl
+#+(or openmcl digitool)
; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
; So this provides a function to convert any quoted symbols to keywords.
(defun keyword (obj)
@@ -39,7 +36,7 @@
obj)))
; Wrapper for unexported function we have to use
-#+(and mcl (not openmcl))
+#+digitool
(defmacro def-mcl-type (name type)
`(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
@@ -53,8 +50,8 @@
(defmacro def-type (name type)
"Generates a (deftype) statement for CL. Currently, only CMUCL
supports takes advantage of this optimization."
- #+(or lispworks allegro mcl cormanlisp) (declare (ignore type))
- #+(or lispworks allegro mcl cormanlisp) `(deftype ,name () t)
+ #+(or lispworks allegro openmcl digitool cormanlisp) (declare (ignore type))
+ #+(or lispworks allegro openmcl digitool cormanlisp) `(deftype ,name () t)
#+(or cmu scl)
`(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
#+sbcl
@@ -71,11 +68,11 @@
#+(or cmu scl) `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
#+sbcl `(sb-alien:define-alien-type ,name ,(convert-from-uffi-type type :type))
#+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
- #+mcl
+ #+(or openmcl digitool)
(let ((mcl-type (convert-from-uffi-type type :type)))
(unless (or (keywordp mcl-type) (consp mcl-type))
(setf mcl-type `(quote ,mcl-type)))
- #+(and mcl (not openmcl))
+ #+digitool
`(def-mcl-type ,(keyword name) ,mcl-type)
#+openmcl
`(ccl::def-foreign-type ,(keyword name) ,mcl-type))
@@ -87,9 +84,6 @@
(make-hash-table :size 20 :test #'eq))
)
-#+(or cmu sbcl scl)
-(defvar *cmu-sbcl-def-type-list* nil)
-
#+(or cmu scl)
(defvar *cmu-sbcl-def-type-list*
'((:char . (alien:signed 8))
@@ -100,12 +94,16 @@
(:unsigned-short . (alien:unsigned 16))
(:int . (alien:signed 32))
(:unsigned-int . (alien:unsigned 32))
- (:long . (alien:signed 32))
- (:unsigned-long . (alien:unsigned 32))
+ #-x86-64 (:long . (alien:signed 32))
+ #-x86-64 (:unsigned-long . (alien:unsigned 32))
+ #+x86-64 (:long . (alien:signed 64))
+ #+x86-64 (:unsigned-long . (alien:unsigned 64))
(:float . alien:single-float)
(:double . alien:double-float)
+ (:void . t)
)
"Conversions in CMUCL for def-foreign-type are different than in def-function")
+
#+sbcl
(defvar *cmu-sbcl-def-type-list*
'((:char . (sb-alien:signed 8))
@@ -116,10 +114,13 @@
(:unsigned-short . (sb-alien:unsigned 16))
(:int . (sb-alien:signed 32))
(:unsigned-int . (sb-alien:unsigned 32))
- (:long . (sb-alien:signed 32))
- (:unsigned-long . (sb-alien:unsigned 32))
+ #-x86-64 (:long . (sb-alien:signed 32))
+ #-x86-64 (:unsigned-long . (sb-alien:unsigned 32))
+ #+x86-64 (:long . (sb-alien:signed 64))
+ #+x86-64 (:unsigned-long . (sb-alien:unsigned 64))
(:float . sb-alien:single-float)
(:double . sb-alien:double-float)
+ (:void . t)
)
"Conversions in SBCL for def-foreign-type are different than in def-function")
@@ -145,14 +146,15 @@
(setq *type-conversion-list*
'((* . *) (:void . sb-alien:void)
(:pointer-void . (* t))
- (:cstring . sb-alien:c-string)
+ #-sb-unicode(:cstring . sb-alien:c-string)
+ #+sb-unicode(:cstring . sb-alien:utf8-string)
(:char . sb-alien:char)
(:unsigned-char . (sb-alien:unsigned 8))
(:byte . (sb-alien:signed 8))
(:unsigned-byte . (sb-alien:unsigned 8))
(:short . sb-alien:short)
(:unsigned-short . sb-alien:unsigned-short)
- (:int . sb-alien:integer) (:unsigned-int . sb-alien:unsigned-int)
+ (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int)
(:long . sb-alien:long) (:unsigned-long . sb-alien:unsigned-long)
(:float . sb-alien:float) (:double . sb-alien:double)
(:array . sb-alien:array)))
@@ -192,7 +194,7 @@
(:float . :float) (:double . :double)
(:array . :c-array)))
-#+(and mcl (not openmcl))
+#+digitool
(setq *type-conversion-list*
'((* . :pointer) (:void . :void)
(:short . :short) (:unsigned-short . :unsigned-short)
@@ -232,8 +234,8 @@
(let ((found-type (gethash type +type-conversion-hash+)))
(if found-type
found-type
- #-mcl type
- #+mcl (keyword type))))
+ #-(or openmcl digitool) type
+ #+(or openmcl digitool) (keyword type))))
(defun %convert-from-uffi-type (type context)
"Converts from a uffi type to an implementation specific type"
@@ -253,7 +255,7 @@
((and (eq context :return)
(eq type :cstring))
(basic-convert-from-uffi-type :cstring-returning))
- #+(and mcl (not openmcl))
+ #+digitool
((and (eq type :void) (eq context :return)) nil)
(t
(basic-convert-from-uffi-type type)))
@@ -262,16 +264,20 @@
(cl:quote
(convert-from-uffi-type (cadr type) context))
(:struct-pointer
- #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
- #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct)
+ #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+ #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
)
(:struct
- #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
- #-mcl (%convert-from-uffi-type (cadr type) :struct)
+ #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+ #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)
)
- (t
- (cons (%convert-from-uffi-type (first type) context)
- (%convert-from-uffi-type (rest type) context)))))))
+ (:union
+ #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
+ #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)
+ )
+ (t
+ (cons (%convert-from-uffi-type (first type) context)
+ (%convert-from-uffi-type (rest type) context)))))))
(defun convert-from-uffi-type (type context)
(let ((result (%convert-from-uffi-type type context)))
@@ -282,7 +288,24 @@
(if (eq context :struct)
(append '(:*) (cdr result))
:address))
- #+(and mcl (not openmcl))
+ #+digitool
((and (eq (car result) :pointer) (eq context :allocation) :pointer))
(t result))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (char= #\a (schar (symbol-name '#:a) 0))
+ (pushnew :uffi-lowercase-reader *features*))
+ (when (not (string= (symbol-name '#:a)
+ (symbol-name '#:A)))
+ (pushnew :uffi-case-sensitive *features*)))
+
+(defun make-lisp-name (name)
+ (let ((converted (substitute #\- #\_ name)))
+ (intern
+ #+uffi-case-sensitive converted
+ #+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
+ #+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq cl:*features* (delete :uffi-lowercase-reader *features*))
+ (setq cl:*features* (delete :uffi-case-sensitive *features*)))
Modified: branches/xml-class-rework/thirdparty/uffi/src/readmacros-mcl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/readmacros-mcl.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/readmacros-mcl.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,24 +7,21 @@
;;;; Programmer: Kevin M. Rosenberg/John Desoi
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: readmacros-mcl.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:uffi)
;; trap macros don't work right directly in the macros
-#+(and mcl (not openmcl))
+#+digitool
(defun new-ptr (size)
(#_NewPtr size))
-#+(and mcl (not openmcl))
+#+digitool
(defun dispose-ptr (ptr)
(#_DisposePtr ptr))
Modified: branches/xml-class-rework/thirdparty/uffi/src/strings.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/src/strings.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/src/strings.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,36 +7,32 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: strings.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;; *************************************************************************
(in-package #:uffi)
-(defvar +null-cstring-pointer+
+(def-pointer-var +null-cstring-pointer+
#+(or cmu sbcl scl) nil
#+allegro 0
#+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
- #+mcl (ccl:%null-ptr)
+ #+(or openmcl digitool) (ccl:%null-ptr)
)
(defmacro convert-from-cstring (obj)
"Converts a string from a c-call. Same as convert-from-foreign-string, except
that LW/CMU automatically converts strings from c-calls."
#+(or cmu sbcl lispworks scl) obj
- #+allegro
+ #+allegro
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (zerop ,stored)
nil
- (values (excl:native-to-string ,stored)))))
- #+mcl
+ (values (excl:native-to-string ,stored)))))
+ #+(or openmcl digitool)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (ccl:%null-ptr-p ,stored)
@@ -47,41 +43,53 @@
(defmacro convert-to-cstring (obj)
#+(or cmu sbcl scl lispworks) obj
#+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
- #+mcl
- `(if (null ,obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,obj)))))
- (ccl::%put-cstring ptr ,obj)
- ptr))
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (null ,stored)
+ 0
+ (values (excl:string-to-native ,stored)))))
+ #+(or openmcl digitool)
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (null ,stored)
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,stored)))))
+ (ccl::%put-cstring ptr ,stored)
+ ptr))))
)
(defmacro free-cstring (obj)
#+(or cmu sbcl scl lispworks) (declare (ignore obj))
#+allegro
- `(unless (zerop ,obj)
- (ff:free-fobject ,obj))
- #+mcl
- `(unless (ccl:%null-ptr-p ,obj)
- (dispose-ptr ,obj))
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (unless (zerop ,stored)
+ (ff:free-fobject ,stored))))
+ #+(or openmcl digitool)
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (unless (ccl:%null-ptr-p ,stored)
+ (dispose-ptr ,stored))))
)
(defmacro with-cstring ((cstring lisp-string) &body body)
#+(or cmu sbcl scl lispworks)
- `(let ((,cstring ,lisp-string)) ,@body)
+ `(let ((,cstring ,lisp-string)) ,@body)
#+allegro
- (let ((acl-native (gensym)))
- `(excl:with-native-string (,acl-native ,lisp-string)
- (let ((,cstring (if ,lisp-string ,acl-native 0)))
- ,@body)))
- #+mcl
- `(if (stringp ,lisp-string)
- (ccl:with-cstrs ((,cstring ,lisp-string))
- ,@body)
- (let ((,cstring +null-cstring-pointer+))
- ,@body))
+ (let ((acl-native (gensym))
+ (stored-lisp-string (gensym)))
+ `(let ((,stored-lisp-string ,lisp-string))
+ (excl:with-native-string (,acl-native ,stored-lisp-string)
+ (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
+ ,@body))))
+ #+(or openmcl digitool)
+ (let ((stored-lisp-string (gensym)))
+ `(let ((,stored-lisp-string ,lisp-string))
+ (if (stringp ,stored-lisp-string)
+ (ccl:with-cstrs ((,cstring ,stored-lisp-string))
+ ,@body)
+ (let ((,cstring +null-cstring-pointer+))
+ ,@body))))
)
(defmacro with-cstrings (bindings &rest body)
@@ -95,134 +103,179 @@
(defmacro convert-to-foreign-string (obj)
#+lispworks
- `(if (null ,obj)
- +null-cstring-pointer+
- (fli:convert-to-foreign-string ,obj :external-format '(:latin-1 :eol-style :lf)))
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (null ,stored)
+ +null-cstring-pointer+
+ (fli:convert-to-foreign-string
+ ,stored
+ :external-format '(:latin-1 :eol-style :lf)))))
#+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (null ,stored)
+ 0
+ (values (excl:string-to-native ,stored)))))
#+(or cmu scl)
(let ((size (gensym))
(storage (gensym))
+ (stored-obj (gensym))
(i (gensym)))
- `(etypecase ,obj
- (null
- (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
- (string
- (let* ((,size (length ,obj))
- (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
- (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (,i ,size)
- (declare (fixnum ,i))
- (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
+ `(let ((,stored-obj ,obj))
+ (etypecase ,stored-obj
+ (null
+ (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+ (string
+ (let* ((,size (length ,stored-obj))
+ (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
+ (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (dotimes (,i ,size)
+ (declare (fixnum ,i))
+ (setf (alien:deref ,storage ,i)
+ (char-code (char ,stored-obj ,i))))
(setf (alien:deref ,storage ,size) 0))
- ,storage))))
+ ,storage)))))
#+sbcl
(let ((size (gensym))
(storage (gensym))
+ (stored-obj (gensym))
(i (gensym)))
- `(etypecase ,obj
- (null
- (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
- (string
- (let* ((,size (length ,obj))
- (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
- (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (,i ,size)
- (declare (fixnum ,i))
- (setf (sb-alien:deref ,storage ,i) (char-code (char ,obj ,i))))
- (setf (sb-alien:deref ,storage ,size) 0))
- ,storage))))
- #+mcl
- `(if (null ,obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,obj)))))
- (ccl::%put-cstring ptr ,obj)
- ptr))
+ `(let ((,stored-obj ,obj))
+ (etypecase ,stored-obj
+ (null
+ (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+ (string
+ (let* ((,size (length ,stored-obj))
+ (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
+ (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (dotimes (,i ,size)
+ (declare (fixnum ,i))
+ (setf (sb-alien:deref ,storage ,i)
+ (char-code (char ,stored-obj ,i))))
+ (setf (sb-alien:deref ,storage ,size) 0))
+ ,storage)))))
+ #+(or openmcl digitool)
+ (let ((stored-obj (gensym)))
+ `(let ((,stored-obj ,obj))
+ (if (null ,stored-obj)
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
+ (ccl::%put-cstring ptr ,stored-obj)
+ ptr))))
)
-
;; Either length or null-terminated-p must be non-nil
(defmacro convert-from-foreign-string (obj &key
length
(locale :default)
(null-terminated-p t))
#+allegro
- `(if (zerop ,obj)
- nil
- (if (eq ,locale :none)
- (fast-native-to-string ,obj ,length)
- (excl:native-to-string
- ,obj
- ,@(when length (list :length length))
- :truncate (not ,null-terminated-p))))
+ (let ((stored-obj (gensym)))
+ `(let ((,stored-obj ,obj))
+ (if (zerop ,stored-obj)
+ nil
+ (if (eq ,locale :none)
+ (fast-native-to-string ,stored-obj ,length)
+ (values
+ (excl:native-to-string
+ ,stored-obj
+ ,@(when length (list :length length))
+ :truncate (not ,null-terminated-p)))))))
#+lispworks
- `(if (fli:null-pointer-p ,obj)
- nil
- (if (eq ,locale :none)
- (fast-native-to-string ,obj ,length)
- (fli:convert-from-foreign-string
- ,obj
- ,@(when length (list :length length))
- :null-terminated-p ,null-terminated-p
- :external-format '(:latin-1 :eol-style :lf))))
+ (let ((stored-obj (gensym)))
+ `(let ((,stored-obj ,obj))
+ (if (fli:null-pointer-p ,stored-obj)
+ nil
+ (if (eq ,locale :none)
+ (fast-native-to-string ,stored-obj ,length)
+ (fli:convert-from-foreign-string
+ ,stored-obj
+ ,@(when length (list :length length))
+ :null-terminated-p ,null-terminated-p
+ :external-format '(:latin-1 :eol-style :lf))))))
#+(or cmu scl)
- `(if (null-pointer-p ,obj)
- nil
- (cmucl-naturalize-cstring (alien:alien-sap ,obj)
- :length ,length
- :null-terminated-p ,null-terminated-p))
+ (let ((stored-obj (gensym)))
+ `(let ((,stored-obj ,obj))
+ (if (null-pointer-p ,stored-obj)
+ nil
+ (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
+ :length ,length
+ :null-terminated-p ,null-terminated-p))))
+
#+sbcl
- `(if (null-pointer-p ,obj)
- nil
- (sbcl-naturalize-cstring (sb-alien:alien-sap ,obj)
- :length ,length
- :null-terminated-p ,null-terminated-p))
- #+mcl
+ (let ((stored-obj (gensym)))
+ `(let ((,stored-obj ,obj))
+ (if (null-pointer-p ,stored-obj)
+ nil
+ (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
+ :length ,length
+ :null-terminated-p ,null-terminated-p))))
+ #+(or openmcl digitool)
(declare (ignore null-terminated-p))
- #+mcl
- `(if (ccl:%null-ptr-p ,obj)
- nil
- (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
+ #+(or openmcl digitool)
+ (let ((stored-obj (gensym)))
+ `(let ((,stored-obj ,obj))
+ (if (ccl:%null-ptr-p ,stored-obj)
+ nil
+ #+digitool (ccl:%get-cstring
+ ,stored-obj 0
+ ,@(if length (list length) nil))
+ #+openmcl ,@(if length
+ `((ccl:%str-from-ptr ,stored-obj ,length))
+ `((ccl:%get-cstring ,stored-obj))))))
)
(defmacro allocate-foreign-string (size &key (unsigned t))
- #+(or cmu scl)
+ #+ignore
(let ((array-def (gensym)))
`(let ((,array-def (list 'alien:array 'c-call:char ,size)))
- (eval `(alien:cast (alien:make-alien ,,array-def)
- ,(if ,unsigned
+ (eval `(alien:cast (alien:make-alien ,,array-def)
+ ,(if ,unsigned
'(* (alien:unsigned 8))
'(* (alien:signed 8)))))))
+
+ #+(or cmu scl)
+ `(alien:make-alien ,(if unsigned
+ '(alien:unsigned 8)
+ '(alien:signed 8))
+ ,size)
+
#+sbcl
- (let ((array-def (gensym)))
- `(let ((,array-def (list 'sb-alien:array 'char ,size)))
- (eval `(sb-alien:cast (sb-alien:make-alien ,,array-def)
- ,(if ,unsigned
- '(* (sb-alien:unsigned 8))
- '(* (sb-alien:signed 8)))))))
+ `(sb-alien:make-alien ,(if unsigned
+ '(sb-alien:unsigned 8)
+ '(sb-alien:signed 8))
+ ,size)
+
#+lispworks
- `(fli:allocate-foreign-object :type
- ,(if unsigned
- ''(:unsigned :char)
+ `(fli:allocate-foreign-object :type
+ ,(if unsigned
+ ''(:unsigned :char)
:char)
:nelems ,size)
#+allegro
(declare (ignore unsigned))
#+allegro
`(ff:allocate-fobject :char :c ,size)
- #+mcl
+ #+(or openmcl digitool)
(declare (ignore unsigned))
- #+mcl
+ #+(or openmcl digitool)
`(new-ptr ,size)
)
+(defun foreign-string-length (foreign-string)
+ #+allegro `(ff:foreign-strlen ,foreign-string)
+ #-allegro
+ `(loop with size = 0
+ until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
+ do (incf size)
+ finally return size))
+
+
(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
(let ((result (gensym)))
`(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
@@ -231,6 +284,11 @@
(free-foreign-object ,foreign-string)
,result)))
+(defmacro with-foreign-strings (bindings &body body)
+ `(with-foreign-string ,(car bindings)
+ ,@(if (cdr bindings)
+ `((with-foreign-strings ,(cdr bindings) ,@body))
+ body)))
;; Modified from CMUCL's source to handle non-null terminated strings
#+cmu
@@ -280,53 +338,75 @@
(setf (char result i) (code-char (system:sap-ref-8 sap i))))
result)))
-#+sbcl
+#+(and sbcl (not sb-unicode))
(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
- (declare (type sb-sys:system-area-pointer sap))
+ (declare (type sb-sys:system-area-pointer sap)
+ (type (or null fixnum) length))
(locally
- (declare (optimize (speed 3) (safety 0)))
- (let ((null-terminated-length
- (when null-terminated-p
- (loop
- for offset of-type fixnum upfrom 0
- until (zerop (sb-sys:sap-ref-8 sap offset))
- finally (return offset)))))
- (if length
- (if (and null-terminated-length
- (> (the fixnum length) (the fixnum null-terminated-length)))
- (setq length null-terminated-length))
- (setq length null-terminated-length)))
- (let ((result (make-string length)))
- (sb-kernel:copy-from-system-area sap 0
- result (* sb-vm:vector-data-offset
- sb-vm:n-word-bits)
- (* length sb-vm:n-byte-bits))
- result)))
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((null-terminated-length
+ (when null-terminated-p
+ (loop
+ for offset of-type fixnum upfrom 0
+ until (zerop (sb-sys:sap-ref-8 sap offset))
+ finally (return offset)))))
+ (if length
+ (if (and null-terminated-length
+ (> (the fixnum length) (the fixnum null-terminated-length)))
+ (setq length null-terminated-length))
+ (setq length null-terminated-length)))
+ (let ((result (make-string length)))
+ (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+ (* length +system-copy-multiplier+))
+ result)))
+#+(and sbcl sb-unicode)
+(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+ (declare (type sb-sys:system-area-pointer sap)
+ (type (or null fixnum) length))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (cond
+ (null-terminated-p
+ (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
+ #+sb-unicode sb-alien:utf8-string
+ #-sb-unicode sb-alien:c-string)))
+ (if length
+ (copy-seq (subseq casted 0 length))
+ (copy-seq casted))))
+ (t
+ (let ((result (make-string length)))
+ ;; this will not work in sb-unicode
+ (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+ (* length +system-copy-multiplier+))
+ result)))))
-(def-function "strlen"
- ((str (* :unsigned-char)))
- :returning :unsigned-int)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-function "strlen"
+ ((str (* :unsigned-char)))
+ :returning :unsigned-int))
+
(def-type char-ptr-def (* :unsigned-char))
-#+(or lispworks (and allegro (not ics)))
+#+(or (and allegro (not ics)) (and lispworks (not lispworks5)))
(defun fast-native-to-string (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
(type char-ptr-def s))
(let* ((len (or len (strlen s)))
(str (make-string len)))
(declare (fixnum len)
- (type (simple-array (signed-byte 8) (*)) str))
+ (type (simple-array #+lispworks base-char
+ #-lispworks (signed-byte 8) (*)) str))
(dotimes (i len str)
- (setf (aref str i)
+ (setf (aref str i)
(uffi:deref-array s '(:array :char) i)))))
-#+(and allegro ics)
+#+(or (and allegro ics) lispworks5)
(defun fast-native-to-string (s len)
(declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
(type char-ptr-def s))
(let* ((len (or len (strlen s)))
(str (make-string len)))
(dotimes (i len str)
- (setf (aref str i) (uffi:deref-array s '(:array :char) i)))))
+ (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))
Modified: branches/xml-class-rework/thirdparty/uffi/tests/Makefile
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/Makefile 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/Makefile 2006-10-22 16:42:37 UTC (rev 2025)
@@ -5,13 +5,9 @@
# Programer: Kevin M. Rosenberg
# Date Started: Mar 2002
#
-# CVS Id: $Id: Makefile,v 1.1 2004/06/23 08:27:10 hans Exp $
+# CVS Id: $Id$
#
-# This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-#
-# UFFI users are granted the rights to distribute and use this software
-# as governed by the terms of the Lisp Lesser GNU Public License
-# (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
SUBDIRS=
Modified: branches/xml-class-rework/thirdparty/uffi/tests/Makefile.msvc
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/Makefile.msvc 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/Makefile.msvc 2006-10-22 16:42:37 UTC (rev 2025)
@@ -5,13 +5,10 @@
# Programer: Kevin M. Rosenberg
# Date Started: Mar 2002
#
-# CVS Id: $Id: Makefile.msvc,v 1.1 2004/06/23 08:27:10 hans Exp $
+# CVS Id: $Id$
#
-# This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
#
-# CLSQL users are granted the rights to distribute and use this software
-# as governed by the terms of the Lisp Lesser GNU Public License
-# (http://opensource.franz.com/preamble.html), also known as the LLGPL.
BASE=c-test-fns
Modified: branches/xml-class-rework/thirdparty/uffi/tests/arrays.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/arrays.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/arrays.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: arrays.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -18,9 +18,9 @@
(uffi:def-constant +column-length+ 10)
(uffi:def-constant +row-length+ 10)
-(uffi:def-foreign-type long-ptr '(* :long))
+(uffi:def-foreign-type long-ptr (* :long))
-(deftest array.1
+(deftest :array.1
(let ((a (uffi:allocate-foreign-object :long +column-length+))
(results nil))
(dotimes (i +column-length+)
@@ -32,7 +32,7 @@
(0 1 4 9 16 25 36 49 64 81))
-(deftest array.2
+(deftest :array.2
(let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+))
(results nil))
(dotimes (r +row-length+)
Modified: branches/xml-class-rework/thirdparty/uffi/tests/atoifl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/atoifl.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/atoifl.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: atoifl.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -37,6 +37,6 @@
(uffi:with-cstring (str-cstring str)
(c-atof str-cstring)))
-(deftest atoi.1 (atoi "123") 123)
-(deftest atoi.2 (atoi "") 0)
-(deftest atof.3 (atof "2.23") 2.23d0)
+(deftest :atoi.1 (atoi "123") 123)
+(deftest :atoi.2 (atoi "") 0)
+(deftest :atof.3 (atof "2.23") 2.23d0)
Modified: branches/xml-class-rework/thirdparty/uffi/tests/casts.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/casts.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/casts.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -1,27 +1,31 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
+;;;; FILE IDENTIFICAION
;;;;
;;;; Name: casts.lisp
;;;; Purpose: Tests of with-cast-pointer
;;;; Programmer: Kevin M. Rosenberg / Edi Weitz
;;;; Date Started: Aug 2003
;;;;
-;;;; $Id: casts.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
;;;; *************************************************************************
(in-package #:uffi-tests)
(uffi:def-function ("cast_test_int" cast-test-int)
()
+ :module "uffi_tests"
:returning :pointer-void)
(uffi:def-function ("cast_test_float" cast-test-float)
()
+ :module "uffi_tests"
:returning :pointer-void)
-(deftest cast.1
+(deftest :cast.1
(progn
(uffi:with-cast-pointer (temp (cast-test-int) :int)
(assert (= (uffi:deref-pointer temp :int) 23)))
@@ -33,7 +37,7 @@
t)
t)
-(deftest cast.2
+(deftest :cast.2
(progn
(uffi:with-cast-pointer (temp (cast-test-float) :double)
(assert (= (uffi:deref-pointer temp :double) 3.21d0)))
Modified: branches/xml-class-rework/thirdparty/uffi/tests/compress.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/compress.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/compress.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: compress.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -36,10 +36,8 @@
(newdestlen (uffi:deref-pointer destlen :long)))
(unwind-protect
(if (zerop result)
- (values (uffi:convert-from-foreign-string
- dest
- :length newdestlen
- :null-terminated-p nil)
+ (values (uffi:convert-from-foreign-usb8
+ dest newdestlen)
newdestlen)
(error "zlib error, code ~D" result))
(progn
@@ -74,12 +72,12 @@
(uffi:free-foreign-object destlen)
(uffi:free-foreign-object dest)))))))
-(deftest compress.1 (map 'list #'char-code (compress ""))
- (120 156 3 0 0 0 0 1))
-(deftest compress.2 (map 'list #'char-code (compress "test"))
- (120 156 43 73 45 46 1 0 4 93 1 193))
-(deftest compress.3 (map 'list #'char-code (compress "test2"))
- (120 156 43 73 45 46 49 2 0 6 80 1 243))
+(deftest :compress.1 (compress "")
+ #(120 156 3 0 0 0 0 1) 8)
+(deftest :compress.2 (compress "test")
+ #(120 156 43 73 45 46 1 0 4 93 1 193) 12)
+(deftest :compress.3 (compress "test2")
+ #(120 156 43 73 45 46 49 2 0 6 80 1 243) 13)
(defun compress-uncompress (str)
(multiple-value-bind (compressed len) (compress str)
@@ -89,6 +87,6 @@
uncompressed)))
-(deftest uncompress.1 "" "")
-(deftest uncompress.2 "test" "test")
-(deftest uncompress.3 "test2" "test2")
+(deftest :uncompress.1 "" "")
+(deftest :uncompress.2 "test" "test")
+(deftest :uncompress.3 "test2" "test2")
Modified: branches/xml-class-rework/thirdparty/uffi/tests/foreign-loader.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/foreign-loader.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/foreign-loader.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: foreign-loader.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -18,6 +18,8 @@
(in-package uffi-tests)
+#+clisp (uffi:load-foreign-library "/usr/lib/libz.so" :module "z")
+#-clisp
(unless (uffi:load-foreign-library
(uffi:find-foreign-library
#-(or macosx darwin)
@@ -25,16 +27,20 @@
#+(or macosx darwin)
"z"
(list (pathname-directory *load-pathname*)
- "/usr/local/lib/" "/usr/lib/" "/zlib/"))
- :module "zlib"
+ "/usr/local/lib/" #+(or 64bit x86-64) "/usr/lib64/"
+ "/usr/lib/" "/zlib/"))
+ :module "zlib"
:supporting-libraries '("c"))
(warn "Unable to load zlib"))
-
-(unless (uffi:load-foreign-library
+
+#+clisp (uffi:load-foreign-library "/home/kevin/debian/src/uffi/tests/uffi-c-test.so" :module "uffi_tests")
+#-clisp
+(unless (uffi:load-foreign-library
(uffi:find-foreign-library
- "uffi-c-test"
+ '(#+(or 64bit x86-64) "uffi-c-test64" "uffi-c-test")
(list (pathname-directory *load-truename*)
- "/usr/lib/uffi/"))
+ "/usr/lib/uffi/"
+ "/home/kevin/debian/src/uffi/tests/"))
:supporting-libraries '("c")
:module "uffi_tests")
(warn "Unable to load uffi-c-test library"))
Modified: branches/xml-class-rework/thirdparty/uffi/tests/foreign-var.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/foreign-var.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/foreign-var.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,8 +7,10 @@
;;;; Authors: Kevin M. Rosenberg and Edi Weitz
;;;; Date Started: Aug 2003
;;;;
-;;;; $Id: foreign-var.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;
;;;; *************************************************************************
(in-package #:uffi-tests)
@@ -22,16 +24,15 @@
(def-foreign-var "float_neg_4_5" :float "uffi_tests")
(def-foreign-var "double_3_1" :double "uffi_tests")
-(deftest fvar.1 uchar-13 13)
-(deftest fvar.2 schar-neg-120 -120)
-(deftest fvar.3 uword-257 257)
-(deftest fvar.4 sword-neg-321 -321)
-(deftest fvar.5 uint-1234567 1234567)
-(deftest fvar.6 sint-neg-123456 -123456)
-(deftest fvar.7 float-neg-4-5 -4.5f0)
-(deftest fvar.8 double-3-1 3.1d0)
+(deftest :fvar.1 uchar-13 13)
+(deftest :fvar.2 schar-neg-120 -120)
+(deftest :fvar.3 uword-257 257)
+(deftest :fvar.4 sword-neg-321 -321)
+(deftest :fvar.5 uint-1234567 1234567)
+(deftest :fvar.6 sint-neg-123456 -123456)
+(deftest :fvar.7 float-neg-4-5 -4.5f0)
+(deftest :fvar.8 double-3-1 3.1d0)
-
(uffi:def-foreign-var ("fvar_addend" *fvar-addend*) :int "uffi_tests")
(uffi:def-struct fvar-struct
@@ -51,14 +52,14 @@
:returning :double
:module "uffi_tests")
-(deftest fvarst.1 *fvar-addend* 3)
-(deftest fvarst.2 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 42)
-(deftest fvarst.3 (= (+ *fvar-addend*
+(deftest :fvarst.1 *fvar-addend* 3)
+(deftest :fvarst.2 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 42)
+(deftest :fvarst.3 (= (+ *fvar-addend*
(uffi:get-slot-value *fvar-struct* 'fvar-struct 'i))
(fvar-struct-int))
t)
-(deftest fvarst.4 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd) 3.2d0)
-(deftest fvarst.5 (= (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd)
+(deftest :fvarst.4 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd) 3.2d0)
+(deftest :fvarst.5 (= (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd)
(fvar-struct-double))
t)
Modified: branches/xml-class-rework/thirdparty/uffi/tests/getenv.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/getenv.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/getenv.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: getenv.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -51,11 +51,11 @@
(uffi:with-cstrings ((key-native key))
(c-unsetenv key-native)))
-(deftest getenv.1 (progn
+(deftest :getenv.1 (progn
(my-unsetenv "__UFFI_FOO1__")
(my-getenv "__UFFI_FOO1__"))
nil)
-(deftest getenv.2 (progn
+(deftest :getenv.2 (progn
(my-setenv "__UFFI_FOO1__" "UFFI-TEST")
(my-getenv "__UFFI_FOO1__"))
"UFFI-TEST")
Modified: branches/xml-class-rework/thirdparty/uffi/tests/gethostname.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/gethostname.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/gethostname.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: gethostname.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -42,11 +42,11 @@
(uffi:convert-from-foreign-string name)
(error "gethostname() failed.")))))
-(deftest gethostname.1 (stringp (gethostname)) t)
-(deftest gethostname.2 (stringp (gethostname2)) t)
-(deftest gethostname.3 (plusp (length (gethostname))) t)
-(deftest gethostname.4 (plusp (length (gethostname2))) t)
-(deftest gethostname.5 (gethostname) #.(gethostname2))
+(deftest :gethostname.1 (stringp (gethostname)) t)
+(deftest :gethostname.2 (stringp (gethostname2)) t)
+(deftest :gethostname.3 (plusp (length (gethostname))) t)
+(deftest :gethostname.4 (plusp (length (gethostname2))) t)
+(deftest :gethostname.5 (string= (gethostname) (gethostname2)) t)
Modified: branches/xml-class-rework/thirdparty/uffi/tests/make.sh
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/make.sh 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/make.sh 2006-10-22 16:42:37 UTC (rev 2025)
@@ -2,17 +2,32 @@
case "`uname`" in
Linux) os_linux=1 ;;
+ FreeBSD) os_freebsd=1 ;;
+ GNU/kFreeBSD) os_gnukfreebsd=1;;
Darwin) os_darwin=1 ;;
SunOS) os_sunos=1 ;;
AIX) os_aix=1 ;;
+ GNU) os_gnu=1 ;;
*) echo "Unable to identify uname " `uname`
- exit 1 ;;
+ exit 1 ;;
esac
-
+
if [ "$os_linux" ]; then
gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
gcc -shared $OBJECT -o $SHARED_LIB
+elif [ "$os_gnu" ]; then
+ gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+ gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_freebsd" ]; then
+ gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+ gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_gnukfreebsd" ]; then
+ gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+ gcc -shared $OBJECT -o $SHARED_LIB
+
elif [ "$os_darwin" ]; then
cc -dynamic -c $SOURCE -o $OBJECT
ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $BASE.dylib $OBJECT
Added: branches/xml-class-rework/thirdparty/uffi/tests/objects.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/objects.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/objects.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -0,0 +1,70 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: pointers.lisp
+;;;; Purpose: Test file for UFFI pointers
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2003
+;;;;
+;;;; $Id: objects.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(deftest :chptr.1
+ (let ((native-string "test string"))
+ (uffi:with-foreign-string (fs native-string)
+ (ensure-char-character
+ (deref-pointer fs :char))))
+ #\t)
+
+(deftest :chptr.2
+ (let ((native-string "test string"))
+ (uffi:with-foreign-string (fs native-string)
+ (ensure-char-character
+ (deref-pointer fs :unsigned-char))))
+ #\t)
+
+(deftest :chptr.3
+ (let ((native-string "test string"))
+ (uffi:with-foreign-string (fs native-string)
+ (ensure-char-integer
+ (deref-pointer fs :unsigned-char))))
+ 116)
+
+(deftest :chptr.4
+ (let ((native-string "test string"))
+ (uffi:with-foreign-string (fs native-string)
+ (integerp
+ (ensure-char-integer
+ (deref-pointer fs :unsigned-char)))))
+ t)
+
+(deftest :chptr.5
+ (let ((fs (uffi:allocate-foreign-object :unsigned-char 128)))
+ (setf (uffi:deref-array fs '(:array :unsigned-char) 0)
+ (uffi:ensure-char-storable #\a))
+ (setf (uffi:deref-array fs '(:array :unsigned-char) 1)
+ (uffi:ensure-char-storable (code-char 0)))
+ (uffi:convert-from-foreign-string fs))
+ "a")
+
+;; This produces an array which needs fli:foreign-aref to access
+;; rather than fli:dereference
+
+#-lispworks
+(deftest :chptr.6
+ (uffi:with-foreign-object (fs '(:array :unsigned-char 128))
+ (setf (uffi:deref-array fs '(:array :unsigned-char) 0)
+ (uffi:ensure-char-storable #\a))
+ (setf (uffi:deref-array fs '(:array :unsigned-char) 1)
+ (uffi:ensure-char-storable (code-char 0)))
+ (uffi:convert-from-foreign-string fs))
+ "a")
+
+
+
Modified: branches/xml-class-rework/thirdparty/uffi/tests/package.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/package.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/package.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,7 +7,9 @@
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
-;;;; $Id: package.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; $Id$
;;;; *************************************************************************
(defpackage #:uffi-tests
Modified: branches/xml-class-rework/thirdparty/uffi/tests/strtol.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/strtol.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/strtol.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: strtol.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -54,10 +54,10 @@
(uffi:free-foreign-object str-native)
(uffi:free-foreign-object endptr)))))
-(deftest strtol.1 (strtol "123") 123 t)
-(deftest strtol.2 (strtol "0") 0 t)
-(deftest strtol.3 (strtol "55a") 55 2)
-(deftest strtol.4 (strtol "a") nil nil)
+(deftest :strtol.1 (strtol "123") 123 t)
+(deftest :strtol.2 (strtol "0") 0 t)
+(deftest :strtol.3 (strtol "55a") 55 2)
+(deftest :strtol.4 (strtol "a") nil nil)
Modified: branches/xml-class-rework/thirdparty/uffi/tests/structs.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/structs.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/structs.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: structs.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -24,8 +24,13 @@
(uffi:def-foreign-type foo-ptr (* foo))
;; tests that compilation worked
-(deftest structs.1
+(deftest :structs.1
(with-foreign-object (p 'foo)
t)
t)
+(deftest :structs.2
+ (progn
+ (uffi:def-foreign-type foo-struct (:struct foo))
+ t)
+ t)
Modified: branches/xml-class-rework/thirdparty/uffi/tests/time.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/time.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/time.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: time.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -26,36 +26,42 @@
(year :int)
(wday :int)
(yday :int)
- (isdst :int))
+ (isdst :int)
+ ;; gmoffset present on SusE SLES9
+ (gmoffset :long))
(uffi:def-function ("time" c-time)
((time (* time-t)))
:returning time-t)
-(uffi:def-function ("gmtime" c-gmtime)
+(uffi:def-function "gmtime"
((time (* time-t)))
- :returning (* tm))
+ :returning (:struct-pointer tm))
+(uffi:def-function "asctime"
+ ((time (:struct-pointer tm)))
+ :returning :cstring)
+
(uffi:def-type time-t :unsigned-long)
-(uffi:def-type tm-pointer (* tm))
+(uffi:def-type tm-pointer (:struct-pointer tm))
-(deftest time.1
+(deftest :time.1
(uffi:with-foreign-object (time 'time-t)
(setf (uffi:deref-pointer time :unsigned-long) 7381)
(uffi:deref-pointer time :unsigned-long))
7381)
-(deftest time.2
- (uffi:with-foreign-object (time 'time-t)
- (setf (uffi:deref-pointer time :unsigned-long) 7381)
- (let ((tm-ptr (the tm-pointer (c-gmtime time))))
- (values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
- (uffi:get-slot-value tm-ptr 'tm 'mday)
- (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
- (uffi:get-slot-value tm-ptr 'tm 'hour)
- (uffi:get-slot-value tm-ptr 'tm 'min)
- (uffi:get-slot-value tm-ptr 'tm 'sec)
- )))
+(deftest :time.2
+ (uffi:with-foreign-object (time 'time-t)
+ (setf (uffi:deref-pointer time :unsigned-long) 7381)
+ (let ((tm-ptr (the tm-pointer (gmtime time))))
+ (values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
+ (uffi:get-slot-value tm-ptr 'tm 'mday)
+ (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
+ (uffi:get-slot-value tm-ptr 'tm 'hour)
+ (uffi:get-slot-value tm-ptr 'tm 'min)
+ (uffi:get-slot-value tm-ptr 'tm 'sec)
+ )))
1 1 1970 2 3 1)
@@ -80,7 +86,7 @@
(uffi:get-slot-value tv 'timeval 'usecs))
res))))
-(deftest timeofday.1
+(deftest :timeofday.1
(multiple-value-bind (t1 res1) (get-utime)
(multiple-value-bind (t2 res2) (get-utime)
(and (or (= t2 t1) (> t2 t1))
@@ -90,3 +96,15 @@
(zerop res2))))
t)
+(defun posix-time-to-asctime (secs)
+ "Converts number of seconds elapsed since 00:00:00 on January 1, 1970, Coordinated Universal Time (UTC)"
+ (string-right-trim
+ '(#\newline #\return)
+ (uffi:convert-from-cstring
+ (uffi:with-foreign-object (time 'time-t)
+ (setf (uffi:deref-pointer time :unsigned-long) secs)
+ (asctime (gmtime time))))))
+
+(deftest :time.3
+ (posix-time-to-asctime 0)
+ "Thu Jan 1 00:00:00 1970")
Modified: branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test-lib.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test-lib.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test-lib.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: uffi-c-test-lib.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -19,7 +19,7 @@
(uffi:def-function ("cs_to_upper" cs-to-upper)
((input (* :unsigned-char)))
:returning :void
- )
+ :module "uffi_tests")
(defun string-to-upper (str)
(uffi:with-foreign-string (str-foreign str)
@@ -29,17 +29,34 @@
(uffi:def-function ("cs_count_upper" cs-count-upper)
((input :cstring))
:returning :int
- )
+ :module "uffi_tests")
(defun string-count-upper (str)
(uffi:with-cstring (str-cstring str)
- (cs-count-upper str-cstring)))
+ (cs-count-upper str-cstring)))
(uffi:def-function ("half_double_vector" half-double-vector)
((size :int)
(vec (* :double)))
- :returning :void)
+ :returning :void
+ :module "uffi_tests")
+(uffi:def-function ("return_long_negative_one" return-long-negative-one)
+ ()
+ :returning :long
+ :module "uffi_tests")
+
+(uffi:def-function ("return_int_negative_one" return-int-negative-one)
+ ()
+ :returning :int
+ :module "uffi_tests")
+
+(uffi:def-function ("return_short_negative_one" return-short-negative-one)
+ ()
+ :returning :short
+ :module "uffi_tests")
+
+
(uffi:def-constant +double-vec-length+ 10)
(defun test-half-double-vector ()
(let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
@@ -69,10 +86,13 @@
(half-double-vector +double-vec-length+ (system:vector-sap vec)))
vec))
-(deftest c-test.1 (string-to-upper "this is a test") "THIS IS A TEST")
-(deftest c-test.2 (string-to-upper nil) nil)
-(deftest c-test.3 (string-count-upper "This is a Test") 2)
-(deftest c-test.4 (string-count-upper nil) -1)
-(deftest c-test.5 (test-half-double-vector)
+(deftest :c-test.1 (string-to-upper "this is a test") "THIS IS A TEST")
+(deftest :c-test.2 (string-to-upper nil) nil)
+(deftest :c-test.3 (string-count-upper "This is a Test") 2)
+(deftest :c-test.4 (string-count-upper nil) -1)
+(deftest :c-test.5 (test-half-double-vector)
(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0))
+(deftest :c-test.6 (return-long-negative-one) -1)
+(deftest :c-test.7 (return-int-negative-one) -1)
+(deftest :c-test.8 (return-short-negative-one) -1)
Modified: branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test.c
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test.c 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/uffi-c-test.c 2006-10-22 16:42:37 UTC (rev 2025)
@@ -6,14 +6,10 @@
* Programer: Kevin M. Rosenberg
* Date Started: Mar 2002
*
- * CVS Id: $Id: uffi-c-test.c,v 1.1 2004/06/23 08:27:10 hans Exp $
+ * CVS Id: $Id$
*
- * This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+ * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
*
- * UFFI users are granted the rights to distribute and use this software
- * as governed by the terms of the Lisp Lesser GNU Public License
- * (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-
* These variables are correct for GCC
* you'll need to modify these for other compilers
***************************************************************************/
@@ -119,6 +115,27 @@
return y;
}
+DLLEXPORT
+long
+return_long_negative_one ()
+{
+ return -1;
+}
+
+DLLEXPORT
+int
+return_int_negative_one ()
+{
+ return -1;
+}
+
+DLLEXPORT
+short
+return_short_negative_one ()
+{
+ return -1;
+}
+
DLLEXPORT int fvar_addend = 3;
typedef struct {
Modified: branches/xml-class-rework/thirdparty/uffi/tests/union.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/tests/union.lisp 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/tests/union.lisp 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,9 +7,9 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: union.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
;;;; *************************************************************************
@@ -35,12 +35,37 @@
(* 256 (char-code #\C))
(* 1 128)))
-(deftest union.1 (uffi:ensure-char-character
- (uffi:get-slot-value *u* 'tunion1 'char)) #\A)
+(deftest :union.1
+ (uffi:ensure-char-character
+ (uffi:get-slot-value *u* 'tunion1 'char))
+ #\A)
-#-(or sparc sparc-v9 mcl)
-(deftest union.2 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t)
+(deftest :union.2
+ (uffi:ensure-char-integer
+ (uffi:get-slot-value *u* 'tunion1 'char))
+ 65)
+#-(or sparc sparc-v9 openmcl digitool)
+(deftest :union.3 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t)
-;; (uffi:free-foreign-object u))
+(uffi:def-union foo-u
+ (bar :pointer-self))
+
+(uffi:def-foreign-type foo-u-ptr (* foo-u))
+
+;; tests that compilation worked
+(deftest :unions.4
+ (with-foreign-object (p 'foo-u)
+ t)
+ t)
+
+(deftest :unions.5
+ (progn
+ (uffi:def-foreign-type foo-union (:union foo-u))
+ t)
+ t)
+
+
+
+
Modified: branches/xml-class-rework/thirdparty/uffi/uffi-tests.asd
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/uffi-tests.asd 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/uffi-tests.asd 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,13 +7,15 @@
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
-;;;; $Id: uffi-tests.asd,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;; *************************************************************************
(defpackage #:uffi-tests-system
(:use #:asdf #:cl))
(in-package #:uffi-tests-system)
+(operate 'load-op 'uffi)
+
(defvar *library-file-dir* (append (pathname-directory *load-truename*)
(list "tests")))
@@ -21,28 +23,47 @@
())
(defmethod output-files ((o compile-op) (c uffi-test-source-file))
- (let ((found (some #'(lambda (dir)
- (probe-file (make-pathname :directory dir
- :name (component-name c)
- :type "so")))
- '((:absolute "usr" "lib" "uffi")))))
+ (let* ((library-file-type
+ (funcall (intern (symbol-name'#:default-foreign-library-type)
+ (symbol-name '#:uffi))))
+ (found
+ (some #'(lambda (dir)
+ (probe-file (make-pathname
+ :directory dir
+ :name (component-name c)
+ :type library-file-type)))
+ '((:absolute "usr" "lib" "uffi")))))
(list (if found
found
(make-pathname :name (component-name c)
- :type "so"
+ :type library-file-type
:directory *library-file-dir*)))))
(defmethod perform ((o load-op) (c uffi-test-source-file))
- nil) ;; lisp loader file will load library
+ nil) ;;; library will be loaded by a loader file
+(defmethod operation-done-p ((o load-op) (c uffi-test-source-file))
+ (and (symbol-function (intern (symbol-name '#:cs-count-upper)
+ (find-package '#:uffi-tests)))
+ t))
+
(defmethod perform ((o compile-op) (c uffi-test-source-file))
- (unless (zerop (run-shell-command
- "cd ~A; make"
- (namestring (make-pathname :name nil
- :type nil
- :directory *library-file-dir*))))
- (error 'operation-error :component c :operation o)))
+ (unless (operation-done-p o c)
+ #-(or win32 mswindows)
+ (unless (zerop (run-shell-command
+ #-freebsd "cd ~A; make"
+ #+freebsd "cd ~A; gmake"
+ (namestring (make-pathname :name nil
+ :type nil
+ :directory *library-file-dir*))))
+ (error 'operation-error :component c :operation o))))
+(defmethod operation-done-p ((o compile-op) (c uffi-test-source-file))
+ (or (and (probe-file #p"/usr/lib/uffi/uffi-c-test.so") t)
+ (let ((lib (make-pathname :defaults (component-pathname c)
+ :type (uffi:default-foreign-library-type))))
+ (and (probe-file lib)
+ (> (file-write-date lib) (file-write-date (component-pathname c)))))))
(defsystem uffi-tests
:depends-on (:uffi)
@@ -50,8 +71,8 @@
((:module tests
:components
((:file "rt")
- (:uffi-test-source-file "uffi-c-test")
(:file "package" :depends-on ("rt"))
+ (:uffi-test-source-file "uffi-c-test" :depends-on ("package"))
(:file "strtol" :depends-on ("package"))
(:file "atoifl" :depends-on ("package"))
(:file "getenv" :depends-on ("package"))
@@ -59,7 +80,7 @@
(:file "union" :depends-on ("package"))
(:file "arrays" :depends-on ("package"))
(:file "structs" :depends-on ("package"))
- (:file "pointers" :depends-on ("package"))
+ (:file "objects" :depends-on ("package"))
(:file "time" :depends-on ("package"))
(:file "foreign-loader" :depends-on ("package" "uffi-c-test"))
(:file "uffi-c-test-lib" :depends-on ("foreign-loader"))
Modified: branches/xml-class-rework/thirdparty/uffi/uffi.asd
===================================================================
--- branches/xml-class-rework/thirdparty/uffi/uffi.asd 2006-10-22 16:40:58 UTC (rev 2024)
+++ branches/xml-class-rework/thirdparty/uffi/uffi.asd 2006-10-22 16:42:37 UTC (rev 2025)
@@ -7,19 +7,16 @@
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Aug 2002
;;;;
-;;;; $Id: uffi.asd,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(defpackage #:uffi-system (:use #:asdf #:cl))
(in-package #:uffi-system)
-#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)
(defsystem uffi
:name "uffi"
:author "Kevin Rosenberg <kevin(a)rosenberg.net>"
@@ -28,22 +25,22 @@
:licence "Lessor Lisp General Public License"
:description "Universal Foreign Function Library for Common Lisp"
:long-description "UFFI provides a universal foreign function interface (FFI) for Common Lisp. UFFI supports CMUCL, Lispworks, and AllegroCL."
-
+
:components
((:module :src
:components
((:file "package")
(:file "primitives" :depends-on ("package"))
- #+mcl (:file "readmacros-mcl" :depends-on ("package"))
+ #+(or openmcl digitool) (:file "readmacros-mcl" :depends-on ("package"))
(:file "objects" :depends-on ("primitives"))
- (:file "strings" :depends-on ("primitives" "functions" "aggregates" "objects"))
(:file "aggregates" :depends-on ("primitives"))
+ (:file "strings" :depends-on ("primitives" "functions" "aggregates" "objects"))
(:file "functions" :depends-on ("primitives"))
(:file "libraries" :depends-on ("package"))
(:file "os" :depends-on ("package"))))
))
-#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)
(defmethod perform ((o test-op) (c (eql (find-system 'uffi))))
(oos 'load-op 'uffi-tests)
(oos 'test-op 'uffi-tests :force t))
1
0
22 Oct '06
Author: hhubner
Date: 2006-10-22 12:40:58 -0400 (Sun, 22 Oct 2006)
New Revision: 2024
Modified:
branches/xml-class-rework/thirdparty/iconv/iconv.asd
branches/xml-class-rework/thirdparty/iconv/iconv.lisp
Log:
converted to use cffi-uffi-compat
Modified: branches/xml-class-rework/thirdparty/iconv/iconv.asd
===================================================================
--- branches/xml-class-rework/thirdparty/iconv/iconv.asd 2006-10-22 15:57:04 UTC (rev 2023)
+++ branches/xml-class-rework/thirdparty/iconv/iconv.asd 2006-10-22 16:40:58 UTC (rev 2024)
@@ -4,4 +4,4 @@
:author "Yoshinori Tahara <read.eval.print(a)gmail.com>"
:version "0.2"
:components ((:file "iconv"))
- :depends-on (uffi))
+ :depends-on (cffi-uffi-compat))
Modified: branches/xml-class-rework/thirdparty/iconv/iconv.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/iconv/iconv.lisp 2006-10-22 15:57:04 UTC (rev 2023)
+++ branches/xml-class-rework/thirdparty/iconv/iconv.lisp 2006-10-22 16:40:58 UTC (rev 2024)
@@ -1,16 +1,19 @@
(defpackage :koto.iconv
(:nicknames :iconv)
- (:use :cl :uffi)
+ (:use :cl :cffi-uffi-compat)
(:export
:iconv
:EILSEQ
:EINVAL
:E2BIG))
-
+
(in-package :iconv)
+(cffi-uffi-compat:load-foreign-library "/usr/lib/libc.so")
+(cffi-uffi-compat:load-foreign-library "/usr/local/lib/libiconv.so")
+
#-:sbcl
-(uffi:def-foreign-var ("errno" errno) :int "iconv")
+(cffi-uffi-compat:def-foreign-var ("errno" errno) :int "iconv")
(defun get-errno ()
#-:sbcl
@@ -19,71 +22,58 @@
(sb-alien:get-errno)
)
-(uffi:def-constant EILSEQ #+freebsd 86 #-freebsd 84) ;invalid multibyte
-(uffi:def-constant EINVAL 22) ;imcomplete multibyte
-(uffi:def-constant E2BIG 7) ;not enough outbuf
+(cffi-uffi-compat:def-constant EILSEQ #+freebsd 86 #-freebsd 84) ;invalid multibyte
+(cffi-uffi-compat:def-constant EINVAL 22) ;imcomplete multibyte
+(cffi-uffi-compat:def-constant E2BIG 7) ;not enough outbuf
-(uffi:def-foreign-type char-ptr (* :unsigned-char))
-(uffi:def-foreign-type iconv-t :pointer-void)
+(cffi-uffi-compat:def-foreign-type uchar-ptr (* :unsigned-char))
+(cffi-uffi-compat:def-foreign-type iconv-t :pointer-void)
-(uffi:def-function ("iconv_open" iconv-open)
+(cffi-uffi-compat:def-function ("iconv_open" iconv-open)
((tocode :cstring)
(fromcode :cstring))
:returning 'iconv-t)
-(uffi:def-function ("iconv_close" iconv-close)
+(cffi-uffi-compat:def-function ("iconv_close" iconv-close)
((cd 'iconv-t))
:returning :int)
-(uffi:def-function ("iconv" %iconv)
+(cffi-uffi-compat:def-function ("iconv" %iconv)
((cd 'iconv-t)
- (inbuf (* char-ptr))
+ (inbuf (* uchar-ptr))
(inbytesleft (* :unsigned-long))
- (outbuf (* char-ptr))
+ (outbuf (* uchar-ptr))
(outbytesleft (* :unsigned-long)))
:returning :unsigned-int)
(defmacro with-iconv-cd ((cd from to) &body body)
- `(uffi:with-cstrings ((fromcode ,from)
+ `(cffi-uffi-compat:with-cstrings ((fromcode ,from)
(tocode ,to))
(let ((,cd (iconv-open tocode fromcode)))
(unwind-protect
(progn ,@body)
(iconv-close ,cd)))))
-(defun iconv (from-code to-code from-vector
+(defun iconv (from-code to-code from-string
&optional error-p (error-value #.(char-code #\?)))
(with-iconv-cd (cd from-code to-code)
- (let* ((from-len (length from-vector))
+ (let* ((from-len (length from-string))
(to-len (* from-len 2))
- (remain (make-array 3
- :element-type '(unsigned-byte 8)
- :fill-pointer 0
- :adjustable t))
- (string-mode (characterp (aref from-vector 0)))
- inbuffer
- (outbuffer (uffi:allocate-foreign-string to-len :unsigned t))
- (in-ptr (uffi:allocate-foreign-object 'char-ptr))
- (out-ptr (uffi:allocate-foreign-object 'char-ptr))
- (inbytesleft (uffi:allocate-foreign-object :unsigned-int))
- (outbytesleft (uffi:allocate-foreign-object :unsigned-int)))
+ (inbuffer (cffi-uffi-compat:convert-to-foreign-string from-string))
+ (outbuffer (cffi-uffi-compat:allocate-foreign-string to-len :unsigned t))
+ (in-ptr (cffi-uffi-compat:allocate-foreign-object 'uchar-ptr))
+ (out-ptr (cffi-uffi-compat:allocate-foreign-object 'uchar-ptr))
+ (inbytesleft (cffi-uffi-compat:allocate-foreign-object :unsigned-int))
+ (outbytesleft (cffi-uffi-compat:allocate-foreign-object :unsigned-int)))
(unwind-protect
(progn
- (if string-mode
- (setf inbuffer (uffi:convert-to-foreign-string from-vector))
- (progn
- (setf inbuffer (uffi:allocate-foreign-string from-len :unsigned t))
- (loop for i from 0 below from-len
- do (setf (uffi:deref-array inbuffer :unsigned-char i)
- (aref from-vector i)))))
- (setf (uffi:deref-pointer in-ptr 'char-ptr) inbuffer
- (uffi:deref-pointer out-ptr 'char-ptr) outbuffer
- (uffi:deref-pointer inbytesleft :unsigned-int) from-len
- (uffi:deref-pointer outbytesleft :unsigned-int) to-len)
+ (setf (cffi-uffi-compat:deref-pointer in-ptr 'uchar-ptr) inbuffer
+ (cffi-uffi-compat:deref-pointer out-ptr 'uchar-ptr) outbuffer
+ (cffi-uffi-compat:deref-pointer inbytesleft :unsigned-int) from-len
+ (cffi-uffi-compat:deref-pointer outbytesleft :unsigned-int) to-len)
(labels
((current ()
- (- from-len (uffi:deref-pointer
- inbytesleft :unsigned-int)))
+ (- from-len (cffi-uffi-compat:deref-pointer inbytesleft :unsigned-int)))
(self ()
(when (= (%iconv cd
in-ptr inbytesleft
@@ -92,29 +82,17 @@
(if (= (get-errno) EILSEQ)
(if error-p
(error "invalid multibyte(~X)."
- (uffi:deref-array
- inbuffer :unsigned-byte (current)))
+ (cffi-uffi-compat:deref-array inbuffer (cffi-uffi-compat::convert-uffi-type :unsigned-byte) (current)))
(progn
- (setf (uffi:deref-array
- inbuffer :unsigned-byte (current))
- error-value)
+ (setf (cffi-uffi-compat:deref-array inbuffer (cffi-uffi-compat::convert-uffi-type :unsigned-byte) (current))
+ error-value)
(self)))
- (loop for i from (current)
- below from-len
- do (vector-push-extend
- (aref from-vector i) remain))))))
+ (error "unexpected iconv error ~A" (get-errno))))))
(self))
- (let* ((out-length (- to-len (uffi:deref-pointer outbytesleft :unsigned-int)))
- (out (make-array out-length
- :element-type (array-element-type from-vector))))
- (dotimes (i out-length)
- (setf (aref out i) (if string-mode
- (code-char (uffi:deref-array outbuffer :unsigned-byte i))
- (uffi:deref-array outbuffer :unsigned-byte i))))
- (values out remain)))
- (progn (uffi:free-foreign-object outbytesleft)
- (uffi:free-foreign-object inbytesleft)
- (uffi:free-foreign-object out-ptr)
- (uffi:free-foreign-object in-ptr)
- (uffi:free-foreign-object outbuffer)
- (uffi:free-foreign-object inbuffer))))))
+ (cffi-uffi-compat:convert-from-foreign-string outbuffer :length (- to-len (cffi-uffi-compat:deref-pointer outbytesleft :unsigned-int))))
+ (cffi-uffi-compat:free-foreign-object outbytesleft)
+ (cffi-uffi-compat:free-foreign-object inbytesleft)
+ (cffi-uffi-compat:free-foreign-object out-ptr)
+ (cffi-uffi-compat:free-foreign-object in-ptr)
+ (cffi-uffi-compat:free-foreign-object outbuffer)
+ (cffi-uffi-compat:free-foreign-object inbuffer)))))
1
0
[bknr-cvs] r2023 - in branches/xml-class-rework/thirdparty: . cffi cffi/doc cffi/examples cffi/scripts cffi/src cffi/tests cffi/uffi-compat
by bknr＠bknr.net 22 Oct '06
by bknr＠bknr.net 22 Oct '06
22 Oct '06
Author: hhubner
Date: 2006-10-22 11:57:04 -0400 (Sun, 22 Oct 2006)
New Revision: 2023
Added:
branches/xml-class-rework/thirdparty/cffi/
branches/xml-class-rework/thirdparty/cffi/COPYRIGHT
branches/xml-class-rework/thirdparty/cffi/HEADER
branches/xml-class-rework/thirdparty/cffi/Makefile
branches/xml-class-rework/thirdparty/cffi/README
branches/xml-class-rework/thirdparty/cffi/TODO
branches/xml-class-rework/thirdparty/cffi/cffi-examples.asd
branches/xml-class-rework/thirdparty/cffi/cffi-tests.asd
branches/xml-class-rework/thirdparty/cffi/cffi-uffi-compat.asd
branches/xml-class-rework/thirdparty/cffi/cffi.asd
branches/xml-class-rework/thirdparty/cffi/doc/
branches/xml-class-rework/thirdparty/cffi/doc/Makefile
branches/xml-class-rework/thirdparty/cffi/doc/allegro-internals.txt
branches/xml-class-rework/thirdparty/cffi/doc/cffi-manual.texinfo
branches/xml-class-rework/thirdparty/cffi/doc/cffi-sys-spec.texinfo
branches/xml-class-rework/thirdparty/cffi/doc/colorize-lisp-examples.lisp
branches/xml-class-rework/thirdparty/cffi/doc/gendocs.sh
branches/xml-class-rework/thirdparty/cffi/doc/gendocs_template
branches/xml-class-rework/thirdparty/cffi/doc/mem-vector.txt
branches/xml-class-rework/thirdparty/cffi/doc/shareable-vectors.txt
branches/xml-class-rework/thirdparty/cffi/doc/style.css
branches/xml-class-rework/thirdparty/cffi/examples/
branches/xml-class-rework/thirdparty/cffi/examples/examples.lisp
branches/xml-class-rework/thirdparty/cffi/examples/gethostname.lisp
branches/xml-class-rework/thirdparty/cffi/examples/gettimeofday.lisp
branches/xml-class-rework/thirdparty/cffi/examples/run-examples.lisp
branches/xml-class-rework/thirdparty/cffi/examples/translator-test.lisp
branches/xml-class-rework/thirdparty/cffi/scripts/
branches/xml-class-rework/thirdparty/cffi/scripts/release.sh
branches/xml-class-rework/thirdparty/cffi/src/
branches/xml-class-rework/thirdparty/cffi/src/cffi-allegro.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-clisp.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-cmucl.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-corman.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-ecl.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-gcl.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-lispworks.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-openmcl.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-sbcl.lisp
branches/xml-class-rework/thirdparty/cffi/src/cffi-scl.lisp
branches/xml-class-rework/thirdparty/cffi/src/early-types.lisp
branches/xml-class-rework/thirdparty/cffi/src/enum.lisp
branches/xml-class-rework/thirdparty/cffi/src/features.lisp
branches/xml-class-rework/thirdparty/cffi/src/foreign-vars.lisp
branches/xml-class-rework/thirdparty/cffi/src/functions.lisp
branches/xml-class-rework/thirdparty/cffi/src/libraries.lisp
branches/xml-class-rework/thirdparty/cffi/src/package.lisp
branches/xml-class-rework/thirdparty/cffi/src/strings.lisp
branches/xml-class-rework/thirdparty/cffi/src/types.lisp
branches/xml-class-rework/thirdparty/cffi/src/utils.lisp
branches/xml-class-rework/thirdparty/cffi/tests/
branches/xml-class-rework/thirdparty/cffi/tests/Makefile
branches/xml-class-rework/thirdparty/cffi/tests/bindings.lisp
branches/xml-class-rework/thirdparty/cffi/tests/callbacks.lisp
branches/xml-class-rework/thirdparty/cffi/tests/compile.bat
branches/xml-class-rework/thirdparty/cffi/tests/defcfun.lisp
branches/xml-class-rework/thirdparty/cffi/tests/enum.lisp
branches/xml-class-rework/thirdparty/cffi/tests/foreign-globals.lisp
branches/xml-class-rework/thirdparty/cffi/tests/funcall.lisp
branches/xml-class-rework/thirdparty/cffi/tests/libtest.c
branches/xml-class-rework/thirdparty/cffi/tests/memory.lisp
branches/xml-class-rework/thirdparty/cffi/tests/misc-types.lisp
branches/xml-class-rework/thirdparty/cffi/tests/misc.lisp
branches/xml-class-rework/thirdparty/cffi/tests/package.lisp
branches/xml-class-rework/thirdparty/cffi/tests/random-tester.lisp
branches/xml-class-rework/thirdparty/cffi/tests/run-tests.lisp
branches/xml-class-rework/thirdparty/cffi/tests/struct.lisp
branches/xml-class-rework/thirdparty/cffi/tests/union.lisp
branches/xml-class-rework/thirdparty/cffi/uffi-compat/
branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp
Log:
Imported cffi_0.9.1
Added: branches/xml-class-rework/thirdparty/cffi/COPYRIGHT
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/COPYRIGHT 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/COPYRIGHT 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,21 @@
+Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use, copy,
+modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
Added: branches/xml-class-rework/thirdparty/cffi/HEADER
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/HEADER 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/HEADER 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,28 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; filename --- description
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+
Added: branches/xml-class-rework/thirdparty/cffi/Makefile
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/Makefile 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/Makefile 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,68 @@
+# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
+#
+# Makefile --- Make targets for various tasks.
+#
+# Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation
+# files (the "Software"), to deal in the Software without
+# restriction, including without limitation the rights to use, copy,
+# modify, merge, publish, distribute, sublicense, and/or sell copies
+# of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+#
+
+# This way you can easily run the tests for different versions
+# of each lisp with, e.g. ALLEGRO=/path/to/some/lisp make test-allegro
+CMUCL=lisp
+OPENMCL=openmcl
+SBCL=sbcl
+CLISP=clisp
+ALLEGRO=acl
+SCL=scl
+
+shlibs:
+ @$(MAKE) -wC tests shlibs
+
+clean:
+ @$(MAKE) -wC tests clean
+ find . -name ".fasls" | xargs rm -rf
+ find . \( -name "*.dfsl" -o -name "*.fasl" -o -name "*.fas" -o -name "*.lib" -o -name "*.x86f" -o -name "*.amd64f" -o -name "*.sparcf" -o -name "*.sparc64f" -o -name "*.hpf" -o -name "*.hp64f" -o -name "*.ppcf" -o -name "*.nfasl" -o -name "*.ufsl" -o -name "*.fsl" \) -exec rm {} \;
+
+test-openmcl:
+ @-$(OPENMCL) --load tests/run-tests.lisp
+
+test-sbcl:
+ @-$(SBCL) --noinform --load tests/run-tests.lisp
+
+test-cmucl:
+ @-$(CMUCL) -load tests/run-tests.lisp
+
+test-scl:
+ @-$(SCL) -load tests/run-tests.lisp
+
+test-clisp:
+ @-$(CLISP) -q -x '(load "tests/run-tests.lisp")'
+
+test-clisp-modern:
+ @-$(CLISP) -modern -q -x '(load "tests/run-tests.lisp")'
+
+test-allegro:
+ @-$(ALLEGRO) -L tests/run-tests.lisp
+
+test: test-openmcl test-sbcl test-cmucl test-clisp
+
+# vim: ft=make ts=3 noet
Property changes on: branches/xml-class-rework/thirdparty/cffi/Makefile
___________________________________________________________________
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/README
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/README 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/README 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,17 @@
+
+CFFI, the Common Foreign Function Interface, purports to be a portable
+foreign function interface, similar in spirit to UFFI.
+
+Unlike UFFI, CFFI requires only a small set of low-level functionality
+from the Lisp implementation, such as calling a foreign function by
+name, allocating foreign memory, and dereferencing pointers.
+
+More complex tasks like accessing foreign structures can be done in
+portable "user space" code, making use of the low-level memory access
+operations defined by the implementation-specific bits.
+
+CFFI also aims to be more efficient than UFFI when possible. In
+particular, UFFI's use of aliens in CMUCL and SBCL can be tricky to
+get right. CFFI avoids this by using system area pointers directly
+instead of alien objects. All foreign function definitions and uses
+should compile without alien-value compiler notes in CMUCL/SBCL.
Added: branches/xml-class-rework/thirdparty/cffi/TODO
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/TODO 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/TODO 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,111 @@
+-*- Text -*-
+
+This is a collection of TODO items and ideas in no particular order.
+
+### Testing
+
+-> Test uffi-compat with more UFFI libraries.
+-> Write more FOREIGN-GLOBALS.SET.* tests.
+-> Finish tests/random-tester.lisp
+-> Write benchmarks comparing CFFI vs. native FFIs and also demonstrating
+ performance of each platform.
+-> Write more STRUCT.ALIGNMENT.* tests (namely involving the :LONG-LONG
+ and :UNSIGNED-LONG-LONG types) and test them in more ABIs.
+-> Run tests both interpreted (where it makes sense) and compiled.
+-> Run tests with the different kinds of shared libraries available on
+ MacOS X.
+
+### Ports
+
+-> Finish GCL port.
+-> Fix the ECL port.
+-> Fix bugs in the Corman port.
+-> Port to MCL.
+
+### Features
+
+-> Implement CFFI-SYS:%CLOSE-FOREIGN-LIBRARY for all supported Lisps and
+ implement a higher-level CFFI:CLOSE-FOREIGN-LIBRARY.
+-> Implement a declarative interface for FOREIGN-FUNCALL-PTR, similar to
+ DEFCUN/FOREIGN-FUNCALL.
+-> Figure out how to portably define types like: time_t, size_t, wchar_t,
+ etc... Likely to involve something like SB-GROVEL and possibly avoiding
+ this step on known platforms?
+-> [Lost Idea] Something involving finalizers?
+-> Implement the proposed interfaces (see doc/).
+-> Add the ability to specify the calling convention to the interface.
+-> Implement CFFI-SYS:ERRNO-VALUE (name?).
+-> Extend FOREIGN-SLOT-VALUE and make it accept multiple "indices" for
+ directly accessing structs inside structs, arrays inside structs, etc...
+-> Implement EXPLAIN-FOREIGN-SLOT-VALUE.
+-> Implement :in/:out/:in-out for DEFCFUN (and FOREIGN-FUNCALL?).
+-> Add support for multiple memory allocation schemes (like CLISP), namely
+ support for allocating with malloc() (so that it can be freed on the C
+ side)>
+-> Extend DEFCVAR's symbol macro in order to handle memory (de)allocation
+ automatically (see CLISP).
+-> Implement byte swapping routines (see /usr/include/linux/byteorder)
+-> [Lost Idea] Implement UB8-REF?
+-> [Lost Idea] Something about MEM-READ-C-STRING returning multiple value?
+-> Implement an array type? Useful when we're working with ranks >= 2?
+-> Implement bitfields. To read: get the word, LDB it. To write: get the
+ word, PDB it, put the word.
+-> External encodings for the :STRING type. See:
+ <http://article.gmane.org/gmane.lisp.cffi.devel/292>
+-> Define a lisp type for pointers in the backends. Eg: for clisp:
+ (deftype pointer-type (or ffi:foreign-address null))
+ Useful for type declarations.
+-> Warn about :void in places where it doesn't make sense.
+
+### Underspecified Semantics
+
+-> (setf (mem-ref ptr <aggregate-type> offset) <value>)
+-> Review the interface for coherence across Lisps with regard to
+ behaviour in "exceptional" situations. Eg: threads, dumping cores,
+ accessing foreign symbols that don't exist, etc...
+-> On Lispworks a Lisp float is a double and therefore won't necessarily
+ fit in a C float. Figure out a way to handle this.
+-> Allegro: callbacks' return values.
+-> Lack of uniformity with regard to pointers. Allegro: 0 -> NULL.
+ CLISP/Lispworks: NIL -> NULL.
+-> Some lisps will accept a lisp float being passed to :double
+ and a lisp double to :float. We should either coerce on lisps that
+ don't accept this or check-type on lisps that do. Probably the former
+ is better since on lispworks/x86 double == float.
+-> What happens when the same library is loaded twice.
+
+### Possible Optimizations
+
+-> More compiler macros on some of the CFFI-SYS implementations.
+-> Optimize UFFI-COMPAT when the vector stuff is implemented.
+-> Being able to declare that some C int will always fit in a Lisp
+ fixnum. Allegro has a :fixnum ftype and CMUCL/SBCL can use
+ (unsigned-byte 29) others could perhaps behave like :int?
+-> An option for defcfun to expand into a compiler macro which would
+ allow the macroexpansion-time translators to look at the forms
+ passed to the functions.
+
+### Known Issues
+
+-> CLISP FASL portability is broken. Fix this by placing LOAD-TIME-VALUE
+ forms in the right places and moving other calculations to load-time.
+ (eg: calculating struct size/alignment.) Ideally we'd only move them
+ to load-time when we actually care about fasl portability.
+ (defmacro maybe-load-time-value (form)
+ (if <we care about fasl portability>
+ `(load-time-value ,form)
+ form))
+-> cffi-tests.asd's :c-test-lib component is causing the whole testsuite
+ to be recompiled everytime. Figure that out.
+-> The (if (constantp foo) (do-something-with (eval foo)) ...) pattern
+ used in many places throughout the code is apparently not 100% safe.
+
+### Documentation
+
+-> Fill the missing sections in the CFFI User Manual.
+-> Update the CFFI-SYS Specification.
+-> Generally improve the reference docs and examples.
+
+### Other
+
+-> Type-checking pointer interface.
Added: branches/xml-class-rework/thirdparty/cffi/cffi-examples.asd
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/cffi-examples.asd 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/cffi-examples.asd 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,41 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-examples.asd --- ASDF system definition for CFFI examples.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(defpackage #:cffi-examples-system
+ (:use #:cl #:asdf))
+(in-package #:cffi-examples-system)
+
+(defsystem cffi-examples
+ :description "CFFI Examples"
+ :author "James Bielman <jamesjb(a)jamesjb.com>"
+ :components
+ ((:module examples
+ :components
+ ((:file "examples")
+ (:file "gethostname")
+ (:file "gettimeofday"))))
+ :depends-on (cffi))
Added: branches/xml-class-rework/thirdparty/cffi/cffi-tests.asd
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/cffi-tests.asd 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/cffi-tests.asd 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,77 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-tests.asd --- ASDF system definition for CFFI unit tests.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(defpackage #:cffi-tests-system
+ (:use #:cl #:asdf))
+(in-package #:cffi-tests-system)
+
+(defvar *tests-dir* (append (pathname-directory *load-truename*) '("tests")))
+
+(defclass c-test-lib (c-source-file)
+ ())
+
+(defmethod perform ((o load-op) (c c-test-lib))
+ nil)
+
+(defmethod perform ((o load-source-op) (c c-test-lib))
+ nil)
+
+(defmethod perform ((o compile-op) (c c-test-lib))
+ #-(or win32 mswindows)
+ (unless (zerop (run-shell-command
+ #-freebsd "cd ~A; make"
+ #+freebsd "cd ~A; gmake"
+ (namestring (make-pathname :name nil :type nil
+ :directory *tests-dir*))))
+ (error 'operation-error :component c :operation o)))
+
+(defsystem cffi-tests
+ :description "Unit tests for CFFI."
+ :depends-on (cffi rt)
+ :components
+ ((:module "tests"
+ :serial t
+ :components
+ ((:c-test-lib "libtest")
+ (:file "package")
+ (:file "bindings")
+ (:file "funcall")
+ (:file "defcfun")
+ (:file "callbacks")
+ (:file "foreign-globals")
+ (:file "memory")
+ (:file "struct")
+ (:file "union")
+ (:file "enum")
+ (:file "misc-types")
+ (:file "misc")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :cffi-tests))))
+ (or (funcall (intern (symbol-name '#:do-tests) '#:regression-test))
+ (error "test-op failed.")))
+
+;;; vim: ft=lisp et
Added: branches/xml-class-rework/thirdparty/cffi/cffi-uffi-compat.asd
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/cffi-uffi-compat.asd 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/cffi-uffi-compat.asd 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,41 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-uffi-compat.asd --- ASDF system definition for CFFI-UFFI-COMPAT.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(defpackage #:cffi-uffi-compat-system
+ (:use #:cl #:asdf))
+(in-package #:cffi-uffi-compat-system)
+
+(defsystem cffi-uffi-compat
+ :description "UFFI Compatibility Layer for CFFI"
+ :author "James Bielman <jamesjb(a)jamesjb.com>"
+ :components
+ ((:module uffi-compat
+ :components
+ ((:file "uffi-compat"))))
+ :depends-on (cffi))
+
+;; vim: ft=lisp et
Added: branches/xml-class-rework/thirdparty/cffi/cffi.asd
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/cffi.asd 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/cffi.asd 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,68 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi.asd --- ASDF system definition for CFFI.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+#-(or openmcl sbcl cmu scl clisp lispworks ecl allegro cormanlisp)
+(error "Sorry, this Lisp is not yet supported. Patches welcome!")
+
+(defpackage #:cffi-system
+ (:use #:cl #:asdf))
+(in-package #:cffi-system)
+
+(defsystem cffi
+ :description "The Common Foreign Function Interface"
+ :author "James Bielman <jamesjb(a)jamesjb.com>"
+ :version "0.9.0"
+ :licence "MIT"
+ :components
+ ((:module src
+ :serial t
+ :components
+ ((:file "utils")
+ (:file "features")
+ #+openmcl (:file "cffi-openmcl")
+ #+sbcl (:file "cffi-sbcl")
+ #+cmu (:file "cffi-cmucl")
+ #+scl (:file "cffi-scl")
+ #+clisp (:file "cffi-clisp")
+ #+lispworks (:file "cffi-lispworks")
+ #+ecl (:file "cffi-ecl")
+ #+allegro (:file "cffi-allegro")
+ #+cormanlisp (:file "cffi-corman")
+ (:file "package")
+ (:file "libraries")
+ (:file "early-types")
+ (:file "types")
+ (:file "enum")
+ (:file "strings")
+ (:file "functions")
+ (:file "foreign-vars")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :cffi))))
+ (operate 'asdf:load-op :cffi-tests)
+ (operate 'asdf:test-op :cffi-tests))
+
+;; vim: ft=lisp et
Added: branches/xml-class-rework/thirdparty/cffi/doc/Makefile
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/Makefile 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/Makefile 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,42 @@
+# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
+#
+# Makefile --- Make targets for generating the documentation.
+#
+# Copyright (C) 2005-2006, Luis Oliveira <loliveira at common-lisp.net>
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation
+# files (the "Software"), to deal in the Software without
+# restriction, including without limitation the rights to use, copy,
+# modify, merge, publish, distribute, sublicense, and/or sell copies
+# of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+#
+
+all: docs
+
+docs:
+ sh gendocs.sh -o manual --html "--css-include=style.css" cffi-manual "CFFI User Manual"
+ sh gendocs.sh -o spec --html "--css-include=style.css" cffi-sys-spec "CFFI-SYS Interface Specification"
+
+clean:
+ find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \;
+ rm -rf manual spec
+
+upload-docs:
+ rsync -av --delete -e ssh manual spec common-lisp.net:/project/cffi/public_html/
+# scp -r manual spec common-lisp.net:/project/cffi/public_html/
+
+# vim: ft=make ts=3 noet
Property changes on: branches/xml-class-rework/thirdparty/cffi/doc/Makefile
___________________________________________________________________
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/doc/allegro-internals.txt
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/allegro-internals.txt 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/allegro-internals.txt 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,132 @@
+July 2005
+These details were kindly provided by Duane Rettig of Franz.
+
+Regarding the following snippet of the macro expansion of
+FF:DEF-FOREIGN-CALL:
+
+ (SYSTEM::FF-FUNCALL
+ (LOAD-TIME-VALUE (EXCL::DETERMINE-FOREIGN-ADDRESS
+ '("foo" :LANGUAGE :C) 2 NIL))
+ '(:INT (INTEGER * *)) ARG1
+ '(:DOUBLE (DOUBLE-FLOAT * *)) ARG2
+ '(:INT (INTEGER * *)))
+
+"
+... in Allegro CL, if you define a foreign call FOO with C entry point
+"foo" and with :call-direct t in the arguments, and if other things are
+satisfied, then if a lisp function BAR is compiled which has a call to
+FOO, that call will not go through ff-funcall (and thus a large amount
+of argument manipulation and processing) but will instead set up its
+arguments directly on the stack, and will then perform the "call" more
+or less directly, through the "entry vec" (a small structure which
+keeps track of a foreign entry's address and status)."
+
+This is the code that generates what the compiler expects to see:
+
+(setq call-direct-form
+ (if* call-direct
+ then `(setf (get ',lispname 'sys::direct-ff-call)
+ (list ',external-name
+ ,callback
+ ,convention
+ ',returning
+ ',arg-types
+ ,arg-checking
+ ,entry-vec-flags))
+ else `(remprop ',lispname 'sys::direct-ff-call)))
+
+Thus generating something like:
+
+ (EVAL-WHEN (COMPILE LOAD EVAL)
+ (SETF (GET 'FOO 'SYSTEM::DIRECT-FF-CALL)
+ (LIST '("foo" :LANGUAGE :C) T :C
+ '(:INT (INTEGER * *))
+ '((:INT (INTEGER * *))
+ (:FLOAT (SINGLE-FLOAT * *)))
+ T
+ 2 ; this magic value is explained later
+ )))
+
+"
+(defun determine-foreign-address (name &optional (flags 0) method-index)
+ ;; return an entry-vec struct suitable for the foreign-call of name.
+ ;;
+ ;; name is either a string, which is taken without conversion, or
+ ;; a list consisting of a string to convert or a conversion function
+ ;; call.
+ ;; flags is an integer representing the flags to place into the entry-vec.
+ ;; method-index, if non-nil, is a word-index into a vtbl (virtual table).
+ ;; If method-index is true, then the name must be a string uniquely
+ ;; represented by the index and by the flags field.
+
+Note that not all architectures implement the :method-index argument
+to def-foreign-call, but your interface likely won't support it
+anyway, so just leave it nil. As for the flags, they are constants
+stored into the entry-vec returned by d-f-a and are given here:
+
+(defconstant ep-flag-call-semidirect 1) ; Real address stored in alt-address slot
+(defconstant ep-flag-never-release 2) ; Never release the heap
+(defconstant ep-flag-always-release 4) ; Always release the heap
+(defconstant ep-flag-release-when-ok 8) ; Release the heap unless without-interrupts
+
+(defconstant ep-flag-tramp-calls #x70) ; Make calls through special trampolines
+(defconstant ep-flag-tramp-shift 4)
+
+(defconstant ep-flag-variable-address #x100) ; Entry-point contains address of C var
+(defconstant ep-flag-strings-convert #x200) ; Convert strings automatically
+
+(defconstant ep-flag-get-errno #x1000) ;; [rfe5060]: Get errno value after call
+(defconstant ep-flag-get-last-error #x2000) ;; [rfe5060]: call GetLastError after call
+;; Leave #x4000 and #x8000 open for expansion
+
+Mostly, you'll give the value 2 (never release the heap), but if you
+give 4 or 8, then d-f-a will automatically set the 1 bit as well,
+which takes the call through a heap-release/reacquire process.
+
+Some docs for entry-vec are:
+
+;; -- entry vec --
+;; An entry-vec is an entry-point descriptor, usually a pointer into
+;; a shared-library. It is represented as a 5-element struct of type
+;; foreign-vector. The reason for this represntation is
+;; that it allows the entry point to be stored in a table, called
+;; the .saved-entry-points. table, and to be used by a foreign
+;; function. When the location of the foreign function to which the entry
+;; point refers changes, it is simply a matter of changing the value in entry
+;; point vector and the foreign call code sees it immediately. There is
+;; even an address that can be put in the entry point vector that denotes
+;; a missing foreign function, thus lookup can happen dynamically.
+
+(defstruct (entry-vec
+ (:type (vector excl::foreign (*)))
+ (:constructor make-entry-vec-boa ()))
+ name ; entry point name
+ (address 0) ; jump address for foreign code
+ (handle 0) ; shared-lib handle
+ (flags 0) ; ep-* flags
+ (alt-address 0) ; sometimes holds the real func addr
+ )
+
+[...]
+"
+
+Regarding the arguments to SYSTEM::FF-FUNCALL:
+ '(:int (integer * *)) argN
+
+"The type-spec is as it is given in the def-foreign-call
+syntax, with a C type optionally followed by a lisp type,
+followed optionally by a user-conversion function name[...]"
+
+
+Getting the alignment:
+
+CL-USER(2): (ff:get-foreign-type :int)
+#S(FOREIGN-FUNCTIONS::IFOREIGN-TYPE
+ :ATTRIBUTES NIL
+ :SFTYPE
+ #S(FOREIGN-FUNCTIONS::SIZED-FTYPE-PRIM
+ :KIND :INT
+ :WIDTH 4
+ :OFFSET 0
+ :ALIGN 4)
+ ...)
Property changes on: branches/xml-class-rework/thirdparty/cffi/doc/allegro-internals.txt
___________________________________________________________________
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/doc/cffi-manual.texinfo
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/cffi-manual.texinfo 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/cffi-manual.texinfo 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,5456 @@
+\input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*-
+@c %**start of header
+@setfilename cffi.info
+@settitle CFFI User Manual
+@exampleindent 2
+
+@c @documentencoding utf-8
+
+@ignore
+Style notes:
+
+* The reference section names and "See Also" list are roman, not
+ @code. This is to follow the format of CLHS.
+
+* How it looks in HTML is the priority.
+@end ignore
+
+@c ============================= Macros =============================
+@c The following macros are used throughout this manual.
+
+@macro Function {args}
+@defun \args\
+@end defun
+@end macro
+
+@macro Macro {args}
+@defmac \args\
+@end defmac
+@end macro
+
+@macro Accessor {args}
+@deffn {Accessor} \args\
+@end deffn
+@end macro
+
+@macro GenericFunction {args}
+@deffn {Generic Function} \args\
+@end deffn
+@end macro
+
+@macro ForeignType {args}
+@deftp {Foreign Type} \args\
+@end deftp
+@end macro
+
+@macro Variable {args}
+@defvr {Special Variable} \args\
+@end defvr
+@end macro
+
+@macro Condition {args}
+@deftp {Condition Type} \args\
+@end deftp
+@end macro
+
+@macro cffi
+@acronym{CFFI}
+@end macro
+
+@macro impnote {text}
+@quotation
+@strong{Implementor's note:} @emph{\text\}
+@end quotation
+@end macro
+
+@c Info "requires" that x-refs end in a period or comma, or ) in the
+@c case of @pxref. So the following implements that requirement for
+@c the "See also" subheadings that permeate this manual, but only in
+@c Info mode.
+@ifinfo
+@macro seealso {name}
+@ref{\name\}.
+@end macro
+@end ifinfo
+
+@ifnotinfo
+@alias seealso = ref
+@end ifnotinfo
+
+@c Set ROMANCOMMENTS to get comments in roman font.
+@ifset ROMANCOMMENTS
+@alias lispcmt = r
+@end ifset
+@ifclear ROMANCOMMENTS
+@alias lispcmt = asis
+@end ifclear
+
+
+@c ============================= Macros =============================
+
+
+@c Show types, functions, and concepts in the same index.
+@syncodeindex tp cp
+@syncodeindex fn cp
+
+@copying
+Copyright @copyright{} 2005, James Bielman <jamesjb at jamesjb.com> @*
+Copyright @copyright{} 2005, 2006 Lu@'{@dotless{i}}s Oliveira
+ <loliveira at common-lisp.net> @*
+Copyright @copyright{} 2006, Stephen Compall <s11 at member.fsf.org>
+
+@quotation
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the ``Software''), to deal in the Software without
+restriction, including without limitation the rights to use, copy,
+modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+@sc{The software is provided ``as is'', without warranty of any kind,
+express or implied, including but not limited to the warranties of
+merchantability, fitness for a particular purpose and noninfringement.
+In no event shall the authors or copyright holders be liable for any
+claim, damages or other liability, whether in an action of contract,
+tort or otherwise, arising from, out of or in connection with the
+software or the use or other dealings in the software.}
+@end quotation
+@end copying
+@c %**end of header
+
+@titlepage
+@title CFFI User Manual
+@c @subtitle Version X.X
+@c @author James Bielman
+
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@contents
+
+@ifnottex
+@node Top
+@top cffi
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction:: What is CFFI?
+* Implementation Support::
+* Tutorial:: Interactive intro to using CFFI.
+* Wrapper generators:: CFFI forms from munging C source code.
+* Foreign Types::
+* Pointers::
+* Strings::
+* Variables::
+* Functions::
+* Libraries::
+* Callbacks::
+* Limitations::
+* Platform-specific features:: Details about the underlying system.
+* Comprehensive Index::
+
+@detailmenu
+ --- Dictionary ---
+
+Foreign Types
+
+* convert-from-foreign:: Outside interface to backward type translator.
+* convert-to-foreign:: Outside interface to forward type translator.
+* defbitfield:: Defines a bitfield.
+* defcstruct:: Defines a C structure type.
+* defcunion:: Defines a C union type.
+* defctype:: Defines a foreign typedef.
+* defcenum:: Defines a C enumeration.
+@c * define-type-spec-parser:: <should be exported?>
+* define-foreign-type:: Defines a foreign type specifier.
+@c * explain-foreign-slot-value:: <unimplemented>
+* foreign-bitfield-symbols:: Returns a list of symbols for a bitfield type.
+* foreign-bitfield-value:: Calculates a value for a bitfield type.
+* foreign-enum-keyword:: Finds a keyword in an enum type.
+* foreign-enum-value:: Finds a value in an enum type.
+* foreign-slot-names:: Returns a list of slot names in a foreign struct.
+* foreign-slot-offset:: Returns the offset of a slot in a foreign struct.
+* foreign-slot-pointer:: Returns a pointer to a slot in a foreign struct.
+* foreign-slot-value:: Returns the value of a slot in a foreign struct.
+* foreign-type-alignment:: Returns the alignment of a foreign type.
+* foreign-type-size:: Returns the size of a foreign type.
+* free-converted-object:: Outside interface to typed object deallocators.
+* free-translated-object:: Free a type translated foreign object.
+* translate-from-foreign:: Translate a foreign object to a Lisp object.
+* translate-to-foreign:: Translate a Lisp object to a foreign object.
+* with-foreign-object:: Allocates a foreign object with dynamic extent.
+* with-foreign-slots:: Access the slots of a foreign structure.
+
+Pointers
+
+* foreign-free:: Deallocates memory.
+* foreign-alloc:: Allocates memory.
+* foreign-symbol-pointer:: Returns a pointer to a foreign symbol.
+* inc-pointer:: Increments the address held by a pointer.
+* make-pointer:: Returns a pointer to a given address.
+* mem-aref:: Accesses the value of an index in an array.
+* mem-ref:: Dereferences a pointer.
+* null-pointer:: Returns a NULL pointer.
+* null-pointer-p:: Tests a pointer for NULL value.
+* pointerp:: Tests whether an object is a pointer or not.
+* pointer-address:: Returns the address pointed to by a pointer.
+* pointer-eq:: Tests if two pointers point to the same address.
+* with-foreign-pointer:: Allocates memory with dynamic extent.
+
+Strings
+
+* foreign-string-alloc:: Converts a Lisp string to a foreign string.
+* foreign-string-free:: Deallocates memory used by a foreign string.
+* foreign-string-to-lisp:: Converts a foreign string to a Lisp string.
+* lisp-string-to-foreign:: Copies a Lisp string into a foreign string.
+* with-foreign-string:: Allocates a foreign string with dynamic extent.
+* with-foreign-pointer-as-string:: Similar to CL's with-output-to-string.
+
+Variables
+
+* defcvar:: Defines a C global variable.
+* get-var-pointer:: Returns a pointer to a defined global variable.
+
+Functions
+
+* defcfun:: Defines a foreign function.
+* foreign-funcall:: Performs a call to a foreign function.
+
+Libraries
+
+* *darwin-framework-directories*:: Search path for Darwin frameworks.
+* define-foreign-library:: Explain how to load a foreign library.
+* *foreign-library-directories*:: Search path for shared libraries.
+* load-foreign-library:: Load a foreign library.
+* load-foreign-library-error:: Signalled on failure of its namesake.
+* use-foreign-library:: Load a foreign library when needed.
+
+Callbacks
+
+* callback:: Returns a pointer to a defined callback.
+* defcallback:: Defines a Lisp callback.
+* get-callback:: Returns a pointer to a defined callback.
+
+@end detailmenu
+@end menu
+
+
+
+
+@c ===================================================================
+@c CHAPTER: Introduction
+
+@node Introduction
+@chapter Introduction
+
+@cffi{} is the Common Foreign Function Interface for @acronym{ANSI}
+Common Lisp systems. By @dfn{foreign function} we mean a function
+written in another programming language and having different data and
+calling conventions than Common Lisp, namely, C. @cffi{} allows you
+to call foreign functions and access foreign variables, all without
+leaving the Lisp image.
+
+We consider this manual ever a work in progress. If you have
+difficulty with anything @cffi{}-specific presented in the manual,
+please contact @email{cffi-devel@@common-lisp.net,the developers} with
+details.
+
+
+@heading Motivation
+
+@xref{Tutorial-Comparison,, What makes Lisp different}, for
+an argument in favor of @acronym{FFI} in general.
+
+@cffi{}'s primary role in any image is to mediate between Lisp
+developers and the widely varying @acronym{FFI}s present in the
+various Lisp implementations it supports. With @cffi{}, you can
+define foreign function interfaces while still maintaining portability
+between implementations. It is not the first Common Lisp package with
+this objective; however, it is meant to be a more malleable framework
+than similar packages.
+
+
+@heading Design Philosophy
+
+@itemize
+@item
+Pointers do not carry around type information. Instead, type
+information is supplied when pointers are dereferenced.
+
+@item
+A type safe pointer interface can be developed on top of an
+untyped one. It is difficult to do the opposite.
+
+@item
+Functions are better than macros. When a macro could be used
+for performance, use a compiler-macro instead.
+@end itemize
+
+
+@c ===================================================================
+@c CHAPTER: Implementation Support
+
+@node Implementation Support
+@chapter Implementation Support
+
+@cffi{} supports various free and commercial Lisp implementations:
+Allegro CL, Corman CL, @sc{clisp}, @acronym{CMUCL}, @acronym{ECL},
+LispWorks, Open@acronym{MCL}, @acronym{SBCL} and the Scieneer CL.
+
+There are also plans to support Digitool @acronym{MCL}, and @acronym{GCL}.
+
+
+@section Allegro CL
+
+@strong{Tested platforms:} linux/x86, linux/ppc, win32/x86, darwin/ppc.
+
+Version 7.0 is supported. The 8.0 beta is also known to work. Earlier
+versions are untested and unsupported but patches to support them
+are welcome.
+
+@subheading Limitations
+
+@itemize
+@item
+Does not support the @code{:long-long} type.
+@end itemize
+
+@section Corman CL
+
+@strong{Tested platforms:} win32/x86.
+
+Versions prior to 2.51 are untested and unsupported. Also, you will
+need to avoid Corman's buggy @code{COMPILE-FILE} and fasl
+loader. Please follow @uref{http://www.weitz.de/corman-asdf/, these
+instructions} by Edi Weitz to setup ASDF for Corman CL in a way that
+works around these issues.
+
+@subheading Limitations
+
+@itemize
+@item
+Does not support @code{foreign-funcall}.
+@end itemize
+
+
+@section @sc{clisp}
+
+@strong{Tested platforms:} linux/x86, linux/ppc, win32/x86, darwin/ppc.
+
+Version is 2.34 or newer is required on win32/x86. For other platforms
+version 2.35 or newer is required.
+
+
+@section @acronym{CMUCL}
+
+@strong{Tested platforms:} linux/x86, darwin/ppc.
+
+Versions prior to 19B are untested. For darwin/ppc, the 2006-02 (19C)
+snapshot or later is recommended.
+
+
+@section @acronym{ECL}
+
+@strong{Tested platforms:} @emph{needs testing...}
+
+As of November 2005, the CVS version of ECL is required. It is
+reported to pass all tests.
+
+@subheading Limitations
+@itemize
+@item
+Does not support the @code{:long-long} type.
+
+@item
+On platforms where ECL's dynamic FFI is not supported (ie. when
+@code{:dffi} is not present in @code{*features*}),
+@code{cffi:load-foreign-library} does not work and you must use ECL's
+own @code{ffi:load-foreign-library} with a constant string argument.
+@end itemize
+
+
+@section Lispworks
+
+@strong{Tested platforms:} linux/x86, win32/x86, darwin/ppc.
+
+Versions prior to 4.4 are untested.
+
+@subheading Limitations
+@itemize
+@item
+Does not support the @code{:long-long} type.
+@end itemize
+
+
+@section Open@acronym{MCL}
+
+@strong{Tested platforms:} darwin/ppc, linux/ppc.
+
+Open@acronym{MCL} 1.0 or newer is recommended.
+
+
+@section @acronym{SBCL}
+
+@strong{Tested platforms:} linux/x86, linux/ppc, darwin/ppc.
+
+Version 0.9.6 or newer is recommended.
+
+@subheading Limitations
+
+@itemize
+@item
+Not all platforms support callbacks.
+@end itemize
+
+
+@section Scieneer CL
+
+@strong{Tested platforms:} linux/x86, linux/amd64.
+
+Version 1.2.10 or newer is recommended. Passes all tests.
+The x86 and AMD64 ports feature long-double support.
+
+
+@c ===================================================================
+@c CHAPTER: An Introduction to Foreign Interfaces and CFFI
+
+@c This macro is merely a marker that I don't think I'll use after
+@c all.
+@macro tutorialsource {text}
+@c \text\
+@end macro
+
+@c because I don't want to type this over and over
+@macro clikicffi
+http://www.cliki.net/CFFI
+@end macro
+@c TeX puts spurious newlines in when you use the above macro
+@c in @examples &c. So it is expanded below in some places.
+
+
+@node Tutorial
+@chapter An Introduction to Foreign Interfaces and @acronym{CFFI}
+
+@c Above, I don't use the cffi macro because it breaks TeX.
+
+@cindex tutorial, @cffi{}
+Users of many popular languages bearing semantic similarity to Lisp,
+such as Perl and Python, are accustomed to having access to popular C
+libraries, such as @acronym{GTK}, by way of ``bindings''. In Lisp, we
+do something similar, but take a fundamentally different approach.
+This tutorial first explains this difference, then explains how you
+can use @cffi{}, a powerful system for calling out to C and C++ and
+access C data from many Common Lisp implementations.
+
+@cindex foreign functions and data
+The concept can be generalized to other languages; at the time of
+writing, only @cffi{}'s C support is fairly complete, but C++
+support is being worked on. Therefore, we will interchangeably refer
+to @dfn{foreign functions} and @dfn{foreign data}, and ``C functions''
+and ``C data''. At no time will the word ``foreign'' carry its usual,
+non-programming meaning.
+
+This tutorial expects you to have a working understanding of both
+Common Lisp and C, including the Common Lisp macro system.
+
+@menu
+* Tutorial-Comparison:: Why FFI?
+* Tutorial-Getting a URL:: An FFI use case.
+* Tutorial-Loading:: Load libcurl.so.
+* Tutorial-Initializing:: Call a function in libcurl.so.
+* Tutorial-easy_setopt:: An advanced libcurl function.
+* Tutorial-Abstraction:: Why breaking it is necessary.
+* Tutorial-Lisp easy_setopt:: Semi-Lispy option interface.
+* Tutorial-Memory:: In C, you collect the garbage.
+* Tutorial-Callbacks:: Make useful C function pointers.
+* Tutorial-Completion:: Minimal get-url functionality.
+* Tutorial-Types:: Defining new foreign types.
+* Tutorial-Conclusion:: What's next?
+@end menu
+
+
+@node Tutorial-Comparison
+@section What makes Lisp different
+
+The following sums up how bindings to foreign libraries are usually
+implemented in other languages, then in Common Lisp:
+
+@table @asis
+@item Perl, Python, Java, other one-implementation languages
+@cindex @acronym{SWIG}
+@cindex Perl
+@cindex Python
+Bindings are implemented as shared objects written in C. In some
+cases, the C code is generated by a tool, such as @acronym{SWIG}, but
+the result is the same: a new C library that manually translates
+between the language implementation's objects, such as @code{PyObject}
+in Python, and whatever C object is called for, often using C
+functions provided by the implementation. It also translates between
+the calling conventions of the language and C.
+
+@item Common Lisp
+@cindex @acronym{SLIME}
+Bindings are written in Lisp. They can be created at-will by Lisp
+programs. Lisp programmers can write new bindings and add them to the
+image, using a listener such as @acronym{SLIME}, as easily as with
+regular Lisp definitions. The only foreign library to load is the one
+being wrapped---the one with the pure C interface; no C or other
+non-Lisp compilation is required.
+@end table
+
+@cindex advantages of @acronym{FFI}
+@cindex benefits of @acronym{FFI}
+We believe the advantages of the Common Lisp approach far outweigh any
+disadvantages. Incremental development with a listener can be as
+productive for C binding development as it is with other Lisp
+development. Keeping it ``in the [Lisp] family'', as it were, makes
+it much easier for you and other Lisp programmers to load and use the
+bindings. Common Lisp implementations such as @acronym{CMUCL}, freed
+from having to provide a C interface to their own objects, are thus
+freed to be implemented in another language (as @acronym{CMUCL} is)
+while still allowing programmers to call foreign functions.
+
+@cindex minimal bindings
+Perhaps the greatest advantage is that using an @acronym{FFI} doesn't
+obligate you to become a professional binding developer. Writers of
+bindings for other languages usually end up maintaining or failing to
+maintain complete bindings to the foreign library. Using an
+@acronym{FFI}, however, means if you only need one or two functions,
+you can write bindings for only those functions, and be assured that
+you can just as easily add to the bindings if need be.
+
+@cindex C abstractions
+@cindex abstractions in C
+The removal of the C compiler, or C interpretation of any kind,
+creates the main disadvantage: some of C's ``abstractions'' are not
+available, violating information encapsulation. For example,
+@code{struct}s that must be passed on the stack, or used as return
+values, without corresponding functional abstractions to create and
+manage the @code{struct}s, must be declared explicitly in Lisp. This
+is fine for structs whose contents are ``public'', but is not so
+pleasant when a struct is supposed to be ``opaque'' by convention,
+even though it is not so defined.@footnote{Admittedly, this is an
+advanced issue, and we encourage you to leave this text until you are
+more familiar with how @cffi{} works.}
+
+Without an abstraction to create the struct, Lisp needs to be able to
+lay out the struct in memory, so must know its internal details.
+
+@cindex workaround for C
+In these cases, you can create a minimal C library to provide the
+missing abstractions, without destroying all the advantages of the
+Common Lisp approach discussed above. In the case of @code{struct}s,
+you can write simple, pure C functions that tell you how many bytes a
+struct requires or allocate new structs, read and write fields of the
+struct, or whatever operations are supposed to be
+public.@footnote{This does not apply to structs whose contents are
+intended to be part of the public library interface. In those cases,
+a pure Lisp struct definition is always preferred. In fact, many
+prefer to stay in Lisp and break the encapsulation anyway, placing the
+burden of correct library interface definition on the library.}
+
+Another disadvantage appears when you would rather use the foreign
+language than Lisp. However, someone who prefers C to Lisp is not a
+likely candidate for developing a Lisp interface to a C library.
+
+
+@node Tutorial-Getting a URL
+@section Getting a @acronym{URL}
+
+@cindex c@acronym{URL}
+The widely available @code{libcurl} is a library for downloading files
+over protocols like @acronym{HTTP}. We will use @code{libcurl} with
+@cffi{} to download a web page.
+
+Please note that there are many other ways to download files from the
+web, not least the @sc{cl-curl} project to provide bindings to
+@code{libcurl} via a similar @acronym{FFI}.@footnote{Specifically,
+@acronym{UFFI}, an older @acronym{FFI} that takes a somewhat different
+approach compared to @cffi{}. I believe that these days (December
+2005) @cffi{} is more portable and actively developed, though not as
+mature yet. Consensus in the free @sc{unix} Common Lisp community
+seems to be that @cffi{} is preferred for new development, though
+@acronym{UFFI} will likely go on for quite some time as many projects
+already use it. @cffi{} includes the @code{UFFI-COMPAT} package for
+complete compatibility with @acronym{UFFI}.}
+
+@uref{http://curl.haxx.se/libcurl/c/libcurl-tutorial.html,,libcurl-tutorial(3)}
+is a tutorial for @code{libcurl} programming in C. We will follow
+that to develop a binding to download a file. We will also use
+(a)file{curl.h}, @file{easy.h}, and the @command{man} pages for the
+@code{libcurl} function, all available in the @samp{curl-dev} package
+or equivalent for your system, or in the c@acronym{URL} source code
+package. If you have the development package, the headers should be
+installed in @file{/usr/include/curl/}, and the @command{man} pages
+may be accessed through your favorite @command{man} facility.
+
+
+@node Tutorial-Loading
+@section Loading foreign libraries
+
+@cindex loading @cffi{}
+@cindex requiring @cffi{}
+First of all, we will create a package to work in. You can save these
+forms in a file, or just send them to the listener as they are. If
+creating bindings for an @acronym{ASDF} package of yours, you will
+want to add @code{:cffi} to the @code{:depends-on} list in your
+(a)file{.asd} file. Otherwise, just use the @code{asdf:oos} function to
+load @cffi{}.
+
+@tutorialsource{Initialization}
+@lisp
+(asdf:oos 'asdf:load-op :cffi)
+
+;;; @lispcmt{Nothing special about the "CFFI-USER" package. We're just}
+;;; @lispcmt{using it as a substitute for your own CL package.}
+(defpackage :cffi-user
+ (:use :common-lisp :cffi))
+
+(in-package :cffi-user)
+
+(define-foreign-library libcurl
+ (:unix (:or "libcurl.so.3" "libcurl.so"))
+ (t (:default "libcurl")))
+
+(use-foreign-library libcurl)
+@end lisp
+
+@cindex foreign library load
+@cindex library, foreign
+Using @code{define-foreign-library} and @code{use-foreign-library}, we
+have loaded @code{libcurl} into Lisp, much as the linker does when you
+start a C program, or @code{common-lisp:load} does with a Lisp source
+file or @acronym{FASL} file. We special-cased for @sc{unix} machines
+to always load a particular version, the one this tutorial was tested
+with; for those who don't care, the @code{define-foreign-library}
+clause @code{(t (:default "libcurl"))} should be satisfactory, and
+will adapt to various operating systems.
+
+
+@node Tutorial-Initializing
+@section Initializing @code{libcurl}
+
+@cindex function definition
+After the introductory matter, the tutorial goes on to present the
+first function you should use.
+
+@example
+CURLcode curl_global_init(long flags);
+@end example
+
+@noindent
+Let's pick this apart into appropriate Lisp code:
+
+@tutorialsource{First CURLcode}
+@lisp
+;;; @lispcmt{A CURLcode is the universal error code. curl/curl.h says}
+;;; @lispcmt{no return code will ever be removed, and new ones will be}
+;;; @lispcmt{added to the end.}
+(defctype curl-code :int)
+
+;;; @lispcmt{Initialize libcurl with FLAGS.}
+(defcfun "curl_global_init" curl-code
+ (flags :long))
+@end lisp
+
+@impnote{CFFI currently assumes the UNIX viewpoint that there is one C
+symbol namespace, containing all symbols in all loaded objects. This
+is not so on Windows and Darwin. The interface may be changed to deal
+with this.}
+
+Note the parallels with the original C declaration. We've defined
+@code{curl-code} as a wrapping type for @code{:int}; right now, it
+only marks it as special, but later we will do something more
+interesting with it. The point is that we don't have to do it yet.
+
+@cindex calling foreign functions
+Looking at @file{curl.h}, @code{CURL_GLOBAL_NOTHING}, a possible value
+for @code{flags} above, is defined as @samp{0}. So we can now call
+the function:
+
+@example
+@sc{cffi-user>} (curl-global-init 0)
+@result{} 0
+@end example
+
+@cindex looks like it worked
+Looking at @file{curl.h} again, @code{0} means @code{CURLE_OK}, so it
+looks like the call succeeded. Note that @cffi{} converted the
+function name to a Lisp-friendly name. You can specify your own name
+if you want; use @code{("curl_global_init" @var{your-name-here})} as
+the @var{name} argument to @code{defcfun}.
+
+The tutorial goes on to have us allocate a handle. For good measure,
+we should also include the deallocator. Let's look at these
+functions:
+
+@example
+CURL *curl_easy_init( );
+void curl_easy_cleanup(CURL *handle);
+@end example
+
+Advanced users may want to define special pointer types; we will
+explore this possibility later. For now, just treat every pointer as
+the same:
+
+@tutorialsource{curl_easy handles}
+@lisp
+(defcfun "curl_easy_init" :pointer)
+
+(defcfun "curl_easy_cleanup" :void
+ (easy-handle :pointer))
+@end lisp
+
+Now we can continue with the tutorial:
+
+@example
+@sc{cffi-user>} (defparameter *easy-handle* (curl-easy-init))
+@result{} *EASY-HANDLE*
+@sc{cffi-user>} *easy-handle*
+@result{} #<FOREIGN-ADDRESS #x09844EE0>
+@end example
+
+@cindex pointers in Lisp
+Note the print representation of a pointer. It changes depending on
+what Lisp you are using, but that doesn't make any difference to
+@cffi{}.
+
+
+@node Tutorial-easy_setopt
+@section Setting download options
+
+The @code{libcurl} tutorial says we'll want to set many options before
+performing any download actions. This is done through
+@code{curl_easy_setopt}:
+
+@c That is literally ..., not an ellipsis.
+@example
+CURLcode curl_easy_setopt(CURL *curl, CURLoption option, ...);
+@end example
+
+@cindex varargs
+@cindex foreign arguments
+We've introduced a new twist: variable arguments. There is no obvious
+translation to the @code{defcfun} form, particularly as there are four
+possible argument types. Because of the way C works, we could define
+four wrappers around @code{curl_easy_setopt}, one for each type; in
+this case, however, we'll use the general-purpose macro
+@code{foreign-funcall} to call this function.
+
+@cindex enumeration, C
+To make things easier on ourselves, we'll create an enumeration of the
+kinds of options we want to set. The @code{enum CURLoption} isn't the
+most straightforward, but reading the @code{CINIT} C macro definition
+should be enlightening.
+
+@tutorialsource{CURLoption enumeration}
+@lisp
+(defmacro define-curl-options (name type-offsets &rest enum-args)
+ "As with CFFI:DEFCENUM, except each of ENUM-ARGS is as follows:
+
+ (NAME TYPE NUMBER)
+
+Where the arguments are as they are with the CINIT macro defined
+in curl.h, except NAME is a keyword.
+
+TYPE-OFFSETS is a plist of TYPEs to their integer offsets, as
+defined by the CURLOPTTYPE_LONG et al constants in curl.h."
+ (flet ((enumerated-value (type offset)
+ (+ (getf type-offsets type) offset)))
+ `(progn
+ (defcenum ,name
+ ,@@(loop for (name type number) in enum-args
+ collect (list name (enumerated-value type number))))
+ ',name))) ;@lispcmt{for REPL users' sanity}
+
+(define-curl-options curl-option
+ (long 0 objectpoint 10000 functionpoint 20000 off-t 30000)
+ (:noprogress long 43)
+ (:nosignal long 99)
+ (:errorbuffer objectpoint 10)
+ (:url objectpoint 2))
+@end lisp
+
+With some well-placed Emacs @code{query-replace-regexp}s, you could
+probably similarly define the entire @code{CURLoption} enumeration. I
+have selected to transcribe a few that we will use in this tutorial.
+
+If you're having trouble following the macrology, just macroexpand the
+@code{curl-option} definition, or see the following macroexpansion,
+conveniently downcased and reformatted:
+
+@tutorialsource{DEFINE-CURL-OPTIONS macroexpansion}
+@lisp
+(progn
+ (defcenum curl-option
+ (:noprogress 43)
+ (:nosignal 99)
+ (:errorbuffer 10010)
+ (:url 10002))
+ 'curl-option)
+@end lisp
+
+@noindent
+That seems more than reasonable. You may notice that we only use the
+@var{type} to compute the real enumeration offset; we will also need
+the type information later.
+
+First, however, let's make sure a simple call to the foreign function
+works:
+
+@example
+@sc{cffi-user>} (foreign-funcall "curl_easy_setopt"
+ :pointer *easy-handle*
+ curl-option :nosignal :long 1 curl-code)
+@result{} 0
+@end example
+
+@code{foreign-funcall}, despite its surface simplicity, can be used to
+call any C function. Its first argument is a string, naming the
+function to be called. Next, for each argument, we pass the name of
+the C type, which is the same as in @code{defcfun}, followed by a Lisp
+object representing the data to be passed as the argument. The final
+argument is the return type, for which we use the @code{curl-code}
+type defined earlier.
+
+@code{defcfun} just puts a convenient fa@,cade on
+@code{foreign-funcall}.@footnote{This isn't entirely true; some Lisps
+don't support @code{foreign-funcall}, so @code{defcfun} is implemented
+without it. @code{defcfun} may also perform optimizations that
+@code{foreign-funcall} cannot.} Our earlier call to
+@code{curl-global-init} could have been written as follows:
+
+@example
+@sc{cffi-user>} (foreign-funcall "curl_global_init" :long 0
+ curl-code)
+@result{} 0
+@end example
+
+Before we continue, we will take a look at what @cffi{} can and can't
+do, and why this is so.
+
+
+@node Tutorial-Abstraction
+@section Breaking the abstraction
+
+@cindex breaking the abstraction
+@cindex abstraction breaking
+In @ref{Tutorial-Comparison,, What makes Lisp different}, we mentioned
+that writing an @acronym{FFI} sometimes requires depending on
+information not provided as part of the interface. The easy option
+@code{CURLOPT_WRITEDATA}, which we will not provide as part of the
+Lisp interface, illustrates this issue.
+
+Strictly speaking, the @code{curl-option} enumeration is not
+necessary; we could have used @code{:int 99} instead of
+@code{curl-option :nosignal} in our call to @code{curl_easy_setopt}
+above. We defined it anyway, in part to hide the fact that we are
+breaking the abstraction that the C @code{enum} provides. If the
+c@acronym{URL} developers decide to change those numbers later, we
+must change the Lisp enumeration, because enumeration values are not
+provided in the compiled C library, @code{libcurl.so.3}.
+
+@cffi{} works because the most useful things in C libraries ---
+non-static functions and non-static variables --- are included
+accessibly in @code{libcurl.so.3}. A C compiler that violated this
+would be considered a worthless compiler.
+
+The other thing @code{define-curl-options} does is give the ``type''
+of the third argument passed to @code{curl_easy_setopt}. Using this
+information, we can tell that the @code{:nosignal} option should
+accept a long integer argument. We can implicitly assume @code{t}
+@equiv{} 1 and @code{nil} @equiv{} 0, as it is in C, which takes care
+of the fact that @code{CURLOPT_NOSIGNAL} is really asking for a
+boolean.
+
+The ``type'' of @code{CURLOPT_WRITEDATA} is @code{objectpoint}.
+However, it is really looking for a @code{FILE*}.
+@code{CURLOPT_ERRORBUFFER} is looking for a @code{char*}, so there is
+no obvious @cffi{} type but @code{:pointer}.
+
+The first thing to note is that nowhere in the C interface includes
+this information; it can only be found in the manual. We could
+disjoin these clearly different types ourselves, by splitting
+@code{objectpoint} into @code{filepoint} and @code{charpoint}, but we
+are still breaking the abstraction, because we have to augment the
+entire enumeration form with this additional
+information.@footnote{Another possibility is to allow the caller to
+specify the desired C type of the third argument. This is essentially
+what happens in a call to the function written in C.}
+
+@cindex streams and C
+@cindex @sc{file}* and streams
+The second is that the @code{CURLOPT_WRITEDATA} argument is completely
+incompatible with the desired Lisp data, a
+stream.@footnote{@xref{Other Kinds of Streams,,, libc, GNU C Library
+Reference}, for a @acronym{GNU}-only way to extend the @code{FILE*}
+type. You could use this to convert Lisp streams to the needed C
+data. This would be quite involved and far outside the scope of this
+tutorial.} It is probably acceptable if we are controlling every file
+we might want to use as this argument, in which case we can just call
+the foreign function @code{fopen}. Regardless, though, we can't write
+to arbitrary streams, which is exactly what we want to do for this
+application.
+
+Finally, note that the @code{curl_easy_setopt} interface itself is a
+hack, intended to work around some of the drawbacks of C. The
+definition of @code{Curl_setopt}, while long, is far less cluttered
+than the equivalent disjoint-function set would be; in addition,
+setting a new option in an old @code{libcurl} can generate a run-time
+error rather than breaking the compile. Lisp can just as concisely
+generate functions as compare values, and the ``undefined function''
+error is just as useful as any explicit error we could define here
+might be.
+
+
+@node Tutorial-Lisp easy_setopt
+@section Option functions in Lisp
+
+We could use @code{foreign-funcall} directly every time we wanted to
+call @code{curl_easy_setopt}. However, we can encapsulate some of the
+necessary information with the following.
+
+@lisp
+;;; @lispcmt{We will use this typedef later in a more creative way. For}
+;;; @lispcmt{now, just consider it a marker that this isn't just any}
+;;; @lispcmt{pointer.}
+(defctype easy-handle :pointer)
+
+(defmacro curl-easy-setopt (easy-handle enumerated-name
+ value-type new-value)
+ "Call `curl_easy_setopt' on EASY-HANDLE, using ENUMERATED-NAME
+as the OPTION. VALUE-TYPE is the CFFI foreign type of the third
+argument, and NEW-VALUE is the Lisp data to be translated to the
+third argument. VALUE-TYPE is not evaluated."
+ `(foreign-funcall "curl_easy_setopt" easy-handle ,easy-handle
+ curl-option ,enumerated-name
+ ,value-type ,new-value curl-code))
+@end lisp
+
+Now we define a function for each kind of argument that encodes the
+correct @code{value-type} in the above. This can be done reasonably
+in the @code{define-curl-options} macroexpansion; after all, that is
+where the different options are listed!
+
+@cindex Lispy C functions
+We could make @code{cl:defun} forms in the expansion that simply call
+@code{curl-easy-setopt}; however, it is probably easier and clearer to
+use @code{defcfun}. @code{define-curl-options} was becoming unwieldy,
+so I defined some helpers in this new definition.
+
+@smalllisp
+(defun curry-curl-option-setter (function-name option-keyword)
+ "Wrap the function named by FUNCTION-NAME with a version that
+curries the second argument as OPTION-KEYWORD.
+
+This function is intended for use in DEFINE-CURL-OPTION-SETTER."
+ (setf (symbol-function function-name)
+ (let ((c-function (symbol-function function-name)))
+ (lambda (easy-handle new-value)
+ (funcall c-function easy-handle option-keyword
+ new-value)))))
+
+(defmacro define-curl-option-setter (name option-type
+ option-value foreign-type)
+ "Define (with DEFCFUN) a function NAME that calls
+curl_easy_setopt. OPTION-TYPE and OPTION-VALUE are the CFFI
+foreign type and value to be passed as the second argument to
+easy_setopt, and FOREIGN-TYPE is the CFFI foreign type to be used
+for the resultant function's third argument.
+
+This macro is intended for use in DEFINE-CURL-OPTIONS."
+ `(progn
+ (defcfun ("curl_easy_setopt" ,name) curl-code
+ (easy-handle easy-handle)
+ (option ,option-type)
+ (new-value ,foreign-type))
+ (curry-curl-option-setter ',name ',option-value)))
+
+(defmacro define-curl-options (type-name type-offsets &rest enum-args)
+ "As with CFFI:DEFCENUM, except each of ENUM-ARGS is as follows:
+
+ (NAME TYPE NUMBER)
+
+Where the arguments are as they are with the CINIT macro defined
+in curl.h, except NAME is a keyword.
+
+TYPE-OFFSETS is a plist of TYPEs to their integer offsets, as
+defined by the CURLOPTTYPE_LONG et al constants in curl.h.
+
+Also, define functions for each option named
+set-`TYPE-NAME'-`OPTION-NAME', where OPTION-NAME is the NAME from
+the above destructuring."
+ (flet ((enumerated-value (type offset)
+ (+ (getf type-offsets type) offset))
+ ;;@lispcmt{map PROCEDURE, destructuring each of ENUM-ARGS}
+ (map-enum-args (procedure)
+ (mapcar (lambda (arg) (apply procedure arg)) enum-args))
+ ;;@lispcmt{build a name like SET-CURL-OPTION-NOSIGNAL}
+ (make-setter-name (option-name)
+ (intern (concatenate
+ 'string "SET-" (symbol-name type-name)
+ "-" (symbol-name option-name)))))
+ `(progn
+ (defcenum ,type-name
+ ,@@(map-enum-args
+ (lambda (name type number)
+ (list name (enumerated-value type number)))))
+ ,@@(map-enum-args
+ (lambda (name type number)
+ (declare (ignore number))
+ `(define-curl-option-setter ,(make-setter-name name)
+ ,type-name ,name ,(ecase type
+ (long :long)
+ (objectpoint :pointer)
+ (functionpoint :pointer)
+ (off-t :long)))))
+ ',type-name)))
+@end smalllisp
+
+@noindent
+Macroexpanding our @code{define-curl-options} form once more, we
+see something different:
+
+@lisp
+(progn
+ (defcenum curl-option
+ (:noprogress 43)
+ (:nosignal 99)
+ (:errorbuffer 10010)
+ (:url 10002))
+ (define-curl-option-setter set-curl-option-noprogress
+ curl-option :noprogress :long)
+ (define-curl-option-setter set-curl-option-nosignal
+ curl-option :nosignal :long)
+ (define-curl-option-setter set-curl-option-errorbuffer
+ curl-option :errorbuffer :pointer)
+ (define-curl-option-setter set-curl-option-url
+ curl-option :url :pointer)
+ 'curl-option)
+@end lisp
+
+@noindent
+Macroexpanding one of the new @code{define-curl-option-setter}
+forms yields the following:
+
+@lisp
+(progn
+ (defcfun ("curl_easy_setopt" set-curl-option-nosignal) curl-code
+ (easy-handle easy-handle)
+ (option curl-option)
+ (new-value :long))
+ (curry-curl-option-setter 'set-curl-option-nosignal ':nosignal))
+@end lisp
+
+@noindent
+Finally, let's try this out:
+
+@example
+@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1)
+@result{} 0
+@end example
+
+@noindent
+Looks like it works just as well. This interface is now reasonably
+high-level to wash out some of the ugliness of the thinnest possible
+@code{curl_easy_setopt} @acronym{FFI}, without obscuring the remaining
+C bookkeeping details we will explore.
+
+
+@node Tutorial-Memory
+@section Memory management
+
+According to the documentation for @code{curl_easy_setopt}, the type
+of the third argument when @var{option} is @code{CURLOPT_ERRORBUFFER}
+is @code{char*}. Above, we've defined
+@code{set-curl-option-errorbuffer} to accept a @code{:pointer} as the
+new option value. However, there is a @cffi{} type @code{:string},
+which translates Lisp strings to C strings when passed as arguments to
+foreign function calls. Why not, then, use @code{:string} as the
+@cffi{} type of the third argument? There are two reasons, both
+related to the necessity of breaking abstraction described in
+@ref{Tutorial-Abstraction,, Breaking the abstraction}.
+
+The first reason also applies to @code{CURLOPT_URL}, which we will use
+to illustrate the point. Assuming we have changed the type of the
+third argument underlying @code{set-curl-option-url} to
+@code{:string}, look at these two equivalent forms.
+
+@lisp
+(set-curl-option-url *easy-handle* "http://www.cliki.net/CFFI")
+
+@equiv{} (with-foreign-string (url "http://www.cliki.net/CFFI")
+ (foreign-funcall "curl_easy_setopt" easy-handle *easy-handle*
+ curl-option :url :pointer url curl-code))
+@end lisp
+
+@noindent
+The latter, in fact, is mostly equivalent to what a foreign function
+call's macroexpansion actually does. As you can see, the Lisp string
+@code{"@clikicffi{}"} is copied into a @code{char} array and
+null-terminated; the pointer to beginning of this array, now a C
+string, is passed as a @cffi{} @code{:pointer} to the foreign
+function.
+
+@cindex dynamic extent
+@cindex foreign values with dynamic extent
+Unfortunately, the C abstraction has failed us, and we must break it.
+While @code{:string} works well for many @code{char*} arguments, it
+does not for cases like this. As the @code{curl_easy_setopt}
+documentation explains, ``The string must remain present until curl no
+longer needs it, as it doesn't copy the string.'' The C string
+created by @code{with-foreign-string}, however, only has dynamic
+extent: it is ``deallocated'' when the body (above containing the
+@code{foreign-funcall} form) exits.
+
+@cindex premature deallocation
+If we are supposed to keep the C string around, but it goes away, what
+happens when some @code{libcurl} function tries to access the
+@acronym{URL} string? We have reentered the dreaded world of C
+``undefined behavior''. In some Lisps, it will probably get a chunk
+of the Lisp/C stack. You may segfault. You may get some random piece
+of other data from the heap. Maybe, in a world where ``dynamic
+extent'' is defined to be ``infinite extent'', everything will turn
+out fine. Regardless, results are likely to be almost universally
+unpleasant.@footnote{``@i{But I thought Lisp was supposed to protect
+me from all that buggy C crap!}'' Before asking a question like that,
+remember that you are a stranger in a foreign land, whose residents
+have a completely different set of values.}
+
+Returning to the current @code{set-curl-option-url} interface, here is
+what we must do:
+
+@lisp
+(let (easy-handle)
+ (unwind-protect
+ (with-foreign-string (url "http://www.cliki.net/CFFI")
+ (setf easy-handle (curl-easy-init))
+ (set-curl-option-url easy-handle url)
+ #|@lispcmt{do more with the easy-handle, like actually get the URL}|#)
+ (when easy-handle
+ (curl-easy-cleanup easy-handle))))
+@end lisp
+
+@c old comment to luis: I go on to say that this isn't obviously
+@c extensible to new option settings that require C strings to stick
+@c around, as it would involve re-evaluating the unwind-protect form
+@c with more dynamic memory allocation. So I plan to show how to
+@c write something similar to ObjC's NSAutoreleasePool, to be managed
+@c with a simple unwind-protect form.
+
+@noindent
+That is fine for the single string defined here, but for every string
+option we want to pass, we have to surround the body of
+@code{with-foreign-string} with another @code{with-foreign-string}
+wrapper, or else do some extremely error-prone pointer manipulation
+and size calculation in advance. We could alleviate some of the pain
+with a recursively expanding macro, but this would not remove the need
+to modify the block every time we want to add an option, anathema as
+it is to a modular interface.
+
+Before modifying the code to account for this case, consider the other
+reason we can't simply use @code{:string} as the foreign type. In C,
+a @code{char *} is a @code{char *}, not necessarily a string. The
+option @code{CURLOPT_ERRORBUFFER} accepts a @code{char *}, but does
+not expect anything about the data there. However, it does expect
+that some @code{libcurl} function we call later can write a C string
+of up to 255 characters there. We, the callers of the function, are
+expected to read the C string at a later time, exactly the opposite of
+what @code{:string} implies.
+
+With the semantics for an input string in mind --- namely, that the
+string should be kept around until we @code{curl_easy_cleanup} the
+easy handle --- we are ready to extend the Lisp interface:
+
+@lisp
+(defvar *easy-handle-cstrings* (make-hash-table)
+ "Hashtable of easy handles to lists of C strings that may be
+safely freed after the handle is freed.")
+
+(defun make-easy-handle ()
+ "Answer a new CURL easy interface handle, to which the lifetime
+of C strings may be tied. See `add-curl-handle-cstring'."
+ (let ((easy-handle (curl-easy-init)))
+ (setf (gethash easy-handle *easy-handle-cstrings*) '())
+ easy-handle))
+
+(defun free-easy-handle (handle)
+ "Free CURL easy interface HANDLE and any C strings created to
+be its options."
+ (curl-easy-cleanup handle)
+ (mapc #'foreign-string-free
+ (gethash handle *easy-handle-cstrings*))
+ (remhash handle *easy-handle-cstrings*))
+
+(defun add-curl-handle-cstring (handle cstring)
+ "Add CSTRING to be freed when HANDLE is, answering CSTRING."
+ (car (push cstring (gethash handle *easy-handle-cstrings*))))
+@end lisp
+
+@noindent
+Here we have redefined the interface to create and free handles, to
+associate a list of allocated C strings with each handle while it
+exists. The strategy of using different function names to wrap around
+simple foreign functions is more common than the solution implemented
+earlier with @code{curry-curl-option-setter}, which was to modify the
+function name's function slot.@footnote{There are advantages and
+disadvantages to each approach; I chose to @code{(setf
+symbol-function)} earlier because it entailed generating fewer magic
+function names.}
+
+Incidentally, the next step is to redefine
+@code{curry-curl-option-setter} to allocate C strings for the
+appropriate length of time, given a Lisp string as the
+@code{new-value} argument:
+
+@lisp
+(defun curry-curl-option-setter (function-name option-keyword)
+ "Wrap the function named by FUNCTION-NAME with a version that
+curries the second argument as OPTION-KEYWORD.
+
+This function is intended for use in DEFINE-CURL-OPTION-SETTER."
+ (setf (symbol-function function-name)
+ (let ((c-function (symbol-function function-name)))
+ (lambda (easy-handle new-value)
+ (funcall c-function easy-handle option-keyword
+ (if (stringp new-value)
+ (add-curl-handle-cstring
+ easy-handle
+ (foreign-string-alloc new-value))
+ new-value))))))
+@end lisp
+
+@noindent
+A quick analysis of the code shows that you need only reevaluate the
+@code{curl-option} enumeration definition to take advantage of these
+new semantics. Now, for good measure, let's reallocate the handle
+with the new functions we just defined, and set its @acronym{URL}:
+
+@example
+@sc{cffi-user>} (curl-easy-cleanup *easy-handle*)
+@result{} NIL
+@sc{cffi-user>} (setf *easy-handle* (make-easy-handle))
+@result{} #<FOREIGN-ADDRESS #x09844EE0>
+@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1)
+@result{} 0
+@sc{cffi-user>} (set-curl-option-url *easy-handle*
+ "http://www.cliki.net/CFFI")
+@result{} 0
+@end example
+
+@cindex strings
+For fun, let's inspect the Lisp value of the C string that was created
+to hold @code{"@clikicffi{}"}. By virtue of the implementation of
+@code{add-curl-handle-cstring}, it should be accessible through the
+hash table defined:
+
+@example
+@sc{cffi-user>} (foreign-string-to-lisp
+ (car (gethash *easy-handle* *easy-handle-cstrings*)))
+@result{} "http://www.cliki.net/CFFI"
+@end example
+
+@noindent
+Looks like that worked, and @code{libcurl} now knows what
+@acronym{URL} we want to retrieve.
+
+Finally, we turn back to the @code{:errorbuffer} option mentioned at
+the beginning of this section. Whereas the abstraction added to
+support string inputs works fine for cases like @code{CURLOPT_URL}, it
+hides the detail of keeping the C string; for @code{:errorbuffer},
+however, we need that C string.
+
+In a moment, we'll define something slightly cleaner, but for now,
+remember that you can always hack around anything. We're modifying
+handle creation, so make sure you free the old handle before
+redefining @code{free-easy-handle}.
+
+@smalllisp
+(defvar *easy-handle-errorbuffers* (make-hash-table)
+ "Hashtable of easy handles to C strings serving as error
+writeback buffers.")
+
+;;; @lispcmt{An extra byte is very little to pay for peace of mind.}
+(defparameter *curl-error-size* 257
+ "Minimum char[] size used by cURL to report errors.")
+
+(defun make-easy-handle ()
+ "Answer a new CURL easy interface handle, to which the lifetime
+of C strings may be tied. See `add-curl-handle-cstring'."
+ (let ((easy-handle (curl-easy-init)))
+ (setf (gethash easy-handle *easy-handle-cstrings*) '())
+ (setf (gethash easy-handle *easy-handle-errorbuffers*)
+ (foreign-alloc :char :count *curl-error-size*
+ :initial-element 0))
+ easy-handle))
+
+(defun free-easy-handle (handle)
+ "Free CURL easy interface HANDLE and any C strings created to
+be its options."
+ (curl-easy-cleanup handle)
+ (foreign-free (gethash handle *easy-handle-errorbuffers*))
+ (remhash handle *easy-handle-errorbuffers*)
+ (mapc #'foreign-string-free
+ (gethash handle *easy-handle-cstrings*))
+ (remhash handle *easy-handle-cstrings*))
+
+(defun get-easy-handle-error (handle)
+ "Answer a string containing HANDLE's current error message."
+ (foreign-string-to-lisp
+ (gethash handle *easy-handle-errorbuffers*)))
+@end smalllisp
+
+Be sure to once again set the options we've set thus far. You may
+wish to define yet another wrapper function to do this.
+
+
+@node Tutorial-Callbacks
+@section Calling Lisp from C
+
+If you have been reading
+@uref{http://curl.haxx.se/libcurl/c/curl_easy_setopt.html,,
+@code{curl_easy_setopt(3)}}, you should have noticed that some options
+accept a function pointer. In particular, we need one function
+pointer to set as @code{CURLOPT_WRITEFUNCTION}, to be called by
+@code{libcurl} rather than the reverse, in order to receive data as it
+is downloaded.
+
+A binding writer without the aid of @acronym{FFI} usually approaches
+this problem by writing a C function that accepts C data, converts to
+the language's internal objects, and calls the callback provided by
+the user, again in a reverse of usual practices.
+
+The @cffi{} approach to callbacks precisely mirrors its differences
+with the non-@acronym{FFI} approach on the ``calling C from Lisp''
+side, which we have dealt with exclusively up to now. That is, you
+define a callback function in Lisp using @code{defcallback}, and
+@cffi{} effectively creates a C function to be passed as a function
+pointer.
+
+@impnote{This is much trickier than calling C functions from Lisp, as
+it literally involves somehow generating a new C function that is as
+good as any created by the compiler. Therefore, not all Lisps support
+them. @xref{Implementation Support}, for information about @cffi{}
+support issues in this and other areas. You may want to consider
+changing to a Lisp that supports callbacks in order to continue with
+this tutorial.}
+
+@cindex callback definition
+@cindex defining callbacks
+Defining a callback is very similar to defining a callout; the main
+difference is that we must provide some Lisp forms to be evaluated as
+part of the callback. Here is the signature for the function the
+@code{:writefunction} option takes:
+
+@example
+size_t
+@var{function}(void *ptr, size_t size, size_t nmemb, void *stream);
+@end example
+
+@impnote{size_t is almost always an unsigned int. You can get this
+and many other types using feature tests for your system by using
+cffi-grovel.}
+
+The above signature trivially translates into a @cffi{}
+@code{defcallback} form, as follows.
+
+@lisp
+;;; @lispcmt{Alias in case size_t changes.}
+(defctype size :unsigned-int)
+
+;;; @lispcmt{To be set as the CURLOPT_WRITEFUNCTION of every easy handle.}
+(defcallback easy-write size ((ptr :pointer) (size size)
+ (nmemb size) (stream :pointer))
+ (let ((data-size (* size nmemb)))
+ (handler-case
+ ;; @lispcmt{We use the dynamically-bound *easy-write-procedure* to}
+ ;; @lispcmt{call a closure with useful lexical context.}
+ (progn (funcall (symbol-value '*easy-write-procedure*)
+ (foreign-string-to-lisp ptr data-size nil))
+ data-size) ;@lispcmt{indicates success}
+ ;; @lispcmt{The WRITEFUNCTION should return something other than the}
+ ;; @lispcmt{#bytes available to signal an error.}
+ (error () (if (zerop data-size) 1 0)))))
+@end lisp
+
+First, note the correlation of the first few forms, used to declare
+the C function's signature, with the signature in C syntax. We
+provide a Lisp name for the function, its return type, and a name and
+type for each argument.
+
+In the body, we call the dynamically-bound
+@code{*easy-write-procedure*} with a ``finished'' translation, of
+pulling together the raw data and size into a Lisp string, rather than
+deal with the data directly. As part of calling
+@code{curl_easy_perform} later, we'll bind that variable to a closure
+with more useful lexical bindings than the top-level
+@code{defcallback} form.
+
+Finally, we make a halfhearted effort to prevent non-local exits from
+unwinding the C stack, covering the most likely case with an
+@code{error} handler, which is usually triggered
+unexpectedly.@footnote{Unfortunately, we can't protect against
+@emph{all} non-local exits, such as @code{return}s and @code{throw}s,
+because @code{unwind-protect} cannot be used to ``short-circuit'' a
+non-local exit in Common Lisp, due to proposal @code{minimal} in
+@uref{http://www.lisp.org/HyperSpec/Issues/iss152-writeup.html,
+@acronym{ANSI} issue @sc{Exit-Extent}}. Furthermore, binding an
+@code{error} handler prevents higher-up code from invoking restarts
+that may be provided under the callback's dynamic context. Such is
+the way of compromise.} The reason is that most C code is written to
+understand its own idiosyncratic error condition, implemented above in
+the case of @code{curl_easy_perform}, and more ``undefined behavior''
+can result if we just wipe C stack frames without allowing them to
+execute whatever cleanup actions as they like.
+
+Using the @code{CURLoption} enumeration in @file{curl.h} once more, we
+can describe the new option by modifying and reevaluating
+@code{define-curl-options}.
+
+@lisp
+(define-curl-options curl-option
+ (long 0 objectpoint 10000 functionpoint 20000 off-t 30000)
+ (:noprogress long 43)
+ (:nosignal long 99)
+ (:errorbuffer objectpoint 10)
+ (:url objectpoint 2)
+ (:writefunction functionpoint 11)) ;@lispcmt{new item here}
+@end lisp
+
+Finally, we can use the defined callback and the new
+@code{set-curl-option-writefunction} to finish configuring the easy
+handle, using the @code{callback} macro to retrieve a @cffi{}
+@code{:pointer}, which works like a function pointer in C code.
+
+@example
+@sc{cffi-user>} (set-curl-option-writefunction
+ *easy-handle* (callback easy-write))
+@result{} 0
+@end example
+
+
+@node Tutorial-Completion
+@section A complete @acronym{FFI}?
+
+@c TeX goes insane on @uref{@clikicffi{}}
+
+With all options finally set and a medium-level interface developed,
+we can finish the definition and retrieve
+@uref{http://www.cliki.net/CFFI}, as is done in the tutorial.
+
+@lisp
+(defcfun "curl_easy_perform" curl-code
+ (handle easy-handle))
+@end lisp
+
+@example
+@sc{cffi-user>} (with-output-to-string (contents)
+ (let ((*easy-write-procedure*
+ (lambda (string)
+ (write-string string contents))))
+ (declare (special *easy-write-procedure*))
+ (curl-easy-perform *easy-handle*)))
+@result{} "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\"
+@enddots{}
+Now fear, comprehensively</P>
+"
+@end example
+
+Of course, that itself is slightly unwieldy, so you may want to define
+a function around it that simply retrieves a @acronym{URL}. I will
+leave synthesis of all the relevant @acronym{REPL} forms presented
+thus far into a single function as an exercise for the reader.
+
+The remaining sections of this tutorial explore some advanced features
+of @cffi{}; the definition of new types will receive special
+attention. Some of these features are essential for particular
+foreign function calls; some are very helpful when trying to develop a
+Lispy interface to C.
+
+
+@node Tutorial-Types
+@section Defining new types
+
+We've occasionally used the @code{defctype} macro in previous sections
+as a kind of documentation, much what you'd use @code{typedef} for in
+C. We also tried one special kind of type definition, the
+@code{defcenum} type. @xref{defcstruct}, for a definition macro that
+may come in handy if you need to use C @code{struct}s as data.
+
+@cindex type definition
+@cindex data in Lisp and C
+@cindex translating types
+However, all of these are mostly sugar for the powerful underlying
+foreign type interface called @dfn{type translators}. You can easily
+define new translators for any simple named foreign type. Since we've
+defined the new type @code{curl-code} to use as the return type for
+various @code{libcurl} functions, we can use that to directly convert
+c@acronym{URL} errors to Lisp errors.
+
+The @code{CURLcode} enumeration seems to follow the typical error code
+convention of @samp{0} meaning all is well, and each non-zero integer
+indicating a different kind of error. We can apply that trivially to
+differentiate between normal exits and error exits.
+
+@lisp
+(define-condition curl-code-error (error)
+ (($code :initarg :curl-code :reader curl-error-code))
+ (:report (lambda (c stream)
+ (format stream "libcurl function returned error ~A"
+ (curl-error-code c))))
+ (:documentation "Signalled when a libcurl function answers
+a code other than CURLE_OK."))
+
+(defmethod translate-from-foreign (value (name (eql 'curl-code)))
+ "Raise a CURL-CODE-ERROR if VALUE, a curl-code, is non-zero."
+ (if (zerop value)
+ :curle-ok
+ (error 'curl-code-error :curl-code value)))
+@end lisp
+
+@noindent
+The heart of this translator is new method
+@code{translate-from-foreign}. By specializing the @var{name}
+parameter on @code{(eql '@var{type-name})}, we immediately modify the
+behavior of every function that returns a @code{curl-code} to pass the
+result through this new method.
+
+To see the translator in action, try invoking a function that returns
+a @code{curl-code}.
+
+@example
+@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1)
+@result{} :CURLE-OK
+@end example
+
+@noindent
+As the result was @samp{0}, the new method returned @code{:curle-ok},
+just as specified.@footnote{It might be better to return
+@code{(values)} than @code{:curle-ok} in real code, but this is good
+for illustration.} I will leave disjoining the separate
+@code{CURLcode}s into condition types and improving the @code{:report}
+function as an exercise for you.
+
+The creation of @code{*easy-handle-cstrings*} and
+@code{*easy-handle-errorbuffers*} as properties of @code{easy-handle}s
+is a kluge. What we really want is a Lisp structure that stores these
+properties along with the C pointer. Unfortunately,
+@code{easy-handle} is currently just a fancy name for the foreign type
+@code{:pointer}; the actual pointer object varies from Common Lisp
+implementation to implementation, needing only to satisfy
+@code{pointerp} and be returned from @code{make-pointer} and friends.
+
+One solution that would allow us to define a new Lisp structure to
+represent @code{easy-handle}s would be to write a wrapper around every
+function that currently takes an @code{easy-handle}; the wrapper would
+extract the pointer and pass it to the foreign function. However, we
+can use type translators to more elegantly integrate this
+``translation'' into the foreign function calling framework, using
+@code{translate-to-foreign}.
+
+@smalllisp
+(defclass easy-handle ()
+ ((pointer :initform (curl-easy-init)
+ :documentation "Foreign pointer from curl_easy_init")
+ (error-buffer
+ :initform (foreign-alloc :char :count *curl-error-size*
+ :initial-element 0)
+ :documentation "C string describing last error")
+ (c-strings :initform '()
+ :documentation "C strings set as options"))
+ (:documentation "I am a parameterization you may pass to
+curl-easy-perform to perform a cURL network protocol request."))
+
+(defmethod initialize-instance :after ((self easy-handle) &key)
+ (set-curl-option-errorbuffer self (slot-value self 'error-buffer)))
+
+(defun add-curl-handle-cstring (handle cstring)
+ "Add CSTRING to be freed when HANDLE is, answering CSTRING."
+ (car (push cstring (slot-value handle 'c-strings))))
+
+(defun get-easy-handle-error (handle)
+ "Answer a string containing HANDLE's current error message."
+ (foreign-string-to-lisp
+ (slot-value handle 'error-buffer)))
+
+(defun free-easy-handle (handle)
+ "Free CURL easy interface HANDLE and any C strings created to
+be its options."
+ (with-slots (pointer error-buffer c-strings) handle
+ (curl-easy-cleanup pointer)
+ (foreign-free error-buffer)
+ (mapc #'foreign-string-free c-strings)))
+
+(defmethod translate-to-foreign (handle (name (eql 'easy-handle)))
+ "Extract the pointer from an easy-HANDLE."
+ (slot-value handle 'pointer))
+@end smalllisp
+
+While we changed some of the Lisp functions defined earlier to use
+@acronym{CLOS} slots rather than hash tables, the foreign functions
+work just as well as they did before.
+
+@cindex limitations of type translators
+The greatest strength, and the greatest limitation, of the type
+translator comes from its generalized interface. As stated
+previously, we could define all foreign function calls in terms of the
+primitive foreign types provided by @cffi{}. The type translator
+interface allows us to cleanly specify the relationship between Lisp
+and C data, independent of where it appears in a function call. This
+independence comes at a price; for example, it cannot be used to
+modify translation semantics based on other arguments to a function
+call. In these cases, you should rely on other features of Lisp,
+rather than the powerful, yet domain-specific, type translator
+interface.
+
+
+@node Tutorial-Conclusion
+@section What's next?
+
+@cffi{} provides a rich and powerful foundation for communicating with
+foreign libraries; as we have seen, it is up to you to make that
+experience a pleasantly Lispy one. This tutorial does not cover all
+the features of @cffi{}; please see the rest of the manual for
+details. In particular, if something seems obviously missing, it is
+likely that either code or a good reason for lack of code is already
+present.
+
+@impnote{There are some other things in @cffi{} that might deserve
+tutorial sections, such as define-foreign-type,
+free-translated-object, or structs. Let us know which ones you care
+about.}
+
+
+@c ===================================================================
+@c CHAPTER: Wrapper generators
+
+@node Wrapper generators
+@chapter Wrapper generators
+
+@cffi{}'s interface is designed for human programmers, being aimed at
+aesthetic as well as technical sophistication. However, there are a
+few programs aimed at translating C and C++ header files, or
+approximations thereof, into @cffi{} forms constituting a foreign
+interface to the symbols in those files.
+
+These wrapper generators are known to support output of @cffi{} forms.
+
+@table @asis
+@item @uref{http://www.cliki.net/Verrazano,Verrazano}
+Designed specifically for Common Lisp. Uses @acronym{GCC}'s parser
+output in @acronym{XML} format to discover functions, variables, and
+other header file data. This means you need @acronym{GCC} to generate
+forms; on the other hand, the parser employed is mostly compliant with
+@acronym{ANSI} C.
+
+@item @uref{http://www.cliki.net/SWIG,SWIG}
+A foreign interface generator originally designed to generate Python
+bindings, it has been ported to many other systems, including @cffi{}
+in version 1.3.28. Includes its own C declaration munger, not
+intended to be fully-compliant with @acronym{ANSI} C.
+@end table
+
+First, this manual does not describe use of these other programs; they
+have documentation of their own. If you have problems using a
+generated interface, please look at the output @cffi{} forms and
+verify that they are a correct @cffi{} interface to the library in
+question; if they are correct, contact @cffi{} developers with
+details, keeping in mind that they communicate in terms of those forms
+rather than any particular wrapper generator. Otherwise, contact the
+maintainers of the wrapper generator you are using, provided you can
+reasonably expect more accuracy from the generator.
+
+When is more accuracy an unreasonable expectation? As described in
+the tutorial (@pxref{Tutorial-Abstraction,, Breaking the
+abstraction}), the information in C declarations is insufficient to
+completely describe every interface. In fact, it is quite common to
+run into an interface that cannot be handled automatically, and
+generators should be excused from generating a complete interface in
+these cases.
+
+As further described in the tutorial, the thinnest Lisp interface to a
+C function is not always the most pleasant one. In many cases, you
+will want to manually write a Lispier interface to the C functions
+that interest you.
+
+Wrapper generators should be treated as time-savers, not complete
+automation of the full foreign interface writing job. Reports of the
+amount of work done by generators vary from 30% to 90%. The
+incremental development style enabled by @cffi{} generally reduces
+this proportion below that for languages like Python.
+
+@c Where I got the above 30-90% figures:
+@c 30%: lemonodor's post about SWIG
+@c 90%: Balooga on #lisp. He said 99%, but that's probably an
+@c exaggeration (leave it to me to pass judgement :)
+@c -stephen
+
+
+@c ===================================================================
+@c CHAPTER: Foreign Types
+
+@node Foreign Types
+@chapter Foreign Types
+
+Foreign types describe how data is translated back and forth between C
+and Lisp. @cffi{} provides various built-in types and allows the user to
+define new types.
+
+@menu
+* Built-In Types::
+* Other Types::
+* Defining Typedefs::
+* Foreign Type Translators::
+* Optimizing Type Translators::
+* Foreign Structure Types::
+* Operations on Types::
+* Allocating Foreign Objects::
+
+Dictionary
+
+* convert-from-foreign::
+* convert-to-foreign::
+* defbitfield::
+* defcstruct::
+* defcunion::
+* defctype::
+* defcenum::
+@c * define-type-spec-parser::
+* define-foreign-type::
+@c * explain-foreign-slot-value::
+* foreign-bitfield-symbols::
+* foreign-bitfield-value::
+* foreign-enum-keyword::
+* foreign-enum-value::
+* foreign-slot-names::
+* foreign-slot-offset::
+* foreign-slot-pointer::
+* foreign-slot-value::
+* foreign-type-alignment::
+* foreign-type-size::
+* free-converted-object::
+* free-translated-object::
+* translate-from-foreign::
+* translate-to-foreign::
+* with-foreign-slots::
+@end menu
+
+@c @menu
+@c Dictionary
+@c
+@c * defctype::
+@c * define-foreign-type::
+@c * define-type-translator::
+@c @end menu
+
+@node Built-In Types
+@section Built-In Types
+
+@ForeignType{:char}
+@ForeignType{:unsigned-char}
+@ForeignType{:short}
+@ForeignType{:unsigned-short}
+@ForeignType{:int}
+@ForeignType{:unsigned-int}
+@ForeignType{:long}
+@ForeignType{:unsigned-long}
+@ForeignType{:long-long}
+@ForeignType{:unsigned-long-long}
+
+These types correspond to the native C integer types according to the
+@acronym{ABI} of the Lisp implementation's host system.
+
+@ForeignType{:uchar}
+@ForeignType{:ushort}
+@ForeignType{:uint}
+@ForeignType{:ulong}
+@ForeignType{:llong}
+@ForeignType{:ullong}
+
+For convenience, the above types are provided as shortcuts for
+@code{unsigned-char}, @code{unsigned-short}, @code{unsigned-int},
+@code{unsigned-long}, @code{long-long} and @code{unsigned-long-long},
+respectively.
+
+@code{:long-long} and @code{:unsigned-long-long} are not supported on
+all implementations. When those types are @strong{not} available, the
+symbol @code{cffi-features:no-long-long} is pushed into
+@code{*features*}.
+
+@ForeignType{:int8}
+@ForeignType{:uint8}
+@ForeignType{:int16}
+@ForeignType{:uint16}
+@ForeignType{:int32}
+@ForeignType{:uint32}
+@ForeignType{:int64}
+@ForeignType{:uint64}
+
+Foreign integer types of specific sizes, corresponding to the C types
+defined in @code{stdint.h}.
+
+@c @ForeignType{:size}
+@c @ForeignType{:ssize}
+@c @ForeignType{:ptrdiff}
+@c @ForeignType{:time}
+
+@c Foreign integer types corresponding to the standard C types (without
+@c the @code{_t} suffix).
+
+@c @impnote{These are not implemented yet. --luis}
+
+@c @impnote{I'm sure there are more of these that could be useful, let's
+@c add any types that can't be defined portably to this list as
+@c necessary. --james}
+
+@ForeignType{:float}
+@ForeignType{:double}
+
+On all systems, the @code{:float} and @code{:double} types represent a
+C @code{float} and @code{double}, respectively. On most but not all
+systems, @code{:float} and @code{:double} represent a Lisp
+@code{single-float} and @code{double-float}, respectively. It is not
+so useful to consider the relationship between Lisp types and C types
+as isomorphic, as simply to recognize the relationship, and relative
+precision, among each respective category.
+
+@ForeignType{:long-double}
+
+This type is only supported on SCL.
+
+@ForeignType{:pointer}
+
+A foreign pointer to an object of any type, corresponding to
+@code{void *}.
+
+@ForeignType{:void}
+
+No type at all. Only valid as the return type of a function.
+
+@node Other Types
+@section Other Types
+
+@cffi{} also provides a few useful types that aren't built-in C
+types.
+
+@ForeignType{:string}
+
+The @code{:string} type performs automatic conversion between Lisp and
+C strings. Note that, in the case of functions the converted C string
+will have dynamic extent (ie. it will be automatically freed after the
+foreign function returns).
+
+@lisp
+;;; :STRING example
+CFFI> (foreign-funcall "getenv" :string "SHELL" :string)
+"/bin/bash"
+@end lisp
+
+@ForeignType{:boolean &optional (base-type :int)}
+
+The @code{:boolean} type converts between a Lisp boolean and a C
+boolean. It canonicalizes to @var{base-type} which is @code{:int} by
+default.
+
+@lisp
+(convert-to-foreign nil :boolean) @result{} 0
+(convert-to-foreign t :boolean) @result{} 1
+(convert-from-foreign 0 :boolean) @result{} nil
+(convert-from-foreign 1 :boolean) @result{} t
+@end lisp
+
+@ForeignType{:wrapper base-type &key to-c from-c}
+
+The @code{:wrapper} type stores two symbols passed to the @var{to-c}
+and @var{from-c} arguments. When a value is being translated to or
+from C, this type @code{funcall}s the respective symbol.
+
+@code{:wrapper} types will be typedefs for @var{base-type} and will
+inherit its translators, if any.
+
+Here's an example of how the @code{:boolean} type could be defined in
+terms of @code{:wrapper}.
+
+@lisp
+(defun bool-c-to-lisp (value)
+ (not (zerop value)))
+
+(defun bool-lisp-to-c (value)
+ (if value 1 0))
+
+(defctype my-bool (:wrapper :int :from-c bool-c-to-lisp
+ :to-c bool-lisp-to-c))
+
+(convert-to-foreign nil 'my-bool) @result{} 0
+(convert-from-foreign 1 'my-bool) @result{} t
+@end lisp
+
+@node Defining Typedefs
+@section Defining Typedefs
+
+Typedefs are similar to @code{typedef}s in C, except they are more
+like ``type wrappers'' than aliases, for reasons that will become
+clear in the next section.
+
+Defining a typedef is as simple as giving @code{defctype} a new name
+and the name of the type to be wrapped. Here is how a simpler version
+of the built-in @code{:boolean} type could be defined:
+
+@lisp
+;;; @lispcmt{Define MY-BOOLEAN as an alias for the built-in type :INT.}
+(defctype my-boolean :int)
+@end lisp
+
+With this type definition, one can declare arguments to foreign
+functions as having the type @code{my-boolean}, and they will be
+passed as integers. No conversion is taking place---if @code{nil} is
+passed as a @code{my-boolean}, a type error will be signalled.
+
+@node Foreign Type Translators
+@section Foreign Type Translators
+
+Type translators are used to automatically convert Lisp values to or
+from foreign values. For example, using type translators, one can
+define a boolean type which converts a Lisp generalized boolean
+(@code{nil} vs.@: non-@code{nil}) to a C boolean (zero vs.@:
+non-zero).
+
+We created the @code{my-boolean} type in the previous section. To
+tell @cffi{} how to automatically convert Lisp values to
+@code{my-boolean} values, specialize the generic function
+@code{translate-to-foreign} on the @code{my-boolean} type:
+
+@lisp
+;;; @lispcmt{Define a method that converts Lisp booleans to C booleans.}
+(defmethod translate-to-foreign (value (type (eql 'my-boolean)))
+ (if value 1 0))
+@end lisp
+
+Now, when an object is passed as a @code{my-boolean} to a foreign
+function, this method will be invoked to convert the Lisp value to an
+integer. To perform the inverse operation, which is needed for
+functions that return a @code{my-boolean}, specialize the
+@code{translate-from-foreign} generic function:
+
+@lisp
+;;; @lispcmt{Define a method that converts C booleans to Lisp booleans.}
+(defmethod translate-from-foreign (value (type (eql 'my-boolean)))
+ (not (zerop value)))
+@end lisp
+
+When a @code{translate-to-foreign} method requires allocation of
+foreign memory, the @code{free-translated-object} method can be
+specialized to free the memory once the foreign object is no longer
+needed. This is called automatically by @cffi{} when passing objects to
+foreign functions.
+
+A type translator does not necessarily need to convert the value. For
+example, one could define a typedef for @code{:pointer} that ensures,
+in the @code{translate-to-foreign} method, that the value is not a
+null pointer, signalling an error if a null pointer is passed. This
+will prevent some pointer errors when calling foreign functions that
+cannot handle null pointers.
+
+@strong{Please note:} these methods are meant as extensible hooks
+only, and you should not call them directly. Use
+@code{convert-to-foreign}, @code{convert-from-foreign} and
+@code{free-converted-object} instead. These will take care of
+following the typedef chain, for example, calling all the applicable
+translators. They will also work for @cffi{}'s built-in types, such
+as enums.
+
+@xref{Tutorial-Types,, Defining new types}, for a more involved
+tutorial example of type translators.
+
+@node Optimizing Type Translators
+@section Optimizing Type Translators
+
+@cindex type translators, optimizing
+@cindex compiler macros for type translation
+@cindex defining type-translation compiler macros
+Being based on generic functions, the type translation mechanism
+described above can add a bit of overhead. This is usually not
+significant, but we nevertheless provide a way of getting rid of the
+overhead for the cases where it matters.
+
+A good way to understand this issue is to look at the code generated
+by @code{defcfun}. Consider the following example using the
+@code{my-boolean} type defined above:
+
+@lisp
+CFFI> (macroexpand-1 '(defcfun foo my-boolean (x my-boolean)))
+(DEFUN FOO (X)
+ (MULTIPLE-VALUE-BIND (#:G3148 #:PARAM3149)
+ (TRANSLATE-TYPE-TO-FOREIGN X #<FOREIGN-TYPEDEF MY-BOOLEAN>)
+ (UNWIND-PROTECT
+ (PROGN
+ (TRANSLATE-TYPE-FROM-FOREIGN
+ (%FOREIGN-FUNCALL "foo" :INT #:G3148 :INT)
+ #<FOREIGN-TYPEDEF MY-BOOLEAN>))
+ (FREE-TYPE-TRANSLATED-OBJECT #:G3148
+ #<FOREIGN-TYPEDEF MY-BOOLEAN>
+ #:PARAM3149))))
+@end lisp
+
+In order to get rid of those generic function calls, @cffi{} has
+another set of extensible generic functions that provide functionality
+similar to @acronym{CL}'s compiler macros:
+@code{expand-to-foreign-dyn}, @code{expand-to-foreign} and
+@code{expand-from-foreign}. Here's how one could define
+@code{my-boolean} with them:
+
+@lisp
+(defmethod expand-to-foreign (value (type (eql 'my-boolean)))
+ `(if ,value 1 0))
+
+(defmethod expand-from-foreign (value (type (eql 'my-boolean)))
+ `(not (zerop ,value)))
+@end lisp
+
+@noindent
+And here's what the macroexpansion of @code{foo} now looks like:
+
+@lisp
+CFFI> (macroexpand-1 '(defcfun foo my-boolean (x my-boolean)))
+(DEFUN FOO (X)
+ (LET ((#:G3182 (IF X 1 0)))
+ (NOT (ZEROP (%FOREIGN-FUNCALL "foo" :INT #:G3182 :INT)))))
+@end lisp
+
+@noindent
+Much better.
+
+@code{expand-to-foreign-dyn}, the third generic function in this
+interface, is especially useful when you can allocate something much
+more efficiently if you know the object has dynamic extent. Consider
+the following example:
+
+@lisp
+;;; This type inherits :string's translators.
+(defctype stack-allocated-string :string)
+
+(defmethod expand-to-foreign-dyn
+ (value var body (type (eql 'stack-allocated-string)))
+ `(with-foreign-string (,var ,value)
+ ,@@body))
+@end lisp
+
+To short-circuit expansion and use the @code{translate-*} functions
+instead, simply call the next method. Return its result in cases
+where your method cannot generate an appropriate replacement for it.
+
+The @code{expand-*} methods have precedence over their
+@code{translate-*} counterparts and are guaranteed to be used in
+@code{defcfun}, @code{foreign-funcall}, @code{defcvar} and
+@code{defcallback}. If you define a method on each of the
+@code{expand-*} generic functions, you are guaranteed to have full
+control over the expressions generated for type translation in these
+macros.
+
+They may or may not be used in other @cffi{} operators that need to
+translate between Lisp and C data; you may only assume that
+@code{expand-*} methods will probably only be called during Lisp
+compilation.
+
+@code{expand-to-foreign-dyn} has precedence over
+@code{expand-to-foreign} and is only used in @code{defcfun} and
+@code{foreign-funcall}, only making sense in those contexts. If you
+do not define a method on @code{expand-to-foreign-dyn}, however,
+please note that this expand method for the hypothetical type
+@code{my-string} is not the same as defining no method at all:
+
+@lisp
+(defmethod expand-to-foreign (value-form (type-name (eql 'my-string)))
+ (call-next-method))
+@end lisp
+
+Without this method, your runtime @code{translate-to-foreign} method
+will be called, and its result will be passed to
+@code{free-translated-object}. However, if you define this method,
+@code{translate-to-foreign} will still be called, but its result will
+not be passed to @code{free-translated-object}. If you need to free
+values with this interface, you must define an
+@code{expand-to-foreign-dyn} method.
+
+@strong{Important note:} this set of generic functions is called at
+macroexpansion time. Methods are defined when loaded or evaluated,
+not compiled. You are responsible for ensuring that your
+@code{expand-*} methods are defined when the @code{foreign-funcall} or
+other forms that use them are compiled. One way to do this is to put
+the method definitions earlier in the file and inside an appropriate
+@code{eval-when} form; another way is to always load a separate Lisp
+or @acronym{FASL} file containing your @code{expand-*} definitions
+before compiling files with forms that ought to use them. Otherwise,
+they will not be found and the runtime translators will be used
+instead.
+
+@node Foreign Structure Types
+@section Foreign Structure Types
+
+For more involved C types than simple aliases to built-in types, such
+as you can make with @code{defctype}, @cffi{} allows declaration of
+structures and unions with @code{defcstruct} and @code{defcunion}.
+
+For example, consider this fictional C structure declaration holding
+some personal information:
+
+@example
+struct person @{
+ int number;
+ char* reason;
+@};
+@end example
+
+@noindent
+The equivalent @code{defcstruct} form follows:
+
+@lisp
+(defcstruct person
+ (number :int)
+ (reason :string))
+@end lisp
+
+@cffi{} knows how to align C @code{struct}s, and how to figure in
+padding between struct elements.
+
+Please note that this interface is only for those that must know about
+the values contained in a relevant struct. If the library you are
+interfacing returns an opaque pointer that needs only be passed to
+other C library functions, by all means just use @code{:pointer} or a
+type-safe definition munged together with @code{defctype} and type
+translation.
+
+@node Operations on Types
+@section Operations on Types
+
+@impnote{Which ``operations'' are worth going over here? --stephen}
+
+@node Allocating Foreign Objects
+@section Allocating Foreign Objects
+
+@c I moved this because I moved with-foreign-object to the Pointers
+@c chapter, where foreign-alloc is.
+
+@xref{Allocating Foreign Memory}.
+
+
+@c ===================================================================
+@c CONVERT-FROM-FOREIGN
+
+@node convert-from-foreign
+@unnumberedsec convert-from-foreign
+@subheading Syntax
+@Function{convert-from-foreign foreign-value type @result{} value}
+
+@subheading Arguments and Values
+
+@table @var
+@item foreign-value
+The primitive C value as returned from a primitive foreign function or
+from @code{convert-to-foreign}.
+
+@item type
+A @cffi{} type specifier.
+
+@item value
+The Lisp value translated from @var{foreign-value}.
+@end table
+
+@subheading Description
+
+This is an external interface to the type translation facility. In
+the implementation, all foreign functions are ultimately defined as
+type translation wrappers around primitive foreign function
+invocations.
+
+This function is available mostly for inspection of the type
+translation process, and possibly optimization of special cases of
+your foreign function calls.
+
+Its behavior is better described under @code{translate-from-foreign}'s
+documentation.
+
+@subheading Examples
+
+@lisp
+CFFI-USER> (convert-to-foreign "a boat" :string)
+@result{} #<FOREIGN-ADDRESS #x097ACDC0>
+@result{} (T)
+CFFI-USER> (convert-from-foreign * :string)
+@result{} "a boat"
+@end lisp
+
+@subheading See Also
+@seealso{convert-to-foreign} @*
+@seealso{translate-from-foreign}
+
+
+@c ===================================================================
+@c CONVERT-TO-FOREIGN
+
+@node convert-to-foreign
+@unnumberedsec convert-to-foreign
+@subheading Syntax
+@Function{convert-to-foreign value type @result{} foreign-value, alloc-params}
+
+@subheading Arguments and Values
+
+@table @var
+@item value
+The Lisp object to be translated to a foreign object.
+
+@item type
+A @cffi{} type specifier.
+
+@item foreign-value
+The primitive C value, ready to be passed to a primitive foreign
+function.
+
+@item alloc-params
+Something of a translation state; you must pass it to
+@code{free-converted-object} along with the foreign value for that to
+work.
+@end table
+
+@subheading Description
+
+This is an external interface to the type translation facility. In
+the implementation, all foreign functions are ultimately defined as
+type translation wrappers around primitive foreign function
+invocations.
+
+This function is available mostly for inspection of the type
+translation process, and possibly optimization of special cases of
+your foreign function calls.
+
+Its behavior is better described under @code{translate-to-foreign}'s
+documentation.
+
+@subheading Examples
+
+@lisp
+CFFI-USER> (convert-to-foreign t :boolean)
+@result{} 1
+@result{} (NIL)
+CFFI-USER> (convert-to-foreign "hello, world" :string)
+@result{} #<FOREIGN-ADDRESS #x097C5F80>
+@result{} (T)
+CFFI-USER> (code-char (mem-aref * :char 5))
+@result{} #\,
+@end lisp
+
+@subheading See Also
+@seealso{convert-from-foreign} @*
+@seealso{free-converted-object} @*
+@seealso{translate-to-foreign}
+
+
+@c ===================================================================
+@c DEFBITFIELD
+
+@node defbitfield
+@unnumberedsec defbitfield
+@subheading Syntax
+@Macro{defbitfield name-and-options &body masks}
+
+masks ::= [docstring] @{ (symbol value) @}* @*
+name-and-options ::= name | (name &optional (base-type :int))
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+The name of the new bitfield type.
+
+@item docstring
+A documentation string, ignored.
+
+@item base-type
+A symbol denoting a foreign type.
+
+@item symbol
+A Lisp symbol.
+
+@item value
+An integer representing a bitmask.
+@end table
+
+@subheading Description
+The @code{defbitfield} macro is used to define foreign types that map
+lists of lisp symbols to integer values.
+
+If @var{value} is omitted its value will either be 0, if it's the
+first entry, or it it will continue the progression from the last
+specified value.
+
+Symbol lists will be automatically converted to values and vice-versa
+when being passed as arguments to or returned from foreign functions,
+respectively. The same applies to any other situations where an object
+of a bitfield type is expected.
+
+Types defined with @code{defbitfield} canonicalize to @var{base-type}
+which is @code{:int} by default.
+
+@subheading Examples
+@lisp
+(defbitfield open-flags
+ (:rdonly #x0000)
+ (:wronly #x0001)
+ (:rdwr #x0002)
+ (:nonblock #x0004)
+ (:append #x0008)
+ (:creat #x0200))
+ ;; etc..
+
+CFFI> (foreign-bitfield-symbols 'open-flags #b1101)
+@result{} (:RDONLY :WRONLY :NONBLOCK :APPEND)
+
+CFFI> (foreign-bitfield-value 'open-flags '(:rdwr :creat))
+@result{} 514 ; #x0202
+
+(defcfun ("open" unix-open) :int
+ (path :string)
+ (flags open-flags)
+ (mode :uint16)) ; unportable
+
+CFFI> (unix-open "/tmp/foo" '(:wronly :creat) #o644)
+@result{} <an fd>
+
+;;; Consider also the following lispier wrapper around open()
+(defun lispier-open (path mode &rest flags)
+ (unix-open path flags mode))
+@end lisp
+
+@subheading See Also
+@seealso{foreign-bitfield-value} @*
+@seealso{foreign-bitfield-symbols}
+
+
+@c ===================================================================
+@c DEFCSTRUCT
+
+@node defcstruct
+@unnumberedsec defcstruct
+@subheading Syntax
+@Macro{defcstruct name-and-options &body doc-and-slots => name}
+
+name-and-options ::= structure-name | (structure-name &key size)
+
+doc-and-slots ::= [docstring] @{ (slot-name slot-type &key count offset) @}*
+
+@subheading Arguments and Values
+
+@table @var
+@item structure-name
+The name of new structure type.
+
+@item docstring
+A documentation string, ignored.
+
+@item slot-name
+A symbol naming the slot.
+
+@item size
+Use this option to override the size (in bytes) of the struct.
+
+@item slot-type
+The type specifier for the slot.
+
+@item count
+Used to declare an array of size @var{count} inside the
+structure.
+
+@item offset
+Overrides the slot's offset. The next slot's offset is calcultated
+based on this one.
+@end table
+
+@subheading Description
+A structure slot is either simple or aggregate.
+
+Simple structure slots contain a single instance of a type that
+canonicalizes to a built-in type, such as @code{:long} or
+@code{:pointer}.
+
+Aggregate slots contain an embedded structure or union, or an array
+of objects.
+
+@subheading Examples
+@lisp
+(defcstruct point
+ "Pointer structure."
+ (x :int)
+ (y :int))
+
+CFFI> (with-foreign-object (ptr 'point)
+ ;; @lispcmt{Initialize the slots}
+ (setf (foreign-slot-value ptr 'point 'x) 42
+ (foreign-slot-value ptr 'point 'y) 42)
+ ;; @lispcmt{Return a list with the coordinates}
+ (with-foreign-slots ((x y) ptr point)
+ (list x y)))
+@result{} (42 42)
+@end lisp
+
+@lisp
+;; @lispcmt{Using the :size and :offset options to define a partial structure.}
+;; @lispcmt{(this is useful when you are interested in only a few slots}
+;; @lispcmt{of a big foreign structure)}
+
+(defcstruct (foo :size 32)
+ "Some struct with 32 bytes."
+ ; @lispcmt{<16 bytes we don't care about>}
+ (x :int :offset 16) ; @lispcmt{an int at offset 16}
+ (y :int) ; @lispcmt{another int at offset 16+sizeof(int)}
+ ; @lispcmt{<a couple more bytes we don't care about>}
+ (z :char :offset 24) ; @lispcmt{a char at offset 24}
+ ; @lispcmt{<7 more bytes ignored (since size is 32)>}
+ )
+
+CFFI> (foreign-type-size 'foo)
+@result{} 32
+@end lisp
+
+@subheading See Also
+@seealso{foreign-slot-pointer} @*
+@seealso{foreign-slot-value} @*
+@seealso{with-foreign-slots}
+
+
+@c ===================================================================
+@c DEFCUNION
+
+@node defcunion
+@unnumberedsec defcunion
+@subheading Syntax
+@Macro{defcunion name &body doc-and-slots => name}
+
+doc-and-slots ::= [docstring] @{ (slot-name slot-type &key count) @}*
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+The name of new union type.
+
+@item docstring
+A documentation string, ignored.
+
+@item slot-name
+A symbol naming the slot.
+
+@item slot-type
+The type specifier for the slot.
+
+@item count
+Used to declare an array of size @var{count} inside the
+structure.
+@end table
+
+@subheading Description
+A union is a structure in which all slots have an offset of
+zero. Therefore, you should use the usual foreign structure operations
+for accessing a union's slots.
+
+@subheading Examples
+@lisp
+(defcunion uint32-bytes
+ (int-value :unsigned-int)
+ (bytes :unsigned-char :count 4))
+@end lisp
+
+@subheading See Also
+@seealso{foreign-slot-pointer} @*
+@seealso{foreign-slot-value}
+
+
+@c ===================================================================
+@c DEFCTYPE
+
+@node defctype
+@unnumberedsec defctype
+@subheading Syntax
+@Macro{defctype name base-type &key documentation translate-p}
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+The name of the new foreign type.
+
+@item base-type
+A symbol or a list defining the new type.
+
+@item documentation
+A documentation string, currently ignored.
+
+@item translate-p
+A boolean. If true (the default), the type will be subject to type
+translation. This may be false to avoid extra generic function call
+overhead when it is known that no type translation is needed, perhaps
+because @var{base-type} is a built-in type.
+@end table
+
+@subheading Description
+The @code{defctype} macro provides a mechanism similar to C's
+@code{typedef} to define new types.
+
+The new type inherits @var{base-type}'s translators.
+
+@subheading Examples
+@lisp
+(defctype my-string :string
+ :documentation "My own string type.")
+
+(defctype long-bools (:boolean :long)
+ :documentation "Booleans that map to C longs.")
+
+(defctype my-float :float :translate-p nil)
+@end lisp
+
+@subheading See Also
+@seealso{define-foreign-type} @*
+@c @ref{define-type-translator}
+
+
+@c ===================================================================
+@c DEFCENUM
+
+@node defcenum
+@unnumberedsec defcenum
+@subheading Syntax
+@Macro{defcenum name-and-options &body enum-list}
+
+enum-list ::= [docstring] @{ keyword | (keyword value) @}*
+name-and-options ::= name | (name &optional (base-type :int))
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+The name of the new enum type.
+
+@item docstring
+A documentation string, ignored.
+
+@item base-type
+A symbol denoting a foreign type.
+
+@item keyword
+A keyword symbol.
+
+@item value
+An index value for a keyword.
+@end table
+
+@subheading Description
+The @code{defcenum} macro is used to define foreign types that map
+keyword symbols to integer values, similar to the C @code{enum} type.
+
+If @var{value} is omitted its value will either be 0, if it's the
+first entry, or it it will continue the progression from the last
+specified value.
+
+Keywords will be automatically converted to values and vice-versa when
+being passed as arguments to or returned from foreign functions,
+respectively. The same applies to any other situations where an object
+of an @code{enum} type is expected.
+
+Types defined with @code{defcenum} canonicalize to @var{base-type}
+which is @code{:int} by default.
+
+@subheading Examples
+@lisp
+(defcenum boolean
+ :no
+ :yes)
+
+CFFI> (foreign-enum-value 'boolean :no)
+@result{} 0
+@end lisp
+
+@lisp
+(defcenum numbers
+ (:one 1)
+ :two
+ (:four 4))
+
+CFFI> (foreign-enum-keyword 'numbers 2)
+@result{} :TWO
+@end lisp
+
+@subheading See Also
+@seealso{foreign-enum-value} @*
+@seealso{foreign-enum-keyword}
+
+
+@c ===================================================================
+@c DEFINE-FOREIGN-TYPE
+
+@node define-foreign-type
+@unnumberedsec define-foreign-type
+@subheading Syntax
+@Macro{define-foreign-type type-name lambda-list &body body => type-name}
+
+@subheading Arguments and Values
+
+@table @var
+@item type-name
+A symbol naming the new foreign type.
+
+@item lambda-list
+A lambda list which is the argument list of the new foreign type.
+
+@item body
+One or more forms that provide a definition of the new foreign type.
+@end table
+
+@subheading Description
+The macro @code{define-foreign-type} defines a new parameterized type
+called @var{type-name}. Given the arguments specified in
+@var{lambda-list}, executing @var{body} should return a type
+specifier which will determine the behaviour of @var{type-name}. The
+behaviour of parameterized types can be further customized by
+specializing @code{translate-to-foreign},
+@code{translate-from-foreign}, and @code{free-translated-object}.
+
+Unlike @code{defctype}, which is used to define simple C-like
+typedefs, @code{define-foreign-type} provides a mechanism for type
+aliases to take arguments. The following examples illustrate this
+capability.
+
+@subheading Examples
+Taken from @cffi{}'s @code{:boolean} type definition:
+
+@lisp
+(define-foreign-type :boolean (&optional (base-type :int))
+ "Boolean type. Maps to an :int by default. Only accepts integer types."
+ (ecase base-type
+ ((:char
+ :unsigned-char
+ :int
+ :unsigned-int
+ :long
+ :unsigned-long) base-type)))
+
+CFFI> (canonicalize-foreign-type :boolean)
+@result{} :INT
+CFFI> (canonicalize-foreign-type '(:boolean :long))
+@result{} :LONG
+CFFI> (canonicalize-foreign-type '(:boolean :float))
+;; @lispcmt{@error{} signalled by ECASE.}
+@end lisp
+
+This next example is hypothetical as there is no @code{:array} type
+yet.
+
+@lisp
+(define-foreign-type int-array (&rest dimensions)
+ `(:array :int ,@@dimensions))
+@end lisp
+
+@subheading See Also
+@seealso{defctype} @*
+@c @ref{define-type-translator}
+
+
+@c ===================================================================
+@c EXPLAIN-FOREIGN-SLOT-VALUE
+
+@c @node explain-foreign-slot-value
+@c @unnumberedsec explain-foreign-slot-value
+@c @subheading Syntax
+@c @Macro{explain-foreign-slot-value ptr type &rest slot-names}
+
+@c @subheading Arguments and Values
+
+@c @table @var
+@c @item ptr
+@c ...
+
+@c @item type
+@c ...
+
+@c @item slot-names
+@c ...
+@c @end table
+
+@c @subheading Description
+@c This macro translates the slot access that would occur by calling
+@c @code{foreign-slot-value} with the same arguments into an equivalent
+@c expression in C and prints it to @code{*standard-output*}.
+
+@c @emph{Note: this is not implemented yet.}
+
+@c @subheading Examples
+@c @lisp
+@c CFFI> (explain-foreign-slot-value ptr 'timeval 'tv-secs)
+@c @result{} ptr->tv_secs
+
+@c CFFI> (explain-foreign-slot-value emp 'employee 'hire-date 'tv-usecs)
+@c @result{} emp->hire_date.tv_usecs
+@c @end lisp
+
+@c @subheading See Also
+
+
+@c ===================================================================
+@c FOREIGN-BITFIELD-SYMBOLS
+
+@node foreign-bitfield-symbols
+@unnumberedsec foreign-bitfield-symbols
+@subheading Syntax
+@Function{foreign-bitfield-symbols type value => symbols}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+A @code{bitfield} type.
+
+@item value
+An integer.
+
+@item symbols
+A list of symbols.
+@code{nil}.
+@end table
+
+@subheading Description
+The function @code{foreign-bitfield-symbols} returns the Lisp symbol
+that corresponds to @var{value} in @var{type}.
+
+@subheading Examples
+@lisp
+(defbitfield flags
+ (flag-a 1)
+ (flag-b 2)
+ (flag-c 4))
+
+CFFI> (foreign-bitfield-symbols 'boolean #b101)
+@result{} (FLAG-A FLAG-C)
+@end lisp
+
+@subheading See Also
+@seealso{defbitfield} @*
+@seealso{foreign-bitfield-value}
+
+
+@c ===================================================================
+@c FOREIGN-BITFIELD-VALUE
+
+@node foreign-bitfield-value
+@unnumberedsec foreign-bitfield-value
+@subheading Syntax
+@Function{foreign-bitfield-value type symbols => value}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+A @code{bitfield} type.
+
+@item symbol
+A Lisp symbol.
+
+@item value
+An integer.
+@end table
+
+@subheading Description
+The function @code{foreign-bitfield-value} returns the @var{value} that
+corresponds to the symbols in the @var{symbols} list.
+
+@subheading Examples
+@lisp
+(defbitfield flags
+ (flag-a 1)
+ (flag-b 2)
+ (flag-c 4))
+
+CFFI> (foreign-bitfield-value 'flags '(flag-a flag-c))
+@result{} 5 ; #b101
+@end lisp
+
+@subheading See Also
+@seealso{defbitfield} @*
+@seealso{foreign-bitfield-symbols}
+
+
+@c ===================================================================
+@c FOREIGN-ENUM-KEYWORD
+
+@node foreign-enum-keyword
+@unnumberedsec foreign-enum-keyword
+@subheading Syntax
+@Function{foreign-enum-keyword type value &key errorp => keyword}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+An @code{enum} type.
+
+@item value
+An integer.
+
+@item errorp
+If true (the default), signal an error if @var{value} is not defined
+in @var{type}. If false, @code{foreign-enum-keyword} returns
+@code{nil}.
+
+@item keyword
+A keyword symbol.
+@end table
+
+@subheading Description
+The function @code{foreign-enum-keyword} returns the keyword symbol
+that corresponds to @var{value} in @var{type}.
+
+An error is signaled if @var{type} doesn't contain such @var{value}
+and @var{errorp} is true.
+
+@subheading Examples
+@lisp
+(defcenum boolean
+ :no
+ :yes)
+
+CFFI> (foreign-enum-keyword 'boolean 1)
+@result{} :YES
+@end lisp
+
+@subheading See Also
+@seealso{defcenum} @*
+@seealso{foreign-enum-value}
+
+
+@c ===================================================================
+@c FOREIGN-ENUM-VALUE
+
+@node foreign-enum-value
+@unnumberedsec foreign-enum-value
+@subheading Syntax
+@Function{foreign-enum-value type keyword &key errorp => value}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+An @code{enum} type.
+
+@item keyword
+A keyword symbol.
+
+@item errorp
+If true (the default), signal an error if @var{keyword} is not
+defined in @var{type}. If false, @code{foreign-enum-value} returns
+@code{nil}.
+
+@item value
+An integer.
+@end table
+
+@subheading Description
+The function @code{foreign-enum-value} returns the @var{value} that
+corresponds to @var{keyword} in @var{type}.
+
+An error is signaled if @var{type} doesn't contain such
+@var{keyword}, and @var{errorp} is true.
+
+@subheading Examples
+@lisp
+(defcenum boolean
+ :no
+ :yes)
+
+CFFI> (foreign-enum-value 'boolean :yes)
+@result{} 1
+@end lisp
+
+@subheading See Also
+@seealso{defcenum} @*
+@seealso{foreign-enum-keyword}
+
+
+@c ===================================================================
+@c FOREIGN-SLOT-NAMES
+
+@node foreign-slot-names
+@unnumberedsec foreign-slot-names
+@subheading Syntax
+@Function{foreign-slot-names type => names}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+A foreign struct type.
+
+@item names
+A list.
+@end table
+
+@subheading Description
+The function @code{foreign-slot-names} returns a list of symbols that denote
+the foreign slots of a struct type. This list has no particular order.
+
+@subheading Examples
+@lisp
+(defcstruct timeval
+ (tv-secs :long)
+ (tv-usecs :long))
+
+CFFI> (foreign-slot-names 'timeval)
+@result{} (TV-SECS TV-USECS)
+@end lisp
+
+@subheading See Also
+@seealso{defcstruct} @*
+@seealso{foreign-slot-offset} @*
+@seealso{foreign-slot-value} @*
+@seealso{foreign-slot-pointer}
+
+
+@c ===================================================================
+@c FOREIGN-SLOT-OFFSET
+
+@node foreign-slot-offset
+@unnumberedsec foreign-slot-offset
+@subheading Syntax
+@Function{foreign-slot-offset type slot-name => offset}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+A foreign struct type.
+
+@item slot-name
+A symbol.
+
+@item offset
+An integer.
+@end table
+
+@subheading Description
+The function @code{foreign-slot-offset} returns the @var{offset} in
+bytes of a slot in a foreign struct type.
+
+@subheading Examples
+@lisp
+(defcstruct timeval
+ (tv-secs :long)
+ (tv-usecs :long))
+
+CFFI> (foreign-slot-offset 'timeval 'tv-secs)
+@result{} 0
+CFFI> (foreign-slot-offset 'timeval 'tv-usecs)
+@result{} 4
+@end lisp
+
+@subheading See Also
+@seealso{defcstruct} @*
+@seealso{foreign-slot-names} @*
+@seealso{foreign-slot-pointer} @*
+@seealso{foreign-slot-value}
+
+
+@c ===================================================================
+@c FOREIGN-SLOT-POINTER
+
+@node foreign-slot-pointer
+@unnumberedsec foreign-slot-pointer
+@subheading Syntax
+@Function{foreign-slot-pointer ptr type &rest slot-names => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A pointer to a structure.
+
+@item type
+A foreign structure type.
+
+@item slot-names
+One or more slot names.
+
+@item pointer
+A pointer to the slot specified in @var{slot-names}.
+@end table
+
+@subheading Description
+Returns a pointer to a slot referred by @var{slot-names} in a foreign
+object of type @var{type} at @var{ptr}. The returned pointer points
+inside the structure. Both the pointer and the memory it points to
+have the same extent as @var{ptr}.
+
+For aggregate slots, this is the same value returned by
+@code{foreign-slot-value}.
+
+@subheading Examples
+@lisp
+(defcstruct point
+ "Pointer structure."
+ (x :int)
+ (y :int))
+
+CFFI> (with-foreign-object (ptr 'point)
+ (foreign-slot-pointer ptr 'point 'x))
+@result{} #<FOREIGN-ADDRESS #xBFFF6E60>
+;; @lispcmt{Note: the exact pointer representation varies from lisp to lisp.}
+@end lisp
+
+@subheading See Also
+@seealso{defcstruct} @*
+@seealso{foreign-slot-value} @*
+@seealso{foreign-slot-names} @*
+@seealso{foreign-slot-offset}
+
+
+@c ===================================================================
+@c FOREIGN-SLOT-VALUE
+
+@node foreign-slot-value
+@unnumberedsec foreign-slot-value
+@subheading Syntax
+@Accessor{foreign-slot-value ptr type slot-name => object}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A pointer to a structure.
+
+@item type
+A foreign structure type.
+
+@item slot-name
+A symbol naming a slot in the structure type.
+
+@item object
+The object contained in the slot specified by @var{slot-name}.
+@end table
+
+@subheading Description
+For simple slots, @code{foreign-slot-value} returns the value of the
+object, such as a Lisp integer or pointer. In C, this would be
+expressed as @code{ptr->slot}.
+
+For aggregate slots, a pointer inside the structure to the beginning
+of the slot's data is returned. In C, this would be expressed as
+@code{&ptr->slot}. This pointer and the memory it points to have the
+same extent as @var{ptr}.
+
+There are compiler macros for @code{foreign-slot-value} and its
+@code{setf} expansion that open code the memory access when
+@var{type} and @var{slot-names} are constant at compile-time.
+
+@subheading Examples
+@lisp
+(defcstruct point
+ "Pointer structure."
+ (x :int)
+ (y :int))
+
+CFFI> (with-foreign-object (ptr 'point)
+ ;; @lispcmt{Initialize the slots}
+ (setf (foreign-slot-value ptr 'point 'x) 42
+ (foreign-slot-value ptr 'point 'y) 42)
+ ;; @lispcmt{Return a list with the coordinates}
+ (with-foreign-slots ((x y) ptr point)
+ (list x y)))
+@result{} (42 42)
+@end lisp
+
+@subheading See Also
+@seealso{defcstruct} @*
+@seealso{foreign-slot-names} @*
+@seealso{foreign-slot-offset} @*
+@seealso{foreign-slot-pointer} @*
+@seealso{with-foreign-slots}
+
+
+@c ===================================================================
+@c FOREIGN-TYPE-ALIGNMENT
+
+@node foreign-type-alignment
+@unnumberedsec foreign-type-alignment
+@subheading Syntax
+@c XXX: This is actually a generic function.
+@Function{foreign-type-alignment type => alignment}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+A foreign type.
+
+@item alignment
+An integer.
+@end table
+
+@subheading Description
+The function @code{foreign-type-alignment} returns the
+@var{alignment} of @var{type} in bytes.
+
+@subheading Examples
+@lisp
+CFFI> (foreign-type-alignment :char)
+@result{} 1
+CFFI> (foreign-type-alignment :short)
+@result{} 2
+CFFI> (foreign-type-alignment :int)
+@result{} 4
+@end lisp
+
+@lisp
+(defcstruct foo
+ (a :char))
+
+CFFI> (foreign-type-alignment 'foo)
+@result{} 1
+@end lisp
+
+@subheading See Also
+@seealso{foreign-type-size}
+
+
+@c ===================================================================
+@c FOREIGN-TYPE-SIZE
+
+@node foreign-type-size
+@unnumberedsec foreign-type-size
+@subheading Syntax
+@c XXX: this is actually a generic function.
+@Function{foreign-type-size type => size}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+A foreign type.
+
+@item size
+An integer.
+@end table
+
+@subheading Description
+The function @code{foreign-type-size} return the @var{size} of
+@var{type} in bytes.
+
+@subheading Examples
+@lisp
+(defcstruct foo
+ (a :double)
+ (c :char))
+
+CFFI> (foreign-type-size :double)
+@result{} 8
+CFFI> (foreign-type-size :char)
+@result{} 1
+CFFI> (foreign-type-size 'foo)
+@result{} 16
+@end lisp
+
+@subheading See Also
+@seealso{foreign-type-alignment}
+
+
+@c ===================================================================
+@c FREE-CONVERTED-OBJECT
+
+@node free-converted-object
+@unnumberedsec free-converted-object
+@subheading Syntax
+@Function{free-converted-object foreign-value type params}
+
+@subheading Arguments and Values
+
+@table @var
+@item foreign-value
+The C object to be freed.
+
+@item type
+A @cffi{} type specifier.
+
+@item params
+The state returned as the second value from @code{convert-to-foreign};
+used to implement the third argument to @code{free-translated-object}.
+@end table
+
+@subheading Description
+
+The return value is unspecified.
+
+This is an external interface to the type translation facility. In
+the implementation, all foreign functions are ultimately defined as
+type translation wrappers around primitive foreign function
+invocations.
+
+This function is available mostly for inspection of the type
+translation process, and possibly optimization of special cases of
+your foreign function calls.
+
+Its behavior is better described under @code{free-translated-object}'s
+documentation.
+
+@subheading Examples
+
+@lisp
+CFFI-USER> (convert-to-foreign "a boat" :string)
+@result{} #<FOREIGN-ADDRESS #x097ACDC0>
+@result{} (T)
+CFFI-USER> (free-converted-object * :string '(t))
+@result{} NIL
+@end lisp
+
+@subheading See Also
+@seealso{convert-from-foreign} @*
+@seealso{convert-to-foreign} @*
+@seealso{free-translated-object}
+
+
+@c ===================================================================
+@c FREE-TRANSLATED-OBJECT
+
+@node free-translated-object
+@unnumberedsec free-translated-object
+@subheading Syntax
+@GenericFunction{free-translated-object value type-name param}
+
+@subheading Arguments and Values
+
+@table @var
+@item pointer
+The foreign value returned by @code{translate-to-foreign}.
+
+@item type-name
+A symbol naming a foreign type defined by @code{defctype}.
+
+@item param
+The second value, if any, returned by @code{translate-to-foreign}.
+@end table
+
+@subheading Description
+This generic function may be specialized by user code to perform
+automatic deallocation of foreign objects as they are passed to C
+functions.
+
+Any methods defined on this generic function must EQL-specialize the
+@var{type-name} parameter on a symbol defined as a foreign type by
+the @code{defctype} macro.
+
+@subheading See Also
+@seealso{Foreign Type Translators} @*
+@seealso{translate-to-foreign}
+
+
+@c ===================================================================
+@c TRANSLATE-FROM-FOREIGN
+
+@node translate-from-foreign
+@unnumberedsec translate-from-foreign
+@subheading Syntax
+@GenericFunction{translate-from-foreign foreign-value type-name
+ => lisp-value}
+
+@subheading Arguments and Values
+
+@table @var
+@item foreign-value
+The foreign value to convert to a Lisp object.
+
+@item type-name
+A symbol naming a foreign type defined by @code{defctype}.
+
+@item lisp-value
+The lisp value to pass in place of @code{foreign-value} to Lisp code.
+@end table
+
+@subheading Description
+This generic function is invoked by @cffi{} to convert a foreign value to
+a Lisp value, such as when returning from a foreign function, passing
+arguments to a callback function, or accessing a foreign variable.
+
+To extend the @cffi{} type system by performing custom translations, this
+method may be specialized by EQL-specializing @code{type-name} on a
+symbol naming a foreign type defined with @code{defctype}. This
+method should return the appropriate Lisp value to use in place of the
+foreign value.
+
+The results are undefined if the @code{type-name} parameter is
+specialized in any way except an EQL specializer on a foreign type
+defined with @code{defctype}. Specifically, translations may not be
+defined for built-in types.
+
+@subheading See Also
+@seealso{Foreign Type Translators} @*
+@seealso{translate-to-foreign} @*
+@seealso{free-translated-object}
+
+
+@c ===================================================================
+@c TRANSLATE-TO-FOREIGN
+
+@node translate-to-foreign
+@unnumberedsec translate-to-foreign
+@subheading Syntax
+@GenericFunction{translate-to-foreign lisp-value type-name
+ => foreign-value, alloc-param}
+
+@subheading Arguments and Values
+
+@table @var
+@item lisp-value
+The lisp value to convert to foreign representation.
+
+@item type-name
+A symbol naming a foreign type defined by @code{defctype}.
+
+@item foreign-value
+The foreign value to pass in place of @code{lisp-value} to foreign code.
+
+@item alloc-param
+If present, this value will be passed to
+@code{free-translated-object}.
+@end table
+
+@subheading Description
+This generic function is invoked by @cffi{} to convert a Lisp value to a
+foreign value, such as when passing arguments to a foreign function,
+returning a value from a callback, or setting a foreign variable.
+
+To extend the @cffi{} type system by performing custom translations, this
+method may be specialized by EQL-specializing @code{type-name} on a
+symbol naming a foreign type defined with @code{defctype}. This
+method should return the appropriate foreign value to use in place of
+the Lisp value.
+
+In cases where @cffi{} can determine the lifetime of the foreign object
+returned by this method, it will invoke @code{free-translated-object}
+on the foreign object at the appropriate time. If
+@code{translate-to-foreign} returns a second value, it will be passed
+as the @code{param} argument to @code{free-translated-object}. This
+can be used to establish communication between the allocation and
+deallocation methods.
+
+The results are undefined if the @code{type-name} parameter is
+specialized in any way except an EQL specializer on a foreign type
+defined with @code{defctype}. Specifically, translations may not be
+defined for built-in types.
+
+@subheading See Also
+@seealso{Foreign Type Translators} @*
+@seealso{translate-from-foreign} @*
+@seealso{free-translated-object}
+
+
+@c ===================================================================
+@c WITH-FOREIGN-SLOTS
+
+@node with-foreign-slots
+@unnumberedsec with-foreign-slots
+@subheading Syntax
+@Macro{with-foreign-slots (vars ptr type) &body body}
+
+@subheading Arguments and Values
+
+@table @var
+@item vars
+A list of symbols.
+
+@item ptr
+A foreign pointer to a structure.
+
+@item type
+A structure type.
+
+@item body
+A list of forms to be executed.
+@end table
+
+@subheading Description
+The @code{with-foreign-slots} macro creates local symbol macros for
+each var in @var{vars} to reference foreign slots in @var{ptr} of
+@var{type}. It is similar to Common Lisp's @code{with-slots} macro.
+
+@subheading Examples
+@lisp
+(defcstruct tm
+ (sec :int)
+ (min :int)
+ (hour :int)
+ (mday :int)
+ (mon :int)
+ (year :int)
+ (wday :int)
+ (yday :int)
+ (isdst :boolean)
+ (zone :string)
+ (gmtoff :long))
+
+CFFI> (with-foreign-object (time :int)
+ (setf (mem-ref time :int)
+ (foreign-funcall "time" :pointer (null-pointer) :int))
+ (foreign-funcall "gmtime" :pointer time tm))
+@result{} #<A Mac Pointer #x102A30>
+CFFI> (with-foreign-slots ((sec min hour mday mon year) * tm)
+ (format nil "~A:~A:~A, ~A/~A/~A" hour min sec (+ 1900 year) mon mday))
+@result{} "7:22:47, 2005/8/2"
+@end lisp
+
+@subheading See Also
+@seealso{defcstruct} @*
+@seealso{defcunion} @*
+@seealso{foreign-slot-value}
+
+
+@c ===================================================================
+@c CHAPTER: Pointers
+
+@node Pointers
+@chapter Pointers
+
+All C data in @cffi{} is referenced through pointers. This includes
+defined C variables that hold immediate values, and integers.
+
+To see why this is, consider the case of the C integer. It is not
+only an arbitrary representation for an integer, congruent to Lisp's
+fixnums; the C integer has a specific bit pattern in memory defined by
+the C @acronym{ABI}. Lisp has no such constraint on its fixnums;
+therefore, it only makes sense to think of fixnums as C integers if
+you assume that @cffi{} converts them when necessary, such as when
+storing one for use in a C function call, or as the value of a C
+variable. This requires defining an area of memory@footnote{The
+definition of @dfn{memory} includes the @acronym{CPU} registers.},
+represented through an effective address, and storing it there.
+
+Due to this compartmentalization, it only makes sense to manipulate
+raw C data in Lisp through pointers to it. For example, while there
+may be a Lisp representation of a @code{struct} that is converted to C
+at store time, you may only manipulate its raw data through a pointer.
+The C compiler does this also, albeit informally.
+
+@menu
+* Basic Pointer Operations::
+* Allocating Foreign Memory::
+* Accessing Foreign Memory::
+
+Dictionary
+
+* foreign-free::
+* foreign-alloc::
+* foreign-symbol-pointer::
+* inc-pointer::
+* make-pointer::
+* mem-aref::
+* mem-ref::
+* null-pointer::
+* null-pointer-p::
+* pointerp::
+* pointer-address::
+* pointer-eq::
+* with-foreign-object::
+* with-foreign-pointer::
+@end menu
+
+@node Basic Pointer Operations
+@section Basic Pointer Operations
+
+Manipulating pointers proper can be accomplished through most of the
+other operations defined in the Pointers dictionary, such as
+@code{make-pointer}, @code{pointer-address}, and @code{pointer-eq}.
+When using them, keep in mind that they merely manipulate the Lisp
+representation of pointers, not the values they point to.
+
+
+@node Allocating Foreign Memory
+@section Allocating Foreign Memory
+
+@cffi{} provides support for stack and heap C memory allocation.
+Stack allocation, done with @code{with-foreign-object}, is sometimes
+called ``dynamic'' allocation in Lisp, because memory allocated as
+such has dynamic extent, much as with @code{let} bindings of special
+variables.
+
+This should not be confused with what C calls ``dynamic'' allocation,
+or that done with @code{malloc} and friends. This sort of heap
+allocation is done with @code{foreign-alloc}, creating objects that
+exist until freed with @code{foreign-free}.
+
+
+@node Accessing Foreign Memory
+@section Accessing Foreign Memory
+
+When manipulating raw C data, consider that all pointers are pointing
+to an array. When you only want one C value, such as a single
+@code{struct}, this array only has one such value. It is worthwhile
+to remember that everything is an array, though, because this is also
+the semantic that C imposes natively.
+
+C values are accessed as the @code{setf}-able places defined by
+@code{mem-aref} and @code{mem-ref}. Given a pointer and a @cffi{}
+type (@pxref{Foreign Types}), either of these will dereference the
+pointer, translate the C data there back to Lisp, and return the
+result of said translation, performing the reverse operation when
+@code{setf}-ing. To decide which one to use, consider whether you
+would use the array index operator @code{[@var{n}]} or the pointer
+dereference @code{*} in C; use @code{mem-aref} for array indexing and
+@code{mem-ref} for pointer dereferencing.
+
+
+@c ===================================================================
+@c FOREIGN-FREE
+
+@node foreign-free
+@unnumberedsec foreign-free
+@subheading Syntax
+@Function{foreign-free ptr => undefined}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A foreign pointer.
+@end table
+
+@subheading Description
+The @code{foreign-free} function frees a @code{ptr} previously
+allocated by @code{foreign-alloc}. The consequences of freeing a given
+pointer twice are undefined.
+
+@subheading Examples
+
+@lisp
+CFFI> (foreign-alloc :int)
+@result{} #<A Mac Pointer #x1022E0>
+CFFI> (foreign-free *)
+@result{} NIL
+@end lisp
+
+@subheading See Also
+@seealso{foreign-alloc} @*
+@seealso{with-foreign-pointer}
+
+
+@c ===================================================================
+@c FOREIGN-ALLOC
+
+@node foreign-alloc
+@unnumberedsec foreign-alloc
+@subheading Syntax
+@Function{foreign-alloc type &key initial-element initial-contents (count 1) null-terminated-p => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item type
+A foreign type.
+
+@item initial-element
+A Lisp object.
+
+@item initial-contents
+A sequence.
+
+@item count
+An integer. Defaults to 1 or the length of @var{initial-contents} if
+supplied.
+
+@item null-terminated-p
+A boolean, false by default.
+
+@item pointer
+A foreign pointer to the newly allocated memory.
+@end table
+
+@subheading Description
+The @code{foreign-alloc} function allocates enough memory to hold
+@var{count} objects of type @var{type} and returns a
+@var{pointer}. This memory must be explicitly freed using
+@code{foreign-free} once it is no longer needed.
+
+If @var{initial-element} is supplied, it is used to initialize the
+@var{count} objects the newly allocated memory holds.
+
+If an @var{initial-contents} sequence is supplied, it must have a
+length less than or equal to @var{count} and each of its elements
+will be used to initialize the contents of the newly allocated
+memory.
+
+If @var{count} is omitted and @var{initial-contents} is specified, it
+will default to @code{(length @var{initial-contents})}.
+
+@var{initial-element} and @var{initial-contents} are mutually
+exclusive.
+
+When @var{null-terminated-p} is true,
+@code{(1+ (max @var{count} (length @var{initial-contents})))} elements
+are allocated and the last one is set to @code{NULL}. Note that in
+this case @var{type} must be a pointer type (ie. a type that
+canonicalizes to @code{:pointer}), otherwise an error is signaled.
+
+@subheading Examples
+@lisp
+CFFI> (foreign-alloc :char)
+@result{} #<A Mac Pointer #x102D80> ; @lispcmt{A pointer to 1 byte of memory.}
+
+CFFI> (foreign-alloc :char :count 20)
+@result{} #<A Mac Pointer #x1024A0> ; @lispcmt{A pointer to 20 bytes of memory.}
+
+CFFI> (foreign-alloc :int :initial-element 12)
+@result{} #<A Mac Pointer #x1028B0>
+CFFI> (mem-ref * :int)
+@result{} 12
+
+CFFI> (foreign-alloc :int :initial-contents '(1 2 3))
+@result{} #<A Mac Pointer #x102950>
+CFFI> (loop for i from 0 below 3
+ collect (mem-aref * :int i))
+@result{} (1 2 3)
+
+CFFI> (foreign-alloc :int :initial-contents #(1 2 3))
+@result{} #<A Mac Pointer #x102960>
+CFFI> (loop for i from 0 below 3
+ collect (mem-aref * :int i))
+@result{} (1 2 3)
+
+;;; Allocate a char** pointer that points to newly allocated memory
+;;; by the :string type translator for the string "foo".
+CFFI> (foreign-alloc :string :initial-element "foo")
+@result{} #<A Mac Pointer #x102C40>
+@end lisp
+
+@lisp
+;;; Allocate a null-terminated array of strings.
+;;; (Note: FOREIGN-STRING-TO-LISP returns NIL when passed a null pointer)
+CFFI> (foreign-alloc :string
+ :initial-contents '("foo" "bar" "baz")
+ :null-terminated-p t)
+@result{} #<A Mac Pointer #x102D20>
+CFFI> (loop for i from 0 below 4
+ collect (mem-aref * :string i))
+@result{} ("foo" "bar" "baz" NIL)
+CFFI> (progn
+ (dotimes (i 3)
+ (foreign-free (mem-aref ** :pointer i)))
+ (foreign-free **))
+@result{} nil
+@end lisp
+
+@subheading See Also
+@seealso{foreign-free} @*
+@seealso{with-foreign-object} @*
+@seealso{with-foreign-pointer}
+
+
+@c ===================================================================
+@c FOREIGN-SYMBOL-POINTER
+
+@node foreign-symbol-pointer
+@unnumberedsec foreign-symbol-pointer
+@subheading Syntax
+@Function{foreign-symbol-pointer foreign-name => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item foreign-name
+A string.
+
+@item pointer
+A foreign pointer, or @code{nil}.
+@end table
+
+@subheading Description
+The function @code{foreign-symbol-pointer} will return a foreign
+pointer corresponding to the foreign symbol denoted by the string
+@var{foreign-name}. If a foreign symbol named @var{foreign-name}
+doesn't exist, @code{nil} is returned.
+
+ABI name manglings will be performed on @var{foreign-name} by
+@code{foreign-symbol-pointer} if necessary. (eg: adding a leading
+underscore on darwin/ppc)
+
+@strong{Important note:} do not keep these pointers across saved Lisp
+cores as the foreign-library may move across sessions.
+
+@subheading Examples
+
+@lisp
+CFFI> (foreign-symbol-pointer "errno")
+@result{} #<A Mac Pointer #xA0008130>
+CFFI> (foreign-symbol-pointer "strerror")
+@result{} #<A Mac Pointer #x9002D0F8>
+CFFI> (foreign-funcall * :int (mem-ref ** :int) :string)
+@result{} "No such file or directory"
+
+CFFI> (foreign-symbol-pointer "inexistent symbol")
+@result{} NIL
+@end lisp
+
+@subheading See Also
+@seealso{defcvar}
+
+
+@c ===================================================================
+@c INC-POINTER
+
+@node inc-pointer
+@unnumberedsec inc-pointer
+@subheading Syntax
+@Function{inc-pointer pointer offset => new-pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item pointer
+@itemx new-pointer
+A foreign pointer.
+
+@item offset
+An integer.
+@end table
+
+@subheading Description
+The function @code{inc-pointer} will return a @var{new-pointer} pointing
+@var{offset} bytes past @var{pointer}.
+
+@subheading Examples
+
+@lisp
+CFFI> (foreign-string-alloc "Common Lisp")
+@result{} #<A Mac Pointer #x102EA0>
+CFFI> (inc-pointer * 7)
+@result{} #<A Mac Pointer #x102EA7>
+CFFI> (foreign-string-to-lisp *)
+@result{} "Lisp"
+@end lisp
+
+@subheading See Also
+@seealso{make-pointer} @*
+@seealso{pointerp} @*
+@seealso{null-pointer} @*
+@seealso{null-pointer-p}
+
+
+@c ===================================================================
+@c MAKE-POINTER
+
+@node make-pointer
+@unnumberedsec make-pointer
+@subheading Syntax
+@Function{make-pointer address => ptr}
+
+@subheading Arguments and Values
+
+@table @var
+@item address
+An integer.
+
+@item ptr
+A foreign pointer.
+@end table
+
+@subheading Description
+The function @code{make-pointer} will return a foreign pointer
+pointing to @var{address}.
+
+@subheading Examples
+
+@lisp
+CFFI> (make-pointer 42)
+@result{} #<FOREIGN-ADDRESS #x0000002A>
+CFFI> (pointerp *)
+@result{} T
+CFFI> (pointer-address **)
+@result{} 42
+CFFI> (inc-pointer *** -42)
+@result{} #<FOREIGN-ADDRESS #x00000000>
+CFFI> (null-pointer-p *)
+@result{} T
+@end lisp
+
+@subheading See Also
+@seealso{inc-pointer} @*
+@seealso{null-pointer} @*
+@seealso{null-pointer-p} @*
+@seealso{pointerp} @*
+@seealso{pointer-address} @*
+@seealso{pointer-eq} @*
+@seealso{mem-ref}
+
+
+@c ===================================================================
+@c MEM-AREF
+
+@node mem-aref
+@unnumberedsec mem-aref
+@subheading Syntax
+@Accessor{mem-aref ptr type &optional (index 0)}
+
+(setf (@strong{mem-aref} @emph{ptr type &optional (index 0)) new-value})
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A foreign pointer.
+
+@item type
+A foreign type.
+
+@item index
+An integer.
+
+@item new-value
+A Lisp value compatible with @var{type}.
+@end table
+
+@subheading Description
+The @code{mem-aref} function is similar to @code{mem-ref} but will
+automatically calculate the offset from an @var{index}.
+
+@lisp
+(mem-aref ptr type n)
+
+;; @lispcmt{is identical to:}
+
+(mem-ref ptr type (* n (foreign-type-size type)))
+@end lisp
+
+@subheading Examples
+
+@lisp
+CFFI> (with-foreign-string (str "Hello, foreign world!")
+ (mem-aref str :char 6))
+@result{} 32
+CFFI> (code-char *)
+@result{} #\Space
+
+CFFI> (with-foreign-object (array :int 10)
+ (loop for i below 10
+ do (setf (mem-aref array :int i) (random 100)))
+ (loop for i below 10 collect (mem-aref array :int i)))
+@result{} (22 7 22 52 69 1 46 93 90 65)
+@end lisp
+
+@subheading See Also
+@seealso{mem-ref}
+
+
+@c ===================================================================
+@c MEM-REF
+
+@node mem-ref
+@unnumberedsec mem-ref
+@subheading Syntax
+@Accessor{mem-ref ptr type &optional offset => object}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A pointer.
+
+@item type
+A foreign type.
+
+@item offset
+An integer (in byte units).
+
+@item object
+The value @var{ptr} points to.
+@end table
+
+@subheading Description
+@subheading Examples
+
+@lisp
+CFFI> (with-foreign-string (ptr "Saluton")
+ (setf (mem-ref ptr :char 3) (char-code #\a))
+ (loop for i from 0 below 8
+ collect (code-char (mem-ref ptr :char i))))
+@result{} (#\S #\a #\l #\a #\t #\o #\n #\Null)
+CFFI> (setq ptr-to-int (foreign-alloc :int))
+@result{} #<A Mac Pointer #x1047D0>
+CFFI> (mem-ref ptr-to-int :int)
+@result{} 1054619
+CFFI> (setf (mem-ref ptr-to-int :int) 1984)
+@result{} 1984
+CFFI> (mem-ref ptr-to-int :int)
+@result{} 1984
+@end lisp
+
+@subheading See Also
+@seealso{mem-aref}
+
+
+@c ===================================================================
+@c NULL-POINTER
+
+@node null-pointer
+@unnumberedsec null-pointer
+@subheading Syntax
+@Function{null-pointer => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item pointer
+A @code{NULL} pointer.
+@end table
+
+@subheading Description
+The function @code{null-pointer} returns a null pointer.
+
+@subheading Examples
+
+@lisp
+CFFI> (null-pointer)
+@result{} #<A Null Mac Pointer>
+CFFI> (pointerp *)
+@result{} T
+@end lisp
+
+@subheading See Also
+@seealso{null-pointer-p} @*
+@seealso{make-pointer}
+
+
+@c ===================================================================
+@c NULL-POINTER-P
+
+@node null-pointer-p
+@unnumberedsec null-pointer-p
+@subheading Syntax
+@Function{null-pointer-p ptr => boolean}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A foreign pointer that may be a null pointer.
+
+@item boolean
+@code{T} or @code{NIL}.
+@end table
+
+@subheading Description
+The function @code{null-pointer-p} returns true if @var{ptr} is a null
+pointer and false otherwise.
+
+@subheading Examples
+
+@lisp
+CFFI> (null-pointer-p (null-pointer))
+@result{} T
+@end lisp
+
+@lisp
+(defun contains-str-p (big little)
+ (not (null-pointer-p
+ (foreign-funcall "strstr" :string big :string little :pointer))))
+
+CFFI> (contains-str-p "Popcorns" "corn")
+@result{} T
+CFFI> (contains-str-p "Popcorns" "salt")
+@result{} NIL
+@end lisp
+
+@subheading See Also
+@seealso{null-pointer} @*
+@seealso{pointerp}
+
+
+@c ===================================================================
+@c POINTERP
+
+@node pointerp
+@unnumberedsec pointerp
+@subheading Syntax
+@Function{pointerp ptr => boolean}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+An object that may be a foreign pointer.
+
+@item boolean
+@code{T} or @code{NIL}.
+@end table
+
+@subheading Description
+The function @code{pointerp} returns true if @var{ptr} is a foreign
+pointer and false otherwise.
+
+@subheading Implementation-specific Notes
+In Allegro CL, foreign pointers are integers thus in this
+implementation @code{pointerp} will return true for any ordinary integer.
+
+@subheading Examples
+
+@lisp
+CFFI> (foreign-alloc 32)
+@result{} #<A Mac Pointer #x102D20>
+CFFI> (pointerp *)
+@result{} T
+CFFI> (pointerp "this is not a pointer")
+@result{} NIL
+@end lisp
+
+@subheading See Also
+@seealso{make-pointer}
+@seealso{null-pointer-p}
+
+
+@c ===================================================================
+@c POINTER-ADDRESS
+
+@node pointer-address
+@unnumberedsec pointer-address
+@subheading Syntax
+@Function{pointer-address ptr => address}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A foreign pointer.
+
+@item address
+An integer.
+@end table
+
+@subheading Description
+The function @code{pointer-address} will return the @var{address} of
+a foreign pointer @var{ptr}.
+
+@subheading Examples
+
+@lisp
+CFFI> (pointer-address (null-pointer))
+@result{} 0
+CFFI> (pointer-address (make-pointer 123))
+@result{} 123
+@end lisp
+
+@subheading See Also
+@seealso{make-pointer} @*
+@seealso{inc-pointer} @*
+@seealso{null-pointer} @*
+@seealso{null-pointer-p} @*
+@seealso{pointerp} @*
+@seealso{pointer-eq} @*
+@seealso{mem-ref}
+
+
+@c ===================================================================
+@c POINTER-EQ
+
+@node pointer-eq
+@unnumberedsec pointer-eq
+@subheading Syntax
+@Function{pointer-eq ptr1 ptr2 => boolean}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr1
+@itemx ptr2
+A foreign pointer.
+
+@item boolean
+@code{T} or @code{NIL}.
+@end table
+
+@subheading Description
+The function @code{pointer-eq} returns true if @var{ptr1} and
+@var{ptr2} point to the same memory address and false otherwise.
+
+@subheading Implementation-specific Notes
+The representation of foreign pointers varies across the various Lisp
+implementations as does the behaviour of the built-in Common Lisp
+equality predicates. Comparing two pointers that point to the same
+address with @code{EQ} Lisps will return true on some Lisps, others require
+more general predicates like @code{EQL} or @code{EQUALP} and finally
+some will return false using any of these predicates. Therefore, for
+portability, you should use @code{POINTER-EQ}.
+
+@subheading Examples
+This is an example using SBCL, see the implementation-specific notes
+above.
+
+@lisp
+CFFI> (eql (null-pointer) (null-pointer))
+@result{} NIL
+CFFI> (pointer-eq (null-pointer) (null-pointer))
+@result{} T
+@end lisp
+
+@subheading See Also
+@seealso{inc-pointer}
+
+
+@c ===================================================================
+@c WITH-FOREIGN-OBJECT
+
+@node with-foreign-object
+@unnumberedsec with-foreign-object
+@subheading Syntax
+@Macro{with-foreign-object (var type &optional count) &body body}
+
+@Macro{with-foreign-objects (bindings) &body body}
+
+bindings ::= @{(var type &optional count)@}*
+
+@subheading Arguments and Values
+
+@table @var
+@item var
+A symbol.
+
+@item type
+A foreign type, evaluated.
+
+@item count
+An integer.
+@end table
+
+@subheading Description
+The macros @code{with-foreign-object} and @code{with-foreign-objects}
+bind @var{var} to a pointer to @var{count} newly allocated objects
+of type @var{type} during @var{body}. The buffer has dynamic extent
+and may be stack allocated if supported by the host Lisp.
+
+@subheading Examples
+
+@lisp
+CFFI> (with-foreign-object (array :int 10)
+ (dotimes (i 10)
+ (setf (mem-aref array :int i) (random 100)))
+ (loop for i below 10
+ collect (mem-aref array :int i)))
+@result{} (22 7 22 52 69 1 46 93 90 65)
+@end lisp
+
+@subheading See Also
+@seealso{foreign-alloc}
+
+
+@c ===================================================================
+@c WITH-FOREIGN-POINTER
+
+@node with-foreign-pointer
+@unnumberedsec with-foreign-pointer
+@subheading Syntax
+@Macro{with-foreign-pointer (var size &optional size-var) &body body}
+
+@subheading Arguments and Values
+
+@table @var
+@item var
+@itemx size-var
+A symbol.
+
+@item size
+An integer.
+
+@item body
+A list of forms to be executed.
+@end table
+
+@subheading Description
+The @code{with-foreign-pointer} macro, binds @var{var} to @var{size}
+bytes of foreign memory during @var{body}. The pointer in @var{var}
+is invalid beyond the dynamic extend of @var{body} and may be
+stack-allocated if supported by the implementation.
+
+If @var{size-var} is supplied, it will be bound to @var{size} during
+@var{body}.
+
+@subheading Examples
+
+@lisp
+CFFI> (with-foreign-pointer (string 4 size)
+ (setf (mem-ref string :char (1- size)) 0)
+ (lisp-string-to-foreign "Popcorns" string size)
+ (loop for i from 0 below size
+ collect (code-char (mem-ref string :char i))))
+@result{} (#\P #\o #\p #\Null)
+@end lisp
+
+@subheading See Also
+@seealso{foreign-alloc} @*
+@seealso{foreign-free}
+
+
+@c ===================================================================
+@c CHAPTER: Strings
+
+@node Strings
+@chapter Strings
+
+As with many languages, Lisp and C have special support for logical
+arrays of characters, going so far as to give them a special name,
+``strings''. In that spirit, @cffi{} provides special support for
+translating between Lisp and C strings.
+
+The @code{:string} type and the symbols related below also serve as an
+example of what you can do portably with @cffi{}; were it not
+included, you could write an equally functional @file{strings.lisp}
+without referring to any implementation-specific symbols.
+
+@menu
+Dictionary
+
+* foreign-string-alloc::
+* foreign-string-free::
+* foreign-string-to-lisp::
+* lisp-string-to-foreign::
+* with-foreign-string::
+* with-foreign-pointer-as-string::
+@end menu
+
+
+@c ===================================================================
+@c FOREIGN-STRING-ALLOC
+
+@node foreign-string-alloc
+@unnumberedsec foreign-string-alloc
+@subheading Syntax
+@Function{foreign-string-alloc string => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item string
+A Lisp string.
+
+@item pointer
+A pointer to the newly allocated foreign string containg @var{string}.
+@end table
+
+@subheading Description
+The @code{foreign-string-alloc} function allocates a foreign string
+containing a Lisp @var{string}.
+
+This string must be freed with @code{foreign-string-free}.
+
+@subheading Examples
+
+@lisp
+CFFI> (setq str (foreign-string-alloc "Hello, foreign world!"))
+@result{} #<FOREIGN-ADDRESS #x00400560>
+CFFI> (foreign-funcall "strlen" :pointer str :int)
+@result{} 21
+@end lisp
+
+@subheading See Also
+@seealso{foreign-string-free} @*
+@seealso{with-foreign-string}
+@c @seealso{:string}
+
+
+@c ===================================================================
+@c FOREIGN-STRING-FREE
+
+@node foreign-string-free
+@unnumberedsec foreign-string-free
+@subheading Syntax
+@Function{foreign-string-free pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item pointer
+A pointer to a string allocated by @code{foreign-string-alloc}.
+@end table
+
+@subheading Description
+The @code{foreign-string-free} function frees a foreign string
+allocated by @code{foreign-string-alloc}.
+
+@subheading Examples
+
+@subheading See Also
+@seealso{foreign-string-alloc}
+
+
+@c ===================================================================
+@c FOREIGN-STRING-TO-LISP
+
+@node foreign-string-to-lisp
+@unnumberedsec foreign-string-to-lisp
+@subheading Syntax
+@Function{foreign-string-to-lisp ptr &optional size null-terminated-p => string}
+
+@subheading Arguments and Values
+
+@table @var
+@item ptr
+A pointer.
+
+@item size
+The maximum string size. @code{most-positive-fixnum}, by default.
+
+@item null-terminated-p
+Specifies if the string @var{ptr} points to is null terminated. True,
+by default.
+@end table
+
+@subheading Description
+The @code{foreign-string-to-lisp} function copies at most @var{size}
+characters from @var{ptr} into a Lisp string.
+
+When @var{null-terminated-p} is true (the default), characters are
+copied until @var{size} is reached or a @code{NULL} character is
+found.
+
+If @var{ptr} is a null pointer, returns nil.
+
+Note that the @code{:string} type will automatically convert between
+Lisp strings and foreign strings.
+
+@subheading Examples
+
+@lisp
+CFFI> (foreign-funcall "getenv" :string "HOME" :pointer)
+@result{} #<FOREIGN-ADDRESS #xBFFFFFD5>
+CFFI> (foreign-string-to-lisp *)
+@result{} "/Users/luis"
+@end lisp
+
+@subheading See Also
+@seealso{lisp-string-to-foreign} @*
+@seealso{foreign-string-alloc}
+@c @seealso{:string}
+
+
+@c ===================================================================
+@c LISP-STRING-TO-FOREIGN
+
+@node lisp-string-to-foreign
+@unnumberedsec lisp-string-to-foreign
+@subheading Syntax
+@Function{lisp-string-to-foreign string ptr size}
+
+@subheading Arguments and Values
+
+@table @var
+@item string
+A Lisp string.
+
+@item ptr
+A foreign pointer.
+
+@item size
+An integer.
+@end table
+
+@subheading Description
+The @code{lisp-string-to-foreign} function copies at most
+@var{size}-1 characters from a Lisp @var{string} to @var{ptr}. The
+foreign string will be null-terminated.
+
+@subheading Examples
+
+@lisp
+CFFI> (with-foreign-pointer-as-string (str 255)
+ (lisp-string-to-foreign "Hello, foreign world!" str 6))
+@result{} "Hello"
+@end lisp
+
+@subheading See Also
+@seealso{foreign-string-alloc} @*
+@seealso{foreign-string-to-lisp} @*
+@seealso{with-foreign-pointer-as-string}
+
+
+@c ===================================================================
+@c WITH-FOREIGN-STRING
+
+@node with-foreign-string
+@unnumberedsec with-foreign-string
+@subheading Syntax
+@Macro{with-foreign-string (var lisp-string) &body body}
+
+@subheading Arguments and Values
+
+@table @var
+@item var
+A symbol.
+
+@item lisp-string
+A Lisp string.
+
+@item body
+A list of forms to be executed.
+@end table
+
+@subheading Description
+The @code{with-foreign-string} macro will bind @var{var} to a newly
+allocated foreign string containing @var{lisp-string}.
+
+@subheading Examples
+
+@lisp
+CFFI> (with-foreign-string (foo "12345")
+ (foreign-funcall "strlen" :pointer foo :int))
+@result{} 5
+@end lisp
+
+@subheading See Also
+@seealso{foreign-string-alloc} @*
+@seealso{with-foreign-pointer-as-string}
+
+
+@c ===================================================================
+@c WITH-FOREIGN-POINTER-AS-STRING
+
+@node with-foreign-pointer-as-string
+@unnumberedsec with-foreign-pointer-as-string
+@subheading Syntax
+@Macro{with-foreign-pointer-as-string (var size &optional size-var) &body body}
+
+@subheading Arguments and Values
+
+@table @var
+@item var
+A symbol.
+
+@item lisp-string
+A Lisp string.
+
+@item body
+List of forms to be executed.
+@end table
+
+@subheading Description
+The @code{with-foreign-pointer-as-string} macro is similar to
+@code{with-foreign-pointer} except that @var{var}, as a Lisp string, is
+used as the returned value of an implicit @code{progn} around @var{body}.
+
+@subheading Examples
+
+@lisp
+CFFI> (with-foreign-pointer-as-string (str 6 str-size)
+ (lisp-string-to-foreign "Hello, foreign world!" str str-size))
+@result{} "Hello"
+@end lisp
+
+@subheading See Also
+@seealso{foreign-string-alloc} @*
+@seealso{with-foreign-string}
+
+
+@c ===================================================================
+@c CHAPTER: Variables
+
+@node Variables
+@chapter Variables
+
+@menu
+Dictionary
+
+* defcvar::
+* get-var-pointer::
+@end menu
+
+
+@c ===================================================================
+@c DEFCVAR
+
+@node defcvar
+@unnumberedsec defcvar
+@subheading Syntax
+@Macro{defcvar name type &key read-only => lisp-name}
+
+name ::= lisp-name | foreign-name | (foreign-name lisp-name)
+
+@subheading Arguments and Values
+
+@table @var
+@item foreign-name
+A string denoting a foreign function.
+
+@item lisp-name
+A symbol naming the Lisp function to be created.
+
+@item type
+A foreign type.
+
+@item read-only
+A boolean.
+@end table
+
+@subheading Description
+The @code{defcvar} macro
+
+When one of @var{lisp-name} or @var{foreign-name} is omitted, the
+other is automatically derived using the following rules:
+
+@itemize
+@item
+Foreign names are converted to Lisp names by uppercasing, replacing
+underscores with hyphens, and wrapping around asterisks.
+@item
+Lisp names are converted to foreign names by lowercasing, replacing
+hyphens with underscores, and removing asterisks, if any.
+@end itemize
+
+@subheading Examples
+
+@lisp
+CFFI> (defcvar "errno" :int)
+@result{} *ERRNO*
+CFFI> (foreign-funcall "strerror" :int *errno* :string)
+@result{} "Inappropriate ioctl for device"
+CFFI> (setf *errno* 1)
+@result{} 1
+CFFI> (foreign-funcall "strerror" :int *errno* :string)
+@result{} "Operation not permitted"
+@end lisp
+
+Trying to modify a read-only foreign variable:
+
+@lisp
+CFFI> (defcvar ("errno" +error-number+) :int :read-only t)
+@result{} +ERROR-NUMBER+
+CFFI> (setf +error-number+ 12)
+;; @lispcmt{@error{} Trying to modify read-only foreign var: +ERROR-NUMBER+.}
+@end lisp
+
+@emph{Note that accessing @code{errno} this way won't work with every
+C standard library.}
+
+@subheading See Also
+@seealso{get-var-pointer}
+
+
+@c ===================================================================
+@c GET-VAR-POINTER
+
+@node get-var-pointer
+@unnumberedsec get-var-pointer
+@subheading Syntax
+@Function{get-var-pointer symbol => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item symbol
+A symbol denoting a foreign variable defined with @code{defcvar}.
+
+@item pointer
+A foreign pointer.
+@end table
+
+@subheading Description
+The function @code{get-var-pointer} will return a @var{pointer} to the
+foreign global variable @var{symbol} previously defined with
+@code{defcvar}.
+
+@subheading Examples
+
+@lisp
+CFFI> (defcvar "errno" :int :read-only t)
+@result{} *ERRNO*
+CFFI> *errno*
+@result{} 25
+CFFI> (get-var-pointer '*errno*)
+@result{} #<A Mac Pointer #xA0008130>
+CFFI> (mem-ref * :int)
+@result{} 25
+@end lisp
+
+@subheading See Also
+@seealso{defcvar}
+
+
+@c ===================================================================
+@c CHAPTER: Functions
+
+@node Functions
+@chapter Functions
+
+@menu
+* Calling Foreign Functions::
+* Defining Foreign Functions::
+
+Dictionary
+
+* defcfun::
+* foreign-funcall::
+@end menu
+
+@node Calling Foreign Functions
+@section Calling Foreign Functions
+
+@node Defining Foreign Functions
+@section Defining Foreign Functions
+
+
+@c ===================================================================
+@c DEFCFUN
+
+@node defcfun
+@unnumberedsec defcfun
+@subheading Syntax
+@Macro{defcfun name return-type &body arguments [varargs-marker] => lisp-name}
+
+name ::= lisp-name | foreign-name | (foreign-name lisp-name) @*
+arguments ::= @{ (arg-name arg-type) @}*
+varargs-marker ::= &rest
+
+@subheading Arguments and Values
+
+@table @var
+@item foreign-name
+A string denoting a foreign function.
+
+@item lisp-name
+A symbol naming the Lisp function to be created.
+
+@item arg-name
+A symbol.
+
+@item return-type
+@itemx arg-type
+A foreign type.
+@end table
+
+@subheading Description
+The @code{defcfun} macro provides a declarative interface for defining
+Lisp functions that call foreign functions.
+
+When one of @var{lisp-name} or @var{foreign-name} is omitted, the
+other is automatically derived using the following rules:
+
+@itemize
+@item
+Foreign names are converted to Lisp names by uppercasing and replacing
+underscores with hyphens.
+@item
+Lisp names are converted to foreign names by lowercasing and replacing
+hyphens with underscores.
+@end itemize
+
+If you place the symbol @code{&rest} in the end of the argument list
+after the fixed arguments, @code{defcfun} will treat the foreign
+function as a @strong{variadic function}. The variadic arguments
+should be passed in a way similar to what @code{foreign-funcall} would
+expect. Unlike @code{foreign-funcall} though, @code{defcfun} will take
+care of doing argument promotion. Note that in this case
+@code{defcfun} will generate a Lisp @emph{macro} instead of a
+function and will only work for Lisps that support
+(a)code{foreign-funcall.}
+
+
+@subheading Examples
+
+@lisp
+(defcfun "strlen" :int (n :string))
+
+CFFI> (strlen "123")
+@result{} 3
+@end lisp
+
+@lisp
+(defcfun ("abs" c-abs) :int (n :int))
+
+CFFI> (c-abs -42)
+@result{} 42
+@end lisp
+
+Variadic function example:
+
+@lisp
+(defcfun "sprintf" :int
+ (str :pointer)
+ (control :string)
+ &rest)
+
+CFFI> (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%c %d %.2f %s" :char 90 :short 42 :float pi
+ :string "super-locrian"))
+@result{} "A 42 3.14 super-locrian"
+@end lisp
+
+@subheading See Also
+@seealso{foreign-funcall}
+
+
+@c ===================================================================
+@c FOREIGN-FUNCALL
+
+@node foreign-funcall
+@unnumberedsec foreign-funcall
+@subheading Syntax
+@Macro{foreign-funcall name-or-pointer &rest arguments => return-value}
+
+arguments ::= @{ arg-type arg @}* [return-type]
+
+@subheading Arguments and Values
+
+@table @var
+@item name-or-pointer
+Either a string or a pointer.
+
+@item arg-type
+A foreign type.
+
+@item arg
+An argument of type @var{arg-type}.
+
+@item return-type
+A foreign type, @code{:void} by default.
+
+@item return-value
+A lisp object.
+@end table
+
+@subheading Description
+The @code{foreign-funcall} macro is the main primitive for calling
+foreign functions.
+
+@emph{Note: The return value of foreign-funcall on functions with a
+:void return type is still undefined.}
+
+@subheading Implementation-specific Notes
+@itemize
+@item
+Corman Lisp does not support @code{foreign-funcall}. On
+implementations that @strong{don't} support @code{foreign-funcall}
+@code{cffi-features:no-foreign-funcall} will be present in
+@code{*features*}. Note: in these Lisps you can still use the
+@code{defcfun} interface.
+@end itemize
+
+@subheading Examples
+
+@lisp
+CFFI> (foreign-funcall "strlen" :string "foo" :int)
+@result{} 3
+@end lisp
+
+Given the C code:
+
+@example
+void print_number(int n)
+@{
+ printf("N: %d\n", n);
+@}
+@end example
+
+@lisp
+CFFI> (foreign-funcall "print_number" :int 123456)
+@print{} N: 123456
+@result{} NIL
+@end lisp
+
+@noindent
+Or, equivalently:
+
+@lisp
+CFFI> (foreign-funcall "print_number" :int 123456 :void)
+@print{} N: 123456
+@result{} NIL
+@end lisp
+
+@lisp
+CFFI> (foreign-funcall "printf" :string (format nil "%s: %d.~%")
+ :string "So long and thanks for all the fish"
+ :int 42 :int)
+@print{} So long and thanks for all the fish: 42.
+@result{} 41
+@end lisp
+
+@subheading See Also
+@seealso{defcfun}
+
+
+@c ===================================================================
+@c CHAPTER: Libraries
+
+@node Libraries
+@chapter Libraries
+
+@menu
+* Defining a library::
+* Library definition style::
+
+Dictionary
+
+* *darwin-framework-directories*:: Search path for Darwin frameworks.
+* define-foreign-library:: Explain how to load a foreign library.
+* *foreign-library-directories*:: Search path for shared libraries.
+* load-foreign-library:: Load a foreign library.
+* load-foreign-library-error:: Signalled on failure of its namesake.
+* use-foreign-library:: Load a foreign library when needed.
+@end menu
+
+
+@node Defining a library
+@section Defining a library
+
+Almost all foreign code you might want to access exists in some kind
+of shared library. The meaning of @dfn{shared library} varies among
+platforms, but for our purposes, we will consider it to include
+(a)file{.so} files on @sc{unix}, frameworks on Darwin (and derivatives
+like Mac @acronym{OS X}), and @file{.dll} files on Windows.
+
+Bringing one of these libraries into the Lisp image is normally a
+two-step process.
+
+@enumerate
+@item
+Describe to @cffi{} how to load the library at some future point,
+depending on platform and other factors, with a
+@code{define-foreign-library} top-level form.
+
+@item
+Load the library so defined with either a top-level
+@code{use-foreign-library} form or by calling the function
+@code{load-foreign-library}.
+@end enumerate
+
+@xref{Tutorial-Loading,, Loading foreign libraries}, for a working
+example of the above two steps.
+
+
+@node Library definition style
+@section Library definition style
+
+Looking at the @code{libcurl} library definition presented earlier,
+you may ask why we did not simply do this:
+
+@lisp
+(define-foreign-library libcurl
+ (t (:default "libcurl")))
+@end lisp
+
+@noindent
+Indeed, this would work just as well on the computer on which I tested
+the tutorial. There are a couple of good reasons to provide the
+(a)file{.so}'s current version number, however. Namely, the versionless
+(a)file{.so} is not packaged on most @sc{unix} systems along with the
+actual, fully-versioned library; instead, it is included in the
+``development'' package along with C headers and static @file{.a}
+libraries.
+
+The reason @cffi{} does not try to account for this lies in the
+meaning of the version numbers. A full treatment of shared library
+versions is beyond this manual's scope; see @ref{Versioning,, Library
+interface versions, libtool, @acronym{GNU} Libtool}, for helpful
+information for the unfamiliar. For our purposes, consider that a
+mismatch between the library version with which you tested and the
+installed library version may cause undefined
+behavior.@footnote{Windows programmers may chafe at adding a
+@sc{unix}-specific clause to @code{define-foreign-library}. Instead,
+ask why the Windows solution to library incompatibility is ``include
+your own version of every library you use with every program''.}
+
+@impnote{Maybe some notes should go here about OS X, which I know
+little about. --stephen}
+
+
+@c ===================================================================
+@c *DARWIN-FRAMEWORK-DIRECTORIES*
+
+@node *darwin-framework-directories*
+@unnumberedsec *darwin-framework-directories*
+@subheading Syntax
+
+@Variable{*darwin-framework-directories*}
+
+@subheading Value type
+
+A list, in which each element is a string, a pathname, or a simple
+Lisp expression.
+
+@subheading Initial value
+
+A list containing the following, in order: an expression corresponding
+to Darwin path @file{~/Library/Frameworks/},
+@code{#P"/Library/Frameworks/"}, and
+@code{#P"/System/Library/Frameworks/"}.
+
+@subheading Description
+
+The meaning of ``simple Lisp expression'' is explained in
+@ref{*foreign-library-directories*}. In contrast to that variable,
+this is not a fallback search path; the default value described above
+is intended to be a reasonably complete search path on Darwin systems.
+
+@subheading Examples
+
+@lisp
+CFFI> (load-foreign-library '(:framework "OpenGL"))
+@result{} #P"/System/Library/Frameworks/OpenGL.framework/OpenGL"
+@end lisp
+
+@subheading See also
+
+@seealso{*foreign-library-directories*} @*
+@seealso{define-foreign-library}
+
+
+@c ===================================================================
+@c DEFINE-FOREIGN-LIBRARY
+
+@node define-foreign-library
+@unnumberedsec define-foreign-library
+
+@subheading Syntax
+
+@Macro{define-foreign-library name @{ load-clause @}* @result{} name}
+
+load-clause ::= (feature @{ library @}*)
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+A symbol.
+
+@item feature
+A feature expression.
+
+@item library
+A library designator.
+@end table
+
+@subheading Description
+
+Creates a new library designator called @var{name}. The
+@var{load-clause}s describe how to load that designator when passed to
+@code{load-foreign-library} or @code{use-foreign-library}.
+
+When trying to load the library @var{name}, the relevant function
+searches the @var{load-clause}s in order for the first one where
+@var{feature} evaluates to true. That happens for any of the
+following situations:@footnote{This is described in
+@code{cffi-feature-p} in @file{libraries.lisp}.}
+
+@enumerate 1
+@item
+If @var{feature} is a symbol (idiomatically a keyword), a symbol with
+the same name, but interned into the @code{cffi-features} package, is
+present in @code{common-lisp:*features*}.
+
+@item
+If @var{feature} is a list, depending on @code{(first @var{feature})},
+a keyword:
+
+@table @code
+@item :and
+All of the feature expressions in @code{(rest @var{feature})} are
+true.
+
+@item :or
+At least one of the feature expressions in @code{(rest @var{feature})}
+is true.
+
+@item :not
+The feature expression @code{(second @var{feature})} is not true.
+@end table
+@end enumerate
+
+Upon finding the first true @var{feature}, the library loader then
+loads each @var{library}. The meaning of ``library designator'' is
+described in @ref{load-foreign-library}.
+
+
+@subheading Examples
+
+@xref{Tutorial-Loading,, Loading foreign libraries}.
+
+
+@subheading See Also
+
+@seealso{load-foreign-library}
+
+
+@c ===================================================================
+@c *FOREIGN-LIBRARY-DIRECTORIES*
+
+@node *foreign-library-directories*
+@unnumberedsec *foreign-library-directories*
+@subheading Syntax
+
+@Variable{*foreign-library-directories*}
+
+@subheading Value type
+
+A list, in which each element is a string, a pathname, or a simple
+Lisp expression.
+
+@subheading Initial value
+
+The empty list.
+
+@subheading Description
+
+You should not have to use this variable.
+
+Most, if not all, Lisps supported by @cffi{} have a reasonable default
+search algorithm for foreign libraries. For example, Lisps for
+@sc{unix} usually call
+@uref{http://www.opengroup.org/onlinepubs/009695399/functions/dlopen.html,,
+@code{dlopen(3)}}, which in turn looks in the system library
+directories. Only if that fails does @cffi{} look for the named
+library file in these directories, and load it from there if found.
+
+Thus, this is intended to be a @cffi{}-only fallback to the library
+search configuration provided by your operating system. For example,
+if you distribute a foreign library with your Lisp package, you can
+add the library's containing directory to this list and portably
+expect @cffi{} to find it.
+
+A @dfn{simple Lisp expression} is intended to provide functionality
+commonly used in search paths such as
+@acronym{ASDF}'s@footnote{@xref{Using asdf to load systems,,, asdf,
+asdf: another system definition facility}, for information on
+@code{asdf:*central-registry*}.}, and is defined recursively as
+follows:@footnote{See @code{mini-eval} in @file{libraries.lisp} for
+the source of this definition. As is always the case with a Lisp
+@code{eval}, it's easier to understand the Lisp definition than the
+english.}
+
+@enumerate
+@item
+A list, whose @samp{first} is a function designator, and whose
+@samp{rest} is a list of simple Lisp expressions to be evaluated and
+passed to the so-designated function. The result is the result of the
+function call.
+
+@item
+A symbol, whose result is its symbol value.
+
+@item
+Anything else evaluates to itself.
+@end enumerate
+
+
+@subheading Examples
+
+@example
+$ ls
+@print{} liblibli.so libli.lisp
+@end example
+
+@noindent
+In @file{libli.lisp}:
+
+@lisp
+(pushnew #P"/home/sirian/lisp/libli/" *foreign-library-directories*
+ :test #'equal)
+
+(load-foreign-library '(:default "liblibli"))
+@end lisp
+
+
+@subheading See also
+
+@seealso{*darwin-framework-directories*} @*
+@seealso{define-foreign-library}
+
+
+@c ===================================================================
+@c LOAD-FOREIGN-LIBRARY
+
+@node load-foreign-library
+@unnumberedsec load-foreign-library
+@subheading Syntax
+@Function{load-foreign-library library}
+
+@subheading Arguments and Values
+
+@table @var
+@item library
+A library designator.
+@end table
+
+@subheading Description
+
+Load the library indicated by @var{library}. A @dfn{library
+designator} is defined as follows:
+
+@enumerate
+@item
+If a symbol, is considered a name previously defined with
+@code{define-foreign-library}.
+
+@item
+If a string or pathname, passed as a namestring directly to the
+implementation's foreign library loader. If that fails, search the
+directories in @code{*foreign-library-directories*} with
+@code{cl:probe-file}; if found, the absolute path is passed to the
+implementation's loader.
+
+@item
+If a list, the meaning depends on @code{(first @var{library})}:
+
+@table @code
+@item :framework
+The second list element is taken to be a Darwin framework name, which
+is then searched in @code{*darwin-framework-directories*}, and loaded
+when found.
+
+@item :or
+Each remaining list element, itself a library designator, is loaded in
+order, until one succeeds.
+
+@item :default
+The name is transformed according to the platform's naming convention
+to shared libraries, and the resultant string is loaded as a library
+designator. For example, on @sc{unix}, the name is suffixed with
+(a)file{.so}.
+@end table
+@end enumerate
+
+If the load fails, signal a @code{load-foreign-library-error}.
+
+@strong{Please note:} For system libraries, you should not need to
+specify the directory containing the library. Each operating system
+has its own idea of a default search path, and you should rely on it
+when it is reasonable.
+
+@subheading Implementation-specific Notes
+On ECL platforms where its dynamic FFI is not supported (ie. when
+@code{:dffi} is not present in @code{*features*}),
+@code{cffi:load-foreign-library} does not work and you must use ECL's
+own @code{ffi:load-foreign-library} with a constant string argument.
+
+@subheading Examples
+
+@xref{Tutorial-Loading,, Loading foreign libraries}.
+
+@subheading See Also
+
+@seealso{*darwin-framework-directories*} @*
+@seealso{define-foreign-library} @*
+@seealso{*foreign-library-directories*} @*
+@seealso{load-foreign-library-error} @*
+@seealso{use-foreign-library}
+
+
+@c ===================================================================
+@c LOAD-FOREIGN-LIBRARY-ERROR
+
+@node load-foreign-library-error
+@unnumberedsec load-foreign-library-error
+
+@subheading Syntax
+
+@Condition{load-foreign-library-error}
+
+@subheading Class precedence list
+
+@code{load-foreign-library-error}, @code{error},
+@code{serious-condition}, @code{condition}, @code{t}
+
+@subheading Description
+
+Signalled when a foreign library load completely fails. The exact
+meaning of this varies depending on the real conditions at work, but
+almost universally, the implementation's error message is useless.
+However, @cffi{} does provide the useful restarts @code{retry} and
+@code{use-value}; invoke the @code{retry} restart to try loading the
+foreign library again, or the @code{use-value} restart to try loading
+a different foreign library designator.
+
+@subheading See also
+
+@seealso{load-foreign-library}
+
+
+@c ===================================================================
+@c USE-FOREIGN-LIBRARY
+
+@node use-foreign-library
+@unnumberedsec use-foreign-library
+
+@subheading Syntax
+
+@Macro{use-foreign-library name}
+
+@subheading Arguments and values
+
+@table @var
+@item name
+A library designator; unevaluated.
+@end table
+
+
+@subheading Description
+
+@xref{load-foreign-library}, for the meaning of ``library
+designator''. This is intended to be the top-level form used
+idiomatically after a @code{define-foreign-library} form to go ahead
+and load the library. @c ; it also sets the ``current foreign library''.
+Finally, on implementations where the regular evaluation rule is
+insufficient for foreign library loading, it loads it at the required
+time.@footnote{Namely, @acronym{CMUCL}. See
+@code{use-foreign-library} in @file{libraries.lisp} for details.}
+
+@c current foreign library is a concept created a few hours ago as of
+@c this writing. It is not actually used yet, but probably will be.
+
+@subheading Examples
+
+@xref{Tutorial-Loading,, Loading foreign libraries}.
+
+
+@subheading See also
+
+@seealso{load-foreign-library}
+
+
+@c ===================================================================
+@c CHAPTER: Callbacks
+
+@node Callbacks
+@chapter Callbacks
+
+@menu
+Dictionary
+
+* callback::
+* defcallback::
+* get-callback::
+@end menu
+
+
+@c ===================================================================
+@c CALLBACK
+
+@node callback
+@unnumberedsec callback
+@subheading Syntax
+@Macro{callback symbol => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item symbol
+A symbol denoting a callback.
+
+@item pointer
+@itemx new-value
+A pointer.
+@end table
+
+@subheading Description
+The @code{callback} macro is analogous to the standard CL special
+operator @code{function} and will return a pointer to the callback
+denoted by the symbol @var{name}.
+
+@subheading Examples
+
+@lisp
+CFFI> (defcallback sum :int ((a :int) (b :int))
+ (+ a b))
+@result{} SUM
+CFFI> (callback sum)
+@result{} #<A Mac Pointer #x102350>
+@end lisp
+
+@subheading See Also
+@seealso{get-callback} @*
+@seealso{defcallback}
+
+
+@c ===================================================================
+@c DEFCALLBACK
+
+@node defcallback
+@unnumberedsec defcallback
+@subheading Syntax
+@Macro{defcallback name return-type arguments &body body => name}
+
+arguments ::= (@{ (arg-name arg-type) @}*)
+
+@subheading Arguments and Values
+
+@table @var
+@item name
+A symbol naming the callback created.
+
+@item return-type
+The foreign type for the callback's return value.
+
+@item arg-name
+A symbol.
+
+@item arg-type
+A foreign type.
+@end table
+
+@subheading Description
+The macro @code{defcallback} defines a Lisp function the can be called
+from C (but not from Lisp). The arguments passed to this function will
+be converted to the appropriate Lisp representation and its return
+value will be converted to its C representation.
+
+This Lisp function can be accessed by the @code{callback} macro or the
+@code{get-callback} function.
+
+@strong{Portability note:} @code{defcallback} will not work correctly
+on some Lisps if it's not a top-level form.
+
+@subheading Examples
+
+@lisp
+(defcfun "qsort" :void
+ (base :pointer)
+ (nmemb :int)
+ (size :int)
+ (fun-compar :pointer))
+
+(defcallback < :int ((a :pointer) (b :pointer))
+ (let ((x (mem-ref a :int))
+ (y (mem-ref b :int)))
+ (cond ((> x y) 1)
+ ((< x y) -1)
+ (t 0))))
+
+CFFI> (with-foreign-object (array :int 10)
+ ;; @lispcmt{Initialize array.}
+ (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
+ do (setf (mem-aref array :int i) n))
+ ;; @lispcmt{Sort it.}
+ (qsort array 10 (foreign-type-size :int) (callback <))
+ ;; @lispcmt{Return it as a list.}
+ (loop for i from 0 below 10
+ collect (mem-aref array :int i)))
+@result{} (1 2 3 4 5 6 7 8 9 10)
+@end lisp
+
+@subheading See Also
+@seealso{callback} @*
+@seealso{get-callback}
+
+
+@c ===================================================================
+@c GET-CALLBACK
+
+@node get-callback
+@unnumberedsec get-callback
+@subheading Syntax
+@Accessor{get-callback symbol => pointer}
+
+@subheading Arguments and Values
+
+@table @var
+@item symbol
+A symbol denoting a callback.
+
+@item pointer
+A pointer.
+@end table
+
+@subheading Description
+This is the functional version of the @code{callback} macro. It
+returns a pointer to the callback named by @var{symbol} suitable, for
+example, to pass as arguments to foreign functions.
+
+@subheading Examples
+
+@lisp
+CFFI> (defcallback sum :int ((a :int) (b :int))
+ (+ a b))
+@result{} SUM
+CFFI> (get-callback 'sum)
+@result{} #<A Mac Pointer #x102350>
+@end lisp
+
+@subheading See Also
+@seealso{callback} @*
+@seealso{defcallback}
+
+
+@c ===================================================================
+@c CHAPTER: Limitations
+
+@node Limitations
+@chapter Limitations
+
+These are @cffi{}'s limitations across all platforms; for information
+on the warts on particular Lisp implementations, see
+@ref{Implementation Support}.
+
+@itemize @bullet
+@item
+The tutorial includes a treatment of the primary, intractable
+limitation of @cffi{}, or any @acronym{FFI}: that the abstractions
+commonly used by C are insufficiently expressive.
+@xref{Tutorial-Abstraction,, Breaking the abstraction}, for more
+details.
+
+@item
+C @code{struct}s cannot be passed by value.
+@end itemize
+
+@c more?
+
+
+@node Platform-specific features
+@appendix Platform-specific features
+
+@cffi{} does some platform tests on loading. The details vary between
+Lisps; in fact, the purpose is to unify the list of available platform
+features for use elsewhere in the @cffi{} code. These features are
+also part of the public interface; see @ref{define-foreign-library}.
+
+The exact meanings of the features follow. Though you will usually
+refer to these symbols as keywords, @cffi{} internally views them in
+the package @code{cffi-features}.
+
+@table @code
+@item darwin
+This operating system is Darwin or a derivative thereof, such as
+Mac @acronym{OS X}.
+
+@item no-foreign-funcall
+The macro @code{foreign-funcall} is @strong{not} available. On such
+platforms, the only way to call a foreign function is through
+@code{defcfun}. @xref{foreign-funcall}, and @ref{defcfun}.
+
+@item no-long-long
+The C @code{long long} type is @strong{not} available as a foreign
+type.
+
+@item ppc32
+The underlying @acronym{CPU} architecture is 32-bit PowerPC.
+
+@item unix
+This operating system is a @sc{unix}-like, such as
+@acronym{GNU}/Linux, Darwin, or even Cygwin on Lisps that show the
+@sc{unix}-like interface provided by Cygwin to Lisp code.
+
+@item windows
+This operating system is Windows.
+
+@item x86
+The underlying @acronym{CPU} architecture is x86, such as on
+processors from Intel or @acronym{AMD}.
+@end table
+
+
+@node Comprehensive Index
+@unnumbered Index
+@printindex cp
+
+@bye
Added: branches/xml-class-rework/thirdparty/cffi/doc/cffi-sys-spec.texinfo
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/cffi-sys-spec.texinfo 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/cffi-sys-spec.texinfo 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,311 @@
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename cffi-sys.info
+@settitle CFFI-SYS Interface Specification
+
+@c Show types in the same index as the functions.
+@synindex tp fn
+
+@copying
+Copyright @copyright{} 2005, James Bielman <jamesjb at jamesjb.com>
+
+@quotation
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the ``Software''), to deal in the Software without
+restriction, including without limitation the rights to use, copy,
+modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+@sc{The software is provided ``as is'', without warranty of any kind,
+express or implied, including but not limited to the warranties of
+merchantability, fitness for a particular purpose and
+noninfringement. In no event shall the authors or copyright
+holders be liable for any claim, damages or other liability,
+whether in an action of contract, tort or otherwise, arising from,
+out of or in connection with the software or the use or other
+dealings in the software.}
+@end quotation
+@end copying
+
+@macro impnote {text}
+@emph{Implementor's note: \text\}
+@end macro
+@c %**end of header
+
+@titlepage
+@title CFFI-SYS Interface Specification
+@c @subtitle Version X.X
+@c @author James Bielman
+
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@contents
+
+@ifnottex
+@node Top
+@top cffi-sys
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction::
+* Built-In Foreign Types::
+* Operations on Foreign Types::
+* Basic Pointer Operations::
+* Foreign Memory Allocation::
+* Memory Access::
+* Foreign Function Calling::
+* Loading Foreign Libraries::
+* Foreign Globals::
+* Symbol Index::
+@end menu
+
+@node Introduction
+@chapter Introduction
+
+@acronym{CFFI}, the Common Foreign Function Interface, purports to be
+a portable foreign function interface for Common Lisp.
+
+This specification defines a set of low-level primitives that must be
+defined for each Lisp implementation supported by @acronym{CFFI}.
+These operators are defined in the @code{CFFI-SYS} package.
+
+The @code{CFFI} package uses the @code{CFFI-SYS} interface
+to implement an extensible foreign type system with support for
+typedefs, structures, and unions, a declarative interface for
+defining foreign function calls, and automatic conversion of
+foreign function arguments to/from Lisp types.
+
+Please note the following conventions that apply to everything in
+@code{CFFI-SYS}:
+
+@itemize @bullet
+@item
+Functions in @code{CFFI-SYS} that are low-level versions of functions
+exported from the @code{CFFI} package begin with a leading
+percent-sign (eg. @code{%mem-ref}).
+
+@item
+Where ``foreign type'' is mentioned as the kind of an argument, the
+meaning is restricted to that subset of all foreign types defined in
+@ref{Built-In Foreign Types}. Support for higher-level types is
+always defined in terms of those lower-level types in @code{CFFI}
+proper.
+@end itemize
+
+
+@node Built-In Foreign Types
+@chapter Built-In Foreign Types
+
+@deftp {Foreign Type} :char
+@deftpx {Foreign Type} :unsigned-char
+@deftpx {Foreign Type} :short
+@deftpx {Foreign Type} :unsigned-short
+@deftpx {Foreign Type} :int
+@deftpx {Foreign Type} :unsigned-int
+@deftpx {Foreign Type} :long
+@deftpx {Foreign Type} :unsigned-long
+@deftpx {Foreign Type} :long-long
+@deftpx {Foreign Type} :unsigned-long-long
+These types correspond to the native C integer types according to the
+ABI of the system the Lisp implementation is compiled against.
+@end deftp
+
+@deftp {Foreign Type} :int8
+@deftpx {Foreign Type} :uint8
+@deftpx {Foreign Type} :int16
+@deftpx {Foreign Type} :uint16
+@deftpx {Foreign Type} :int32
+@deftpx {Foreign Type} :uint32
+@deftpx {Foreign Type} :int64
+@deftpx {Foreign Type} :uint64
+Foreign integer types of specific sizes, corresponding to the C types
+defined in @code{stdint.h}.
+@end deftp
+
+@deftp {Foreign Type} :size
+@deftpx {Foreign Type} :ssize
+@deftpx {Foreign Type} :ptrdiff
+@deftpx {Foreign Type} :time
+Foreign integer types corresponding to the standard C types (without
+the @code{_t} suffix).
+@end deftp
+
+@impnote{I'm sure there are more of these that could be useful, let's
+add any types that can't be defined portably to this list as
+necessary.}
+
+@deftp {Foreign Type} :float
+@deftpx {Foreign Type} :double
+The @code{:float} type represents a C @code{float} and a Lisp
+@code{single-float}. @code{:double} represents a C @code{double} and a
+Lisp @code{double-float}.
+@end deftp
+
+@deftp {Foreign Type} :pointer
+A foreign pointer to an object of any type, corresponding to
+@code{void *}.
+@end deftp
+
+@deftp {Foreign Type} :void
+No type at all. Only valid as the return type of a function.
+@end deftp
+
+
+@node Operations on Foreign Types
+@chapter Operations on Built-in Foreign Types
+
+@defun %foreign-type-size type @result{} size
+Return the @var{size}, in bytes, of objects having foreign type
+@var{type}. An error is signalled if @var{type} is not a known
+built-in foreign type.
+@end defun
+
+@defun %foreign-type-alignment type @result{} alignment
+Return the default alignment in bytes for structure members of foreign
+type @var{type}. An error is signalled if @var{type} is not a known
+built-in foreign type.
+
+@impnote{Maybe this should take an optional keyword argument specifying an
+alternate alignment system, eg. :mac68k for 68000-compatible alignment
+on Darwin.}
+@end defun
+
+
+@node Basic Pointer Operations
+@chapter Basic Pointer Operations
+
+@defun pointerp ptr @result{} boolean
+Return true if @var{ptr} is a foreign pointer.
+@end defun
+
+@defun null-pointer @result{} pointer
+Return a null foreign pointer.
+@end defun
+
+@defun null-pointer-p ptr @result{} boolean
+Return true if @var{ptr} is a null foreign pointer.
+@end defun
+
+@defun make-pointer address @result{} pointer
+Return a pointer corresponding to the numeric integer @var{address}.
+@end defun
+
+@defun inc-pointer ptr offset @result{} pointer
+Return the result of numerically incrementing @var{ptr} by @var{offset}.
+@end defun
+
+
+@node Foreign Memory Allocation
+@chapter Foreign Memory Allocation
+
+@defun foreign-alloc size @result{} pointer
+Allocate @var{size} bytes of foreign-addressable memory and return
+a @var{pointer} to the allocated block. An implementation-specific
+error is signalled if the memory cannot be allocated.
+@end defun
+
+@defun foreign-free ptr @result{} unspecified
+Free a pointer @var{ptr} allocated by @code{foreign-alloc}. The
+results are undefined if @var{ptr} is used after being freed.
+@end defun
+
+@defmac with-foreign-pointer (var size &optional size-var) &body body
+Bind @var{var} to a pointer to @var{size} bytes of
+foreign-accessible memory during @var{body}. Both @var{ptr} and the
+memory block it points to have dynamic extent and may be stack
+allocated if supported by the implementation. If @var{size-var} is
+supplied, it will be bound to @var{size} during @var{body}.
+@end defmac
+
+
+@node Memory Access
+@chapter Memory Access
+
+@deffn {Accessor} %mem-ref ptr type &optional offset
+Dereference a pointer @var{offset} bytes from @var{ptr} to an object
+for reading (or writing when used with @code{setf}) of built-in type
+@var{type}.
+@end deffn
+
+@heading Example
+
+@lisp
+;; An impractical example, since time returns the time as well,
+;; but it demonstrates %MEM-REF. Better (simple) examples wanted!
+(with-foreign-pointer (p (foreign-type-size :time))
+ (foreign-funcall "time" :pointer p :time)
+ (%mem-ref p :time))
+@end lisp
+
+
+@node Foreign Function Calling
+@chapter Foreign Function Calling
+
+@defmac %foreign-funcall name @{arg-type arg@}* &optional result-type @result{} object
+@defmacx %foreign-funcall-pointer ptr @{arg-type arg@}* &optional result-type @result{} object
+Invoke a foreign function called @var{name} in the foreign source code.
+
+Each @var{arg-type} is a foreign type specifier, followed by
+@var{arg}, Lisp data to be converted to foreign data of type
+@var{arg-type}. @var{result-type} is the foreign type of the
+function's return value, and is assumed to be @code{:void} if not
+supplied.
+
+@code{%foreign-funcall-pointer} takes a pointer @var{ptr} to the
+function, as returned by @code{foreign-symbol-pointer}, rather than a
+string @var{name}.
+@end defmac
+
+@heading Examples
+
+@lisp
+;; Calling a standard C library function:
+(%foreign-funcall "sqrtf" :float 16.0 :float) @result{} 4.0
+@end lisp
+
+@lisp
+;; Dynamic allocation of a buffer and passing to a function:
+(with-foreign-ptr (buf 255 buf-size)
+ (%foreign-funcall "gethostname" :pointer buf :size buf-size :int)
+ ;; Convert buf to a Lisp string using MAKE-STRING and %MEM-REF or
+ ;; a portable CFFI function such as CFFI:FOREIGN-STRING-TO-LISP.
+)
+@end lisp
+
+
+@node Loading Foreign Libraries
+@chapter Loading Foreign Libraries
+
+@defun %load-foreign-library name @result{} unspecified
+Load the foreign shared library @var{name}.
+
+@impnote{There is a lot of behavior to decide here. Currently I lean
+toward not requiring NAME to be a full path to the library so
+we can search the system library directories (maybe even get
+LD_LIBRARY_PATH from the environment) as necessary.}
+@end defun
+
+
+@node Foreign Globals
+@chapter Foreign Globals
+
+@defun foreign-symbol-pointer name kind @result{} pointer
+Return a pointer to a foreign symbol @var{name}. @var{kind} is one of
+@code{:code} or @code{:data}, and is ignored on some platforms.
+@end defun
+
+
+@node Symbol Index
+@unnumbered Symbol Index
+@printindex fn
+
+@bye
Added: branches/xml-class-rework/thirdparty/cffi/doc/colorize-lisp-examples.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/colorize-lisp-examples.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/colorize-lisp-examples.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,1051 @@
+;;; This is code was taken from lisppaste2 and is a quick hack
+;;; to colorize lisp examples in the html generated by Texinfo.
+;;; It is not general-purpose utility, though it could easily be
+;;; turned into one.
+
+;;;; colorize-package.lisp
+
+(defpackage :colorize
+ (:use :common-lisp)
+ (:export :scan-string :format-scan :html-colorization
+ :find-coloring-type :autodetect-coloring-type
+ :coloring-types :scan :scan-any :advance :call-parent-formatter
+ :*coloring-css* :make-background-css :*css-background-class*
+ :colorize-file :colorize-file-to-stream :*version-token*))
+
+;;;; coloring-css.lisp
+
+(in-package :colorize)
+
+(defparameter *coloring-css*
+ ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;}
+a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+.special { color : #FF5000; background-color : inherit; }
+.keyword { color : #770000; background-color : inherit; }
+.comment { color : #007777; background-color : inherit; }
+.string { color : #777777; background-color : inherit; }
+.character { color : #0055AA; background-color : inherit; }
+.syntaxerror { color : #FF0000; background-color : inherit; }
+span.paren1:hover { color : inherit; background-color : #BAFFFF; }
+span.paren2:hover { color : inherit; background-color : #FFCACA; }
+span.paren3:hover { color : inherit; background-color : #FFFFBA; }
+span.paren4:hover { color : inherit; background-color : #CACAFF; }
+span.paren5:hover { color : inherit; background-color : #CAFFCA; }
+span.paren6:hover { color : inherit; background-color : #FFBAFF; }
+")
+
+(defvar *css-background-class* "lisp-bg")
+
+(defun for-css (thing)
+ (if (symbolp thing) (string-downcase (symbol-name thing))
+ thing))
+
+(defun make-background-css (color &key (class *css-background-class*) (extra nil))
+ (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:*
+.~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%"
+ class color
+ (mapcar #'(lambda (extra)
+ (format nil "~A : ~{~A ~}"
+ (for-css (first extra))
+ (mapcar #'for-css (cdr extra))))
+ extra)))
+
+;;;; colorize.lisp
+
+;(in-package :colorize)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *coloring-types* nil)
+ (defparameter *version-token* (gensym)))
+
+(defclass coloring-type ()
+ ((modes :initarg :modes :accessor coloring-type-modes)
+ (default-mode :initarg :default-mode :accessor coloring-type-default-mode)
+ (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
+ (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
+ (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
+ (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
+ (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
+ (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
+ :initform (constantly nil))
+ (parent-type :initarg :parent-type :accessor coloring-type-parent-type
+ :initform nil)
+ (visible :initarg :visible :accessor coloring-type-visible
+ :initform t)))
+
+(defun find-coloring-type (type)
+ (if (typep type 'coloring-type)
+ type
+ (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name))))
+
+(defun autodetect-coloring-type (name)
+ (car
+ (find name *coloring-types*
+ :key #'cdr
+ :test #'(lambda (name type)
+ (and (coloring-type-visible type)
+ (funcall (coloring-type-autodetect-function type) name))))))
+
+(defun coloring-types ()
+ (loop for type-pair in *coloring-types*
+ if (coloring-type-visible (cdr type-pair))
+ collect (cons (car type-pair)
+ (coloring-type-fancy-name (cdr type-pair)))))
+
+(defun (setf find-coloring-type) (new-value type)
+ (if new-value
+ (let ((found (assoc type *coloring-types*)))
+ (if found
+ (setf (cdr found) new-value)
+ (setf *coloring-types*
+ (nconc *coloring-types*
+ (list (cons type new-value))))))
+ (setf *coloring-types* (remove type *coloring-types* :key #'car))))
+
+(defvar *scan-calls* 0)
+
+(defvar *reset-position* nil)
+
+(defmacro with-gensyms ((&rest names) &body body)
+ `(let ,(mapcar #'(lambda (name)
+ (list name `(make-symbol ,(symbol-name name)))) names)
+ ,@body))
+
+(defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
+ (with-gensyms (num items position not-preceded-by string item new-mode until advancing)
+ `(labels ((advance (,num)
+ (setf ,position-place (+ ,position-place ,num))
+ t)
+ (peek-any (,items &key ,not-preceded-by)
+ (incf *scan-calls*)
+ (let* ((,items (if (stringp ,items)
+ (coerce ,items 'list) ,items))
+ (,not-preceded-by (if (characterp ,not-preceded-by)
+ (string ,not-preceded-by) ,not-preceded-by))
+ (,position ,position-place)
+ (,string ,string-param))
+ (let ((,item (and
+ (< ,position (length ,string))
+ (find ,string ,items
+ :test #'(lambda (,string ,item)
+ #+nil
+ (format t "looking for ~S in ~S starting at ~S~%"
+ ,item ,string ,position)
+ (if (characterp ,item)
+ (char= (elt ,string ,position)
+ ,item)
+ (search ,item ,string :start2 ,position
+ :end2 (min (length ,string)
+ (+ ,position (length ,item))))))))))
+ (if (characterp ,item)
+ (setf ,item (string ,item)))
+ (if
+ (if ,item
+ (if ,not-preceded-by
+ (if (>= (- ,position (length ,not-preceded-by)) 0)
+ (not (string= (subseq ,string
+ (- ,position (length ,not-preceded-by))
+ ,position)
+ ,not-preceded-by))
+ t)
+ t)
+ nil)
+ ,item
+ (progn
+ (and *reset-position*
+ (setf ,position-place *reset-position*))
+ nil)))))
+ (scan-any (,items &key ,not-preceded-by)
+ (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
+ (and ,item (advance (length ,item)))))
+ (peek (,item &key ,not-preceded-by)
+ (peek-any (list ,item) :not-preceded-by ,not-preceded-by))
+ (scan (,item &key ,not-preceded-by)
+ (scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
+ (macrolet ((set-mode (,new-mode &key ,until (,advancing t))
+ (list 'progn
+ (list 'setf ',mode-place ,new-mode)
+ (list 'setf ',mode-wait-place
+ (list 'lambda (list ',position)
+ (list 'let (list (list '*reset-position* ',position))
+ (list 'values ,until ,advancing)))))))
+ ,@body))))
+
+(defvar *formatter-local-variables*)
+
+(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
+ autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
+ invisible)
+ (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
+ `(let ((,parent-type (or (find-coloring-type ,parent)
+ (and ,parent
+ (error "No such coloring type: ~S" ,parent)))))
+ (setf (find-coloring-type ,name)
+ (make-instance 'coloring-type
+ :fancy-name ',fancy-name
+ :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type)))
+ :default-mode (or ',default-mode
+ (if ,parent-type (coloring-type-default-mode ,parent-type)))
+ ,@(if autodetect
+ `(:autodetect-function ,autodetect))
+ :parent-type ,parent-type
+ :visible (not ,invisible)
+ :formatter-initial-values (lambda nil
+ (list* ,@(mapcar #'(lambda (e)
+ `(cons ',(car e) ,(second e)))
+ formatter-variables)
+ (if ,parent-type
+ (funcall (coloring-type-formatter-initial-values ,parent-type))
+ nil)))
+ :formatter-after-hook (lambda nil
+ (symbol-macrolet ,(mapcar #'(lambda (e)
+ `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
+ formatter-variables)
+ (concatenate 'string
+ (funcall ,formatter-after-hook)
+ (if ,parent-type
+ (funcall (coloring-type-formatter-after-hook ,parent-type))
+ ""))))
+ :term-formatter
+ (symbol-macrolet ,(mapcar #'(lambda (e)
+ `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
+ formatter-variables)
+ (lambda (,term)
+ (labels ((call-parent-formatter (&optional (,type (car ,term))
+ (,string (cdr ,term)))
+ (if ,parent-type
+ (funcall (coloring-type-term-formatter ,parent-type)
+ (cons ,type ,string))))
+ (call-formatter (&optional (,type (car ,term))
+ (,string (cdr ,term)))
+ (funcall
+ (case (first ,type)
+ ,@formatters
+ (t (lambda (,type text)
+ (call-parent-formatter ,type text))))
+ ,type ,string)))
+ (call-formatter))))
+ :transition-functions
+ (list
+ ,@(loop for transition in transitions
+ collect (destructuring-bind (mode &rest table) transition
+ `(cons ',mode
+ (lambda (,current-mode ,string ,position)
+ (let ((,mode-wait (constantly nil))
+ (,position-foobage ,position))
+ (with-scanning-functions ,string ,position-foobage
+ ,current-mode ,mode-wait
+ (let ((*reset-position* ,position))
+ (cond ,@table))
+ (values ,position-foobage ,current-mode
+ (lambda (,new-position)
+ (setf ,position-foobage ,new-position)
+ (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
+ (values ,position-foobage ,advance)))))
+ )))))))))))
+
+(defun full-transition-table (coloring-type-object)
+ (let ((parent (coloring-type-parent-type coloring-type-object)))
+ (if parent
+ (append (coloring-type-transition-functions coloring-type-object)
+ (full-transition-table parent))
+ (coloring-type-transition-functions coloring-type-object))))
+
+(defun scan-string (coloring-type string)
+ (let* ((coloring-type-object (or (find-coloring-type coloring-type)
+ (error "No such coloring type: ~S" coloring-type)))
+ (transitions (full-transition-table coloring-type-object))
+ (result nil)
+ (low-bound 0)
+ (current-mode (coloring-type-default-mode coloring-type-object))
+ (mode-stack nil)
+ (current-wait (constantly nil))
+ (wait-stack nil)
+ (current-position 0)
+ (*scan-calls* 0))
+ (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop)
+ (let ((to (if extend new-position current-position)))
+ (if (> to low-bound)
+ (setf result (nconc result
+ (list (cons (cons current-mode mode-stack)
+ (subseq string low-bound
+ to))))))
+ (setf low-bound to)
+ (when pop
+ (pop mode-stack)
+ (pop wait-stack))
+ (when push
+ (push current-mode mode-stack)
+ (push current-wait wait-stack))
+ (setf current-mode new-mode
+ current-position new-position
+ current-wait new-wait))))
+ (loop
+ (if (> current-position (length string))
+ (return-from scan-string
+ (progn
+ (format *trace-output* "Scan was called ~S times.~%"
+ *scan-calls*)
+ (finish-current (length string) nil (constantly nil))
+ result))
+ (or
+ (loop for transition in
+ (mapcar #'cdr
+ (remove current-mode transitions
+ :key #'car
+ :test-not #'(lambda (a b)
+ (or (eql a b)
+ (if (listp b)
+ (member a b))))))
+ if
+ (and transition
+ (multiple-value-bind
+ (new-position new-mode new-wait)
+ (funcall transition current-mode string current-position)
+ (when (> new-position current-position)
+ (finish-current new-position new-mode new-wait :extend nil :push t)
+ t)))
+ return t)
+ (multiple-value-bind
+ (pos advance)
+ (funcall current-wait current-position)
+ #+nil
+ (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
+ (and pos
+ (when (> pos current-position)
+ (finish-current (if advance
+ pos
+ current-position)
+ (car mode-stack)
+ (car wait-stack)
+ :extend advance
+ :pop t)
+ t)))
+ (progn
+ (incf current-position)))
+ )))))
+
+(defun format-scan (coloring-type scan)
+ (let* ((coloring-type-object (or (find-coloring-type coloring-type)
+ (error "No such coloring type: ~S" coloring-type)))
+ (color-formatter (coloring-type-term-formatter coloring-type-object))
+ (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
+ (format nil "~{~A~}~A"
+ (mapcar color-formatter scan)
+ (funcall (coloring-type-formatter-after-hook coloring-type-object)))))
+
+(defun encode-for-pre (string)
+ (declare (simple-string string))
+ (let ((output (make-array (truncate (length string) 2/3)
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)))
+ (with-output-to-string (out output)
+ (loop for char across string
+ do (case char
+ ((#\&) (write-string "&" out))
+ ((#\<) (write-string "<" out))
+ ((#\>) (write-string ">" out))
+ (t (write-char char out)))))
+ (coerce output 'simple-string)))
+
+(defun string-substitute (string substring replacement-string)
+ "String substitute by Larry Hunter. Obtained from Google"
+ (let ((substring-length (length substring))
+ (last-end 0)
+ (new-string ""))
+ (do ((next-start
+ (search substring string)
+ (search substring string :start2 last-end)))
+ ((null next-start)
+ (concatenate 'string new-string (subseq string last-end)))
+ (setq new-string
+ (concatenate 'string
+ new-string
+ (subseq string last-end next-start)
+ replacement-string))
+ (setq last-end (+ next-start substring-length)))))
+
+(defun decode-from-tt (string)
+ (string-substitute (string-substitute (string-substitute string "&" "&")
+ "<" "<")
+ ">" ">"))
+
+(defun html-colorization (coloring-type string)
+ (format-scan coloring-type
+ (mapcar #'(lambda (p)
+ (cons (car p)
+ (let ((tt (encode-for-pre (cdr p))))
+ (if (and (> (length tt) 0)
+ (char= (elt tt (1- (length tt))) #\>))
+ (format nil "~A~%" tt) tt))))
+ (scan-string coloring-type string))))
+
+(defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default"))
+ (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
+ (merge-pathnames input-file-name)
+ (make-pathname :type "lisp"
+ :defaults (merge-pathnames input-file-name))))
+ (*css-background-class* css-background))
+ (with-open-file (s input-file :direction :input)
+ (let ((lines nil)
+ (string nil))
+ (block done
+ (loop (let ((line (read-line s nil nil)))
+ (if line
+ (push line lines)
+ (return-from done)))))
+ (setf string (format nil "~{~A~%~}"
+ (nreverse lines)))
+ (if wrap
+ (format s2
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
+<html><head><style type=\"text/css\">~A~%~A</style><body>
+<table width=\"100%\"><tr><td class=\"~A\">
+<tt>~A</tt>
+</tr></td></table></body></html>"
+ *coloring-css*
+ (make-background-css "white")
+ *css-background-class*
+ (html-colorization coloring-type string))
+ (write-string (html-colorization coloring-type string) s2))))))
+
+(defun colorize-file (coloring-type input-file-name &optional output-file-name)
+ (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
+ (merge-pathnames input-file-name)
+ (make-pathname :type "lisp"
+ :defaults (merge-pathnames input-file-name))))
+ (output-file (or output-file-name
+ (make-pathname :type "html"
+ :defaults input-file))))
+ (with-open-file (s2 output-file :direction :output :if-exists :supersede)
+ (colorize-file-to-stream coloring-type input-file-name s2))))
+
+;; coloring-types.lisp
+
+;(in-package :colorize)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *version-token* (gensym)))
+
+(defparameter *symbol-characters*
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890")
+
+(defparameter *non-constituent*
+ '(#\space #\tab #\newline #\linefeed #\page #\return
+ #\" #\' #\( #\) #\, #\; #\` #\[ #\]))
+
+(defparameter *special-forms*
+ '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
+ "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
+ "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
+ "return-from" "setq" "multiple-value-call"))
+
+(defparameter *common-macros*
+ '("loop" "cond" "lambda"))
+
+(defparameter *open-parens* '(#\())
+(defparameter *close-parens* '(#\)))
+
+(define-coloring-type :lisp "Basic Lisp"
+ :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
+ :multiline :character
+ :single-escaped :in-list :syntax-error)
+ :default-mode :first-char-on-line
+ :transitions
+ (((:in-list)
+ ((or
+ (scan-any *symbol-characters*)
+ (and (scan #\.) (scan-any *symbol-characters*))
+ (and (scan #\\) (advance 1)))
+ (set-mode :symbol
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((or (scan #\:) (scan "#:"))
+ (set-mode :keyword
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((scan "#\\")
+ (let ((count 0))
+ (set-mode :character
+ :until (progn
+ (incf count)
+ (if (> count 1)
+ (scan-any *non-constituent*)))
+ :advancing nil)))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((scan #\;)
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#")))
+ ((scan #\()
+ (set-mode :in-list
+ :until (scan #\)))))
+ ((:normal :first-char-on-line)
+ ((scan #\()
+ (set-mode :in-list
+ :until (scan #\)))))
+ (:first-char-on-line
+ ((scan #\;)
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#")))
+ ((advance 1)
+ (set-mode :normal
+ :until (scan #\newline))))
+ (:multiline
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#"))))
+ ((:symbol :keyword :escaped-symbol :string)
+ ((scan #\\)
+ (let ((count 0))
+ (set-mode :single-escaped
+ :until (progn
+ (incf count)
+ (if (< count 2)
+ (advance 1))))))))
+ :formatter-variables ((paren-counter 0))
+ :formatter-after-hook (lambda nil
+ (format nil "~{~A~}"
+ (loop for i from paren-counter downto 1
+ collect "</span></span>")))
+ :formatters
+ (((:normal :first-char-on-line)
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ ((:in-list)
+ (lambda (type s)
+ (declare (ignore type))
+ (labels ((color-parens (s)
+ (let ((paren-pos (find-if-not #'null
+ (mapcar #'(lambda (c)
+ (position c s))
+ (append *open-parens*
+ *close-parens*)))))
+ (if paren-pos
+ (let ((before-paren (subseq s 0 paren-pos))
+ (after-paren (subseq s (1+ paren-pos)))
+ (paren (elt s paren-pos))
+ (open nil)
+ (count 0))
+ (when (member paren *open-parens* :test #'char=)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter)
+ (setf open t))
+ (when (member paren *close-parens* :test #'char=)
+ (decf paren-counter))
+ (if open
+ (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
+ before-paren
+ (1+ count)
+ paren *css-background-class*
+ (color-parens after-paren))
+ (format nil "~A</span>~C</span>~A"
+ before-paren
+ paren (color-parens after-paren))))
+ s))))
+ (color-parens s))))
+ ((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let* ((colon (position #\: s :from-end t))
+ (new-s (or (and colon (subseq s (1+ colon))) s)))
+ (cond
+ ((or
+ (member new-s *common-macros* :test #'string-equal)
+ (member new-s *special-forms* :test #'string-equal)
+ (some #'(lambda (e)
+ (and (> (length new-s) (length e))
+ (string-equal e (subseq new-s 0 (length e)))))
+ '("WITH-" "DEF")))
+ (format nil "<i><span class=\"symbol\">~A</span></i>" s))
+ ((and (> (length new-s) 2)
+ (char= (elt new-s 0) #\*)
+ (char= (elt new-s (1- (length new-s))) #\*))
+ (format nil "<span class=\"special\">~A</span>" s))
+ (t s)))))
+ (:keyword (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"keyword\">~A</span>"
+ s)))
+ ((:comment :multiline)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ ((:character)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ ((:string)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ ((:single-escaped)
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ ((:syntax-error)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"syntaxerror\">~A</span>"
+ s)))))
+
+(define-coloring-type :scheme "Scheme"
+ :autodetect (lambda (text)
+ (or
+ (search "scheme" text :test #'char-equal)
+ (search "chicken" text :test #'char-equal)))
+ :parent :lisp
+ :transitions
+ (((:normal :in-list)
+ ((scan "...")
+ (set-mode :symbol
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((scan #\[)
+ (set-mode :in-list
+ :until (scan #\])))))
+ :formatters
+ (((:in-list)
+ (lambda (type s)
+ (declare (ignore type s))
+ (let ((*open-parens* (cons #\[ *open-parens*))
+ (*close-parens* (cons #\] *close-parens*)))
+ (call-parent-formatter))))
+ ((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((result (if (find-package :r5rs-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :elisp "Emacs Lisp"
+ :autodetect (lambda (name)
+ (member name '("emacs")
+ :test #'(lambda (name ext)
+ (search ext name :test #'char-equal))))
+ :parent :lisp
+ :formatters
+ (((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((result (if (find-package :elisp-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :common-lisp "Common Lisp"
+ :autodetect (lambda (text)
+ (search "lisp" text :test #'char-equal))
+ :parent :lisp
+ :transitions
+ (((:normal :in-list)
+ ((scan #\|)
+ (set-mode :escaped-symbol
+ :until (scan #\|)))))
+ :formatters
+ (((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let* ((colon (position #\: s :from-end t :test #'char=))
+ (to-lookup (if colon (subseq s (1+ colon)) s))
+ (result (if (find-package :clhs-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
+ to-lookup))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :common-lisp-file "Common Lisp File"
+ :parent :common-lisp
+ :default-mode :in-list
+ :invisible t)
+
+(defvar *c-open-parens* "([{")
+(defvar *c-close-parens* ")]}")
+
+(defvar *c-reserved-words*
+ '("auto" "break" "case" "char" "const"
+ "continue" "default" "do" "double" "else"
+ "enum" "extern" "float" "for" "goto"
+ "if" "int" "long" "register" "return"
+ "short" "signed" "sizeof" "static" "struct"
+ "switch" "typedef" "union" "unsigned" "void"
+ "volatile" "while" "__restrict" "_Bool"))
+
+(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
+(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
+
+(define-coloring-type :basic-c "Basic C"
+ :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
+ :default-mode :normal
+ :invisible t
+ :transitions
+ ((:normal
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (scan-any *c-terminators*)
+ :advancing nil))
+ ((scan "/*")
+ (set-mode :comment
+ :until (scan "*/")))
+
+ ((or
+ (scan-any *c-open-parens*)
+ (scan-any *c-close-parens*))
+ (set-mode :paren-ish
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((or (scan "'\\")
+ (scan #\'))
+ (set-mode :character
+ :until (advance 2))))
+ (:string
+ ((scan #\\)
+ (set-mode :single-escape
+ :until (advance 1)))))
+ :formatter-variables
+ ((paren-counter 0))
+ :formatter-after-hook (lambda nil
+ (format nil "~{~A~}"
+ (loop for i from paren-counter downto 1
+ collect "</span></span>")))
+ :formatters
+ ((:normal
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ (:comment
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ (:string
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ (:character
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ (:single-escape
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ (:paren-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((open nil)
+ (count 0))
+ (if (eql (length s) 1)
+ (progn
+ (when (member (elt s 0) (coerce *c-open-parens* 'list))
+ (setf open t)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter))
+ (when (member (elt s 0) (coerce *c-close-parens* 'list))
+ (setf open nil)
+ (decf paren-counter)
+ (setf count (mod paren-counter 6)))
+ (if open
+ (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
+ (1+ count) s *css-background-class*)
+ (format nil "</span>~A</span>"
+ s)))
+ s))))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *c-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ s)))
+ ))
+
+(define-coloring-type :c "C"
+ :parent :basic-c
+ :transitions
+ ((:normal
+ ((scan #\#)
+ (set-mode :preprocessor
+ :until (scan-any '(#\return #\newline))))))
+ :formatters
+ ((:preprocessor
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"special\">~A</span>" s)))))
+
+(defvar *c++-reserved-words*
+ '("asm" "auto" "bool" "break" "case"
+ "catch" "char" "class" "const" "const_cast"
+ "continue" "default" "delete" "do" "double"
+ "dynamic_cast" "else" "enum" "explicit" "export"
+ "extern" "false" "float" "for" "friend"
+ "goto" "if" "inline" "int" "long"
+ "mutable" "namespace" "new" "operator" "private"
+ "protected" "public" "register" "reinterpret_cast" "return"
+ "short" "signed" "sizeof" "static" "static_cast"
+ "struct" "switch" "template" "this" "throw"
+ "true" "try" "typedef" "typeid" "typename"
+ "union" "unsigned" "using" "virtual" "void"
+ "volatile" "wchar_t" "while"))
+
+(define-coloring-type :c++ "C++"
+ :parent :c
+ :transitions
+ ((:normal
+ ((scan "//")
+ (set-mode :comment
+ :until (scan-any '(#\return #\newline))))))
+ :formatters
+ ((:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *c++-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>"
+ s)
+ s)))))
+
+(defvar *java-reserved-words*
+ '("abstract" "boolean" "break" "byte" "case"
+ "catch" "char" "class" "const" "continue"
+ "default" "do" "double" "else" "extends"
+ "final" "finally" "float" "for" "goto"
+ "if" "implements" "import" "instanceof" "int"
+ "interface" "long" "native" "new" "package"
+ "private" "protected" "public" "return" "short"
+ "static" "strictfp" "super" "switch" "synchronized"
+ "this" "throw" "throws" "transient" "try"
+ "void" "volatile" "while"))
+
+(define-coloring-type :java "Java"
+ :parent :c++
+ :formatters
+ ((:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *java-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>"
+ s)
+ s)))))
+
+(let ((terminate-next nil))
+ (define-coloring-type :objective-c "Objective C"
+ :autodetect (lambda (text) (search "mac" text :test #'char=))
+ :modes (:begin-message-send :end-message-send)
+ :transitions
+ ((:normal
+ ((scan #\[)
+ (set-mode :begin-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\])
+ (set-mode :end-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (or
+ (and (peek-any '(#\:))
+ (setf terminate-next t))
+ (and terminate-next (progn
+ (setf terminate-next nil)
+ (advance 1)))
+ (scan-any *c-terminators*))
+ :advancing nil)))
+ (:word-ish
+ #+nil
+ ((scan #\:)
+ (format t "hi~%")
+ (set-mode :word-ish :until (advance 1) :advancing nil)
+ (setf terminate-next t))))
+ :parent :c++
+ :formatter-variables ((is-keyword nil) (in-message-send nil))
+ :formatters
+ ((:begin-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send t)
+ (call-formatter (cons :paren-ish type) s)))
+ (:end-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send nil)
+ (call-formatter (cons :paren-ish type) s)))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (prog1
+ (let ((result (if (find-package :cocoa-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result s)
+ (if (member s *c-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ (if in-message-send
+ (if is-keyword
+ (format nil "<span class=\"keyword\">~A</span>" s)
+ s)
+ s))))
+ (setf is-keyword (not is-keyword))))))))
+
+
+;#!/usr/bin/clisp
+;#+sbcl
+;(require :asdf)
+;(asdf:oos 'asdf:load-op :colorize)
+
+(defmacro with-each-stream-line ((var stream) &body body)
+ (let ((eof (gensym))
+ (eof-value (gensym))
+ (strm (gensym)))
+ `(let ((,strm ,stream)
+ (,eof ',eof-value))
+ (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
+ ((eql ,var ,eof))
+ ,@body))))
+
+(defun system (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *verbose-out*. Returns the shell's exit code."
+ (let ((command (apply #'format nil control-string args)))
+ (format t "; $ ~A~%" command)
+ #+sbcl
+ (sb-impl::process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *standard-output*))
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*))
+ #+clisp ;XXX not exactly *verbose-out*, I know
+ (ext:run-shell-command command :output :terminal :wait t)
+ ))
+
+(defun strcat (&rest strings)
+ (apply #'concatenate 'string strings))
+
+(defun string-starts-with (start str)
+ (and (>= (length str) (length start))
+ (string-equal start str :end2 (length start))))
+
+(defmacro string-append (outputstr &rest args)
+ `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defconstant +indent+ 2
+ "Indentation used in the examples.")
+
+(defun texinfo->raw-lisp (code)
+ "Answer CODE with spurious Texinfo output removed. For use in
+preprocessing output in a @lisp block before passing to colorize."
+ (decode-from-tt
+ (with-output-to-string (output)
+ (do* ((last-position 0)
+ (next-position
+ #0=(search #1="<span class=\"roman\">" code
+ :start2 last-position :test #'char-equal)
+ #0#))
+ ((eq nil next-position)
+ (write-string code output :start last-position))
+ (write-string code output :start last-position :end next-position)
+ (let ((end (search #2="</span>" code
+ :start2 (+ next-position (length #1#))
+ :test #'char-equal)))
+ (assert (integerp end) ()
+ "Missing ~A tag in HTML for @lisp block~%~
+ HTML contents of block:~%~A" #2# code)
+ (write-string code output
+ :start (+ next-position (length #1#))
+ :end end)
+ (setf last-position (+ end (length #2#))))))))
+
+(defun process-file (from to)
+ (with-open-file (output to :direction :output :if-exists :error)
+ (with-open-file (input from :direction :input)
+ (let ((line-processor nil)
+ (piece-of-code '()))
+ (labels
+ ((process-line-inside-pre (line)
+ (cond ((string-starts-with "</pre>" line)
+ (with-input-from-string
+ (stream (colorize:html-colorization
+ :common-lisp
+ (texinfo->raw-lisp
+ (apply #'concatenate 'string
+ (nreverse piece-of-code)))))
+ (with-each-stream-line (cline stream)
+ (format output " ~A~%" cline)))
+ (write-line line output)
+ (setq piece-of-code '()
+ line-processor #'process-regular-line))
+ (t (let ((to-append (subseq line +indent+)))
+ (push (if (string= "" to-append)
+ " "
+ to-append) piece-of-code)
+ (push (string #\Newline) piece-of-code)))))
+ (process-regular-line (line)
+ (let ((len (some (lambda (test-string)
+ (when (string-starts-with test-string line)
+ (length test-string)))
+ '("<pre class=\"lisp\">"
+ "<pre class=\"smalllisp\">"))))
+ (cond (len
+ (setq line-processor #'process-line-inside-pre)
+ (write-string "<pre class=\"lisp\">" output)
+ (push (subseq line (+ len +indent+)) piece-of-code)
+ (push (string #\Newline) piece-of-code))
+ (t (write-line line output))))))
+ (setf line-processor #'process-regular-line)
+ (with-each-stream-line (line input)
+ (funcall line-processor line)))))))
+
+(defun process-dir (dir)
+ (dolist (html-file (directory dir))
+ (let* ((name (namestring html-file))
+ (temp-name (strcat name ".temp")))
+ (process-file name temp-name)
+ (system "mv ~A ~A" temp-name name))))
+
+;; (go "/tmp/doc/manual/html_node/*.html")
+
+#+clisp
+(progn
+ (assert (first ext:*args*))
+ (process-dir (first ext:*args*)))
+
+#+sbcl
+(progn
+ (assert (second sb-ext:*posix-argv*))
+ (process-dir (second sb-ext:*posix-argv*))
+ (sb-ext:quit))
Added: branches/xml-class-rework/thirdparty/cffi/doc/gendocs.sh
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/gendocs.sh 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/gendocs.sh 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,310 @@
+#!/bin/sh
+# gendocs.sh -- generate a GNU manual in many formats. This script is
+# mentioned in maintain.texi. See the help message below for usage details.
+# $Id: gendocs.sh,v 1.16 2005/05/15 00:00:08 karl Exp $
+#
+# Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, you can either send email to this
+# program's maintainer or write to: The Free Software Foundation,
+# Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA.
+#
+# Original author: Mohit Agarwal.
+# Send bug reports and any other correspondence to bug-texinfo(a)gnu.org.
+
+prog="`basename \"$0\"`"
+srcdir=`pwd`
+
+scripturl="http://common-lisp.net/project/cffi/darcs/cffi/doc/gendocs.sh"
+templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_templa…"
+
+: ${MAKEINFO="makeinfo"}
+: ${TEXI2DVI="texi2dvi -t @finalout"}
+: ${DVIPS="dvips"}
+: ${DOCBOOK2TXT="docbook2txt"}
+: ${DOCBOOK2HTML="docbook2html"}
+: ${DOCBOOK2PDF="docbook2pdf"}
+: ${DOCBOOK2PS="docbook2ps"}
+: ${GENDOCS_TEMPLATE_DIR="."}
+unset CDPATH
+
+rcs_revision='$Revision: 1.16 $'
+rcs_version=`set - $rcs_revision; echo $2`
+program=`echo $0 | sed -e 's!.*/!!'`
+version="gendocs.sh $rcs_version
+
+Copyright (C) 2005 Free Software Foundation, Inc.
+There is NO warranty. You may redistribute this software
+under the terms of the GNU General Public License.
+For more information about these matters, see the files named COPYING."
+
+usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE
+
+Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source.
+See the GNU Maintainers document for a more extensive discussion:
+ http://www.gnu.org/prep/maintain_toc.html
+
+Options:
+ -o OUTDIR write files into OUTDIR, instead of manual/.
+ --docbook convert to DocBook too (xml, txt, html, pdf and ps).
+ --html ARG pass indicated ARG to makeinfo for HTML targets.
+ --help display this help and exit successfully.
+ --version display version information and exit successfully.
+
+Simple example: $prog emacs \"GNU Emacs Manual\"
+
+Typical sequence:
+ cd YOURPACKAGESOURCE/doc
+ wget \"$scripturl\"
+ wget \"$templateurl\"
+ $prog YOURMANUAL \"GNU YOURMANUAL - One-line description\"
+
+Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR
+to override). Move all the new files into your web CVS tree, as
+explained in the Web Pages node of maintain.texi.
+
+MANUAL-TITLE is included as part of the HTML <title> of the overall
+manual/index.html file. It should include the name of the package being
+documented. manual/index.html is created by substitution from the file
+$GENDOCS_TEMPLATE_DIR/gendocs_template. (Feel free to modify the
+generic template for your own purposes.)
+
+If you have several manuals, you'll need to run this script several
+times with different YOURMANUAL values, specifying a different output
+directory with -o each time. Then write (by hand) an overall index.html
+with links to them all.
+
+You can set the environment variables MAKEINFO, TEXI2DVI, and DVIPS to
+control the programs that get executed, and GENDOCS_TEMPLATE_DIR to
+control where the gendocs_template file is looked for.
+
+Email bug reports or enhancement requests to bug-texinfo(a)gnu.org.
+"
+
+calcsize()
+{
+ size="`ls -ksl $1 | awk '{print $1}'`"
+ echo $size
+}
+
+outdir=manual
+html=
+PACKAGE=
+MANUAL_TITLE=
+
+while test $# -gt 0; do
+ case $1 in
+ --help) echo "$usage"; exit 0;;
+ --version) echo "$version"; exit 0;;
+ -o) shift; outdir=$1;;
+ --docbook) docbook=yes;;
+ --html) shift; html=$1;;
+ -*)
+ echo "$0: Unknown or ambiguous option \`$1'." >&2
+ echo "$0: Try \`--help' for more information." >&2
+ exit 1;;
+ *)
+ if test -z "$PACKAGE"; then
+ PACKAGE=$1
+ elif test -z "$MANUAL_TITLE"; then
+ MANUAL_TITLE=$1
+ else
+ echo "$0: extra non-option argument \`$1'." >&2
+ exit 1
+ fi;;
+ esac
+ shift
+done
+
+if test -s $srcdir/$PACKAGE.texinfo; then
+ srcfile=$srcdir/$PACKAGE.texinfo
+elif test -s $srcdir/$PACKAGE.texi; then
+ srcfile=$srcdir/$PACKAGE.texi
+elif test -s $srcdir/$PACKAGE.txi; then
+ srcfile=$srcdir/$PACKAGE.txi
+else
+ echo "$0: cannot find .texinfo or .texi or .txi for $PACKAGE in $srcdir." >&2
+ exit 1
+fi
+
+if test ! -r $GENDOCS_TEMPLATE_DIR/gendocs_template; then
+ echo "$0: cannot read $GENDOCS_TEMPLATE_DIR/gendocs_template." >&2
+ echo "$0: it is available from $templateurl." >&2
+ exit 1
+fi
+
+echo Generating output formats for $srcfile
+
+cmd="${MAKEINFO} -o $PACKAGE.info $srcfile"
+echo "Generating info files... ($cmd)"
+eval $cmd
+mkdir -p $outdir/
+tar czf $outdir/$PACKAGE.info.tar.gz $PACKAGE.info*
+info_tgz_size="`calcsize $outdir/$PACKAGE.info.tar.gz`"
+# do not mv the info files, there's no point in having them available
+# separately on the web.
+
+cmd="${TEXI2DVI} $srcfile"
+echo "Generating dvi ... ($cmd)"
+eval $cmd
+
+# now, before we compress dvi:
+echo Generating postscript...
+${DVIPS} $PACKAGE -o
+gzip -f -9 $PACKAGE.ps
+ps_gz_size="`calcsize $PACKAGE.ps.gz`"
+mv $PACKAGE.ps.gz $outdir/
+
+# compress/finish dvi:
+gzip -f -9 $PACKAGE.dvi
+dvi_gz_size="`calcsize $PACKAGE.dvi.gz`"
+mv $PACKAGE.dvi.gz $outdir/
+
+cmd="${TEXI2DVI} --pdf $srcfile"
+echo "Generating pdf ... ($cmd)"
+eval $cmd
+pdf_size="`calcsize $PACKAGE.pdf`"
+mv $PACKAGE.pdf $outdir/
+
+cmd="${MAKEINFO} -o $PACKAGE.txt --no-split --no-headers $srcfile"
+echo "Generating ASCII... ($cmd)"
+eval $cmd
+ascii_size="`calcsize $PACKAGE.txt`"
+gzip -f -9 -c $PACKAGE.txt >$outdir/$PACKAGE.txt.gz
+ascii_gz_size="`calcsize $outdir/$PACKAGE.txt.gz`"
+mv $PACKAGE.txt $outdir/
+
+# Print a SED expression that will translate references to MANUAL to
+# the proper page on gnu.org. This is a horrible shell hack done
+# because \| in sed regexps is a GNU extension.
+monognuorg () {
+ case "$1" in
+ libtool) echo "s!$1.html!http://www.gnu.org/software/$1/manual.html!" ;;
+ *) echo "s!$1.html!http://www.gnu.org/software/$1/manual/html_mono/$1.html!" ;;
+ esac
+}
+polygnuorg () {
+ case "$1" in
+ libtool) echo 's!\.\./'"$1/.*\.html!http://www.gnu.org/software/$1/manual.html!" ;;
+ *) echo 's!\.\./'"$1!http://www.gnu.org/software/$1/manual/html_node!" ;;
+ esac
+}
+
+cmd="${MAKEINFO} --no-split --html -o $PACKAGE.html $html $srcfile"
+echo "Generating monolithic html... ($cmd)"
+rm -rf $PACKAGE.html # in case a directory is left over
+eval $cmd
+sbcl --load colorize-lisp-examples.lisp $PACKAGE.html
+#fix libc/libtool xrefs
+sed -e `monognuorg libc` -e `monognuorg libtool` $PACKAGE.html >$outdir/$PACKAGE.html
+rm $PACKAGE.html
+html_mono_size="`calcsize $outdir/$PACKAGE.html`"
+gzip -f -9 -c $outdir/$PACKAGE.html >$outdir/$PACKAGE.html.gz
+html_mono_gz_size="`calcsize $outdir/$PACKAGE.html.gz`"
+
+cmd="${MAKEINFO} --html -o $PACKAGE.html $html $srcfile"
+echo "Generating html by node... ($cmd)"
+eval $cmd
+split_html_dir=$PACKAGE.html
+sbcl --load colorize-lisp-examples.lisp "${split_html_dir}/*.html"
+(
+ cd ${split_html_dir} || exit 1
+ #fix libc xrefs
+ for broken_file in *.html; do
+ sed -e `polygnuorg libc` -e `polygnuorg libtool` "$broken_file" > "$broken_file".temp
+ mv -f "$broken_file".temp "$broken_file"
+ done
+ tar -czf ../$outdir/${PACKAGE}.html_node.tar.gz -- *.html
+)
+html_node_tgz_size="`calcsize $outdir/${PACKAGE}.html_node.tar.gz`"
+rm -f $outdir/html_node/*.html
+mkdir -p $outdir/html_node/
+mv ${split_html_dir}/*.html $outdir/html_node/
+rmdir ${split_html_dir}
+
+echo Making .tar.gz for sources...
+srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null`
+tar cvzfh $outdir/$PACKAGE.texi.tar.gz $srcfiles
+texi_tgz_size="`calcsize $outdir/$PACKAGE.texi.tar.gz`"
+
+if test -n "$docbook"; then
+ cmd="${MAKEINFO} -o - --docbook $srcfile > ${srcdir}/$PACKAGE-db.xml"
+ echo "Generating docbook XML... $(cmd)"
+ eval $cmd
+ docbook_xml_size="`calcsize $PACKAGE-db.xml`"
+ gzip -f -9 -c $PACKAGE-db.xml >$outdir/$PACKAGE-db.xml.gz
+ docbook_xml_gz_size="`calcsize $outdir/$PACKAGE-db.xml.gz`"
+ mv $PACKAGE-db.xml $outdir/
+
+ cmd="${DOCBOOK2HTML} -o $split_html_db_dir ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook HTML... ($cmd)"
+ eval $cmd
+ split_html_db_dir=html_node_db
+ (
+ cd ${split_html_db_dir} || exit 1
+ tar -czf ../$outdir/${PACKAGE}.html_node_db.tar.gz -- *.html
+ )
+ html_node_db_tgz_size="`calcsize $outdir/${PACKAGE}.html_node_db.tar.gz`"
+ rm -f $outdir/html_node_db/*.html
+ mkdir -p $outdir/html_node_db
+ mv ${split_html_db_dir}/*.html $outdir/html_node_db/
+ rmdir ${split_html_db_dir}
+
+ cmd="${DOCBOOK2TXT} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook ASCII... ($cmd)"
+ eval $cmd
+ docbook_ascii_size="`calcsize $PACKAGE-db.txt`"
+ mv $PACKAGE-db.txt $outdir/
+
+ cmd="${DOCBOOK2PS} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook PS... $(cmd)"
+ eval $cmd
+ gzip -f -9 -c $PACKAGE-db.ps >$outdir/$PACKAGE-db.ps.gz
+ docbook_ps_gz_size="`calcsize $outdir/$PACKAGE-db.ps.gz`"
+ mv $PACKAGE-db.ps $outdir/
+
+ cmd="${DOCBOOK2PDF} ${outdir}/$PACKAGE-db.xml"
+ echo "Generating docbook PDF... ($cmd)"
+ eval $cmd
+ docbook_pdf_size="`calcsize $PACKAGE-db.pdf`"
+ mv $PACKAGE-db.pdf $outdir/
+fi
+
+echo Writing index file...
+curdate="`date '+%B %d, %Y'`"
+sed \
+ -e "s!%%TITLE%%!$MANUAL_TITLE!g" \
+ -e "s!%%DATE%%!$curdate!g" \
+ -e "s!%%PACKAGE%%!$PACKAGE!g" \
+ -e "s!%%HTML_MONO_SIZE%%!$html_mono_size!g" \
+ -e "s!%%HTML_MONO_GZ_SIZE%%!$html_mono_gz_size!g" \
+ -e "s!%%HTML_NODE_TGZ_SIZE%%!$html_node_tgz_size!g" \
+ -e "s!%%INFO_TGZ_SIZE%%!$info_tgz_size!g" \
+ -e "s!%%DVI_GZ_SIZE%%!$dvi_gz_size!g" \
+ -e "s!%%PDF_SIZE%%!$pdf_size!g" \
+ -e "s!%%PS_GZ_SIZE%%!$ps_gz_size!g" \
+ -e "s!%%ASCII_SIZE%%!$ascii_size!g" \
+ -e "s!%%ASCII_GZ_SIZE%%!$ascii_gz_size!g" \
+ -e "s!%%TEXI_TGZ_SIZE%%!$texi_tgz_size!g" \
+ -e "s!%%DOCBOOK_HTML_NODE_TGZ_SIZE%%!$html_node_db_tgz_size!g" \
+ -e "s!%%DOCBOOK_ASCII_SIZE%%!$docbook_ascii_size!g" \
+ -e "s!%%DOCBOOK_PS_GZ_SIZE%%!$docbook_ps_gz_size!g" \
+ -e "s!%%DOCBOOK_PDF_SIZE%%!$docbook_pdf_size!g" \
+ -e "s!%%DOCBOOK_XML_SIZE%%!$docbook_xml_size!g" \
+ -e "s!%%DOCBOOK_XML_GZ_SIZE%%!$docbook_xml_gz_size!g" \
+ -e "s,%%SCRIPTURL%%,$scripturl,g" \
+ -e "s!%%SCRIPTNAME%%!$prog!g" \
+$GENDOCS_TEMPLATE_DIR/gendocs_template >$outdir/index.html
+
+echo "Done! See $outdir/ subdirectory for new files."
Property changes on: branches/xml-class-rework/thirdparty/cffi/doc/gendocs.sh
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/doc/gendocs_template
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/gendocs_template 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/gendocs_template 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,259 @@
+<?xml version="1.0" encoding="utf-8" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<!-- $Id: gendocs_template,v 1.7 2005/05/15 00:00:08 karl Exp $ -->
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
+
+<!--
+
+ This template was adapted from Texinfo:
+ http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_templa…
+
+-->
+
+
+<head>
+<title>%%TITLE%%</title>
+<meta http-equiv="content-type" content='text/html; charset=utf-8' />
+<!-- <link rel="stylesheet" type="text/css" href="/gnu.css" /> -->
+<!-- <link rev="made" href="webmasters(a)gnu.org" /> -->
+<style>
+/* CSS style taken from http://gnu.org/gnu.css */
+
+html, body {
+ background-color: #FFFFFF;
+ color: #000000;
+ font-family: sans-serif;
+}
+
+a:link {
+ color: #1f00ff;
+ background-color: transparent;
+ text-decoration: underline;
+ }
+
+a:visited {
+ color: #9900dd;
+ background-color: transparent;
+ text-decoration: underline;
+ }
+
+a:hover {
+ color: #9900dd;
+ background-color: transparent;
+ text-decoration: none;
+ }
+
+.center {
+ text-align: center;
+}
+
+.italic {
+ font-style: italic;
+ }
+
+.bold {
+ font-weight: bold;
+ }
+
+.quote {
+ margin-left: 40px;
+ margin-right: 40px;
+}
+
+.hrsmall {
+ width: 80px;
+ height: 1px;
+ margin-left: 20px;
+}
+
+.td_title {
+ border-color: #3366cc;
+ border-style: solid;
+ border-width: thin;
+ color: #3366cc;
+ background-color : #f2f2f9;
+ font-weight: bold;
+}
+
+.td_con {
+ padding-top: 3px;
+ padding-left: 8px;
+ padding-bottom: 3px;
+ color : #303030;
+ background-color : #fefefe;
+ font-size: smaller;
+}
+
+.translations {
+ background-color: transparent;
+ color: black;
+ font-family: serif;
+ font-size: smaller;
+}
+
+.fsflink {
+ font-size: smaller;
+ font-family: monospace;
+ color : #000000;
+ border-left: #3366cc thin solid;
+ border-bottom: #3366cc thin solid;
+ padding-left: 5px;
+ padding-bottom: 5px;
+}
+
+/*
+ * rtl stands for right-to-left layout, as in farsi/persian,
+ * arabic, etc. See also trans_rtl.
+ */
+.fsflink_rtl {
+ font-size: smaller;
+ font-family: monospace;
+ color : #000000;
+ border-right: #3366cc thin solid;
+ border-bottom: #3366cc thin solid;
+ padding-right: 5px;
+ padding-bottom: 5px;
+}
+
+.trans {
+ font-size: smaller;
+ color : #000000;
+ border-left: #3366cc thin solid;
+ padding-left: 20px;
+}
+
+.trans_rtl {
+ font-size: smaller;
+ color : #000000;
+ border-right: #3366cc thin solid;
+ padding-right: 20px;
+}
+
+img {
+ border: none 0;
+}
+
+td.side {
+ color: #3366cc;
+/* background: #f2f2f9;
+ border-color: #3366cc;
+ border-style: solid;
+ border-width: thin; */
+ border-color: white;
+ border-style: none;
+ vertical-align: top;
+ width: 150px;
+}
+
+div.copyright {
+ font-size: 80%;
+ border: 2px solid #3366cc;
+ padding: 4px;
+ background: #f2f2f9;
+ border-style: solid;
+ border-width: thin;
+}
+
+.footnoteref {
+ font-size: smaller;
+ vertical-align: text-top;
+}
+</style>
+</head>
+
+<!-- This document is in XML, and xhtml 1.0 -->
+<!-- Please make sure to properly nest your tags -->
+<!-- and ensure that your final document validates -->
+<!-- consistent with W3C xhtml 1.0 and CSS standards -->
+<!-- See validator.w3.org -->
+
+<body>
+
+<h3>%%TITLE%%</h3>
+
+<!-- <address>Free Software Foundation</address> -->
+<address>last updated %%DATE%%</address>
+
+<!--
+<p>
+<a href="/graphics/gnu-head.jpg">
+ <img src="/graphics/gnu-head-sm.jpg"
+ alt=" [image of the head of a GNU] "
+ width="129" height="122" />
+</a>
+<a href="/philosophy/gif.html">(no gifs due to patent problems)</a>
+</p>
+-->
+
+<hr />
+
+<p>This document <!--(%%PACKAGE%%)--> is available in the following formats:</p>
+
+<ul>
+ <li><a href="%%PACKAGE%%.html">HTML
+ (%%HTML_MONO_SIZE%%K characters)</a> - entirely on one web page.</li>
+ <li><a href="html_node/index.html">HTML</a> - with one web page per
+ node.</li>
+ <li><a href="%%PACKAGE%%.html.gz">HTML compressed
+ (%%HTML_MONO_GZ_SIZE%%K gzipped characters)</a> - entirely on
+ one web page.</li>
+ <li><a href="%%PACKAGE%%.html_node.tar.gz">HTML compressed
+ (%%HTML_NODE_TGZ_SIZE%%K gzipped tar file)</a> -
+ with one web page per node.</li>
+ <li><a href="%%PACKAGE%%.info.tar.gz">Info document
+ (%%INFO_TGZ_SIZE%%K characters gzipped tar file)</a>.</li>
+ <li><a href="%%PACKAGE%%.txt">ASCII text
+ (%%ASCII_SIZE%%K characters)</a>.</li>
+ <li><a href="%%PACKAGE%%.txt.gz">ASCII text compressed
+ (%%ASCII_GZ_SIZE%%K gzipped characters)</a>.</li>
+ <li><a href="%%PACKAGE%%.dvi.gz">TeX dvi file
+ (%%DVI_GZ_SIZE%%K characters gzipped)</a>.</li>
+ <li><a href="%%PACKAGE%%.ps.gz">PostScript file
+ (%%PS_GZ_SIZE%%K characters gzipped)</a>.</li>
+ <li><a href="%%PACKAGE%%.pdf">PDF file
+ (%%PDF_SIZE%%K characters)</a>.</li>
+ <li><a href="%%PACKAGE%%.texi.tar.gz">Texinfo source
+ (%%TEXI_TGZ_SIZE%%K characters gzipped tar file)</a></li>
+</ul>
+
+<p>(This page was generated by the <a href="%%SCRIPTURL%%">%%SCRIPTNAME%%
+script</a>.)</p>
+
+<div class="copyright">
+<p>
+Return to <a href="/project/cffi/">CFFI's home page</a>.
+</p>
+
+<!--
+<p>
+Please send FSF & GNU inquiries to
+<a href="mailto:gnu@gnu.org"><em>gnu(a)gnu.org</em></a>.
+There are also <a href="/home.html#ContactInfo">other ways to contact</a>
+the FSF.
+<br />
+Please send broken links and other corrections (or suggestions) to
+<a href="mailto:webmasters@gnu.org"><em>webmasters(a)gnu.org</em></a>.
+</p>
+-->
+
+<p>
+Copyright (C) 2005 James Bielman <jamesjb at jamesjb.com><br />
+Copyright (C) 2005 Luís Oliveira <loliveira at common-lisp.net>
+<!--
+<br />
+Verbatim copying and distribution of this entire article is
+permitted in any medium, provided this notice is preserved.
+-->
+</p>
+
+<p>
+Updated: %%DATE%%
+<!-- timestamp start -->
+<!-- $Date: 2005/05/15 00:00:08 $ $Author: karl $ -->
+<!-- timestamp end -->
+</p>
+</div>
+
+</body>
+</html>
Added: branches/xml-class-rework/thirdparty/cffi/doc/mem-vector.txt
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/mem-vector.txt 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/mem-vector.txt 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,75 @@
+
+# Block Memory Operations
+
+Function: mem-fill ptr type count value &optional (offset 0)
+
+Fill COUNT objects of TYPE, starting at PTR plus offset, with VALUE.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below count
+ for off from offset by (%foreign-type-size type)
+ do (setf (%mem-ref ptr type off) value))
+
+Function: mem-read-vector vector ptr type count &optional (offset 0)
+
+Copy COUNT objects of TYPE from foreign memory at PTR plus OFFSET into
+VECTOR. If VECTOR is not large enough to contain COUNT objects, it
+will copy as many objects as necessary to fill the vector. The
+results are undefined if the foreign memory block is not large enough
+to supply the data to copy.
+
+TYPE must be a built-in foreign type (integer, float, double, or
+pointer).
+
+Returns the number of objects copied.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below (min count (length vector))
+ for off from offset by (%foreign-type-size type)
+ do (setf (aref vector i) (%mem-ref ptr type off))
+ finally (return i))
+
+
+Function: mem-read-c-string string ptr &optional (offset 0)
+
+Copy a null-terminated C string from PTR plus OFFSET into STRING, a
+Lisp string. If STRING is not large enough to contain the data at PTR
+it will be truncated.
+
+Returns the number of characters copied into STRING.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below (length string)
+ for off from offset
+ for char = (%mem-ref ptr :char off)
+ until (zerop char)
+ do (setf (char string i) char)
+ finally (return i))
+
+Function: mem-write-vector vector ptr type &optional
+ (count (length vector)) (offset 0)
+
+Copy COUNT objects from VECTOR into objects of TYPE in foreign memory,
+starting at PTR plus OFFSET. The results are undefined if PTR does
+not point to a memory block large enough to hold the data copied.
+
+TYPE must be a built-in type (integer, float, double, or pointer).
+
+Returns the number of objects copied from VECTOR to PTR.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below count
+ for off from offset by (%foreign-type-size type)
+ do (setf (%mem-ref ptr type off) (aref vector i))
+ finally (return i))
+
+
+Function: mem-write-c-string string ptr &optional (offset 0)
+
+Copy the characters from a Lisp STRING to PTR plus OFFSET, adding a
+final null terminator at the end. The results are undefined if the
+memory at PTR is not large enough to accomodate the data.
+
+This interface is currently equivalent to MEM-WRITE-VECTOR with a TYPE
+of :CHAR, but will be useful when proper support for Unicode strings
+is implemented.
Property changes on: branches/xml-class-rework/thirdparty/cffi/doc/mem-vector.txt
___________________________________________________________________
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/doc/shareable-vectors.txt
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/shareable-vectors.txt 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/shareable-vectors.txt 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,44 @@
+
+# Shareable Byte Vectors
+
+Function: make-shareable-byte-vector size
+
+Create a vector of element type (UNSIGNED-BYTE 8) suitable for passing
+to WITH-POINTER-TO-VECTOR-DATA.
+
+;; Minimal implementation:
+(defun make-shareable-byte-vector (size)
+ (make-array size :element-type '(unsigned-byte 8)))
+
+
+Macro: with-pointer-to-vector-data (ptr-var vector) &body body
+
+Bind PTR-VAR to a pointer to the data contained in a shareable byte
+vector.
+
+VECTOR must be a shareable vector created by MAKE-SHAREABLE-BYTE-VECTOR.
+
+PTR-VAR may point directly into the Lisp vector data, or it may point
+to a temporary block of foreign memory which will be copied to and
+from VECTOR.
+
+Both the pointer object in PTR-VAR and the memory it points to have
+dynamic extent. The results are undefined if foreign code attempts to
+access this memory outside this dynamic contour.
+
+The implementation must guarantee the memory pointed to by PTR-VAR
+will not be moved during the dynamic contour of this operator, either
+by creating the vector in a static area or temporarily disabling the
+garbage collector.
+
+;; Minimal (copying) implementation:
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+ (let ((vector-var (gensym))
+ (size-var (gensym)))
+ `(let* ((,vector-var ,vector)
+ (,size-var (length ,vector-var)))
+ (with-foreign-ptr (,ptr-var ,size-var)
+ (mem-write-vector ,vector-var ,ptr :uint8)
+ (prog1
+ (progn ,@body)
+ (mem-read-vector ,vector-var ,ptr-var :uint8 ,size-var))))))
Property changes on: branches/xml-class-rework/thirdparty/cffi/doc/shareable-vectors.txt
___________________________________________________________________
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/doc/style.css
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/doc/style.css 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/doc/style.css 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,48 @@
+body {font-family: century schoolbook, serif;
+ line-height: 1.3;
+ padding-left: 5em; padding-right: 1em;
+ padding-bottom: 1em; max-width: 60em;}
+table {border-collapse: collapse}
+span.roman { font-family: century schoolbook, serif; font-weight: normal; }
+h1, h2, h3, h4, h5, h6 {font-family: Helvetica, sans-serif}
+/*h4 {padding-top: 0.75em;}*/
+dfn {font-family: inherit; font-variant: italic; font-weight: bolder }
+kbd {font-family: monospace; text-decoration: underline}
+/*var {font-family: Helvetica, sans-serif; font-variant: slanted}*/
+var {font-variant: slanted;}
+td {padding-right: 1em; padding-left: 1em}
+sub {font-size: smaller}
+.node {padding: 0; margin: 0}
+
+.lisp { font-family: monospace;
+ background-color: #F4F4F4; border: 1px solid #AAA;
+ padding-top: 0.5em; padding-bottom: 0.5em; }
+
+/* coloring */
+
+.lisp-bg { background-color: #F4F4F4 ; color: black; }
+.lisp-bg:hover { background-color: #F4F4F4 ; color: black; }
+
+.symbol { font-weight: bold; color: #770055; background-color : transparent; border: 0px; margin: 0px;}
+a.symbol:link { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:active { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:visited { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:hover { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+.special { font-weight: bold; color: #FF5000; background-color: inherit; }
+.keyword { font-weight: bold; color: #770000; background-color: inherit; }
+.comment { font-weight: normal; color: #007777; background-color: inherit; }
+.string { font-weight: bold; color: #777777; background-color: inherit; }
+.character { font-weight: bold; color: #0055AA; background-color: inherit; }
+.syntaxerror { font-weight: bold; color: #FF0000; background-color: inherit; }
+span.paren1 { font-weight: bold; color: #777777; }
+span.paren1:hover { color: #777777; background-color: #BAFFFF; }
+span.paren2 { color: #777777; }
+span.paren2:hover { color: #777777; background-color: #FFCACA; }
+span.paren3 { color: #777777; }
+span.paren3:hover { color: #777777; background-color: #FFFFBA; }
+span.paren4 { color: #777777; }
+span.paren4:hover { color: #777777; background-color: #CACAFF; }
+span.paren5 { color: #777777; }
+span.paren5:hover { color: #777777; background-color: #CAFFCA; }
+span.paren6 { color: #777777; }
+span.paren6:hover { color: #777777; background-color: #FFBAFF; }
Added: branches/xml-class-rework/thirdparty/cffi/examples/examples.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/examples/examples.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/examples/examples.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,78 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; examples.lisp --- Simple test examples of CFFI.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(defpackage #:cffi-examples
+ (:use #:cl #:cffi)
+ (:export
+ #:run-examples
+ #:sqrtf
+ #:getenv))
+
+(in-package #:cffi-examples)
+
+;; A simple libc function.
+(defcfun "sqrtf" :float
+ (n :float))
+
+;; This definition uses the STRING type translator to automatically
+;; convert Lisp strings to foreign strings and vice versa.
+(defcfun "getenv" :string
+ (name :string))
+
+;; Calling a varargs function.
+(defun sprintf-test ()
+ "Test calling a varargs function."
+ (with-foreign-pointer-as-string (buf 255 buf-size)
+ (foreign-funcall
+ "snprintf" :pointer buf :int buf-size
+ :string "%d %f #x%x!" :int 666
+ :double (coerce pi 'double-float)
+ :unsigned-int #xcafebabe
+ :void)))
+
+;; Defining an emerated type.
+(defcenum test-enum
+ (:invalid 0)
+ (:positive 1)
+ (:negative -1))
+
+;; Use the absolute value function to test keyword/enum translation.
+(defcfun ("abs" c-abs) test-enum
+ (n test-enum))
+
+(defun cffi-version ()
+ (asdf:component-version (asdf:find-system 'cffi)))
+
+(defun run-examples ()
+ (format t "~&;;; CFFI version ~A on ~A ~A:~%"
+ (cffi-version) (lisp-implementation-type)
+ (lisp-implementation-version))
+ (format t "~&;; shell: ~A~%" (getenv "SHELL"))
+ (format t "~&;; sprintf test: ~A~%" (sprintf-test))
+ (format t "~&;; (c-abs :positive): ~A~%" (c-abs :positive))
+ (format t "~&;; (c-abs :negative): ~A~%" (c-abs :negative))
+ (force-output))
Added: branches/xml-class-rework/thirdparty/cffi/examples/gethostname.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/examples/gethostname.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/examples/gethostname.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,51 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; gethostname.lisp --- A simple CFFI example.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# CFFI Example: gethostname binding
+;;;
+;;; This is a very simple CFFI example that illustrates calling a C
+;;; function that fills in a user-supplied string buffer.
+
+(defpackage #:cffi-example-gethostname
+ (:use #:common-lisp #:cffi)
+ (:export #:gethostname))
+
+(in-package #:cffi-example-gethostname)
+
+;;; Define the Lisp function %GETHOSTNAME to call the C 'gethostname'
+;;; function, which will fill BUF with up to BUFSIZE characters of the
+;;; system's hostname.
+(defcfun ("gethostname" %gethostname) :int
+ (buf :pointer)
+ (bufsize :int))
+
+;;; Define a Lispy interface to 'gethostname'. The utility macro
+;;; WITH-FOREIGN-POINTER-AS-STRING is used to allocate a temporary
+;;; buffer and return it as a Lisp string.
+(defun gethostname ()
+ (with-foreign-pointer-as-string (buf 255 bufsize)
+ (%gethostname buf bufsize)))
Added: branches/xml-class-rework/thirdparty/cffi/examples/gettimeofday.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/examples/gettimeofday.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/examples/gettimeofday.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,87 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2)
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# CFFI Example: gettimeofday binding
+;;;
+;;; This example illustrates the use of foreign structures, typedefs,
+;;; and using type translators to do checking of input and output
+;;; arguments to a foreign function.
+
+(defpackage #:cffi-example-gettimeofday
+ (:use #:common-lisp #:cffi #:cffi-utils)
+ (:export #:gettimeofday))
+
+(in-package #:cffi-example-gettimeofday)
+
+;;; Define the TIMEVAL structure used by 'gettimeofday'. This assumes
+;;; that 'time_t' is a 'long' --- it would be nice if CFFI could
+;;; provide a proper :TIME-T type to help make this portable.
+(defcstruct timeval
+ (tv-sec :long)
+ (tv-usec :long))
+
+;;; A NULL-POINTER is a foreign :POINTER that must always be NULL.
+;;; Both a NULL pointer and NIL are legal values---any others will
+;;; result in a runtime error.
+(defctype null-pointer :pointer)
+
+;;; This type translator is used to ensure that a NULL-POINTER has a
+;;; null value. It also converts NIL to a null pointer.
+(defmethod translate-to-foreign (value (name (eql 'null-pointer)))
+ (cond
+ ((null value) (null-pointer))
+ ((null-pointer-p value) value)
+ (t (error "~A is not a null pointer." value))))
+
+;;; The SYSCALL-RESULT type is an integer type used for the return
+;;; value of C functions that return -1 and set errno on errors.
+;;; Someday when CFFI has a portable interface for dealing with
+;;; 'errno', this error reporting can be more useful.
+(defctype syscall-result :int)
+
+;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error
+;;; if the value is negative.
+(defmethod translate-from-foreign (value (name (eql 'syscall-result)))
+ (if (minusp value)
+ (error "System call failed with return value ~D." value)
+ value))
+
+;;; Define the Lisp function %GETTIMEOFDAY to call the C function
+;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill
+;;; in. The TZP parameter is deprecated and should be NULL --- we can
+;;; enforce this by using our NULL-POINTER type defined above.
+(defcfun ("gettimeofday" %gettimeofday) syscall-result
+ (tp :pointer)
+ (tzp null-pointer))
+
+;;; Define a Lispy interface to 'gettimeofday' that returns the
+;;; seconds and microseconds as multiple values.
+(defun gettimeofday ()
+ (with-foreign-object (tv 'timeval)
+ (%gettimeofday tv nil)
+ (with-foreign-slots ((tv-sec tv-usec) tv timeval)
+ (values tv-sec tv-usec))))
Added: branches/xml-class-rework/thirdparty/cffi/examples/run-examples.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/examples/run-examples.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/examples/run-examples.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,38 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; run-examples.lisp --- Simple script to run the examples.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(setf *load-verbose* nil *compile-verbose* nil)
+
+#+(and (not asdf) (or sbcl openmcl))
+(require "asdf")
+#+clisp
+(load "~/Downloads/asdf")
+
+(asdf:operate 'asdf:load-op 'cffi-examples :verbose nil)
+(cffi-examples:run-examples)
+(force-output)
+(quit)
Added: branches/xml-class-rework/thirdparty/cffi/examples/translator-test.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/examples/translator-test.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/examples/translator-test.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,108 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; translator-test.lisp --- Testing type translators.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(defpackage #:cffi-translator-test
+ (:use #:common-lisp #:cffi #:cffi-utils))
+
+(in-package #:cffi-translator-test)
+
+;;;# Verbose Pointer Translator
+;;;
+;;; This is a silly type translator that doesn't actually do any
+;;; translating, but it prints out a debug message when the pointer is
+;;; converted to/from its foreign representation.
+
+(defctype verbose-pointer :pointer)
+
+(defmethod translate-to-foreign (value (name (eql 'verbose-pointer)))
+ (format *debug-io* "~&;; to foreign: VERBOSE-POINTER: ~S~%" value)
+ value)
+
+(defmethod translate-from-foreign (value (name (eql 'verbose-pointer)))
+ (format *debug-io* "~&;; from foreign: VERBOSE-POINTER: ~S~%" value)
+ value)
+
+;;;# Verbose String Translator
+;;;
+;;; A VERBOSE-STRING is a typedef for a VERBOSE-POINTER except the
+;;; Lisp string is first converted to a C string. If things are
+;;; working properly, both type translators should be called when
+;;; converting a Lisp string to/from a C string.
+;;;
+;;; The translators should be called most-specific-first when
+;;; translating to C, and most-specific-last when translating from C.
+
+(defctype verbose-string verbose-pointer)
+
+(defmethod translate-to-foreign ((s string) (name (eql 'verbose-string)))
+ (let ((value (foreign-string-alloc s)))
+ (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~S~%" s value)
+ (values value t)))
+
+(defmethod translate-to-foreign (value (name (eql 'verbose-string)))
+ (if (pointerp value)
+ (progn
+ (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~:*~S~%" value)
+ (values value nil))
+ (error "Cannot convert ~S to a foreign string: it is not a Lisp ~
+ string or pointer." value)))
+
+(defmethod translate-from-foreign (ptr (name (eql 'verbose-string)))
+ (let ((value (foreign-string-to-lisp ptr)))
+ (format *debug-io* "~&;; from foreign: VERBOSE-STRING: ~S -> ~S~%" ptr value)
+ value))
+
+(defmethod free-translated-object (ptr (name (eql 'verbose-string)) free-p)
+ (when free-p
+ (foreign-string-free ptr)))
+
+(defun test-verbose-string ()
+ (foreign-funcall "getenv" verbose-string "SHELL" verbose-string))
+
+;;;# Testing Chained Parameters
+
+(defctype inner-type :int)
+(defctype middle-type inner-type)
+(defctype outer-type middle-type)
+
+(defmethod translate-to-foreign (value (name (eql 'inner-type)))
+ (values value 1))
+
+(defmethod translate-to-foreign (value (name (eql 'middle-type)))
+ (values value 2))
+
+(defmethod translate-to-foreign (value (name (eql 'outer-type)))
+ (values value 3))
+
+(defmethod free-translated-object (value (name (eql 'inner-type)) param)
+ (format t "~&;; free inner-type ~A~%" param))
+
+(defmethod free-translated-object (value (name (eql 'middle-type)) param)
+ (format t "~&;; free middle-type ~A~%" param))
+
+(defmethod free-translated-object (value (name (eql 'outer-type)) param)
+ (format t "~&;; free outer-type ~A~%" param))
Added: branches/xml-class-rework/thirdparty/cffi/scripts/release.sh
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/scripts/release.sh 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/scripts/release.sh 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,45 @@
+#! /bin/sh
+#
+# release.sh --- Create a signed tarball release for ASDF-INSTALL.
+#
+# Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation
+# files (the "Software"), to deal in the Software without
+# restriction, including without limitation the rights to use, copy,
+# modify, merge, publish, distribute, sublicense, and/or sell copies
+# of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+#
+
+VERSION=${VERSION:=`date +"%Y%m%d"`}
+TARBALL_NAME="cffi_$VERSION"
+TARBALL="$TARBALL_NAME.tar.gz"
+SIGNATURE="$TARBALL.asc"
+RELEASE_DIR=${RELEASE_DIR:="/project/cffi/public_html/releases"}
+
+echo "Creating distribution..."
+darcs dist -d "$TARBALL_NAME"
+
+echo "Signing tarball..."
+gpg -b -a "$TARBALL_NAME.tar.gz"
+
+echo "Copying tarball to web server..."
+scp "$TARBALL" "$SIGNATURE" common-lisp.net:"$RELEASE_DIR"
+
+echo "Uploaded $TARBALL and $SIGNATURE."
+echo "Don't forget to update the link on the CLiki page!"
+
Property changes on: branches/xml-class-rework/thirdparty/cffi/scripts/release.sh
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-allegro.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-allegro.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-allegro.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,414 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ ;#:make-shareable-byte-vector
+ ;#:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:defcfun-helper-forms
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; Backend mis-features.
+ cffi-features:no-long-long
+ ;; OS/CPU features.
+ #+macosx cffi-features:darwin
+ #+unix cffi-features:unix
+ #+mswindows cffi-features:windows
+ #+powerpc cffi-features:ppc32
+ #+x86 cffi-features:x86
+ #+x86-64 cffi-features:x86-64
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (if (eq excl:*current-case-mode* :case-sensitive-lower)
+ (string-downcase name)
+ (string-upcase name)))
+
+;;;# Basic Pointer Operations
+
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (integerp ptr))
+
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (eql ptr1 ptr2))
+
+(defun null-pointer ()
+ "Return a null pointer."
+ 0)
+
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ (zerop ptr))
+
+(defun inc-pointer (ptr offset)
+ "Return a pointer pointing OFFSET bytes past PTR."
+ (+ ptr offset))
+
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ address)
+
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ ptr)
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap. The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes on the heap and return a pointer."
+ (ff:allocate-fobject :char :c size))
+
+(defun foreign-free (ptr)
+ "Free a PTR allocated by FOREIGN-ALLOC."
+ (ff:free-fobject ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation. If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ `(let ((,size-var ,size))
+ (declare (ignorable ,size-var))
+ (ff:with-stack-fobject (,var :char :c ,size-var)
+ ,@body)))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+;(defun make-shareable-byte-vector (size)
+; "Create a Lisp vector of SIZE bytes can passed to
+;WITH-POINTER-TO-VECTOR-DATA."
+; (make-array size :element-type '(unsigned-byte 8)))
+;
+;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+; `(sb-sys:without-gcing
+; (let ((,ptr-var (sb-sys:vector-sap ,vector)))
+; ,@body)))
+
+;;;# Dereferencing
+
+(defun convert-foreign-type (type-keyword &optional (context :normal))
+ "Convert a CFFI type keyword to an Allegro type."
+ (ecase type-keyword
+ (:char :char)
+ (:unsigned-char :unsigned-char)
+ (:short :short)
+ (:unsigned-short :unsigned-short)
+ (:int :int)
+ (:unsigned-int :unsigned-int)
+ (:long :long)
+ (:unsigned-long :unsigned-long)
+ (:float :float)
+ (:double :double)
+ (:pointer (ecase context
+ (:normal '(* :void))
+ (:funcall :foreign-address)))
+ (:void :void)))
+
+(defun %mem-ref (ptr type &optional (offset 0))
+ "Dereference an object of TYPE at OFFSET bytes from PTR."
+ (unless (zerop offset)
+ (setf ptr (inc-pointer ptr offset)))
+ (ff:fslot-value-typed (convert-foreign-type type) :c ptr))
+
+;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the
+;;; CFFI type is constant. Allegro does its own transformation on the
+;;; call that results in efficient code.
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
+ (if (constantp type)
+ (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
+ `(ff:fslot-value-typed ',(convert-foreign-type (eval type))
+ :c ,ptr-form))
+ form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+ "Set the object of TYPE at OFFSET bytes from PTR."
+ (unless (zerop offset)
+ (setf ptr (inc-pointer ptr offset)))
+ (setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value))
+
+;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED)
+;;; when the CFFI type is constant. Allegro does its own
+;;; transformation on the call that results in efficient code.
+(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
+ (if (constantp type)
+ (once-only (val)
+ (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
+ `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval type))
+ :c ,ptr-form) ,val)))
+ form))
+
+;;;# Calling Foreign Functions
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (ff:sizeof-fobject (convert-foreign-type type-keyword)))
+
+(defun %foreign-type-alignment (type-keyword)
+ "Returns the alignment in bytes of a foreign type."
+ #+(and powerpc macosx32)
+ (when (eq type-keyword :double)
+ (return-from %foreign-type-alignment 8))
+ ;; No override necessary for the remaining types....
+ (ff::sized-ftype-prim-align
+ (ff::iforeign-type-sftype
+ (ff:get-foreign-type
+ (convert-foreign-type type-keyword)))))
+
+(defun foreign-funcall-type-and-args (args)
+ "Returns a list of types, list of args and return type."
+ (let ((return-type :void))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (convert-foreign-type type :funcall) into types
+ and collect arg into fargs
+ else do (setf return-type (convert-foreign-type type :funcall))
+ finally (return (values types fargs return-type)))))
+
+(defun convert-to-lisp-type (type)
+ (if (equal '(* :void) type)
+ 'integer
+ (ecase type
+ (:char 'signed-byte)
+ (:unsigned-char 'integer) ;'unsigned-byte)
+ ((:short
+ :unsigned-short
+ :int
+ :unsigned-int
+ :long
+ :unsigned-long) 'integer)
+ (:float 'single-float)
+ (:double 'double-float)
+ (:foreign-address :foreign-address)
+ (:void 'null))))
+
+(defun foreign-allegro-type (type)
+ (if (eq type :foreign-address)
+ nil
+ type))
+
+(defun allegro-type-pair (type)
+ (list (foreign-allegro-type type)
+ (convert-to-lisp-type type)))
+
+#+ignore
+(defun note-named-foreign-function (symbol name types rettype)
+ "Give Allegro's compiler a hint to perform a direct call."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',symbol 'system::direct-ff-call)
+ (list '(,name :language :c)
+ t ; callback
+ :c ; convention
+ ;; return type '(:c-type lisp-type)
+ ',(allegro-type-pair (convert-foreign-type rettype :funcall))
+ ;; arg types '({(:c-type lisp-type)}*)
+ '(,@(loop for type in types
+ collect (allegro-type-pair
+ (convert-foreign-type type :funcall))))
+ nil ; arg-checking
+ ff::ep-flag-never-release))))
+
+(defmacro %foreign-funcall (name &rest args)
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ `(system::ff-funcall
+ (load-time-value (excl::determine-foreign-address
+ '(,name :language :c)
+ ff::ep-flag-never-release
+ nil ; method-index
+ ))
+ ;; arg types {'(:c-type lisp-type) argN}*
+ ,@(mapcan (lambda (type arg)
+ `(',(allegro-type-pair type) ,arg))
+ types fargs)
+ ;; return type '(:c-type lisp-type)
+ ',(allegro-type-pair rettype))))
+
+(defun defcfun-helper-forms (name lisp-name rettype args types)
+ "Return 2 values for DEFCFUN. A prelude form and a caller form."
+ (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
+ (values
+ `(ff:def-foreign-call (,ff-name ,name)
+ ,(mapcar (lambda (ty)
+ (let ((allegro-type (convert-foreign-type ty)))
+ (list (gensym) allegro-type
+ (convert-to-lisp-type allegro-type))))
+ types)
+ :returning ,(allegro-type-pair
+ (convert-foreign-type rettype :funcall))
+ ;; Don't use call-direct when there are no arguments.
+ ,@(unless (null args) '(:call-direct t))
+ :arg-checking nil
+ :strings-convert nil)
+ `(,ff-name ,@args))))
+
+;;; See doc/allegro-internals.txt for a clue about entry-vec.
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ (with-unique-names (entry-vec)
+ `(let ((,entry-vec (excl::make-entry-vec-boa)))
+ (setf (aref ,entry-vec 1) ,ptr) ; set jump address
+ (system::ff-funcall
+ ,entry-vec
+ ;; arg types {'(:c-type lisp-type) argN}*
+ ,@(mapcan (lambda (type arg)
+ `(',(allegro-type-pair type) ,arg))
+ types fargs)
+ ;; return type '(:c-type lisp-type)
+ ',(allegro-type-pair rettype))))))
+
+;;;# Callbacks
+
+;;; The *CALLBACKS* hash table contains information about a callback
+;;; for the Allegro FFI. The key is the name of the CFFI callback,
+;;; and the value is a cons, the car containing the symbol the
+;;; callback was defined on in the CFFI-CALLBACKS package, the cdr
+;;; being an Allegro FFI pointer (a fixnum) that can be passed to C
+;;; functions.
+;;;
+;;; These pointers must be restored when a saved Lisp image is loaded.
+;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to
+;;; re-register the callbacks during Lisp startup.
+(defvar *callbacks* (make-hash-table))
+
+;;; Register a callback in the *CALLBACKS* hash table.
+(defun register-callback (cffi-name callback-name)
+ (setf (gethash cffi-name *callbacks*)
+ (cons callback-name (ff:register-foreign-callable
+ callback-name :reuse t))))
+
+;;; Restore the saved pointers in *CALLBACKS* when loading an image.
+(defun restore-callbacks ()
+ (maphash (lambda (key value)
+ (register-callback key (car value)))
+ *callbacks*))
+
+;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing
+;;; CFFI is restarted.
+(eval-when (:load-toplevel :execute)
+ (pushnew 'restore-callbacks excl:*restart-actions*))
+
+;;; Create a package to contain the symbols for callback functions.
+(defpackage #:cffi-callbacks
+ (:use))
+
+(defun intern-callback (name)
+ (intern (format nil "~A::~A" (package-name (symbol-package name))
+ (symbol-name name))
+ '#:cffi-callbacks))
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ (declare (ignore rettype))
+ (let ((cb-name (intern-callback name)))
+ `(progn
+ (ff:defun-foreign-callable ,cb-name
+ ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
+ arg-names arg-types)
+ (declare (:convention :c))
+ ,@body)
+ (register-callback ',name ',cb-name))))
+
+;;; Return the saved Lisp callback pointer from *CALLBACKS* for the
+;;; CFFI callback named NAME.
+(defun %callback (name)
+ (or (cdr (gethash name *callbacks*))
+ (error "Undefined callback: ~S" name)))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load the foreign library NAME."
+ ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load
+ ;; the argument. However, previous versions do not and will only
+ ;; foreign load the argument if its type is a member of the
+ ;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special
+ ;; to a list containing whatever type NAME has.
+ (let ((excl::*load-foreign-types*
+ (list (pathname-type (parse-namestring name)))))
+ (ignore-errors #+(version>= 7) (load name :foreign t)
+ #-(version>= 7) (load name))))
+
+(defun %close-foreign-library (name)
+ "Close the foreign library NAME."
+ (ff:unload-foreign-library name))
+
+;;;# Foreign Globals
+
+(defun convert-external-name (name)
+ "Add an underscore to NAME if necessary for the ABI."
+ #+macosx (concatenate 'string "_" name)
+ #-macosx name)
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol NAME."
+ (prog1 (ff:get-entry-point (convert-external-name name))))
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-clisp.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-clisp.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-clisp.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,333 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;; (C) 2005, Joerg Hoehle <hoehle(a)users.sourceforge.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ #:foreign-symbol-pointer
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;; FIXME: long-long could be supported anyway on 64-bit machines. --luis
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; Backend mis-features.
+ cffi-features:no-long-long
+ ;; OS/CPU features.
+ #+macos cffi-features:darwin
+ #+unix cffi-features:unix
+ #+win32 cffi-features:windows
+ ))
+ (cond ((string-equal (machine-type) "X86_64")
+ (pushnew 'cffi-features:x86-64 *features*))
+ ((member :pc386 *features*)
+ (pushnew 'cffi-features:x86 *features*))
+ ;; FIXME: probably catches PPC64 as well
+ ((string-equal (machine-type) "POWER MACINTOSH")
+ (pushnew 'cffi-features:ppc32 *features*))))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Built-In Foreign Types
+
+(defun convert-foreign-type (type)
+ "Convert a CFFI built-in type keyword to a CLisp FFI type."
+ (ecase type
+ (:char 'ffi:char)
+ (:unsigned-char 'ffi:uchar)
+ (:short 'ffi:short)
+ (:unsigned-short 'ffi:ushort)
+ (:int 'ffi:int)
+ (:unsigned-int 'ffi:uint)
+ (:long 'ffi:long)
+ (:unsigned-long 'ffi:ulong)
+ (:float 'ffi:single-float)
+ (:double 'ffi:double-float)
+ ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
+ ;; we have a workaround in the pointer operations...
+ (:pointer 'ffi:c-pointer)
+ (:void nil)))
+
+(defun %foreign-type-size (type)
+ "Return the size in bytes of objects having foreign type TYPE."
+ (nth-value 0 (ffi:sizeof (convert-foreign-type type))))
+
+;; Remind me to buy a beer for whoever made getting the alignment
+;; of foreign types part of the public interface in CLisp. :-)
+(defun %foreign-type-alignment (type)
+ "Return the structure alignment in bytes of foreign TYPE."
+ #+(and cffi-features:darwin cffi-features:ppc32)
+ (when (eq type :double)
+ (return-from %foreign-type-alignment 8))
+ ;; Override not necessary for the remaining types...
+ (nth-value 1 (ffi:sizeof (convert-foreign-type type))))
+
+;;;# Basic Pointer Operations
+
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (or (null ptr) (typep ptr 'ffi:foreign-address)))
+
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (eql (ffi:foreign-address-unsigned ptr1)
+ (ffi:foreign-address-unsigned ptr2)))
+
+(defun null-pointer ()
+ "Return a null foreign pointer."
+ (ffi:unsigned-foreign-address 0))
+
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null foreign pointer."
+ (or (null ptr) (zerop (ffi:foreign-address-unsigned ptr))))
+
+(defun inc-pointer (ptr offset)
+ "Return a pointer pointing OFFSET bytes past PTR."
+ (ffi:unsigned-foreign-address
+ (+ offset (if (null ptr) 0 (ffi:foreign-address-unsigned ptr)))))
+
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ (ffi:unsigned-foreign-address address))
+
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ (ffi:foreign-address-unsigned ptr))
+
+;;;# Foreign Memory Allocation
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes of foreign-addressable memory and return a
+pointer to the allocated block. An implementation-specific error
+is signalled if the memory cannot be allocated."
+ (ffi:foreign-address (ffi:allocate-shallow 'ffi:uint8 :count size)))
+
+(defun foreign-free (ptr)
+ "Free a pointer PTR allocated by FOREIGN-ALLOC. The results
+are undefined if PTR is used after being freed."
+ (ffi:foreign-free ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to a pointer to SIZE bytes of foreign-addressable
+memory during BODY. Both PTR and the memory block pointed to
+have dynamic extent and may be stack allocated if supported by
+the implementation. If SIZE-VAR is supplied, it will be bound to
+SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ (let ((obj-var (gensym)))
+ `(let ((,size-var ,size))
+ (ffi:with-foreign-object
+ (,obj-var `(ffi:c-array ffi:uint8 ,,size-var))
+ (let ((,var (ffi:foreign-address ,obj-var)))
+ ,@body)))))
+
+;;;# Memory Access
+
+(defun %mem-ref (ptr type &optional (offset 0))
+ "Dereference a pointer OFFSET bytes from PTR to an object of
+built-in foreign TYPE. Returns the object as a foreign pointer
+or Lisp number."
+ (ffi:memory-as ptr (convert-foreign-type type) offset))
+
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
+ "Compiler macro to open-code when TYPE is constant."
+ (if (constantp type)
+ `(ffi:memory-as ,ptr ',(convert-foreign-type (eval type)) ,offset)
+ form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+ "Set a pointer OFFSET bytes from PTR to an object of built-in
+foreign TYPE to VALUE."
+ (setf (ffi:memory-as ptr (convert-foreign-type type) offset) value))
+
+(define-compiler-macro %mem-set
+ (&whole form value ptr type &optional (offset 0))
+ (if (constantp type)
+ ;; (setf (ffi:memory-as) value) is exported, but not so nice
+ ;; w.r.t. the left to right evaluation rule
+ `(ffi::write-memory-as ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
+ form))
+
+;;;# Foreign Function Calling
+
+(defun parse-foreign-funcall-args (args)
+ "Return three values, a list of CLisp FFI types, a list of
+values to pass to the function, and the CLisp FFI return type."
+ (let ((return-type nil))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (list (gensym) (convert-foreign-type type)) into types
+ and collect arg into fargs
+ else do (setf return-type (convert-foreign-type type))
+ finally (return (values types fargs return-type)))))
+
+(defmacro %foreign-funcall (name &rest args)
+ "Invoke a foreign function called NAME, taking pairs of
+foreign-type/value pairs from ARGS. If a single element is left
+over at the end of ARGS, it specifies the foreign return type of
+the function call."
+ (multiple-value-bind (types fargs rettype)
+ (parse-foreign-funcall-args args)
+ (let ((ctype `(ffi:c-function (:arguments ,@types)
+ (:return-type ,rettype)
+ (:language :stdc))))
+ `(funcall
+ (load-time-value
+ (multiple-value-bind (ff error)
+ (ignore-errors
+ (ffi::foreign-library-function
+ ,name (ffi::foreign-library :default)
+ nil (ffi:parse-c-type ',ctype)))
+ (or ff
+ (warn (format nil "~?"
+ (simple-condition-format-control error)
+ (simple-condition-format-arguments error))))))
+ ,@fargs))))
+
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ "Similar to %foreign-funcall but takes a pointer instead of a string."
+ (multiple-value-bind (types fargs rettype)
+ (parse-foreign-funcall-args args)
+ `(funcall (ffi:foreign-function ,ptr
+ (load-time-value
+ (ffi:parse-c-type
+ '(ffi:c-function
+ (:arguments ,@types)
+ (:return-type ,rettype)
+ (:language :stdc)))))
+ ,@fargs)))
+
+;;;# Callbacks
+
+;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK
+;;; macro. The symbol naming the callback is the key, and the value
+;;; is a list containing a Lisp function, the parsed CLISP FFI type of
+;;; the callback, and a saved pointer that should not persist across
+;;; saved images.
+(defvar *callbacks* (make-hash-table))
+
+;;; Return a CLISP FFI function type for a CFFI callback function
+;;; given a return type and list of argument names and types.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun callback-type (rettype arg-names arg-types)
+ (ffi:parse-c-type
+ `(ffi:c-function
+ (:arguments ,@(mapcar (lambda (sym type)
+ (list sym (convert-foreign-type type)))
+ arg-names arg-types))
+ (:return-type ,(convert-foreign-type rettype))
+ (:language :stdc)))))
+
+;;; Register and create a callback function.
+(defun register-callback (name function parsed-type)
+ (setf (gethash name *callbacks*)
+ (list function parsed-type
+ (ffi:with-foreign-object (ptr 'ffi:c-pointer)
+ ;; Create callback by converting Lisp function to foreign
+ (setf (ffi:memory-as ptr parsed-type) function)
+ (ffi:foreign-value ptr)))))
+
+;;; Restore all saved callback pointers when restarting the Lisp
+;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*.
+;;; Needs clisp > 2.35, bugfix 2005-09-29
+(defun restore-callback-pointers ()
+ (maphash
+ (lambda (name list)
+ (register-callback name (first list) (second list)))
+ *callbacks*))
+
+;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
+;;; when an image is restarted.
+(eval-when (:load-toplevel :execute)
+ (pushnew 'restore-callback-pointers custom:*init-hooks*))
+
+;;; Define a callback function NAME to run BODY with arguments
+;;; ARG-NAMES translated according to ARG-TYPES and the return type
+;;; translated according to RETTYPE. Obtain a pointer that can be
+;;; passed to C code for this callback by calling %CALLBACK.
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ `(register-callback ',name (lambda ,arg-names ,@body)
+ ,(callback-type rettype arg-names arg-types)))
+
+;;; Look up the name of a callback and return a pointer that can be
+;;; passed to a C function. Signals an error if no callback is
+;;; defined called NAME.
+(defun %callback (name)
+ (multiple-value-bind (list winp) (gethash name *callbacks*)
+ (unless winp
+ (error "Undefined callback: ~S" name))
+ (third list)))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load a foreign library from NAME."
+ (ffi::foreign-library name))
+
+(defun %close-foreign-library (name)
+ "Close a foreign library NAME."
+ (ffi:close-foreign-library name))
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol NAME."
+ (prog1 (ignore-errors
+ (ffi:foreign-address
+ (ffi::foreign-library-variable
+ name (ffi::foreign-library :default) nil nil)))))
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-cmucl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-cmucl.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-cmucl.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,347 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-sbcl.lisp --- CFFI-SYS implementation for CMU CL.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:alien #:c-call #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ #:make-shareable-byte-vector
+ #:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; OS/CPU features.
+ #+darwin cffi-features:darwin
+ #+unix cffi-features:unix
+ #+x86 cffi-features:x86
+ #+(and ppc (not ppc64)) cffi-features:ppc32
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Basic Pointer Operations
+
+(declaim (inline pointerp))
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (sys:system-area-pointer-p ptr))
+
+(declaim (inline pointer-eq))
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (sys:sap= ptr1 ptr2))
+
+(declaim (inline null-pointer))
+(defun null-pointer ()
+ "Construct and return a null pointer."
+ (sys:int-sap 0))
+
+(declaim (inline null-pointer-p))
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ (zerop (sys:sap-int ptr)))
+
+(declaim (inline inc-pointer))
+(defun inc-pointer (ptr offset)
+ "Return a pointer pointing OFFSET bytes past PTR."
+ (sys:sap+ ptr offset))
+
+(declaim (inline make-pointer))
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ (sys:int-sap address))
+
+(declaim (inline pointer-address))
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ (sys:sap-int ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation. If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ ;; If the size is constant we can stack-allocate.
+ (if (constantp size)
+ (let ((alien-var (gensym "ALIEN")))
+ `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
+ (let ((,size-var ,(eval size))
+ (,var (alien-sap ,alien-var)))
+ (declare (ignorable ,size-var))
+ ,@body)))
+ `(let* ((,size-var ,size)
+ (,var (%foreign-alloc ,size-var)))
+ (unwind-protect
+ (progn ,@body)
+ (foreign-free ,var)))))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap. The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes on the heap and return a pointer."
+ (declare (type (unsigned-byte 32) size))
+ (alien-funcall
+ (extern-alien
+ "malloc"
+ (function system-area-pointer unsigned))
+ size))
+
+(defun foreign-free (ptr)
+ "Free a PTR allocated by FOREIGN-ALLOC."
+ (declare (type system-area-pointer ptr))
+ (alien-funcall
+ (extern-alien
+ "free"
+ (function (values) system-area-pointer))
+ ptr))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(defun make-shareable-byte-vector (size)
+ "Create a Lisp vector of SIZE bytes that can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+ (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+ "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+ `(sys:without-gcing
+ (let ((,ptr-var (sys:vector-sap ,vector)))
+ ,@body)))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+ `(progn
+ (defun %mem-ref (ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (,fn ptr offset)))))
+ (defun %mem-set (value ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (setf (,fn ptr offset) value)))))
+ (define-compiler-macro %mem-ref
+ (&whole form ptr type &optional (offset 0))
+ (if (constantp type)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(,',fn ,ptr ,offset))))
+ form))
+ (define-compiler-macro %mem-set
+ (&whole form value ptr type &optional (offset 0))
+ (if (constantp type)
+ (once-only (value)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(setf (,',fn ,ptr ,offset)
+ ,value)))))
+ form))))
+
+(define-mem-accessors
+ (:char sys:signed-sap-ref-8)
+ (:unsigned-char sys:sap-ref-8)
+ (:short sys:signed-sap-ref-16)
+ (:unsigned-short sys:sap-ref-16)
+ (:int sys:signed-sap-ref-32)
+ (:unsigned-int sys:sap-ref-32)
+ (:long sys:signed-sap-ref-32)
+ (:unsigned-long sys:sap-ref-32)
+ (:long-long sys:signed-sap-ref-64)
+ (:unsigned-long-long sys:sap-ref-64)
+ (:float sys:sap-ref-single)
+ (:double sys:sap-ref-double)
+ (:pointer sys:sap-ref-sap))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to an ALIEN type."
+ (ecase type-keyword
+ (:char 'char)
+ (:unsigned-char 'unsigned-char)
+ (:short 'short)
+ (:unsigned-short 'unsigned-short)
+ (:int 'int)
+ (:unsigned-int 'unsigned-int)
+ (:long 'long)
+ (:unsigned-long 'unsigned-long)
+ (:long-long '(signed 64))
+ (:unsigned-long-long '(unsigned 64))
+ (:float 'single-float)
+ (:double 'double-float)
+ (:pointer 'system-area-pointer)
+ (:void 'void)))
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (/ (alien-internals:alien-type-bits
+ (alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword))) 8))
+
+(defun %foreign-type-alignment (type-keyword)
+ "Return the alignment in bytes of a foreign type."
+ (/ (alien-internals:alien-type-alignment
+ (alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword))) 8))
+
+(defun foreign-funcall-type-and-args (args)
+ "Return an ALIEN function type for ARGS."
+ (let ((return-type nil))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (convert-foreign-type type) into types
+ and collect arg into fargs
+ else do (setf return-type (convert-foreign-type type))
+ finally (return (values types fargs return-type)))))
+
+(defmacro %%foreign-funcall (name types fargs rettype)
+ "Internal guts of %FOREIGN-FUNCALL."
+ `(alien-funcall
+ (extern-alien ,name (function ,rettype ,@types))
+ ,@fargs))
+
+(defmacro %foreign-funcall (name &rest args)
+ "Perform a foreign function call, document it more later."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
+
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ "Funcall a pointer to a foreign function."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ (with-unique-names (function)
+ `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
+ (alien-funcall ,function ,@fargs)))))
+
+;;;# Callbacks
+
+(defvar *callbacks* (make-hash-table))
+
+;;; Create a package to contain the symbols for callback functions. We
+;;; want to redefine callbacks with the same symbol so the internal data
+;;; structures are reused.
+(defpackage #:cffi-callbacks
+ (:use))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
+;;; callback for NAME.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun intern-callback (name)
+ (intern (format nil "~A::~A" (package-name (symbol-package name))
+ (symbol-name name))
+ '#:cffi-callbacks)))
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ (let ((cb-name (intern-callback name)))
+ `(progn
+ (def-callback ,cb-name
+ (,(convert-foreign-type rettype)
+ ,@(mapcar (lambda (sym type)
+ (list sym (convert-foreign-type type)))
+ arg-names arg-types))
+ ,@body)
+ (setf (gethash ',name *callbacks*) (callback ,cb-name)))))
+
+(defun %callback (name)
+ (multiple-value-bind (pointer winp)
+ (gethash name *callbacks*)
+ (unless winp
+ (error "Undefined callback: ~S" name))
+ pointer))
+
+;;;# Loading and Closing Foreign Libraries
+
+;;; Work-around for compiling ffi code without loading the
+;;; respective library at compile-time.
+(setf c::top-level-lambda-max 0)
+
+(defun %load-foreign-library (name)
+ "Load the foreign library NAME."
+ (sys::load-object-file name))
+
+;;; XXX: doesn't work on Darwin; does not check for errors. I suppose we'd
+;;; want something like SBCL's dlclose-or-lose in foreign-load.lisp:66
+(defun %close-foreign-library (name)
+ "Closes the foreign library NAME."
+ (let ((lib (find name sys::*global-table* :key #'cdr :test #'string=)))
+ (sys::dlclose (car lib))
+ (setf (car lib) (sys:int-sap 0))))
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol NAME."
+ (let ((address (sys:alternate-get-global-address
+ (vm:extern-alien-name name))))
+ (if (zerop address)
+ nil
+ (sys:int-sap address))))
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-corman.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-corman.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-corman.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,321 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:c-types #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ ;#:make-shareable-byte-vector
+ ;#:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:defcfun-helper-forms
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; Backend mis-features.
+ cffi-features:no-long-long
+ cffi-features:no-foreign-funcall
+ ;; OS/CPU features.
+ cffi-features:windows
+ cffi-features:x86
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Basic Pointer Operations
+
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (cpointerp ptr))
+
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (cpointer= ptr1 ptr2))
+
+(defun null-pointer ()
+ "Return a null pointer."
+ (create-foreign-ptr))
+
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ (cpointer-null ptr))
+
+(defun inc-pointer (ptr offset)
+ "Return a pointer pointing OFFSET bytes past PTR."
+ (let ((new-ptr (create-foreign-ptr)))
+ (setf (cpointer-value new-ptr)
+ (+ (cpointer-value ptr) offset))
+ new-ptr))
+
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ (int-to-foreign-ptr address))
+
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ (foreign-ptr-to-int ptr))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap. The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes on the heap and return a pointer."
+ (malloc size))
+
+(defun foreign-free (ptr)
+ "Free a PTR allocated by FOREIGN-ALLOC."
+ (free ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation. If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ `(let* ((,size-var ,size)
+ (,var (malloc ,size-var)))
+ (unwind-protect
+ (progn ,@body)
+ (free ,var))))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+;(defun make-shareable-byte-vector (size)
+; "Create a Lisp vector of SIZE bytes can passed to
+;WITH-POINTER-TO-VECTOR-DATA."
+; (make-array size :element-type '(unsigned-byte 8)))
+;
+;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+; `(sb-sys:without-gcing
+; (let ((,ptr-var (sb-sys:vector-sap ,vector)))
+; ,@body)))
+
+;;;# Dereferencing
+
+;; According to the docs, Corman's C Function Definition Parser
+;; converts int to long, so we'll assume that.
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to a CormanCL type."
+ (ecase type-keyword
+ (:char :char)
+ (:unsigned-char :unsigned-char)
+ (:short :short)
+ (:unsigned-short :unsigned-short)
+ (:int :long)
+ (:unsigned-int :unsigned-long)
+ (:long :long)
+ (:unsigned-long :unsigned-long)
+ (:float :single-float)
+ (:double :double-float)
+ (:pointer :handle)
+ (:void :void)))
+
+(defun %mem-ref (ptr type &optional (offset 0))
+ "Dereference an object of TYPE at OFFSET bytes from PTR."
+ (unless (eql offset 0)
+ (setq ptr (inc-pointer ptr offset)))
+ (ecase type
+ (:char (cref (:char *) ptr 0))
+ (:unsigned-char (cref (:unsigned-char *) ptr 0))
+ (:short (cref (:short *) ptr 0))
+ (:unsigned-short (cref (:unsigned-short *) ptr 0))
+ (:int (cref (:long *) ptr 0))
+ (:unsigned-int (cref (:unsigned-long *) ptr 0))
+ (:long (cref (:long *) ptr 0))
+ (:unsigned-long (cref (:unsigned-long *) ptr 0))
+ (:float (cref (:single-float *) ptr 0))
+ (:double (cref (:double-float *) ptr 0))
+ (:pointer (cref (:handle *) ptr 0))))
+
+;(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
+; (if (constantp type)
+; `(cref (,(convert-foreign-type type) *) ,ptr ,offset)
+; form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+ "Set the object of TYPE at OFFSET bytes from PTR."
+ (unless (eql offset 0)
+ (setq ptr (inc-pointer ptr offset)))
+ (ecase type
+ (:char (setf (cref (:char *) ptr 0) value))
+ (:unsigned-char (setf (cref (:unsigned-char *) ptr 0) value))
+ (:short (setf (cref (:short *) ptr 0) value))
+ (:unsigned-short (setf (cref (:unsigned-short *) ptr 0) value))
+ (:int (setf (cref (:long *) ptr 0) value))
+ (:unsigned-int (setf (cref (:unsigned-long *) ptr 0) value))
+ (:long (setf (cref (:long *) ptr 0) value))
+ (:unsigned-long (setf (cref (:unsigned-long *) ptr 0) value))
+ (:float (setf (cref (:single-float *) ptr 0) value))
+ (:double (setf (cref (:double-float *) ptr 0) value))
+ (:pointer (setf (cref (:handle *) ptr 0) value))))
+
+;;;# Calling Foreign Functions
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (sizeof (convert-foreign-type type-keyword)))
+
+;; Couldn't find anything in sys/ffi.lisp and the C declaration parser
+;; doesn't seem to care about alignment so we'll assume that it's the
+;; same as its size.
+(defun %foreign-type-alignment (type-keyword)
+ (sizeof (convert-foreign-type type-keyword)))
+
+(defun find-dll-containing-function (name)
+ "Searches for NAME in the loaded DLLs. If found, returns
+the DLL's name (a string), else returns NIL."
+ (dolist (dll ct::*dlls-loaded*)
+ (when (ignore-errors
+ (ct::get-dll-proc-address name (ct::dll-record-handle dll)))
+ (return (ct::dll-record-name dll)))))
+
+;; This won't work at all...
+;(defmacro %foreign-funcall (name &rest args)
+; (let ((sym (gensym)))
+; `(let (,sym)
+; (ct::install-dll-function ,(find-dll-containing-function name)
+; ,name ,sym)
+; (funcall ,sym ,@(loop for (type arg) on args by #'cddr
+; if arg collect arg)))))
+
+;; It *might* be possible to implement by copying
+;; most of the code from Corman's DEFUN-DLL.
+(defmacro %foreign-funcall (name &rest args)
+ "Call a foreign function NAME passing arguments ARGS."
+ `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
+
+(defun defcfun-helper-forms (name lisp-name rettype args types)
+ "Return 2 values for DEFCFUN. A prelude form and a caller form."
+ (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name)))
+ ;; XXX This will only work if the dll is already loaded, fix this.
+ (dll (find-dll-containing-function name)))
+ (values
+ `(defun-dll ,ff-name
+ ,(mapcar (lambda (type)
+ (list (gensym) (convert-foreign-type type)))
+ types)
+ :return-type ,(convert-foreign-type rettype)
+ :library-name ,dll
+ :entry-name ,name
+ ;; we want also :pascal linkage type to access
+ ;; the win32 api for instance..
+ :linkage-type :c)
+ `(,ff-name ,@args))))
+
+;;;# Callbacks
+
+;; defun-c-callback vs. defun-direct-c-callback?
+;; same issue as Allegro, no return type declaration, should we coerce?
+(defmacro %defcallback (name rettype arg-names arg-types body-form)
+ (declare (ignore rettype))
+ (with-unique-names (cb-sym)
+ `(progn
+ (defun-c-callback ,cb-sym
+ ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
+ arg-names arg-types)
+ ,body-form)
+ (setf (get ',name 'callback-ptr)
+ (get-callback-procinst ',cb-sym)))))
+
+;;; Just continue to use the plist for now even though this really
+;;; should use a *CALLBACKS* hash table and not define the callbacks
+;;; as gensyms. Someone with access to Corman should update this.
+(defun %callback (name)
+ (get name 'callback-ptr))
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load the foreign library NAME."
+ (ct::get-dll-record name))
+
+(defun %close-foreign-library (name)
+ "Close the foreign library NAME."
+ (error "Not implemented."))
+
+;;;# Foreign Globals
+
+;; FFI to GetProcAddress from the Win32 API.
+;; "The GetProcAddress function retrieves the address of an exported
+;; function or variable from the specified dynamic-link library (DLL)."
+(defun-dll get-proc-address
+ ((module HMODULE)
+ (name LPCSTR))
+ :return-type FARPROC
+ :library-name "Kernel32.dll"
+ :entry-name "GetProcAddress"
+ :linkage-type :pascal)
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol NAME."
+ (let ((str (lisp-string-to-c-string name)))
+ (unwind-protect
+ (dolist (dll ct::*dlls-loaded*)
+ (let ((ptr (get-proc-address
+ (int-to-foreign-ptr (ct::dll-record-handle dll))
+ str)))
+ (when (not (cpointer-null ptr))
+ (return ptr))))
+ (free str))))
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-ecl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-ecl.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-ecl.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,266 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-ecl.lisp --- ECL backend for CFFI.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%mem-ref
+ #:%mem-set
+ #:%foreign-funcall
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:make-shareable-byte-vector
+ #:with-pointer-to-vector-data
+ #:%defcallback
+ #:%callback
+ #:foreign-symbol-pointer))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; Backend mis-features.
+ cffi-features:no-long-long
+ ;; OS/CPU features.
+ #+darwin cffi-features:darwin
+ #+unix cffi-features:unix
+ #+win32 cffi-features:windows
+ ;; XXX: figure out a way to get a X86 feature
+ ;;#+athlon cffi-features:x86
+ #+powerpc7450 cffi-features:ppc32
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Allocation
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes of foreign-addressable memory."
+ (si:allocate-foreign-data :void size))
+
+(defun foreign-free (ptr)
+ "Free a pointer PTR allocated by FOREIGN-ALLOC."
+ (si:free-foreign-data ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation. If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ `(let* ((,size-var ,size)
+ (,var (%foreign-alloc ,size-var)))
+ (unwind-protect
+ (progn ,@body)
+ (foreign-free ,var))))
+
+;;;# Misc. Pointer Operations
+
+(defun null-pointer ()
+ "Construct and return a null pointer."
+ (si:allocate-foreign-data :void 0))
+
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ (si:null-pointer-p ptr))
+
+(defun inc-pointer (ptr offset)
+ "Return a pointer OFFSET bytes past PTR."
+ (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
+
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (typep ptr 'si:foreign-data))
+
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
+
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ (ffi:make-pointer address :void))
+
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ (ffi:pointer-address ptr))
+
+;;;# Dereferencing
+
+(defun %mem-ref (ptr type &optional (offset 0))
+ "Dereference an object of TYPE at OFFSET bytes from PTR."
+ (let* ((type (convert-foreign-type type))
+ (type-size (ffi:size-of-foreign-type type)))
+ (si:foreign-data-ref-elt
+ (si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+ "Set an object of TYPE at OFFSET bytes from PTR."
+ (let* ((type (convert-foreign-type type))
+ (type-size (ffi:size-of-foreign-type type)))
+ (si:foreign-data-set-elt
+ (si:foreign-data-recast ptr (+ offset type-size) :void)
+ offset type value)))
+
+;;;# Type Operations
+
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to an ECL type keyword."
+ (ecase type-keyword
+ (:char :byte)
+ (:unsigned-char :unsigned-byte)
+ (:short :short)
+ (:unsigned-short :unsigned-short)
+ (:int :int)
+ (:unsigned-int :unsigned-int)
+ (:long :long)
+ (:unsigned-long :unsigned-long)
+ (:float :float)
+ (:double :double)
+ (:pointer :pointer-void)
+ (:void :void)))
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (nth-value 0 (ffi:size-of-foreign-type
+ (convert-foreign-type type-keyword))))
+
+(defun %foreign-type-alignment (type-keyword)
+ "Return the alignment in bytes of a foreign type."
+ (nth-value 1 (ffi:size-of-foreign-type
+ (convert-foreign-type type-keyword))))
+
+;;;# Calling Foreign Functions
+
+(defun produce-function-call (c-name nargs)
+ (format nil "~a(~a)" c-name
+ (subseq "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z"
+ 0 (max 0 (1- (* nargs 3))))))
+
+#-dfii
+(defun foreign-function-inline-form (name arg-types arg-values return-type)
+ "Generate a C-INLINE form for a foreign function call."
+ `(ffi:c-inline
+ ,arg-values ,arg-types ,return-type
+ ,(produce-function-call name (length arg-values))
+ :one-liner t :side-effects t))
+
+#+dffi
+(defun foreign-function-dynamic-form (name arg-types arg-values return-type)
+ "Generate a dynamic FFI form for a foreign function call."
+ `(si:call-cfun (si:find-foreign-symbol ,name :default :pointer-void 0)
+ ,return-type (list ,@arg-types) (list ,@arg-values)))
+
+(defun foreign-funcall-parse-args (args)
+ "Return three values, lists of arg types, values, and result type."
+ (let ((return-type :void))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (convert-foreign-type type) into types
+ and collect arg into values
+ else do (setf return-type (convert-foreign-type type))
+ finally (return (values types values return-type)))))
+
+(defmacro %foreign-funcall (name &rest args)
+ "Call a foreign function."
+ (multiple-value-bind (types values return-type)
+ (foreign-funcall-parse-args args)
+ #-dffi (foreign-function-inline-form name types values return-type)
+ #+dffi (foreign-function-dynamic-form name types values return-type)))
+
+#+dffi
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ "Funcall a pointer to a foreign function."
+ (multiple-value-bind (types values return-type)
+ (foreign-funcall-parse-args args)
+ `(si:call-cfun ,ptr ,return-type (list ,@arg-types) (list ,@arg-values))))
+
+;;;# Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load a foreign library from NAME."
+ #-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
+ FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.")
+ #+dffi (ffi:load-foreign-library name))
+
+;;;# Callbacks
+
+;;; Create a package to contain the symbols for callback functions.
+;;; We want to redefine callbacks with the same symbol so the internal
+;;; data structures are reused.
+(defpackage #:cffi-callbacks
+ (:use))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
+;;; internal callback for NAME.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun intern-callback (name)
+ (intern (format nil "~A::~A" (package-name (symbol-package name))
+ (symbol-name name))
+ '#:cffi-callbacks)))
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ (let ((cb-name (intern-callback name)))
+ `(progn
+ (ffi:defcallback (,cb-name :cdecl)
+ ,(convert-foreign-type rettype)
+ ,(mapcar #'list arg-names
+ (mapcar #'convert-foreign-type arg-types))
+ ,@body)
+ (setf (gethash ',name *callbacks*) ',cb-name))))
+
+(defun %callback (name)
+ (multiple-value-bind (symbol winp)
+ (gethash name *callbacks*)
+ (unless winp
+ (error "Undefined callback: ~S" name))
+ (ffi:callback name)))
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name kind)
+ "Returns a pointer to a foreign symbol NAME."
+ (si:find-foreign-symbol name :default :pointer-void 0))
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-gcl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-gcl.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-gcl.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,313 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; GCL specific notes:
+;;;
+;;; On ELF systems, a library can be loaded with the help of this:
+;;; http://www.copyleft.de/lisp/gcl-elf-loader.html
+;;;
+;;; Another way is to link the library when creating a new image:
+;;; (compiler::link nil "new_image" "" "-lfoo")
+;;;
+;;; As GCL's FFI is not dynamic, CFFI declarations will only work
+;;; after compiled and loaded.
+
+;;; *** this port is broken ***
+;;; gcl doesn't compile the rest of CFFI anyway..
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-ptr
+ #:null-ptr
+ #:null-ptr-p
+ #:inc-ptr
+ #:%mem-ref
+ #:%mem-set
+ #:%foreign-funcall
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ ;#:make-shareable-byte-vector
+ ;#:with-pointer-to-vector-data
+ #:foreign-var-ptr
+ #:make-callback))
+
+(in-package #:cffi-sys)
+
+;;;# Mis-*features*
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew :cffi/no-foreign-funcall *features*))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap. The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
+;;; usage when the memory has dynamic extent.
+
+(defentry %foreign-alloc (int) (int "malloc"))
+
+;(defun foreign-alloc (size)
+; "Allocate SIZE bytes on the heap and return a pointer."
+; (%foreign-alloc size))
+
+(defentry foreign-free (int) (void "free"))
+
+;(defun foreign-free (ptr)
+; "Free a PTR allocated by FOREIGN-ALLOC."
+; (%free ptr))
+
+(defmacro with-foreign-ptr ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation. If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ `(let* ((,size-var ,size)
+ (,var (foreign-alloc ,size-var)))
+ (unwind-protect
+ (progn ,@body)
+ (foreign-free ,var))))
+
+;;;# Misc. Pointer Operations
+
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (integerp ptr))
+
+(defun null-ptr ()
+ "Construct and return a null pointer."
+ 0)
+
+(defun null-ptr-p (ptr)
+ "Return true if PTR is a null pointer."
+ (= ptr 0))
+
+(defun inc-ptr (ptr offset)
+ "Return a pointer OFFSET bytes past PTR."
+ (+ ptr offset))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+;(defun make-shareable-byte-vector (size)
+; "Create a Lisp vector of SIZE bytes that can passed to
+;WITH-POINTER-TO-VECTOR-DATA."
+; (make-array size :element-type '(unsigned-byte 8)))
+
+;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+; `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
+; ,@body))
+
+;;;# Dereferencing
+
+(defmacro define-mem-ref/set (type gcl-type &optional c-name)
+ (unless c-name
+ (setq c-name (substitute #\_ #\Space type)))
+ (let ((ref-fn (concatenate 'string "ref_" c-name))
+ (set-fn (concatenate 'string "set_" c-name)))
+ `(progn
+ ;; ref
+ (defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
+ 0 "return *ptr;")
+ (defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
+ (int) (,gcl-type ,ref-fn))
+ ;; set
+ (defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type)
+ 0 "*ptr = value;")
+ (defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
+ (int ,gcl-type) (void ,set-fn)))))
+
+(define-mem-ref/set "char" char)
+(define-mem-ref/set "unsigned char" char)
+(define-mem-ref/set "short" int)
+(define-mem-ref/set "unsigned short" int)
+(define-mem-ref/set "int" int)
+(define-mem-ref/set "unsigned int" int)
+(define-mem-ref/set "long" int)
+(define-mem-ref/set "unsigned long" int)
+(define-mem-ref/set "float" float)
+(define-mem-ref/set "double" double)
+(define-mem-ref/set "void *" int "ptr")
+
+(defun %mem-ref (ptr type &optional (offset 0))
+ "Dereference an object of TYPE at OFFSET bytes from PTR."
+ (unless (zerop offset)
+ (incf ptr offset))
+ (ecase type
+ (:char (ref-char ptr))
+ (:unsigned-char (ref-unsigned-char ptr))
+ (:short (ref-short ptr))
+ (:unsigned-short (ref-unsigned-short ptr))
+ (:int (ref-int ptr))
+ (:unsigned-int (ref-unsigned-int ptr))
+ (:long (ref-long ptr))
+ (:unsigned-long (ref-unsigned-long ptr))
+ (:float (ref-float ptr))
+ (:double (ref-double ptr))
+ (:pointer (ref-ptr ptr))))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+ (unless (zerop offset)
+ (incf ptr offset))
+ (ecase type
+ (:char (set-char ptr value))
+ (:unsigned-char (set-unsigned-char ptr value))
+ (:short (set-short ptr value))
+ (:unsigned-short (set-unsigned-short ptr value))
+ (:int (set-int ptr value))
+ (:unsigned-int (set-unsigned-int ptr value))
+ (:long (set-long ptr value))
+ (:unsigned-long (set-unsigned-long ptr value))
+ (:float (set-float ptr value))
+ (:double (set-double ptr value))
+ (:pointer (set-ptr ptr value)))
+ value)
+
+;;;# Calling Foreign Functions
+
+;; TODO: figure out if these type conversions make any sense...
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to a GCL type."
+ (ecase type-keyword
+ (:char 'char)
+ (:unsigned-char 'char)
+ (:short 'int)
+ (:unsigned-short 'int)
+ (:int 'int)
+ (:unsigned-int 'int)
+ (:long 'int)
+ (:unsigned-long 'int)
+ (:float 'float)
+ (:double 'double)
+ (:pointer 'int)
+ (:void 'void)))
+
+(defparameter +cffi-types+
+ '(:char :unsigned-char :short :unsigned-short :int :unsigned-int
+ :long :unsigned-long :float :double :pointer))
+
+(defcfun "int size_of(int type)" 0
+ "switch (type) {
+ case 0: return sizeof(char);
+ case 1: return sizeof(unsigned char);
+ case 2: return sizeof(short);
+ case 3: return sizeof(unsigned short);
+ case 4: return sizeof(int);
+ case 5: return sizeof(unsigned int);
+ case 6: return sizeof(long);
+ case 7: return sizeof(unsigned long);
+ case 8: return sizeof(float);
+ case 9: return sizeof(double);
+ case 10: return sizeof(void *);
+ default: return -1;
+ }")
+
+(defentry size-of (int) (int "size_of"))
+
+;; TODO: all this is doable inside the defcfun; figure that out..
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (size-of (position type-keyword +cffi-types+)))
+
+(defcfun "int align_of(int type)" 0
+ "switch (type) {
+ case 0: return __alignof__(char);
+ case 1: return __alignof__(unsigned char);
+ case 2: return __alignof__(short);
+ case 3: return __alignof__(unsigned short);
+ case 4: return __alignof__(int);
+ case 5: return __alignof__(unsigned int);
+ case 6: return __alignof__(long);
+ case 7: return __alignof__(unsigned long);
+ case 8: return __alignof__(float);
+ case 9: return __alignof__(double);
+ case 10: return __alignof__(void *);
+ default: return -1;
+ }")
+
+(defentry align-of (int) (int "align_of"))
+
+;; TODO: like %foreign-type-size
+(defun %foreign-type-alignment (type-keyword)
+ "Return the alignment in bytes of a foreign type."
+ (align-of (position type-keyword +cffi-types+)))
+
+#+ignore
+(defun convert-external-name (name)
+ "Add an underscore to NAME if necessary for the ABI."
+ #+darwinppc-target (concatenate 'string "_" name)
+ #-darwinppc-target name)
+
+(defmacro %foreign-funcall (function-name &rest args)
+ "Perform a foreign function all, document it more later."
+ `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
+
+(defun defcfun-helper-forms (name rettype args types)
+ "Return 2 values for DEFCFUN. A prelude form and a caller form."
+ (let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name))))
+ (values
+ `(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
+ (,(convert-foreign-type rettype) ,name))
+ `(,ff-name ,@args))))
+
+;;;# Callbacks
+
+;;; XXX unimplemented
+(defmacro make-callback (name rettype arg-names arg-types body-form)
+ 0)
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "_Won't_ load the foreign library NAME."
+ (declare (ignore name)))
+
+;;;# Foreign Globals
+
+;;; XXX unimplemented
+(defmacro foreign-var-ptr (name)
+ "Return a pointer pointing to the foreign symbol NAME."
+ 0)
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-lispworks.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-lispworks.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-lispworks.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,404 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-lispworks.lisp --- Lispworks CFFI-SYS implementation.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:cl #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ #:make-shareable-byte-vector
+ #:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:defcfun-helper-forms
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; Backend mis-features.
+ cffi-features:no-long-long
+ ;; OS/CPU features.
+ #+darwin cffi-features:darwin
+ #+unix cffi-features:unix
+ #+win32 cffi-features:windows
+ #+harp::pc386 cffi-features:x86
+ #+harp::powerpc cffi-features:ppc32
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Basic Pointer Operations
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (fli:pointerp ptr))
+
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (fli:pointer-eq ptr1 ptr2))
+
+;; We use FLI:MAKE-POINTER here instead of FLI:*NULL-POINTER* since old
+;; versions of Lispworks don't seem to have it.
+(defun null-pointer ()
+ "Return a null foreign pointer."
+ (fli:make-pointer :address 0 :type :void))
+
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ (fli:null-pointer-p ptr))
+
+;; FLI:INCF-POINTER won't work on FLI pointers to :void so we
+;; increment "manually."
+(defun inc-pointer (ptr offset)
+ "Return a pointer OFFSET bytes past PTR."
+ (fli:make-pointer :type :void :address (+ (fli:pointer-address ptr) offset)))
+
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ (fli:make-pointer :type :void :address address))
+
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ (fli:pointer-address ptr))
+
+;;;# Allocation
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes of memory and return a pointer."
+ (fli:allocate-foreign-object :type :byte :nelems size))
+
+(defun foreign-free (ptr)
+ "Free a pointer PTR allocated by FOREIGN-ALLOC."
+ (fli:free-foreign-object ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. Both the
+pointer in VAR and the memory it points to have dynamic extent and may
+be stack allocated if supported by the implementation."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ `(fli:with-dynamic-foreign-objects ()
+ (let* ((,size-var ,size)
+ (,var (fli:alloca :type :byte :nelems ,size-var)))
+ ,@body)))
+
+;;;# Shareable Vectors
+
+(defun make-shareable-byte-vector (size)
+ "Create a shareable byte vector."
+ (sys:in-static-area
+ (make-array size :element-type '(unsigned-byte 8))))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+ "Bind PTR-VAR to a pointer at the data in VECTOR."
+ `(fli:with-dynamic-lisp-array-pointer (,ptr-var ,vector)
+ ,@body))
+
+;;;# Dereferencing
+
+(defun convert-foreign-type (cffi-type)
+ "Convert a CFFI type keyword to an FLI type."
+ (ecase cffi-type
+ (:char :byte)
+ (:unsigned-char '(:unsigned :byte))
+ (:short :short)
+ (:unsigned-short '(:unsigned :short))
+ (:int :int)
+ (:unsigned-int '(:unsigned :int))
+ (:long :long)
+ (:unsigned-long '(:unsigned :long))
+ (:float :float)
+ (:double :double)
+ (:pointer :pointer)
+ (:void :void)))
+
+;;; Convert a CFFI type keyword to a symbol suitable for passing to
+;;; FLI:FOREIGN-TYPED-AREF.
+#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(defun convert-foreign-typed-aref-type (cffi-type)
+ (ecase cffi-type
+ ((:char :short :int :long)
+ `(signed-byte ,(* 8 (%foreign-type-size cffi-type))))
+ ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long)
+ `(unsigned-byte ,(* 8 (%foreign-type-size cffi-type))))
+ (:float 'single-float)
+ (:double 'double-float)))
+
+(defun %mem-ref (ptr type &optional (offset 0))
+ "Dereference an object of type TYPE OFFSET bytes from PTR."
+ (unless (zerop offset)
+ (setf ptr (inc-pointer ptr offset)))
+ (fli:dereference ptr :type (convert-foreign-type type)))
+
+;;; Determine the most efficient way to increment PTR by OFFSET bytes
+;;; for use in a call to FLI:FOREIGN-TYPED-AREF. Returns a form to
+;;; use as the pointer in the call and a second value to pass as the
+;;; index. If OFFSET is constant and a multiple of the size of TYPE,
+;;; convert it to an array index, otherwise use INC-POINTER.
+#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(defun pointer-and-index (ptr type offset)
+ (if (constantp offset)
+ (let ((offset (eval offset))
+ (size (%foreign-type-size type)))
+ (multiple-value-bind (q r) (truncate offset size)
+ (if (zerop r)
+ (values ptr q)
+ (values `(inc-pointer ,ptr ,offset) 0))))
+ (values `(inc-pointer ,ptr ,offset) 0)))
+
+;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
+;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF.
+#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
+ (if (constantp type)
+ (let ((type (eval type)))
+ (if (eql type :pointer)
+ (let ((fli-type (convert-foreign-type type))
+ (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
+ `(fli:dereference ,ptr-form :type ',fli-type))
+ (let ((lisp-type (convert-foreign-typed-aref-type type)))
+ (multiple-value-bind (ptr-form index)
+ (pointer-and-index ptr type off)
+ `(locally
+ (declare (optimize (speed 3) (safety 0)))
+ (fli:foreign-typed-aref ',lisp-type ,ptr-form ,index))))))
+ form))
+
+;;; Open-code the call to FLI:DEREFERENCE when TYPE is constant at
+;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available.
+#-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
+ (if (constantp type)
+ (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
+ (type (convert-foreign-type (eval type))))
+ `(fli:dereference ,ptr-form :type ',type))
+ form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+ "Set the object of TYPE at OFFSET bytes from PTR."
+ (unless (zerop offset)
+ (setf ptr (inc-pointer ptr offset)))
+ (setf (fli:dereference ptr :type (convert-foreign-type type)) value))
+
+;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
+;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET.
+#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
+ (if (constantp type)
+ (once-only (val)
+ (let ((type (eval type)))
+ (if (eql type :pointer)
+ (let ((fli-type (convert-foreign-type type))
+ (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
+ `(setf (fli:dereference ,ptr-form :type ',fli-type) ,val))
+ (let ((lisp-type (convert-foreign-typed-aref-type type)))
+ (multiple-value-bind (ptr-form index)
+ (pointer-and-index ptr type off)
+ `(locally
+ (declare (optimize (speed 3) (safety 0)))
+ (setf (fli:foreign-typed-aref ',lisp-type ,ptr-form ,index) ,val)))))))
+ form))
+
+;;; Open-code the call to (SETF FLI:DEREFERENCE) when TYPE is constant
+;;; at macroexpansion time.
+#-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
+ (if (constantp type)
+ (once-only (val)
+ (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
+ (type (convert-foreign-type (eval type))))
+ `(setf (fli:dereference ,ptr-form :type ',type) ,val)))
+ form))
+
+;;;# Foreign Type Operations
+
+(defun %foreign-type-size (type)
+ "Return the size in bytes of a foreign type."
+ (fli:size-of (convert-foreign-type type)))
+
+(defun %foreign-type-alignment (type)
+ "Return the structure alignment in bytes of foreign type."
+ #+(and darwin harp::powerpc)
+ (when (eq type :double)
+ (return-from %foreign-type-alignment 8))
+ ;; Override not necessary for the remaining types...
+ (fli:align-of (convert-foreign-type type)))
+
+;;;# Calling Foreign Functions
+
+(defvar *foreign-funcallable-cache* (make-hash-table :test 'equal)
+ "Caches foreign funcallables created by %FOREIGN-FUNCALL or
+%FOREIGN-FUNCALL-POINTER. We only need to have one per each
+signature.")
+
+(defun foreign-funcall-type-and-args (args)
+ "Returns a list of types, list of args and return type."
+ (let ((return-type :void))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (convert-foreign-type type) into types
+ and collect arg into fargs
+ else do (setf return-type (convert-foreign-type type))
+ finally (return (values types fargs return-type)))))
+
+(defun create-foreign-funcallable (types rettype)
+ "Creates a foreign funcallable for the signature TYPES -> RETTYPE."
+ (format t "~&Creating foreign funcallable for signature ~S -> ~S~%"
+ types rettype)
+ ;; yes, ugly, this most likely wants to be a top-level form...
+ (let ((internal-name (gensym)))
+ (funcall
+ (compile nil
+ `(lambda ()
+ (fli:define-foreign-funcallable ,internal-name
+ ,(loop for type in types
+ collect (list (gensym) type))
+ :result-type ,rettype
+ :language :ansi-c
+ ;; avoid warning about cdecl not being supported on mac
+ #-mac ,@'(:calling-convention :cdecl)))))
+ internal-name))
+
+(defun get-foreign-funcallable (types rettype)
+ "Returns a foreign funcallable for the signature TYPES -> RETTYPE -
+either from the cache or newly created."
+ (let ((signature (cons rettype types)))
+ (or (gethash signature *foreign-funcallable-cache*)
+ ;; (SETF GETHASH) is supposed to be thread-safe
+ (setf (gethash signature *foreign-funcallable-cache*)
+ (create-foreign-funcallable types rettype)))))
+
+(defmacro %%foreign-funcall (foreign-function &rest args)
+ "Does the actual work for %FOREIGN-FUNCALL-POINTER and %FOREIGN-FUNCALL.
+Checks if a foreign funcallable which fits ARGS already exists and creates
+and caches it if necessary. Finally calls it."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ `(funcall (load-time-value (get-foreign-funcallable ',types ',rettype))
+ ,foreign-function ,@fargs)))
+
+(defmacro %foreign-funcall (name &rest args)
+ "Calls a foreign function named NAME passing arguments ARGS."
+ `(%%foreign-funcall (fli:make-pointer :symbol-name ,name) ,@args))
+
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ "Calls a foreign function pointed at by PTR passing arguments ARGS."
+ `(%%foreign-funcall ,ptr ,@args))
+
+(defun defcfun-helper-forms (name lisp-name rettype args types)
+ "Return 2 values for DEFCFUN. A prelude form and a caller form."
+ (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
+ (values
+ `(fli:define-foreign-function (,ff-name ,name :source)
+ ,(mapcar (lambda (ty) (list (gensym) (convert-foreign-type ty)))
+ types)
+ :result-type ,(convert-foreign-type rettype)
+ :language :ansi-c
+ ;; avoid warning about cdecl not being supported on mac platforms
+ #-mac ,@'(:calling-convention :cdecl))
+ `(,ff-name ,@args))))
+
+;;;# Callbacks
+
+(defvar *callbacks* (make-hash-table))
+
+;;; Create a package to contain the symbols for callback functions. We
+;;; want to redefine callbacks with the same symbol so the internal data
+;;; structures are reused.
+(defpackage #:cffi-callbacks
+ (:use))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
+;;; callback for NAME.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun intern-callback (name)
+ (intern (format nil "~A::~A" (package-name (symbol-package name))
+ (symbol-name name))
+ '#:cffi-callbacks)))
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ (let ((cb-name (intern-callback name)))
+ `(progn
+ (fli:define-foreign-callable
+ (,cb-name :encode :lisp
+ :result-type ,(convert-foreign-type rettype)
+ :calling-convention :cdecl
+ :language :ansi-c
+ :no-check nil)
+ ,(mapcar (lambda (sym type)
+ (list sym (convert-foreign-type type)))
+ arg-names arg-types)
+ ,@body)
+ (setf (gethash ',name *callbacks*) ',cb-name))))
+
+(defun %callback (name)
+ (multiple-value-bind (symbol winp)
+ (gethash name *callbacks*)
+ (unless winp
+ (error "Undefined callback: ~S" name))
+ (fli:make-pointer :symbol-name symbol :module :callbacks)))
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load the foreign library NAME."
+ (fli:register-module name :connection-style :immediate))
+
+(defun %close-foreign-library (name)
+ "Close the foreign library NAME."
+ (fli:disconnect-module name :remove t))
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol NAME."
+ (prog1 (ignore-errors (fli:make-pointer :symbol-name name :type :void))))
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-openmcl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-openmcl.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-openmcl.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,298 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:ccl #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp ; ccl:pointerp
+ #:pointer-eq
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%mem-ref
+ #:%mem-set
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:make-shareable-byte-vector
+ #:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; OS/CPU features.
+ #+darwinppc-target cffi-features:darwin
+ #+unix cffi-features:unix
+ #+ppc32-target cffi-features:ppc32
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap. The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
+;;; usage when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes on the heap and return a pointer."
+ (ccl::malloc size))
+
+(defun foreign-free (ptr)
+ "Free a PTR allocated by FOREIGN-ALLOC."
+ ;; TODO: Should we make this a dead macptr?
+ (ccl::free ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation. If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ `(let ((,size-var ,size))
+ (%stack-block ((,var ,size-var))
+ ,@body)))
+
+;;;# Misc. Pointer Operations
+
+(defun null-pointer ()
+ "Construct and return a null pointer."
+ (ccl:%null-ptr))
+
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ (ccl:%null-ptr-p ptr))
+
+(defun inc-pointer (ptr offset)
+ "Return a pointer OFFSET bytes past PTR."
+ (ccl:%inc-ptr ptr offset))
+
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (ccl:%ptr-eql ptr1 ptr2))
+
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ (ccl:%int-to-ptr address))
+
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ (ccl:%ptr-to-int ptr))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(defun make-shareable-byte-vector (size)
+ "Create a Lisp vector of SIZE bytes that can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+ (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+ "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+ `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
+ ,@body))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+ `(progn
+ (defun %mem-ref (ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (,fn ptr offset)))))
+ (defun %mem-set (value ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (setf (,fn ptr offset) value)))))
+ (define-compiler-macro %mem-ref
+ (&whole form ptr type &optional (offset 0))
+ (if (constantp type)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(,',fn ,ptr ,offset))))
+ form))
+ (define-compiler-macro %mem-set
+ (&whole form value ptr type &optional (offset 0))
+ (if (constantp type)
+ (once-only (value)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(setf (,',fn ,ptr ,offset)
+ ,value)))))
+ form))))
+
+(define-mem-accessors
+ (:char %get-signed-byte)
+ (:unsigned-char %get-unsigned-byte)
+ (:short %get-signed-word)
+ (:unsigned-short %get-unsigned-word)
+ (:int %get-signed-long)
+ (:unsigned-int %get-unsigned-long)
+ #+ppc32-target (:long %get-signed-long)
+ #+ppc64-target (:long ccl::%%get-signed-longlong)
+ #+ppc32-target (:unsigned-long %get-unsigned-long)
+ #+ppc64-target (:unsigned-long ccl::%%get-unsigned-longlong)
+ (:long-long ccl::%get-signed-long-long)
+ (:unsigned-long-long ccl::%get-unsigned-long-long)
+ (:float %get-single-float)
+ (:double %get-double-float)
+ (:pointer %get-ptr))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to an OpenMCL type."
+ (ecase type-keyword
+ (:char :signed-byte)
+ (:unsigned-char :unsigned-byte)
+ (:short :signed-short)
+ (:unsigned-short :unsigned-short)
+ (:int :signed-int)
+ (:unsigned-int :unsigned-int)
+ (:long :signed-long)
+ (:unsigned-long :unsigned-long)
+ (:long-long :signed-doubleword)
+ (:unsigned-long-long :unsigned-doubleword)
+ (:float :single-float)
+ (:double :double-float)
+ (:pointer :address)
+ (:void :void)))
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (/ (ccl::foreign-type-bits
+ (ccl::parse-foreign-type
+ (convert-foreign-type type-keyword))) 8))
+
+;; There be dragons here. See the following thread for details:
+;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
+(defun %foreign-type-alignment (type-keyword)
+ "Return the alignment in bytes of a foreign type."
+ (/ (ccl::foreign-type-alignment
+ (ccl::parse-foreign-type
+ (convert-foreign-type type-keyword))) 8))
+
+(defun convert-foreign-funcall-types (args)
+ "Convert foreign types for a call to FOREIGN-FUNCALL."
+ (loop for (type arg) on args by #'cddr
+ collect (convert-foreign-type type)
+ if arg collect arg))
+
+(defun convert-external-name (name)
+ "Add an underscore to NAME if necessary for the ABI."
+ #+darwinppc-target (concatenate 'string "_" name)
+ #-darwinppc-target name)
+
+(defmacro %foreign-funcall (function-name &rest args)
+ "Perform a foreign function call, document it more later."
+ `(external-call
+ ,(convert-external-name function-name)
+ ,@(convert-foreign-funcall-types args)))
+
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ `(ff-call ,ptr ,@(convert-foreign-funcall-types args)))
+
+;;;# Callbacks
+
+;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
+;;; entry points. It is safe to store the pointers directly because
+;;; OpenMCL will update the address of these pointers when a saved image
+;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
+(defvar *callbacks* (make-hash-table))
+
+;;; Create a package to contain the symbols for callback functions. We
+;;; want to redefine callbacks with the same symbol so the internal data
+;;; structures are reused.
+(defpackage #:cffi-callbacks
+ (:use))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
+;;; callback for NAME.
+(defun intern-callback (name)
+ (intern (format nil "~A::~A" (package-name (symbol-package name))
+ (symbol-name name))
+ '#:cffi-callbacks))
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ (let ((cb-name (intern-callback name)))
+ `(progn
+ (defcallback ,cb-name
+ (,@(mapcan (lambda (sym type)
+ (list (convert-foreign-type type) sym))
+ arg-names arg-types)
+ ,(convert-foreign-type rettype))
+ ,@body)
+ (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
+
+(defun %callback (name)
+ (or (gethash name *callbacks*)
+ (error "Undefined callback: ~S" name)))
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load the foreign library NAME."
+ (open-shared-library name))
+
+(defun %close-foreign-library (name)
+ "Close the foreign library NAME."
+ (close-shared-library name)) ; :completely t ?
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol NAME."
+ (foreign-symbol-address (convert-external-name name)))
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-sbcl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-sbcl.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-sbcl.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,315 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:sb-alien #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ #:make-shareable-byte-vector
+ #:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; OS/CPU features.
+ #+darwin cffi-features:darwin
+ #+(and unix (not win32)) cffi-features:unix
+ #+win32 cffi-features:windows
+ #+x86 cffi-features:x86
+ #+x86-64 cffi-features:x86-64
+ #+(and ppc (not ppc64)) cffi-features:ppc32
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (string-upcase name))
+
+;;;# Basic Pointer Operations
+
+(defun pointerp (ptr)
+ "Return true if PTR is a foreign pointer."
+ (sb-sys:system-area-pointer-p ptr))
+
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if PTR1 and PTR2 point to the same address."
+ (sb-sys:sap= ptr1 ptr2))
+
+(defun null-pointer ()
+ "Construct and return a null pointer."
+ (sb-sys:int-sap 0))
+
+(defun null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ (zerop (sb-sys:sap-int ptr)))
+
+(defun inc-pointer (ptr offset)
+ "Return a pointer pointing OFFSET bytes past PTR."
+ (sb-sys:sap+ ptr offset))
+
+(defun make-pointer (address)
+ "Return a pointer pointing to ADDRESS."
+ (sb-sys:int-sap address))
+
+(defun pointer-address (ptr)
+ "Return the address pointed to by PTR."
+ (sb-sys:sap-int ptr))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap. The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+ "Allocate SIZE bytes on the heap and return a pointer."
+ (alien-sap (make-alien (unsigned 8) size)))
+
+(defun foreign-free (ptr)
+ "Free a PTR allocated by FOREIGN-ALLOC."
+ (free-alien (sap-alien ptr (* (unsigned 8)))))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind VAR to SIZE bytes of foreign memory during BODY. The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation. If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+ (unless size-var
+ (setf size-var (gensym "SIZE")))
+ ;; If the size is constant we can stack-allocate.
+ (if (constantp size)
+ (let ((alien-var (gensym "ALIEN")))
+ `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
+ (let ((,size-var ,(eval size))
+ (,var (alien-sap ,alien-var)))
+ (declare (ignorable ,size-var))
+ ,@body)))
+ `(let* ((,size-var ,size)
+ (,var (%foreign-alloc ,size-var)))
+ (unwind-protect
+ (progn ,@body)
+ (foreign-free ,var)))))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(defun make-shareable-byte-vector (size)
+ "Create a Lisp vector of SIZE bytes can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+ (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+ "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+ (let ((vector-var (gensym "VECTOR")))
+ `(let ((,vector-var ,vector))
+ (sb-sys:with-pinned-objects (,vector-var)
+ (let ((,ptr-var (sb-sys:vector-sap ,vector-var)))
+ ,@body)))))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+ `(progn
+ (defun %mem-ref (ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (,fn ptr offset)))))
+ (defun %mem-set (value ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (setf (,fn ptr offset) value)))))
+ (define-compiler-macro %mem-ref
+ (&whole form ptr type &optional (offset 0))
+ (if (constantp type)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(,',fn ,ptr ,offset))))
+ form))
+ (define-compiler-macro %mem-set
+ (&whole form value ptr type &optional (offset 0))
+ (if (constantp type)
+ (once-only (value)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(setf (,',fn ,ptr ,offset)
+ ,value)))))
+ form))))
+
+(define-mem-accessors
+ (:char sb-sys:signed-sap-ref-8)
+ (:unsigned-char sb-sys:sap-ref-8)
+ (:short sb-sys:signed-sap-ref-16)
+ (:unsigned-short sb-sys:sap-ref-16)
+ (:int sb-sys:signed-sap-ref-32)
+ (:unsigned-int sb-sys:sap-ref-32)
+ (:long sb-sys:signed-sap-ref-word)
+ (:unsigned-long sb-sys:sap-ref-word)
+ (:long-long sb-sys:signed-sap-ref-64)
+ (:unsigned-long-long sb-sys:sap-ref-64)
+ (:float sb-sys:sap-ref-single)
+ (:double sb-sys:sap-ref-double)
+ (:pointer sb-sys:sap-ref-sap))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to an SB-ALIEN type."
+ (ecase type-keyword
+ (:char 'char)
+ (:unsigned-char 'unsigned-char)
+ (:short 'short)
+ (:unsigned-short 'unsigned-short)
+ (:int 'int)
+ (:unsigned-int 'unsigned-int)
+ (:long 'long)
+ (:unsigned-long 'unsigned-long)
+ (:long-long 'long-long)
+ (:unsigned-long-long 'unsigned-long-long)
+ (:float 'single-float)
+ (:double 'double-float)
+ (:pointer 'system-area-pointer)
+ (:void 'void)))
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (/ (sb-alien-internals:alien-type-bits
+ (sb-alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword) nil)) 8))
+
+(defun %foreign-type-alignment (type-keyword)
+ "Return the alignment in bytes of a foreign type."
+ #+(and darwin ppc (not ppc64))
+ (when (member type-keyword '(:double :long-long))
+ (return-from %foreign-type-alignment 8))
+ ;; No override necessary for other types...
+ (/ (sb-alien-internals:alien-type-alignment
+ (sb-alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword) nil)) 8))
+
+(defun foreign-funcall-type-and-args (args)
+ "Return an SB-ALIEN function type for ARGS."
+ (let ((return-type 'void))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (convert-foreign-type type) into types
+ and collect arg into fargs
+ else do (setf return-type (convert-foreign-type type))
+ finally (return (values types fargs return-type)))))
+
+(defmacro %%foreign-funcall (name types fargs rettype)
+ "Internal guts of %FOREIGN-FUNCALL."
+ `(alien-funcall
+ (extern-alien ,name (function ,rettype ,@types))
+ ,@fargs))
+
+(defmacro %foreign-funcall (name &rest args)
+ "Perform a foreign function call, document it more later."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
+
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ "Funcall a pointer to a foreign function."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ (with-unique-names (function)
+ `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
+ (alien-funcall ,function ,@fargs)))))
+
+;;;# Callbacks
+
+;;; The *CALLBACKS* hash table contains a direct mapping of CFFI
+;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA.
+;;; SBCL will maintain the addresses of the callbacks across saved
+;;; images, so it is safe to store the pointers directly.
+(defvar *callbacks* (make-hash-table))
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ `(setf (gethash ',name *callbacks*)
+ (alien-sap
+ (sb-alien::alien-lambda ,(convert-foreign-type rettype)
+ ,(mapcar (lambda (sym type)
+ (list sym (convert-foreign-type type)))
+ arg-names arg-types)
+ ,@body))))
+
+(defun %callback (name)
+ (or (gethash name *callbacks*)
+ (error "Undefined callback: ~S" name)))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load the foreign library NAME."
+ (load-shared-object name))
+
+(defun %close-foreign-library (name)
+ "Closes the foreign library NAME."
+ (sb-alien::dlclose-or-lose
+ (find name sb-alien::*shared-objects*
+ :key #'sb-alien::shared-object-file
+ :test #'string=)))
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol NAME."
+ (let-when (address (sb-sys:find-foreign-symbol-address name))
+ (sb-sys:int-sap address)))
Added: branches/xml-class-rework/thirdparty/cffi/src/cffi-scl.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/cffi-scl.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/cffi-scl.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,328 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;; Copyright (C) 2006, Scieneer Pty Ltd.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; For posterity, a few optimizations we might use in the future:
+
+#-(and)
+(defun lisp-string-to-foreign (string ptr size)
+ (c-call::deport-string-to-system-area string ptr size :iso-8859-1))
+
+#-(and)
+(defun foreign-string-to-lisp (ptr &optional (size most-positive-fixnum)
+ (null-terminated-p t))
+ (unless (null-pointer-p ptr)
+ (if null-terminated-p
+ (c-call::naturalize-c-string ptr :iso-8859-1)
+ (c-call::naturalize-c-string ptr :iso-8859-1 size))))
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:alien #:c-call #:cffi-utils)
+ (:export
+ #:canonicalize-symbol-name-case
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ #:make-shareable-byte-vector
+ #:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; OS/CPU features.
+ #+unix cffi-features:unix
+ #+x86 cffi-features:x86
+ #+amd64 cffi-features:x86-64
+ #+(and ppc (not ppc64)) cffi-features:ppc32
+ )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+ (declare (string name))
+ (if (eq ext:*case-mode* :upper)
+ (string-upcase name)
+ (string-downcase name)))
+
+;;;# Basic Pointer Operations
+
+(declaim (inline pointerp))
+(defun pointerp (ptr)
+ "Return true if 'ptr is a foreign pointer."
+ (sys:system-area-pointer-p ptr))
+
+(declaim (inline pointer-eq))
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if 'ptr1 and 'ptr2 point to the same address."
+ (sys:sap= ptr1 ptr2))
+
+(declaim (inline null-pointer))
+(defun null-pointer ()
+ "Construct and return a null pointer."
+ (sys:int-sap 0))
+
+(declaim (inline null-pointer-p))
+(defun null-pointer-p (ptr)
+ "Return true if 'ptr is a null pointer."
+ (zerop (sys:sap-int ptr)))
+
+(declaim (inline inc-pointer))
+(defun inc-pointer (ptr offset)
+ "Return a pointer pointing 'offset bytes past 'ptr."
+ (sys:sap+ ptr offset))
+
+(declaim (inline make-pointer))
+(defun make-pointer (address)
+ "Return a pointer pointing to 'address."
+ (sys:int-sap address))
+
+(declaim (inline pointer-address))
+(defun pointer-address (ptr)
+ "Return the address pointed to by 'ptr."
+ (sys:sap-int ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind 'var to 'size bytes of foreign memory during 'body. The
+ pointer in 'var is invalid beyond the dynamic extent of 'body, and
+ may be stack-allocated if supported by the implementation. If
+ 'size-var is supplied, it will be bound to 'size during 'body."
+ (unless size-var
+ (setf size-var (gensym (symbol-name '#:size))))
+ ;; If the size is constant we can stack-allocate.
+ (cond ((constantp size)
+ (let ((alien-var (gensym (symbol-name '#:alien))))
+ `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
+ (let ((,size-var ,size)
+ (,var (alien-sap ,alien-var)))
+ (declare (ignorable ,size-var))
+ ,@body))))
+ (t
+ `(let ((,size-var ,size))
+ (alien:with-bytes (,var ,size-var)
+ ,@body)))))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack and on the
+;;; heap. The main CFFI package defines macros that wrap 'foreign-alloc and
+;;; 'foreign-free in 'unwind-protect for the common usage when the memory has
+;;; dynamic extent.
+
+(defun %foreign-alloc (size)
+ "Allocate 'size bytes on the heap and return a pointer."
+ (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
+ (alien-funcall (extern-alien "malloc"
+ (function system-area-pointer unsigned))
+ size))
+
+(defun foreign-free (ptr)
+ "Free a 'ptr allocated by 'foreign-alloc."
+ (declare (type system-area-pointer ptr))
+ (alien-funcall (extern-alien "free"
+ (function (values) system-area-pointer))
+ ptr))
+
+;;;# Shareable Vectors
+
+(defun make-shareable-byte-vector (size)
+ "Create a Lisp vector of 'size bytes that can passed to
+ 'with-pointer-to-vector-data."
+ (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+ "Bind 'ptr-var to a foreign pointer to the data in 'vector."
+ (let ((vector-var (gensym (symbol-name '#:vector))))
+ `(let ((,vector-var ,vector))
+ (ext:with-pinned-object (,vector-var)
+ (let ((,ptr-var (sys:vector-sap ,vector-var)))
+ ,@body)))))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+ `(progn
+ (defun %mem-ref (ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (,fn ptr offset)))))
+ (defun %mem-set (value ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword (setf (,fn ptr offset) value)))))
+ (define-compiler-macro %mem-ref
+ (&whole form ptr type &optional (offset 0))
+ (if (constantp type)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(,',fn ,ptr ,offset))))
+ form))
+ (define-compiler-macro %mem-set
+ (&whole form value ptr type &optional (offset 0))
+ (if (constantp type)
+ (once-only (value)
+ (ecase (eval type)
+ ,@(loop for (keyword fn) in pairs
+ collect `(,keyword `(setf (,',fn ,ptr ,offset)
+ ,value)))))
+ form))))
+
+(define-mem-accessors
+ (:char sys:signed-sap-ref-8)
+ (:unsigned-char sys:sap-ref-8)
+ (:short sys:signed-sap-ref-16)
+ (:unsigned-short sys:sap-ref-16)
+ (:int sys:signed-sap-ref-32)
+ (:unsigned-int sys:sap-ref-32)
+ (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
+ (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
+ (:long-long sys:signed-sap-ref-64)
+ (:unsigned-long-long sys:sap-ref-64)
+ (:float sys:sap-ref-single)
+ (:double sys:sap-ref-double)
+ #+long-float (:long-double sys:sap-ref-long)
+ (:pointer sys:sap-ref-sap))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to an ALIEN type."
+ (ecase type-keyword
+ (:char 'char)
+ (:unsigned-char 'unsigned-char)
+ (:short 'short)
+ (:unsigned-short 'unsigned-short)
+ (:int 'int)
+ (:unsigned-int 'unsigned-int)
+ (:long 'long)
+ (:unsigned-long 'unsigned-long)
+ (:long-long '(signed 64))
+ (:unsigned-long-long '(unsigned 64))
+ (:float 'single-float)
+ (:double 'double-float)
+ #+long-float
+ (:long-double 'long-float)
+ (:pointer 'system-area-pointer)
+ (:void 'void)))
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (values (truncate (alien-internals:alien-type-bits
+ (alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword)))
+ 8)))
+
+(defun %foreign-type-alignment (type-keyword)
+ "Return the alignment in bytes of a foreign type."
+ (values (truncate (alien-internals:alien-type-alignment
+ (alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword)))
+ 8)))
+
+(defun foreign-funcall-type-and-args (args)
+ "Return an 'alien function type for 'args."
+ (let ((return-type nil))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (convert-foreign-type type) into types
+ and collect arg into fargs
+ else do (setf return-type (convert-foreign-type type))
+ finally (return (values types fargs return-type)))))
+
+(defmacro %%foreign-funcall (name types fargs rettype)
+ "Internal guts of '%foreign-funcall."
+ `(alien-funcall (extern-alien ,name (function ,rettype ,@types))
+ ,@fargs))
+
+(defmacro %foreign-funcall (name &rest args)
+ "Perform a foreign function call, document it more later."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
+
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ "Funcall a pointer to a foreign function."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ (with-unique-names (function)
+ `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
+ (alien-funcall ,function ,@fargs)))))
+
+;;; Callbacks
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ `(alien:defcallback ,name
+ (,(convert-foreign-type rettype)
+ ,@(mapcar (lambda (sym type)
+ (list sym (convert-foreign-type type)))
+ arg-names arg-types))
+ ,@body))
+
+(declaim (inline %callback))
+(defun %callback (name)
+ (alien:callback-sap name))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load the foreign library 'name."
+ (ext:load-dynamic-object name))
+
+(defun %close-foreign-library (name)
+ "Closes the foreign library 'name."
+ (ext:close-dynamic-object name))
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name)
+ "Returns a pointer to a foreign symbol 'name."
+ (let ((sap (sys:foreign-symbol-address name)))
+ (if (zerop (sys:sap-int sap)) nil sap)))
Added: branches/xml-class-rework/thirdparty/cffi/src/early-types.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/early-types.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/early-types.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,498 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; early-types.lisp --- Low-level foreign type operations.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Early Type Definitions
+;;;
+;;; This module contains basic operations on foreign types. These
+;;; definitions are in a separate file because they may be used in
+;;; compiler macros defined later on.
+
+(in-package #:cffi)
+
+;;;# Foreign Types
+
+(defvar *foreign-types* (make-hash-table)
+ "Hash table of all user-defined foreign types.")
+
+(defun find-type (name)
+ "Return the foreign type instance for NAME or nil."
+ (gethash name *foreign-types*))
+
+(defun find-type-or-lose (name)
+ "Return the foreign type instance for NAME or signal an error."
+ (or (find-type name)
+ (error "Undefined foreign type: ~S" name)))
+
+(defun notice-foreign-type (type)
+ "Inserts TYPE in the *FOREIGN-TYPES* hashtable."
+ (setf (gethash (name type) *foreign-types*) type)
+ (name type))
+
+;;;# Parsing Type Specifications
+;;;
+;;; Type specifications are of the form (type {args}*). The
+;;; type parser can specify how its arguments should look like
+;;; through a lambda list.
+;;;
+;;; "type" is a shortcut for "(type)", ie, no args were specified.
+;;;
+;;; Examples of such types: boolean, (boolean), (boolean :int)
+;;; If the boolean type parser specifies the lambda list:
+;;; &optional (base-type :int), then all of the above three
+;;; type specs would be parsed to an identical type.
+;;;
+;;; Type parsers, defined with DEFINE-TYPE-SPEC-PARSER should
+;;; return a subtype of the foreign-type class.
+
+(defvar *type-parsers* (make-hash-table)
+ "Hash table of defined type parsers.")
+
+(defun find-type-parser (symbol)
+ "Return the type parser for SYMBOL."
+ (gethash symbol *type-parsers*))
+
+(defun (setf find-type-parser) (func symbol)
+ "Set the type parser for SYMBOL."
+ (setf (gethash symbol *type-parsers*) func))
+
+(defmacro define-type-spec-parser (symbol lambda-list &body body)
+ "Define a type parser on SYMBOL and lists whose CAR is SYMBOL."
+ (when (stringp (car body)) ; discard-docstring
+ (setq body (cdr body)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (find-type-parser ',symbol)
+ (lambda ,lambda-list ,@body))))
+
+(defun parse-type (type-spec-or-name)
+ (or (find-type type-spec-or-name)
+ (let* ((type-spec (mklist type-spec-or-name))
+ (parser (find-type-parser (car type-spec))))
+ (if parser
+ (apply parser (cdr type-spec))
+ (error "Unknown CFFI type: ~S." type-spec-or-name)))))
+
+;;;# Generic Functions on Types
+
+(defgeneric canonicalize (foreign-type)
+ (:documentation
+ "Return the built-in foreign type for FOREIGN-TYPE.
+Signals an error if FOREIGN-TYPE is undefined."))
+
+(defgeneric aggregatep (foreign-type)
+ (:documentation
+ "Return true if FOREIGN-TYPE is an aggregate type."))
+
+(defgeneric foreign-type-alignment (foreign-type)
+ (:documentation
+ "Return the structure alignment in bytes of a foreign type."))
+
+(defgeneric foreign-type-size (foreign-type)
+ (:documentation
+ "Return the size in bytes of a foreign type."))
+
+(defgeneric unparse (type-name type-class)
+ (:documentation
+ "Unparse FOREIGN-TYPE to a type specification (symbol or list)."))
+
+(defgeneric translate-p (foreign-type)
+ (:documentation
+ "Return true if type translators should run on FOREIGN-TYPE."))
+
+;;;# Foreign Types
+
+(defclass foreign-type ()
+ ((name
+ ;; Name of this foreign type, a symbol.
+ :initform (gensym "ANONYMOUS-CFFI-TYPE")
+ :initarg :name
+ :accessor name))
+ (:documentation "Contains information about a basic foreign type."))
+
+(defmethod print-object ((type foreign-type) stream)
+ "Print a FOREIGN-TYPE instance to STREAM unreadably."
+ (print-unreadable-object (type stream :type t :identity nil)
+ (format stream "~S" (name type))))
+
+(defmethod make-load-form ((type foreign-type) &optional env)
+ "Return the form used to dump types to a FASL file."
+ (declare (ignore env))
+ `(parse-type ',(unparse-type type)))
+
+(defun canonicalize-foreign-type (type)
+ "Convert TYPE to a built-in type by following aliases.
+Signals an error if the type cannot be resolved."
+ (canonicalize (parse-type type)))
+
+(defmethod unparse (name (type foreign-type))
+ "Default method to unparse TYPE to its name."
+ (declare (ignore name))
+ (name type))
+
+(defun unparse-type (type)
+ "Unparse a foreign type to a symbol or list type spec."
+ (unparse (name type) type))
+
+(defmethod foreign-type-size (type)
+ "Return the size in bytes of a foreign type."
+ (foreign-type-size (parse-type type)))
+
+(defmethod translate-p ((type foreign-type))
+ "By default, types will be translated."
+ t)
+
+;;;# Built-In Foreign Types
+
+(defclass foreign-built-in-type (foreign-type)
+ ((type-keyword
+ ;; Keyword in CFFI-SYS representing this type.
+ :initform (error "A type keyword is required.")
+ :initarg :type-keyword
+ :accessor type-keyword))
+ (:documentation "A built-in foreign type."))
+
+(defmethod canonicalize ((type foreign-built-in-type))
+ "Return the built-in type keyword for TYPE."
+ (type-keyword type))
+
+(defmethod aggregatep ((type foreign-built-in-type))
+ "Returns false, built-in types are never aggregate types."
+ nil)
+
+(defmethod foreign-type-alignment ((type foreign-built-in-type))
+ "Return the alignment of a built-in type."
+ (%foreign-type-alignment (type-keyword type)))
+
+(defmethod foreign-type-size ((type foreign-built-in-type))
+ "Return the size of a built-in type."
+ (%foreign-type-size (type-keyword type)))
+
+(defmethod translate-p ((type foreign-built-in-type))
+ "Built-in types are never translated."
+ nil)
+
+(defmacro define-built-in-foreign-type (keyword)
+ "Defines a built-in foreign-type."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (notice-foreign-type
+ (make-instance 'foreign-built-in-type :name ,keyword
+ :type-keyword ,keyword))))
+
+;;;# Foreign Typedefs
+;;;
+;;; We have two classes: foreign-type-alias and foreign-typedef.
+;;; The former is a direct super-class of the latter. The only
+;;; difference between the two is that foreign-typedef has different
+;;; behaviour wrt type translations. (see types.lisp)
+
+(defclass foreign-type-alias (foreign-type)
+ ((actual-type
+ ;; The FOREIGN-TYPE instance this type is an alias for.
+ :initarg :actual-type
+ :accessor actual-type)
+ (translate-p
+ ;; If true, this type should be translated (the default).
+ :initform t
+ :initarg :translate-p
+ :accessor translate-p))
+ (:documentation "A type that aliases another type."))
+
+(defmethod canonicalize ((type foreign-type-alias))
+ "Return the built-in type keyword for TYPE."
+ (canonicalize (actual-type type)))
+
+(defmethod aggregatep ((type foreign-type-alias))
+ "Return true if TYPE's actual type is aggregate."
+ (aggregatep (actual-type type)))
+
+(defmethod foreign-type-alignment ((type foreign-type-alias))
+ "Return the alignment of a foreign typedef."
+ (foreign-type-alignment (actual-type type)))
+
+(defmethod foreign-type-size ((type foreign-type-alias))
+ "Return the size in bytes of a foreign typedef."
+ (foreign-type-size (actual-type type)))
+
+(defclass foreign-typedef (foreign-type-alias)
+ ())
+
+;;; This should probably be an argument to parse-type.
+;;; So we'd have: (parse-type foo :follow-typedefs t)
+;;; instead of (follow-typedefs (parse-type foo)) ? --luis
+(defun follow-typedefs (type)
+ (if (eq (type-of type) 'foreign-typedef)
+ (follow-typedefs (actual-type type))
+ type))
+
+;;;# Structure Type
+
+(defclass foreign-struct-type (foreign-type)
+ ((slots
+ ;; Hash table of slots in this structure, keyed by name.
+ :initform (make-hash-table)
+ :initarg :slots
+ :accessor slots)
+ (size
+ ;; Cached size in bytes of this structure.
+ :initarg :size
+ :accessor size)
+ (alignment
+ ;; This struct's alignment requirements
+ :initarg :alignment
+ :accessor alignment))
+ (:documentation "Hash table of plists containing slot information."))
+
+(defmethod canonicalize ((type foreign-struct-type))
+ "Returns :POINTER, since structures can not be passed by value."
+ :pointer)
+
+(defmethod aggregatep ((type foreign-struct-type))
+ "Returns true, structure types are aggregate."
+ t)
+
+(defmethod foreign-type-size ((type foreign-struct-type))
+ "Return the size in bytes of a foreign structure type."
+ (size type))
+
+(defmethod foreign-type-alignment ((type foreign-struct-type))
+ "Return the alignment requirements for this struct."
+ (alignment type))
+
+;;;# Type Translators
+;;;
+;;; Type translation is now done with generic functions at runtime.
+;;;
+;;; The main internal interface to type translation is through the
+;;; generic functions TRANSLATE-TYPE-{TO,FROM}-FOREIGN and
+;;; FREE-TYPE-TRANSLATED-OBJECT. These should be specialized for
+;;; subclasses of FOREIGN-TYPE requiring translation.
+;;;
+;;; User-defined type translators are defined by specializing
+;;; additional methods that are called by the internal methods
+;;; specialized on FOREIGN-TYPEDEF. These methods dispatch on the
+;;; name of the type.
+
+;;; Translate VALUE to a foreign object of the type represented by
+;;; TYPE, which will be a subclass of FOREIGN-TYPE. Returns the
+;;; foreign value and an optional second value which will be passed to
+;;; FREE-TYPE-TRANSLATED-OBJECT as the PARAM argument.
+(defgeneric translate-type-to-foreign (value type)
+ (:method (value type)
+ (declare (ignore type))
+ value))
+
+;;; Translate the foreign object VALUE from the type repsented by
+;;; TYPE, which will be a subclass of FOREIGN-TYPE. Returns the
+;;; converted Lisp value.
+(defgeneric translate-type-from-foreign (value type)
+ (:method (value type)
+ (declare (ignore type))
+ value))
+
+;;; Free an object allocated by TRANSLATE-TYPE-TO-FOREIGN. VALUE is a
+;;; foreign object of the type represented by TYPE, which will be a
+;;; FOREIGN-TYPE subclass. PARAM, if present, contains the second
+;;; value returned by TRANSLATE-TYPE-TO-FOREIGN, and is used to
+;;; communicate between the two functions.
+(defgeneric free-type-translated-object (value type param)
+ (:method (value type param)
+ (declare (ignore value type param))))
+
+;;;## Translations for Typedefs
+;;;
+;;; By default, the translation methods for type definitions delegate
+;;; to the translation methods for the ACTUAL-TYPE of the typedef.
+;;;
+;;; The user is allowed to intervene in this process by specializing
+;;; TRANSLATE-TO-FOREIGN, TRANSLATE-FROM-FOREIGN, and
+;;; FREE-TRANSLATED-OBJECT on the name of the typedef.
+
+;;; Exported hook method allowing specific typedefs to define custom
+;;; translators to convert VALUE to the foreign type named by NAME.
+(defgeneric translate-to-foreign (value name)
+ (:method (value name)
+ (declare (ignore name))
+ value))
+
+;;; Exported hook method allowing specific typedefs to define custom
+;;; translators to convert VALUE from the foreign type named by NAME.
+(defgeneric translate-from-foreign (value name)
+ (:method (value name)
+ (declare (ignore name))
+ value))
+
+;;; Exported hook method allowing specific typedefs to free objects of
+;;; type NAME allocated by TRANSLATE-TO-FOREIGN.
+(defgeneric free-translated-object (value name param)
+ (:method (value name param)
+ (declare (ignore value name param))))
+
+;;; Default translator to foreign for typedefs. We build a list out
+;;; of the second value returned from each translator so we can pass
+;;; each parameter to the appropriate free method when freeing the
+;;; object.
+(defmethod translate-type-to-foreign (value (type foreign-typedef))
+ (multiple-value-bind (value param)
+ (translate-to-foreign value (name type))
+ (multiple-value-bind (new-value new-param)
+ (translate-type-to-foreign value (actual-type type))
+ (values new-value (cons param new-param)))))
+
+;;; Default translator from foreign for typedefs.
+(defmethod translate-type-from-foreign (value (type foreign-typedef))
+ (translate-from-foreign
+ (translate-type-from-foreign value (actual-type type))
+ (name type)))
+
+;;; Default method for freeing translated foreign typedefs. PARAM
+;;; will actually be a list of parameters to pass to each translator
+;;; method as returned by TRANSLATE-TYPE-TO-FOREIGN.
+(defmethod free-type-translated-object (value (type foreign-typedef) param)
+ (free-translated-object value (name type) (car param))
+ (free-type-translated-object value (actual-type type) (cdr param)))
+
+;;;## Macroexpansion Time Translation
+;;;
+;;; The following expand-* generic functions are similar to their
+;;; translate-* counterparts but are usually called at macroexpansion
+;;; time. They offer a way to optimize the runtime translators.
+;;;
+;;; The default methods expand to forms calling the runtime translators
+;;; unless TRANSLATE-P returns NIL for the type.
+
+(defun %expand-type-to-foreign-dyn (value var body type)
+ (with-unique-names (param)
+ (if (translate-p type)
+ `(multiple-value-bind (,var ,param)
+ (translate-type-to-foreign ,value ,type)
+ (unwind-protect
+ (progn ,@body)
+ (free-type-translated-object ,var ,type ,param)))
+ `(let ((,var ,value))
+ ,@body))))
+
+(defun %expand-type-to-foreign (value type)
+ (if (translate-p type)
+ `(values (translate-type-to-foreign ,value ,type))
+ value))
+
+(defun %expand-type-from-foreign (value type)
+ (if (translate-p type)
+ `(translate-type-from-foreign ,value ,type)
+ `(values ,value)))
+
+;;; This special variable is bound by the various :around methods
+;;; below to the respective form generated by the above %EXPAND-*
+;;; functions. This way, an expander can "bail out" by calling the
+;;; next method. All 6 of the below-defined GFs have a default method
+;;; that simply answers the rtf bound by the default :around method.
+(defvar *runtime-translator-form*)
+
+(defun specializedp (gf &rest args)
+ "Answer whether GF has more than one applicable method for ARGS."
+ (typep (compute-applicable-methods gf args) '(cons t cons)))
+
+(defgeneric expand-type-to-foreign-dyn (value var body type)
+ (:method :around (value var body type)
+ (let ((*runtime-translator-form*
+ (%expand-type-to-foreign-dyn value var body type)))
+ (call-next-method)))
+ (:method (value var body type)
+ ;; If COMPUTE-APPLICABLE-METHODS only finds one method it's
+ ;; the default one meaning that there is no to-foreign expander
+ ;; therefore we return *RUNTIME-TRANSLATOR-FORM* instead.
+ (if (specializedp #'expand-type-to-foreign value type)
+ `(let ((,var ,(expand-type-to-foreign value type)))
+ ,@body)
+ *runtime-translator-form*)))
+
+(defgeneric expand-type-to-foreign (value type)
+ (:method :around (value type)
+ (let ((*runtime-translator-form* (%expand-type-to-foreign value type)))
+ (call-next-method)))
+ (:method (value type)
+ (declare (ignore value type))
+ *runtime-translator-form*))
+
+(defgeneric expand-type-from-foreign (value type)
+ (:method :around (value type)
+ (let ((*runtime-translator-form* (%expand-type-from-foreign value type)))
+ (call-next-method)))
+ (:method (value type)
+ (declare (ignore value type))
+ *runtime-translator-form*))
+
+(defgeneric expand-to-foreign-dyn (value var body type)
+ (:method (value var body type)
+ (declare (ignore value var body type))
+ *runtime-translator-form*))
+(defgeneric expand-to-foreign (value type)
+ (:method (value type)
+ (declare (ignore value type))
+ *runtime-translator-form*))
+(defgeneric expand-from-foreign (value type)
+ (:method (value type)
+ (declare (ignore value type))
+ *runtime-translator-form*))
+
+(defmethod expand-type-to-foreign-dyn (value var body (type foreign-typedef))
+ (if (or (specializedp #'expand-to-foreign-dyn
+ value var body (name type))
+ (not (specializedp #'expand-to-foreign value (name type))))
+ (expand-to-foreign-dyn value var body (name type))
+ ;; If there is to-foreign _expansion_, but not to-foreign-dyn
+ ;; expansion, we use that.
+ `(let ((,var ,(expand-type-to-foreign value type)))
+ ,@body)))
+
+(defmethod expand-type-to-foreign (value (type foreign-typedef))
+ (expand-to-foreign value (name type)))
+
+(defmethod expand-type-from-foreign (value (type foreign-typedef))
+ (expand-from-foreign value (name type)))
+
+;;; User interface for converting values from/to foreign using the
+;;; type translators. Something doesn't feel right about this, makes
+;;; me want to just export PARSE-TYPE...
+
+(defun convert-to-foreign (value type)
+ (translate-type-to-foreign value (parse-type type)))
+
+(define-compiler-macro convert-to-foreign (value type)
+ (if (constantp type)
+ (expand-type-to-foreign value (parse-type (eval type)))
+ `(translate-type-to-foreign ,value (parse-type ,type))))
+
+(defun convert-from-foreign (value type)
+ (translate-type-from-foreign value (parse-type type)))
+
+(define-compiler-macro convert-from-foreign (value type)
+ (if (constantp type)
+ (expand-type-from-foreign value (parse-type (eval type)))
+ `(translate-type-from-foreign ,value (parse-type ,type))))
+
+(defun free-converted-object (value type param)
+ (free-type-translated-object value type param))
Added: branches/xml-class-rework/thirdparty/cffi/src/enum.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/enum.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/enum.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,196 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; enum.lisp --- Defining foreign constants as Lisp keywords.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Foreign Constants as Lisp Keywords
+;;;
+;;; This module defines the DEFCENUM macro, which provides an
+;;; interface for defining a type and associating a set of integer
+;;; constants with keyword symbols for that type.
+;;;
+;;; The keywords are automatically translated to the appropriate
+;;; constant for the type by a type translator when passed as
+;;; arguments or a return value to a foreign function.
+
+(defclass foreign-enum (foreign-type-alias)
+ ((keyword-values
+ :initform (make-hash-table :test 'eq)
+ :reader keyword-values)
+ (value-keywords
+ :initform (make-hash-table)
+ :reader value-keywords))
+ (:documentation "Describes a foreign enumerated type."))
+
+(defun make-foreign-enum (type-name base-type values)
+ "Makes a new instance of the foreign-enum class."
+ (let ((type (make-instance 'foreign-enum :name type-name
+ :actual-type (parse-type base-type)))
+ (default-value 0))
+ (dolist (pair values)
+ (destructuring-bind (keyword &optional (value default-value))
+ (mklist pair)
+ (check-type keyword keyword)
+ (check-type value integer)
+ (if (gethash keyword (keyword-values type))
+ (error "A foreign enum cannot contain duplicate keywords: ~S."
+ keyword)
+ (setf (gethash keyword (keyword-values type)) value))
+ ;; This completely arbitrary behaviour: we keep the last we
+ ;; value->keyword mapping. I suppose the opposite would be just as
+ ;; good (keeping the first). Returning a list with all the keywords
+ ;; might be a solution too? Suggestions welcome. --luis
+ (setf (gethash value (value-keywords type)) keyword)
+ (setq default-value (1+ value))))
+ type))
+
+(defmacro defcenum (name-and-options &body enum-list)
+ "Define an foreign enumerated type."
+ (discard-docstring enum-list)
+ (destructuring-bind (name &optional (base-type :int))
+ (mklist name-and-options)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (notice-foreign-type
+ (make-foreign-enum ',name ',base-type ',enum-list)))))
+
+;;; These [four] functions could be good canditates for compiler macros
+;;; when the value or keyword is constant. I am not going to bother
+;;; until someone has a serious performance need to do so though. --jamesjb
+(defun %foreign-enum-value (type keyword &key errorp)
+ (check-type keyword keyword)
+ (or (gethash keyword (keyword-values type))
+ (when errorp
+ (error "~S is not defined as a keyword for enum type ~S."
+ keyword type))))
+
+(defun foreign-enum-value (type keyword &key (errorp t))
+ "Convert a KEYWORD into an integer according to the enum TYPE."
+ (let ((type-obj (parse-type type)))
+ (if (not (typep type-obj 'foreign-enum))
+ (error "~S is not a foreign enum type." type)
+ (%foreign-enum-value type-obj keyword :errorp errorp))))
+
+(defun %foreign-enum-keyword (type value &key errorp)
+ (check-type value integer)
+ (or (gethash value (value-keywords type))
+ (when errorp
+ (error "~S is not defined as a value for enum type ~S."
+ value type))))
+
+(defun foreign-enum-keyword (type value &key (errorp t))
+ "Convert an integer VALUE into a keyword according to the enum TYPE."
+ (let ((type-obj (parse-type type)))
+ (if (not (typep type-obj 'foreign-enum))
+ (error "~S is not a foreign enum type." type)
+ (%foreign-enum-keyword type-obj value :errorp errorp))))
+
+(defmethod translate-type-to-foreign (value (type foreign-enum))
+ (if (keywordp value)
+ (%foreign-enum-value type value)
+ value))
+
+(defmethod translate-type-from-foreign (value (type foreign-enum))
+ (%foreign-enum-keyword type value))
+
+;;;# Foreign Bitfields as Lisp keywords
+;;;
+;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM.
+;;; With some changes to DEFCENUM, this could certainly be implemented on
+;;; top of it.
+
+(defclass foreign-bitfield (foreign-type-alias)
+ ((symbol-values
+ :initform (make-hash-table :test 'eq)
+ :reader symbol-values)
+ (value-symbols
+ :initform (make-hash-table)
+ :reader value-symbols))
+ (:documentation "Describes a foreign bitfield type."))
+
+(defun make-foreign-bitfield (type-name base-type values)
+ "Makes a new instance of the foreign-bitfield class."
+ (let ((type (make-instance 'foreign-bitfield :name type-name
+ :actual-type (parse-type base-type))))
+ (dolist (pair values)
+ (destructuring-bind (symbol value) pair
+ (check-type value integer)
+ (check-type symbol symbol)
+ (if (gethash symbol (symbol-values type))
+ (error "A foreign bitfield cannot contain duplicate symbols: ~S."
+ symbol)
+ (setf (gethash symbol (symbol-values type)) value))
+ (push symbol (gethash value (value-symbols type)))))
+ type))
+
+(defmacro defbitfield (name-and-options &body masks)
+ "Define an foreign enumerated type."
+ (discard-docstring masks)
+ (destructuring-bind (name &optional (base-type :int))
+ (mklist name-and-options)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (notice-foreign-type
+ (make-foreign-bitfield ',name ',base-type ',masks)))))
+
+(defun %foreign-bitfield-value (type symbols)
+ (let ((bitfield 0))
+ (dolist (symbol symbols)
+ (check-type symbol symbol)
+ (let ((value (or (gethash symbol (symbol-values type))
+ (error "~S is not a valid symbol for bitfield type ~S."
+ symbol type))))
+ (setq bitfield (logior bitfield value))))
+ bitfield))
+
+(defun foreign-bitfield-value (type symbols)
+ "Convert a list of symbols into an integer according to the TYPE bitfield."
+ (let ((type-obj (parse-type type)))
+ (if (not (typep type-obj 'foreign-bitfield))
+ (error "~S is not a foreign bitfield type." type)
+ (%foreign-bitfield-value type-obj symbols))))
+
+(defun %foreign-bitfield-symbols (type value)
+ (check-type value integer)
+ (loop for mask being the hash-keys in (value-symbols type)
+ using (hash-value symbols)
+ when (= (logand value mask) mask)
+ append symbols))
+
+(defun foreign-bitfield-symbols (type value)
+ "Convert an integer VALUE into a list of matching symbols according to
+the bitfield TYPE."
+ (let ((type-obj (parse-type type)))
+ (if (not (typep type-obj 'foreign-bitfield))
+ (error "~S is not a foreign bitfield type." type)
+ (%foreign-bitfield-symbols type-obj value))))
+
+(defmethod translate-type-to-foreign (value (type foreign-bitfield))
+ (if (integerp value)
+ value
+ (%foreign-bitfield-value type (mklist value))))
+
+(defmethod translate-type-from-foreign (value (type foreign-bitfield))
+ (%foreign-bitfield-symbols type value))
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/src/features.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/features.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/features.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,56 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; features.lisp --- CFFI-specific features.
+;;;
+;;; Copyright (C) 2006, Luis Oliveira <loliveira(a)common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew :cffi *features*))
+
+(defpackage #:cffi-features
+ (:export
+ ;; Features related to the CFFI-SYS backend.
+ ;; Why no-*? This reflects the hope that these symbols will
+ ;; go away completely and all lisps support long-long's and
+ ;; the foreign-funcall primitive.
+ #:no-long-long
+ #:no-foreign-funcall
+
+ ;; Only SCL support long-double...
+ ;;#:no-long-double
+
+ ;; Features related to the operating system.
+ ;; Currently only these are pushed to *features*, more should be added.
+ #:darwin
+ #:unix
+ #:windows
+
+ ;; Features related to the processor.
+ ;; Currently only these are pushed to *features*, more should be added.
+ #:ppc32
+ #:x86
+ #:x86-64
+ ))
Added: branches/xml-class-rework/thirdparty/cffi/src/foreign-vars.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/foreign-vars.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/foreign-vars.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,84 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; foreign-vars.lisp --- High-level interface to foreign globals.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Accessing Foreign Globals
+
+(defun lisp-var-name (name)
+ "Return the Lisp symbol for foreign var NAME."
+ (etypecase name
+ (list (second name))
+ (string (intern (format nil "*~A*" (canonicalize-symbol-name-case
+ (substitute #\- #\_ name)))))))
+
+(defun foreign-var-name (name)
+ "Return the foreign var name of NAME."
+ (etypecase name
+ (list (first name))
+ (string name)
+ (symbol
+ (let ((sn (substitute #\_ #\- (string-downcase (symbol-name name)))))
+ (if (eql (char sn 0) #\*)
+ ;; remove asterisks around the var name
+ (subseq sn 1 (1- (length sn)))
+ sn)))))
+
+(defun get-var-pointer (symbol)
+ "Return a pointer to the foreign global variable relative to SYMBOL."
+ (foreign-symbol-pointer (get symbol 'foreign-var-name)))
+
+(defun foreign-symbol-pointer-or-lose (foreign-name)
+ "Like foreign-symbol-ptr but throws an error instead of
+returning nil when foreign-name is not found."
+ (or (foreign-symbol-pointer foreign-name)
+ (error "Trying to access undefined foreign variable ~S." foreign-name)))
+
+(defmacro defcvar (name type &key read-only)
+ "Define a foreign global variable."
+ (let* ((lisp-name (lisp-var-name name))
+ (foreign-name (foreign-var-name name))
+ (fn (symbolicate '#:%var-accessor- lisp-name)))
+ (when (aggregatep (parse-type type)) ; we can't really setf an aggregate
+ (setq read-only t)) ; type, at least not yet...
+ `(progn
+ ;; Save foreign-name for posterior access by get-var-pointer
+ (setf (get ',lisp-name 'foreign-var-name) ,foreign-name)
+ ;; Getter
+ (defun ,fn ()
+ (mem-ref (foreign-symbol-pointer-or-lose ,foreign-name) ',type))
+ ;; Setter
+ (defun (setf ,fn) (value)
+ ,(if read-only '(declare (ignore value)) (values))
+ ,(if read-only
+ `(error ,(format nil "Trying to modify read-only foreign var: ~A."
+ lisp-name))
+ `(setf (mem-ref (foreign-symbol-pointer-or-lose ,foreign-name)
+ ',type)
+ value)))
+ ;; Symbol macro
+ (define-symbol-macro ,lisp-name (,fn)))))
Added: branches/xml-class-rework/thirdparty/cffi/src/functions.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/functions.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/functions.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,223 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; functions.lisp --- High-level interface to foreign functions.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Calling Foreign Functions
+;;;
+;;; FOREIGN-FUNCALL is the main primitive for calling foreign
+;;; functions. It converts each argument based on the installed
+;;; translators for its type, then passes the resulting list to
+;;; CFFI-SYS:%FOREIGN-FUNCALL.
+;;;
+;;; For implementation-specific reasons, DEFCFUN doesn't use
+;;; FOREIGN-FUNCALL directly and might use something else
+;;; (passed to TRANSLATE-OBJECTS as the CALL argument) instead
+;;; of CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function.
+
+(defun translate-objects (syms args types rettype call-form)
+ "Helper function for FOREIGN-FUNCALL and DEFCFUN."
+ (if (null args)
+ (expand-type-from-foreign call-form (parse-type rettype))
+ (expand-type-to-foreign-dyn
+ (car args) (car syms)
+ (list (translate-objects (cdr syms) (cdr args)
+ (cdr types) rettype call-form))
+ (parse-type (car types)))))
+
+(defun parse-args-and-types (args)
+ "Returns 4 values. Types, canonicalized types, args and return type."
+ (let ((return-type :void))
+ (loop for (type arg) on args by #'cddr
+ if arg collect type into types
+ and collect (canonicalize-foreign-type type) into ctypes
+ and collect arg into fargs
+ else do (setf return-type type)
+ finally (return (values types ctypes fargs return-type)))))
+
+(defmacro foreign-funcall (name-or-pointer &rest args)
+ "Wrapper around %FOREIGN-FUNCALL(-POINTER) that translates its arguments."
+ (multiple-value-bind (types ctypes fargs rettype)
+ (parse-args-and-types args)
+ (let ((syms (make-gensym-list (length fargs))))
+ (translate-objects
+ syms fargs types rettype
+ `(,(if (stringp name-or-pointer)
+ '%foreign-funcall
+ '%foreign-funcall-pointer)
+ ,name-or-pointer ,@(mapcan #'list ctypes syms)
+ ,(canonicalize-foreign-type rettype))))))
+
+(defun promote-varargs-type (builtin-type)
+ "Default argument promotions."
+ (case builtin-type
+ (:float :double)
+ ((:char :short) :int)
+ ((:unsigned-char :unsigned-short) :unsigned-int)
+ (t builtin-type)))
+
+;;; ATM, the only difference between this macro and FOREIGN-FUNCALL is that
+;;; it does argument promotion for that variadic argument. This could be useful
+;;; to call an hypothetical %foreign-funcall-varargs on some hypothetical lisp
+;;; on an hypothetical platform that has different calling conventions for
+;;; varargs functions. :-)
+(defmacro foreign-funcall-varargs (name-or-pointer fixed-args &rest varargs)
+ "Wrapper around %FOREIGN-FUNCALL(-POINTER) that translates its arguments
+and does type promotion for the variadic arguments."
+ (multiple-value-bind (fixed-types fixed-ctypes fixed-fargs)
+ (parse-args-and-types fixed-args)
+ (multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype)
+ (parse-args-and-types varargs)
+ (let ((fixed-syms (make-gensym-list (length fixed-fargs)))
+ (varargs-syms (make-gensym-list (length varargs-fargs))))
+ (translate-objects
+ (append fixed-syms varargs-syms) (append fixed-fargs varargs-fargs)
+ (append fixed-types varargs-types) rettype
+ `(,(if (stringp name-or-pointer)
+ '%foreign-funcall
+ '%foreign-funcall-pointer)
+ ,name-or-pointer
+ ,@(mapcan #'list
+ (nconc fixed-ctypes
+ (mapcar #'promote-varargs-type varargs-ctypes))
+ (append fixed-syms
+ (loop for sym in varargs-syms
+ and type in varargs-ctypes
+ if (eq type :float)
+ collect `(float ,sym 1.0d0)
+ else collect sym)))
+ ,(canonicalize-foreign-type rettype)))))))
+
+;;;# Defining Foreign Functions
+;;;
+;;; The DEFCFUN macro provides a declarative interface for defining
+;;; Lisp functions that call foreign functions.
+
+(defun lisp-function-name (name)
+ "Return the Lisp function name for foreign function NAME."
+ (etypecase name
+ (list (second name))
+ (string (intern (canonicalize-symbol-name-case (substitute #\- #\_ name))))
+ (symbol name)))
+
+(defun foreign-function-name (name)
+ "Return the foreign function name of NAME."
+ (etypecase name
+ (list (first name))
+ (string name)
+ (symbol (substitute #\_ #\- (string-downcase (symbol-name name))))))
+
+;; If cffi-sys doesn't provide a defcfun-helper-forms,
+;; we define one that uses %foreign-funcall.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (fboundp 'defcfun-helper-forms)
+ (defun defcfun-helper-forms (name lisp-name rettype args types)
+ (declare (ignore lisp-name))
+ (values
+ '()
+ `(%foreign-funcall ,name ,@(mapcan #'list types args) ,rettype)))))
+
+(defun %defcfun (lisp-name foreign-name return-type args)
+ (let ((arg-names (mapcar #'car args))
+ (arg-types (mapcar #'cadr args))
+ (syms (make-gensym-list (length args))))
+ (multiple-value-bind (prelude caller)
+ (defcfun-helper-forms
+ foreign-name lisp-name (canonicalize-foreign-type return-type)
+ syms (mapcar #'canonicalize-foreign-type arg-types))
+ `(progn
+ ,prelude
+ (defun ,lisp-name ,arg-names
+ ,(translate-objects
+ syms arg-names arg-types return-type caller))))))
+
+(defun %defcfun-varargs (lisp-name foreign-name return-type args)
+ (with-unique-names (varargs)
+ (let ((arg-names (mapcar #'car args)))
+ `(defmacro ,lisp-name (,@arg-names &rest ,varargs)
+ `(foreign-funcall-varargs
+ ,',foreign-name
+ ,,`(list ,@(loop for (name type) in args
+ collect type collect name))
+ ,@,varargs
+ ,',return-type)))))
+
+;;; If we find a &REST token at the end of ARGS, it's a varargs function
+;;; therefore we define a lisp macro using %DEFCFUN-VARARGS instead of a
+;;; lisp macro with %DEFCFUN as we would otherwise do.
+(defmacro defcfun (name return-type &body args)
+ "Defines a Lisp function that calls a foreign function."
+ (discard-docstring args)
+ (let ((lisp-name (lisp-function-name name))
+ (foreign-name (foreign-function-name name)))
+ (if (eq (car (last args)) '&rest) ; probably should use STRING=
+ (%defcfun-varargs lisp-name foreign-name return-type (butlast args))
+ (%defcfun lisp-name foreign-name return-type args))))
+
+;;;# Defining Callbacks
+
+(defun inverse-translate-objects (args ignored-args types rettype call)
+ "Helper function for DEFCALLBACK."
+ (labels ((rec (args types)
+ (cond ((null args)
+ (expand-type-to-foreign call (parse-type rettype)))
+ ;; Don't apply translations for arguments that were
+ ;; declared ignored in order to avoid warnings.
+ ((not (member (car args) ignored-args))
+ `(let ((,(car args) ,(expand-type-from-foreign
+ (car args) (parse-type (car types)))))
+ ,(rec (cdr args) (cdr types))))
+ (t (rec (cdr args) (cdr types))))))
+ (rec args types)))
+
+(defun collect-ignored-args (declarations)
+ (loop for declaration in declarations
+ append (loop for decl in (cdr declaration)
+ when (eq (car decl) 'cl:ignore)
+ append (cdr decl))))
+
+(defmacro defcallback (name return-type args &body body)
+ (multiple-value-bind (body docstring declarations)
+ (parse-body body)
+ (declare (ignore docstring))
+ (let ((arg-names (mapcar #'car args))
+ (arg-types (mapcar #'cadr args)))
+ `(progn
+ (%defcallback ,name ,(canonicalize-foreign-type return-type)
+ ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
+ ,@declarations
+ ,(inverse-translate-objects
+ arg-names (collect-ignored-args declarations) arg-types
+ return-type `(block ,name ,@body)))
+ ',name))))
+
+(declaim (inline get-callback))
+(defun get-callback (symbol)
+ (%callback symbol))
+
+(defmacro callback (name)
+ `(%callback ',name))
Added: branches/xml-class-rework/thirdparty/cffi/src/libraries.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/libraries.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/libraries.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,257 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; libraries.lisp --- Finding and loading foreign libraries.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;; Copyright (C) 2006, Luis Oliveira <loliveira(a)common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Finding Foreign Libraries
+;;;
+;;; We offer two ways for the user of a CFFI library to define
+;;; his/her own library directories: *FOREIGN-LIBRARY-DIRECTORIES*
+;;; for regular libraries and *DARWIN-FRAMEWORK-DIRECTORIES* for
+;;; Darwin frameworks.
+;;;
+;;; These two special variables behave similarly to
+;;; ASDF:*CENTRAL-REGISTRY* as its arguments are evaluated before
+;;; being used. We used our MINI-EVAL instead of the full-blown EVAL
+;;; though.
+;;;
+;;; Only after failing to find a library through the normal ways
+;;; (eg: on Linux LD_LIBRARY_PATH, /etc/ld.so.cache, /usr/lib/, /lib)
+;;; do we try to find the library ourselves.
+
+(defvar *foreign-library-directories* '()
+ "List onto which user-defined library paths can be pushed.")
+
+(defvar *darwin-framework-directories*
+ '((merge-pathnames #p"Library/Frameworks/" (user-homedir-pathname))
+ #p"/Library/Frameworks/"
+ #p"/System/Library/Frameworks/")
+ "List of directories where Frameworks are searched for.")
+
+(defun mini-eval (form)
+ "Simple EVAL-like function to evaluate the elements of
+*FOREIGN-LIBRARY-DIRECTORIES* and *DARWIN-FRAMEWORK-DIRECTORIES*."
+ (typecase form
+ (cons (apply (car form) (mapcar #'mini-eval (cdr form))))
+ (symbol (symbol-value form))
+ (t form)))
+
+(defun find-file (path directories)
+ "Searches for PATH in a list of DIRECTORIES and returns the first it finds."
+ (some (lambda (directory) (probe-file (merge-pathnames path directory)))
+ directories))
+
+(defun find-darwin-framework (framework-name)
+ "Searches for FRAMEWORK-NAME in *DARWIN-FRAMEWORK-DIRECTORIES*."
+ (dolist (framework-directory *darwin-framework-directories*)
+ (let ((path (make-pathname
+ :name framework-name
+ :directory
+ (append (pathname-directory (mini-eval framework-directory))
+ (list (format nil "~A.framework" framework-name))))))
+ (when (probe-file path)
+ (return-from find-darwin-framework path)))))
+
+;;;# Defining Foreign Libraries
+;;;
+;;; Foreign libraries can be defined using the
+;;; DEFINE-FOREIGN-LIBRARY macro. Example usage:
+;;;
+;;; (define-foreign-library opengl
+;;; (:darwin (:framework "OpenGL"))
+;;; (:unix (:alternatives "libGL.so" "libGL.so.1"
+;;; #p"/myhome/mylibGL.so"))
+;;; (:windows "opengl32.dll")
+;;; ;; a hypothetical example of a particular platform
+;;; ;; where the OpenGL library is split in two.
+;;; ((:and :some-system :some-cpu) "libGL-support.lib" "libGL-main.lib")
+;;; ;; if no other clauses apply, this one will and a type will be
+;;; ;; automagically appended to the name passed to :default
+;;; (t (:default "libGL")))
+;;;
+;;; This information is stored in the *FOREIGN-LIBRARIES* hashtable
+;;; and when the library is loaded through LOAD-FOREIGN-LIBRARY (usually
+;;; indirectly through the USE-FOREIGN-LIBRARY macro) the first clause
+;;; that returns true when passed to CFFI-FEATURE-P is processed.
+
+(defvar *foreign-libraries* (make-hash-table :test 'eq)
+ "Hashtable of defined libraries.")
+
+(defun get-foreign-library (name)
+ "Look up a library by NAME, signalling an error if not found."
+ (or (gethash name *foreign-libraries*)
+ (error "Undefined foreign library: ~S" name)))
+
+(defun (setf get-foreign-library) (value name)
+ (setf (gethash name *foreign-libraries*) value))
+
+(defmacro define-foreign-library (name &body pairs)
+ "Defines a foreign library NAME that can be posteriorly used with
+the USE-FOREIGN-LIBRARY macro."
+ `(progn (setf (get-foreign-library ',name) ',pairs)
+ ',name))
+
+(defun cffi-feature-p (feature-expression)
+ "Matches a FEATURE-EXPRESSION against the symbols in *FEATURES*
+that belong to the CFFI-FEATURES package only."
+ (when (eql feature-expression t)
+ (return-from cffi-feature-p t))
+ (let ((features-package (find-package '#:cffi-features)))
+ (flet ((cffi-feature-eq (name feature-symbol)
+ (and (eq (symbol-package feature-symbol) features-package)
+ (string= name (symbol-name feature-symbol)))))
+ (etypecase feature-expression
+ (symbol
+ (not (null (member (symbol-name feature-expression) *features*
+ :test #'cffi-feature-eq))))
+ (cons
+ (ecase (first feature-expression)
+ (:and (every #'cffi-feature-p (rest feature-expression)))
+ (:or (some #'cffi-feature-p (rest feature-expression)))
+ (:not (not (cffi-feature-p (cadr feature-expression))))))))))
+
+;;;# LOAD-FOREIGN-LIBRARY-ERROR condition
+;;;
+;;; The various helper functions that load foreign libraries
+;;; can signal this error when something goes wrong. We ignore
+;;; the host's error. We should probably reuse its error message
+;;; but they're usually meaningless.
+
+(define-condition load-foreign-library-error (error)
+ ((text :initarg :text :reader text))
+ (:report (lambda (condition stream)
+ (write-string (text condition) stream))))
+
+(defun read-new-value ()
+ (format t "~&Enter a new value (unevaluated): ")
+ (force-output)
+ (read))
+
+;;; The helper library loading functions will use this function
+;;; to signal a LOAD-FOREIGN-LIBRARY-ERROR and offer the user a
+;;; couple of restarts.
+(defun handle-load-foreign-library-error (argument control &rest arguments)
+ (restart-case (error 'load-foreign-library-error
+ :text (format nil "~?" control arguments))
+ (retry ()
+ :report "Try loading the foreign library again."
+ (load-foreign-library argument))
+ (use-value (new-library)
+ :report "Use another library instead."
+ :interactive read-new-value
+ (load-foreign-library new-library))))
+
+;;;# Loading Foreign Libraries
+
+(defun load-darwin-framework (framework-name)
+ "Tries to find and load a darwin framework in one of the directories
+in *DARWIN-FRAMEWORK-DIRECTORIES*. If unable to find FRAMEWORK-NAME,
+it signals a LOAD-FOREIGN-LIBRARY-ERROR."
+ (let ((framework (find-darwin-framework framework-name)))
+ (if framework
+ (load-foreign-library framework)
+ (handle-load-foreign-library-error
+ (cons :framework framework-name)
+ "Unable to find framework: ~A" framework-name))))
+
+(defun load-foreign-library-name (name)
+ "Tries to load NAME using %LOAD-FOREIGN-LIBRARY which should try and
+find it using the OS's usual methods. If that fails we try to find it
+ourselves."
+ (or (ignore-errors (%load-foreign-library name))
+ (let ((file (find-file name *foreign-library-directories*)))
+ (when file
+ (%load-foreign-library (namestring file))))
+ ;; couldn't load it directly or find it...
+ (handle-load-foreign-library-error
+ name "Unable to load foreign library: ~A" name)))
+
+(defun try-foreign-library-alternatives (library-list)
+ "Goes through a list of alternatives and only signals an error when
+none of alternatives were successfully loaded."
+ (or (some (lambda (lib) (ignore-errors (load-foreign-library lib)))
+ library-list)
+ (handle-load-foreign-library-error
+ (cons :or library-list)
+ "Unable to load any of the alternatives:~% ~S" library-list)))
+
+(defparameter *cffi-feature-suffix-map*
+ '((cffi-features:windows . ".dll")
+ (cffi-features:darwin . ".dylib")
+ (cffi-features:unix . ".so"))
+ "Mapping of OS feature keywords to shared library suffixes.")
+
+(defun default-library-suffix ()
+ "Return a string to use as default library suffix based on the
+operating system. This is used to implement the :DEFAULT option.
+This will need to be extended as we test on more OSes."
+ (loop for (feature . suffix) in *cffi-feature-suffix-map*
+ when (cffi-feature-p feature)
+ do (return-from default-library-suffix suffix))
+ (error "Unable to determine the default library suffix on this OS."))
+
+(defun load-foreign-library (library)
+ "Loads a foreign LIBRARY which can be a symbol denoting a library defined
+through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we try to
+load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIES*;
+or finally list: either (:or lib1 lib2) or (:framework <framework-name>)."
+ (etypecase library
+ (symbol
+ (dolist (library-description (get-foreign-library library))
+ (when (cffi-feature-p (first library-description))
+ (dolist (lib (rest library-description))
+ (load-foreign-library lib))
+ (return-from load-foreign-library t))))
+ (string
+ (load-foreign-library-name library))
+ (pathname
+ (load-foreign-library-name (namestring library)))
+ (cons
+ (ecase (first library)
+ (:framework (load-darwin-framework (second library)))
+ (:default
+ (unless (stringp (second library))
+ (error "Argument to :DEFAULT must be a string."))
+ (load-foreign-library
+ (concatenate 'string (second library) (default-library-suffix))))
+ (:or (try-foreign-library-alternatives (rest library)))))))
+
+(defmacro use-foreign-library (name)
+ `(load-foreign-library ',name))
+
+;;;# Closing Foreign Libraries
+;;;
+;;; FIXME: LOAD-FOREIGN-LIBRARY should probably keep track of what
+;;; libraries it managed to open and CLOSE-FOREIGN-LIBRARY would then
+;;; take a look at that. So, for now, this function is unexported.
+
+(defun close-foreign-library (name)
+ "Closes a foreign library NAME."
+ (%close-foreign-library (etypecase name
+ (pathname (namestring name))
+ (string name))))
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/src/package.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/package.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/package.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,113 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; package.lisp --- Package definition for CFFI.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(defpackage #:cffi
+ (:use #:common-lisp #:cffi-sys #:cffi-utils)
+ (:export
+ ;; Primitive pointer operations.
+ #:foreign-free
+ #:foreign-alloc
+ #:mem-aref
+ #:mem-ref
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:with-foreign-pointer
+ #:make-pointer
+ #:pointer-address
+
+ ;; Shareable vectors.
+ #:make-shareable-vector
+ #:with-pointer-to-vector-data
+
+ ;; Foreign string operations.
+ #:foreign-string-alloc
+ #:foreign-string-free
+ #:foreign-string-to-lisp
+ #:lisp-string-to-foreign
+ #:with-foreign-string
+ #:with-foreign-pointer-as-string
+
+ ;; Foreign function operations.
+ #:defcfun
+ #:foreign-funcall
+
+ ;; Foreign library operations.
+ #:*foreign-library-directories*
+ #:*darwin-framework-directories*
+ #:define-foreign-library
+ #:load-foreign-library
+ #:load-foreign-library-error
+ #:use-foreign-library
+ ;#:close-foreign-library
+
+ ;; Callbacks.
+ #:callback
+ #:get-callback
+ #:defcallback
+
+ ;; Foreign type operations.
+ #:defcstruct
+ #:defcunion
+ #:defctype
+ #:defcenum
+ #:defbitfield
+ #:define-foreign-type
+ #:foreign-enum-keyword
+ #:foreign-enum-value
+ #:foreign-bitfield-symbols
+ #:foreign-bitfield-value
+ #:foreign-slot-pointer
+ #:foreign-slot-value
+ #:foreign-slot-offset
+ #:foreign-slot-names
+ #:foreign-type-alignment
+ #:foreign-type-size
+ #:with-foreign-object
+ #:with-foreign-objects
+ #:with-foreign-slots
+ #:convert-to-foreign
+ #:convert-from-foreign
+ #:free-converted-object
+
+ ;; Extensible foreign type operations.
+ #:translate-to-foreign
+ #:translate-from-foreign
+ #:free-translated-object
+ #:expand-to-foreign-dyn
+ #:expand-to-foreign
+ #:expand-from-foreign
+
+ ;; Foreign globals.
+ #:defcvar
+ #:get-var-pointer
+ #:foreign-symbol-pointer
+ ))
Added: branches/xml-class-rework/thirdparty/cffi/src/strings.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/strings.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/strings.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,140 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; strings.lisp --- Operations on foreign strings.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Foreign String Conversion
+;;;
+;;; Functions for converting NULL-terminated C-strings to Lisp strings
+;;; and vice versa. Currently this is blithely ignorant of encoding
+;;; and assumes characters can fit in 8 bits.
+
+(defun lisp-string-to-foreign (string ptr size)
+ "Copy at most SIZE-1 characters from a Lisp STRING to PTR.
+The foreign string will be null-terminated."
+ (decf size)
+ (loop with i = 0 for char across string
+ while (< i size)
+ do (%mem-set (char-code char) ptr :unsigned-char (post-incf i))
+ finally (%mem-set 0 ptr :unsigned-char i)))
+
+(defun foreign-string-to-lisp (ptr &optional (size most-positive-fixnum)
+ (null-terminated-p t))
+ "Copy at most SIZE characters from PTR into a Lisp string.
+If PTR is a null pointer, returns nil."
+ (unless (null-pointer-p ptr)
+ (with-output-to-string (s)
+ (loop for i fixnum from 0 below size
+ for code = (mem-ref ptr :unsigned-char i)
+ until (and null-terminated-p (zerop code))
+ do (write-char (code-char code) s)))))
+
+;;;# Using Foreign Strings
+
+(defun foreign-string-alloc (string)
+ "Allocate a foreign string containing Lisp string STRING.
+The string must be freed with FOREIGN-STRING-FREE."
+ (check-type string string)
+ (let* ((length (1+ (length string)))
+ (ptr (foreign-alloc :char :count length)))
+ (lisp-string-to-foreign string ptr length)
+ ptr))
+
+(defun foreign-string-free (ptr)
+ "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
+ (foreign-free ptr))
+
+(defmacro with-foreign-string ((var lisp-string) &body body)
+ "Bind VAR to a foreign string containing LISP-STRING in BODY."
+ (with-unique-names (str length)
+ `(let* ((,str ,lisp-string)
+ (,length (progn (check-type ,str string)
+ (1+ (length ,str)))))
+ (with-foreign-pointer (,var ,length)
+ (lisp-string-to-foreign ,str ,var ,length)
+ ,@body))))
+
+(defmacro with-foreign-pointer-as-string
+ ((var size &optional size-var) &body body)
+ "Like WITH-FOREIGN-POINTER except VAR as a Lisp string is used as
+the return value of an implicit PROGN around BODY."
+ `(with-foreign-pointer (,var ,size ,size-var)
+ (progn
+ ,@body
+ (foreign-string-to-lisp ,var))))
+
+;;;# Automatic Conversion of Foreign Strings
+
+(defctype :string :pointer)
+
+(defmethod translate-to-foreign ((s string) (name (eql :string)))
+ (values (foreign-string-alloc s) t))
+
+(defmethod translate-to-foreign (obj (name (eql :string)))
+ (if (pointerp obj)
+ (values obj nil)
+ (error "~A is not a Lisp string or pointer." obj)))
+
+(defmethod translate-from-foreign (ptr (name (eql :string)))
+ (foreign-string-to-lisp ptr))
+
+(defmethod free-translated-object (ptr (name (eql :string)) free-p)
+ (when free-p
+ (foreign-string-free ptr)))
+
+;;; It'd be pretty nice if returning multiple values from translators
+;;; worked as expected:
+;;;
+;;; (define-type-translator :string :from-c (type value)
+;;; "Type translator for string arguments."
+;;; (once-only (value)
+;;; `(values (foreign-string-to-lisp ,value) ,value)))
+;;;
+;;; For now we'll just define a new type.
+;;;
+;;; Also as this examples shows, it'd be nice to specify
+;;; that we don't want to inherit the from-c translators.
+;;; So we could use (defctype :string+ptr :string) and
+;;; just add the new :from-c translator.
+
+(defctype :string+ptr :pointer)
+
+(defmethod translate-to-foreign ((s string) (name (eql :string+ptr)))
+ (values (foreign-string-alloc s) t))
+
+(defmethod translate-to-foreign (obj (name (eql :string+ptr)))
+ (if (pointerp obj)
+ (values obj nil)
+ (error "~A is not a Lisp string or pointer." obj)))
+
+(defmethod translate-from-foreign (value (name (eql :string+ptr)))
+ (list (foreign-string-to-lisp value) value))
+
+(defmethod free-translated-object (value (name (eql :string+ptr)) free-p)
+ (when free-p
+ (foreign-string-free value)))
+
Added: branches/xml-class-rework/thirdparty/cffi/src/types.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/types.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/types.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,680 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; types.lisp --- User-defined CFFI types.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Built-In Types
+
+(define-built-in-foreign-type :char)
+(define-built-in-foreign-type :unsigned-char)
+(define-built-in-foreign-type :short)
+(define-built-in-foreign-type :unsigned-short)
+(define-built-in-foreign-type :int)
+(define-built-in-foreign-type :unsigned-int)
+(define-built-in-foreign-type :long)
+(define-built-in-foreign-type :unsigned-long)
+(define-built-in-foreign-type :float)
+(define-built-in-foreign-type :double)
+(define-built-in-foreign-type :pointer)
+(define-built-in-foreign-type :void)
+
+#-cffi-features:no-long-long
+(progn
+ (define-built-in-foreign-type :long-long)
+ (define-built-in-foreign-type :unsigned-long-long))
+
+;;; When some lisp other than SCL supports :long-double we should
+;;; use #-cffi-features:no-long-double here instead.
+#+(and scl long-float) (define-built-in-foreign-type :long-double)
+
+;;;# Dereferencing Foreign Pointers
+
+(defun mem-ref (ptr type &optional (offset 0))
+ "Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggregate,
+we don't return its 'value' but a pointer to it, which is PTR itself."
+ (let ((ptype (parse-type type)))
+ (if (aggregatep ptype)
+ (inc-pointer ptr offset)
+ (let ((raw-value (%mem-ref ptr (canonicalize ptype) offset)))
+ (if (translate-p ptype)
+ (translate-type-from-foreign raw-value ptype)
+ raw-value)))))
+
+(define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0))
+ "Compiler macro to open-code MEM-REF when TYPE is constant."
+ (if (constantp type)
+ (let ((parsed-type (parse-type (eval type))))
+ (if (aggregatep parsed-type)
+ `(inc-pointer ,ptr ,offset)
+ (expand-type-from-foreign
+ `(%mem-ref ,ptr ,(canonicalize parsed-type) ,offset)
+ parsed-type)))
+ form))
+
+(defun mem-set (value ptr type &optional (offset 0))
+ "Set the value of TYPE at OFFSET bytes from PTR to VALUE."
+ (let ((ptype (parse-type type)))
+ (%mem-set (if (translate-p ptype)
+ (translate-type-to-foreign value ptype)
+ value)
+ ptr (canonicalize ptype) offset)))
+
+(define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env)
+ "SETF expander for MEM-REF that doesn't rebind TYPE.
+This is necessary for the compiler macro on MEM-SET to be able
+to open-code (SETF MEM-REF) forms."
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion ptr env)
+ (declare (ignore setter newval))
+ ;; if either TYPE or OFFSET are constant, we avoid rebinding them
+ ;; so that the compiler macros on MEM-SET and %MEM-SET work.
+ (with-unique-names (store type-tmp offset-tmp)
+ (values
+ (append (unless (constantp type) (list type-tmp))
+ (unless (constantp offset) (list offset-tmp))
+ dummies)
+ (append (unless (constantp type) (list type))
+ (unless (constantp offset) (list offset))
+ vals)
+ (list store)
+ `(progn
+ (mem-set ,store ,getter
+ ,@(if (constantp type) (list type) (list type-tmp))
+ ,@(if (constantp offset) (list offset) (list offset-tmp)))
+ ,store)
+ `(mem-ref ,getter
+ ,@(if (constantp type) (list type) (list type-tmp))
+ ,@(if (constantp offset) (list offset) (list offset-tmp)))))))
+
+(define-compiler-macro mem-set
+ (&whole form value ptr type &optional (offset 0))
+ "Compiler macro to open-code (SETF MEM-REF) when type is constant."
+ (if (constantp type)
+ (let ((parsed-type (parse-type (eval type))))
+ `(%mem-set ,(expand-type-to-foreign value parsed-type) ,ptr
+ ,(canonicalize parsed-type) ,offset))
+ form))
+
+;;;# Dereferencing Foreign Arrays
+
+(defun mem-aref (ptr type &optional (index 0))
+ "Like MEM-REF except for accessing 1d arrays."
+ (mem-ref ptr type (* index (foreign-type-size type))))
+
+(define-compiler-macro mem-aref (&whole form ptr type &optional (index 0))
+ "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)."
+ (if (constantp type)
+ (if (constantp index)
+ `(mem-ref ,ptr ,type
+ ,(* (eval index) (foreign-type-size (eval type))))
+ `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type)))))
+ form))
+
+(define-setf-expander mem-aref (ptr type &optional (index 0) &environment env)
+ "SETF expander for MEM-AREF."
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion ptr env)
+ (declare (ignore setter newval))
+ ;; we avoid rebinding type and index, if possible (and if type is not
+ ;; constant, we don't bother about the index), so that the compiler macros
+ ;; on MEM-SET or %MEM-SET can work.
+ (with-unique-names (store type-tmp index-tmp)
+ (values
+ (append (unless (constantp type)
+ (list type-tmp))
+ (unless (and (constantp type) (constantp index))
+ (list index-tmp))
+ dummies)
+ (append (unless (constantp type)
+ (list type))
+ (unless (and (constantp type) (constantp index))
+ (list index))
+ vals)
+ (list store)
+ ;; Here we'll try to calculate the offset from the type and index,
+ ;; or if not possible at least get the type size early.
+ `(progn
+ ,(if (constantp type)
+ (if (constantp index)
+ `(mem-set ,store ,getter ,type
+ ,(* (eval index) (foreign-type-size (eval type))))
+ `(mem-set ,store ,getter ,type
+ (* ,index-tmp ,(foreign-type-size (eval type)))))
+ `(mem-set ,store ,getter ,type-tmp
+ (* ,index-tmp (foreign-type-size ,type-tmp))))
+ ,store)
+ `(mem-aref ,getter
+ ,@(if (constantp type)
+ (list type)
+ (list type-tmp))
+ ,@(if (and (constantp type) (constantp index))
+ (list index)
+ (list index-tmp)))))))
+
+;;;# Foreign Structures
+
+;;;## Foreign Structure Slots
+
+(defgeneric foreign-struct-slot-pointer (ptr slot)
+ (:documentation
+ "Get the address of SLOT relative to PTR."))
+
+(defgeneric foreign-struct-slot-pointer-form (ptr slot)
+ (:documentation
+ "Return a form to get the address of SLOT in PTR."))
+
+(defgeneric foreign-struct-slot-value (ptr slot)
+ (:documentation
+ "Return the value of SLOT in structure PTR."))
+
+(defgeneric (setf foreign-struct-slot-value) (value ptr slot)
+ (:documentation
+ "Set the value of a SLOT in structure PTR."))
+
+(defgeneric foreign-struct-slot-value-form (ptr slot)
+ (:documentation
+ "Return a form to get the value of SLOT in struct PTR."))
+
+(defgeneric foreign-struct-slot-set-form (value ptr slot)
+ (:documentation
+ "Return a form to set the value of SLOT in struct PTR."))
+
+(defclass foreign-struct-slot ()
+ ((name :initarg :name :reader slot-name)
+ (offset :initarg :offset :accessor slot-offset)
+ (type :initarg :type :accessor slot-type))
+ (:documentation "Base class for simple and aggregate slots."))
+
+(defmethod foreign-struct-slot-pointer (ptr (slot foreign-struct-slot))
+ "Return the address of SLOT relative to PTR."
+ (inc-pointer ptr (slot-offset slot)))
+
+(defmethod foreign-struct-slot-pointer-form (ptr (slot foreign-struct-slot))
+ "Return a form to get the address of SLOT relative to PTR."
+ (let ((offset (slot-offset slot)))
+ (if (zerop offset)
+ ptr
+ `(inc-pointer ,ptr ,offset))))
+
+(defun foreign-slot-names (type)
+ "Returns a list of TYPE's slot names in no particular order."
+ (loop for value being the hash-values
+ in (slots (follow-typedefs (parse-type type)))
+ collect (slot-name value)))
+
+;;;### Simple Slots
+
+(defclass simple-struct-slot (foreign-struct-slot)
+ ()
+ (:documentation "Non-aggregate structure slots."))
+
+(defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot))
+ "Return the value of a simple SLOT from a struct at PTR."
+ (mem-ref ptr (slot-type slot) (slot-offset slot)))
+
+(defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot))
+ "Return a form to get the value of a slot from PTR."
+ `(mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)))
+
+(defmethod (setf foreign-struct-slot-value) (value ptr (slot simple-struct-slot))
+ "Set the value of a simple SLOT to VALUE in PTR."
+ (setf (mem-ref ptr (slot-type slot) (slot-offset slot)) value))
+
+(defmethod foreign-struct-slot-set-form (value ptr (slot simple-struct-slot))
+ "Return a form to set the value of a simple structure slot."
+ `(setf (mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)) ,value))
+
+;;;### Aggregate Slots
+
+(defclass aggregate-struct-slot (foreign-struct-slot)
+ ((count :initarg :count :accessor slot-count))
+ (:documentation "Aggregate structure slots."))
+
+;;; A case could be made for just returning an error here instead of
+;;; this rather DWIM-ish behavior to return the address. It would
+;;; complicate being able to chain together slot names when accessing
+;;; slot values in nested structures though.
+(defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot))
+ "Return a pointer to SLOT relative to PTR."
+ (foreign-struct-slot-pointer ptr slot))
+
+(defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-slot))
+ "Return a form to get the value of SLOT relative to PTR."
+ (foreign-struct-slot-pointer-form ptr slot))
+
+;;; This is definitely an error though. Eventually, we could define a
+;;; new type of type translator that can convert certain aggregate
+;;; types, notably C strings or arrays of integers. For now, just error.
+(defmethod (setf foreign-struct-slot-value) (value ptr (slot aggregate-struct-slot))
+ "Signal an error; setting aggregate slot values is forbidden."
+ (declare (ignore value ptr))
+ (error "Cannot set value of aggregate slot ~A." slot))
+
+(defmethod foreign-struct-slot-set-form (value ptr (slot aggregate-struct-slot))
+ "Signal an error; setting aggregate slot values is forbidden."
+ (declare (ignore value ptr))
+ (error "Cannot set value of aggregate slot ~A." slot))
+
+;;;## Defining Foreign Structures
+
+(defun make-struct-slot (name offset type count)
+ "Make the appropriate type of structure slot."
+ ;; If TYPE is an aggregate type or COUNT is >1, create an
+ ;; AGGREGATE-STRUCT-SLOT, otherwise a SIMPLE-STRUCT-SLOT.
+ (if (or (> count 1) (aggregatep (parse-type type)))
+ (make-instance 'aggregate-struct-slot :offset offset :type type
+ :name name :count count)
+ (make-instance 'simple-struct-slot :offset offset :type type
+ :name name)))
+
+;;; Regarding structure alignment, the following ABIs were checked:
+;;; - System-V ABI: x86, x86-64, ppc, arm, mips and itanium. (more?)
+;;; - Mac OS X ABI Function Call Guide: ppc32, ppc64 and x86.
+;;;
+;;; Rules used here:
+;;;
+;;; 1. "An entire structure or union object is aligned on the same boundary
+;;; as its most strictly aligned member."
+;;; 2. "Each member is assigned to the lowest available offset with the
+;;; appropriate alignment. This may require internal padding, depending
+;;; on the previous member."
+;;; 3. "A structure's size is increased, if necessary, to make it a multiple
+;;; of the alignment. This may require tail padding, depending on the last
+;;; member."
+;;;
+;;; Special case from darwin/ppc32's ABI:
+;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevel…
+;;;
+;;; 1. "The embedding alignment of the first element in a data structure is
+;;; equal to the element's natural alignment."
+;;; 2. "For subsequent elements that have a natural alignment greater than 4
+;;; bytes, the embedding alignment is 4, unless the element is a vector."
+;;; (note: this applies for structures too)
+
+;; FIXME: get a better name for this. --luis
+(defun get-alignment (type alignment-type firstp)
+ "Return alignment for TYPE according to ALIGNMENT-TYPE."
+ (declare (ignorable firstp))
+ (ecase alignment-type
+ (:normal #-(and cffi-features:darwin cffi-features:ppc32)
+ (foreign-type-alignment type)
+ #+(and cffi-features:darwin cffi-features:ppc32)
+ (if firstp
+ (foreign-type-alignment type)
+ (min 4 (foreign-type-alignment type))))))
+
+(defun adjust-for-alignment (type offset alignment-type firstp)
+ "Return OFFSET aligned properly for TYPE according to ALIGNMENT-TYPE."
+ (let* ((align (get-alignment type alignment-type firstp))
+ (rem (mod offset align)))
+ (if (zerop rem)
+ offset
+ (+ offset (- align rem)))))
+
+(defun notice-foreign-struct-definition (name-and-options slots)
+ "Parse and install a foreign structure definition."
+ (destructuring-bind (name &key size #+nil alignment)
+ (mklist name-and-options)
+ (let ((struct (make-instance 'foreign-struct-type :name name))
+ (current-offset 0)
+ (max-align 1)
+ (firstp t))
+ ;; determine offsets
+ (dolist (slotdef slots)
+ (destructuring-bind (slotname type &key (count 1) offset) slotdef
+ (when (eq (canonicalize-foreign-type type) :void)
+ (error "void type not allowed in structure definition: ~S" slotdef))
+ (setq current-offset
+ (or offset
+ (adjust-for-alignment type current-offset :normal firstp)))
+ (let* ((slot (make-struct-slot slotname current-offset type count))
+ (align (get-alignment (slot-type slot) :normal firstp)))
+ (setf (gethash slotname (slots struct)) slot)
+ (when (> align max-align)
+ (setq max-align align)))
+ (incf current-offset (* count (foreign-type-size type))))
+ (setq firstp nil))
+ ;; calculate padding and alignment
+ (setf (alignment struct) max-align) ; See point 1 above.
+ (let ((tail-padding (- max-align (rem current-offset max-align))))
+ (unless (= tail-padding max-align) ; See point 3 above.
+ (incf current-offset tail-padding)))
+ (setf (size struct) (or size current-offset))
+ (notice-foreign-type struct))))
+
+(defmacro defcstruct (name &body fields)
+ "Define the layout of a foreign structure."
+ (discard-docstring fields)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (notice-foreign-struct-definition ',name ',fields)))
+
+;;;## Accessing Foreign Structure Slots
+
+(defun get-slot-info (type slot-name)
+ "Return the slot info for SLOT-NAME or raise an error."
+ (let* ((struct (follow-typedefs (parse-type type)))
+ (info (gethash slot-name (slots struct))))
+ (unless info
+ (error "Undefined slot ~A in foreign type ~A." slot-name type))
+ info))
+
+(defun foreign-slot-pointer (ptr type slot-name)
+ "Return the address of SLOT-NAME in the structure at PTR."
+ (foreign-struct-slot-pointer ptr (get-slot-info type slot-name)))
+
+(defun foreign-slot-offset (type slot-name)
+ "Return the offset of SLOT in a struct TYPE."
+ (slot-offset (get-slot-info type slot-name)))
+
+(defun foreign-slot-value (ptr type slot-name)
+ "Return the value of SLOT-NAME in the foreign structure at PTR."
+ (foreign-struct-slot-value ptr (get-slot-info type slot-name)))
+
+(define-compiler-macro foreign-slot-value (&whole form ptr type slot-name)
+ "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant."
+ (if (and (constantp type) (constantp slot-name))
+ (foreign-struct-slot-value-form
+ ptr (get-slot-info (eval type) (eval slot-name)))
+ form))
+
+(define-setf-expander foreign-slot-value (ptr type slot-name &environment env)
+ "SETF expander for FOREIGN-SLOT-VALUE."
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion ptr env)
+ (declare (ignore setter newval))
+ (if (and (constantp type) (constantp slot-name))
+ ;; if TYPE and SLOT-NAME are constant we avoid rebinding them
+ ;; so that the compiler macro on FOREIGN-SLOT-SET works.
+ (with-unique-names (store)
+ (values
+ dummies
+ vals
+ (list store)
+ `(progn
+ (foreign-slot-set ,store ,getter ,type ,slot-name)
+ ,store)
+ `(foreign-slot-value ,getter ,type ,slot-name)))
+ ;; if not...
+ (with-unique-names (store slot-name-tmp type-tmp)
+ (values
+ (list* type-tmp slot-name-tmp dummies)
+ (list* type slot-name vals)
+ (list store)
+ `(progn
+ (foreign-slot-set ,store ,getter ,type-tmp ,slot-name-tmp)
+ ,store)
+ `(foreign-slot-value ,getter ,type-tmp ,slot-name-tmp))))))
+
+(defun foreign-slot-set (value ptr type slot-name)
+ "Set the value of SLOT-NAME in a foreign structure."
+ (setf (foreign-struct-slot-value ptr (get-slot-info type slot-name)) value))
+
+(define-compiler-macro foreign-slot-set
+ (&whole form value ptr type slot-name)
+ "Optimizer when TYPE and SLOT-NAME are constant."
+ (if (and (constantp type) (constantp slot-name))
+ (foreign-struct-slot-set-form
+ value ptr (get-slot-info (eval type) (eval slot-name)))
+ form))
+
+(defmacro with-foreign-slots ((vars ptr type) &body body)
+ "Create local symbol macros for each var in VARS to reference
+foreign slots in PTR of TYPE. Similar to WITH-SLOTS."
+ (let ((ptr-var (gensym "PTR")))
+ `(let ((,ptr-var ,ptr))
+ (symbol-macrolet
+ ,(loop for var in vars
+ collect `(,var (foreign-slot-value ,ptr-var ',type ',var)))
+ ,@body))))
+
+;;;# Foreign Unions
+;;;
+;;; A union is a FOREIGN-STRUCT-TYPE in which all slots have an offset
+;;; of zero.
+
+;;; See also the notes regarding ABI requirements in
+;;; NOTICE-FOREIGN-STRUCT-DEFINITION
+(defun notice-foreign-union-definition (name-and-options slots)
+ "Parse and install a foreign union definition."
+ (destructuring-bind (name &key size)
+ (mklist name-and-options)
+ (let ((struct (make-instance 'foreign-struct-type :name name))
+ (max-size 0)
+ (max-align 0))
+ (dolist (slotdef slots)
+ (destructuring-bind (slotname type &key (count 1)) slotdef
+ (when (eq (canonicalize-foreign-type type) :void)
+ (error "void type not allowed in union definition: ~S" slotdef))
+ (let* ((slot (make-struct-slot slotname 0 type count))
+ (size (* count (foreign-type-size type)))
+ (align (foreign-type-alignment (slot-type slot))))
+ (setf (gethash slotname (slots struct)) slot)
+ (when (> size max-size)
+ (setf max-size size))
+ (when (> align max-align)
+ (setf max-align align)))))
+ (setf (size struct) (or size max-size))
+ (setf (alignment struct) max-align)
+ (notice-foreign-type struct))))
+
+(defmacro defcunion (name &body fields)
+ "Define the layout of a foreign union."
+ (discard-docstring fields)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (notice-foreign-union-definition ',name ',fields)))
+
+;;;# Operations on Types
+
+(defmethod foreign-type-alignment (type)
+ "Return the alignment in bytes of a foreign type."
+ (foreign-type-alignment (parse-type type)))
+
+(defun foreign-alloc (type &key (initial-element nil initial-element-p)
+ (initial-contents nil initial-contents-p)
+ (count 1 count-p) null-terminated-p)
+ "Allocate enough memory to hold COUNT objects of type TYPE. If
+INITIAL-ELEMENT is supplied, each element of the newly allocated
+memory is initialized with its value. If INITIAL-CONTENTS is supplied,
+each of its elements will be used to initialize the contents of the
+newly allocated memory."
+ (let (contents-length)
+ ;; Some error checking, etc...
+ (when (and null-terminated-p
+ (not (eq (canonicalize-foreign-type type) :pointer)))
+ (error "Cannot use :NULL-TERMINATED-P with non-pointer types."))
+ (when (and initial-element-p initial-contents-p)
+ (error "Cannot specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
+ (when initial-contents-p
+ (setq contents-length (length initial-contents))
+ (if count-p
+ (assert (>= count contents-length))
+ (setq count contents-length)))
+ ;; Everything looks good.
+ (let ((ptr (%foreign-alloc (* (foreign-type-size type)
+ (if null-terminated-p (1+ count) count)))))
+ (when initial-element-p
+ (dotimes (i count)
+ (setf (mem-aref ptr type i) initial-element)))
+ (when initial-contents-p
+ (dotimes (i contents-length)
+ (setf (mem-aref ptr type i) (elt initial-contents i))))
+ (when null-terminated-p
+ (setf (mem-aref ptr :pointer count) (null-pointer)))
+ ptr)))
+
+;;; Stuff we could optimize here:
+;;; 1. (and (constantp type) (constantp count)) => calculate size
+;;; 2. (constantp type) => use the translators' expanders
+#-(and)
+(define-compiler-macro foreign-alloc
+ (&whole form type &key (initial-element nil initial-element-p)
+ (initial-contents nil initial-contents-p) (count 1 count-p))
+ )
+
+(defmacro with-foreign-object ((var type &optional (count 1)) &body body)
+ "Bind VAR to a pointer to COUNT objects of TYPE during BODY.
+The buffer has dynamic extent and may be stack allocated."
+ `(with-foreign-pointer
+ (,var ,(if (constantp type)
+ ;; with-foreign-pointer may benefit from constant folding:
+ (if (constantp count)
+ (* (eval count) (foreign-type-size (eval type)))
+ `(* ,count ,(foreign-type-size (eval type))))
+ `(* ,count (foreign-type-size ,type))))
+ ,@body))
+
+(defmacro with-foreign-objects (bindings &rest body)
+ (if bindings
+ `(with-foreign-object ,(car bindings)
+ (with-foreign-objects ,(cdr bindings)
+ ,@body))
+ `(progn ,@body)))
+
+;;;# User-defined Types and Translations.
+
+(defmacro define-foreign-type (type lambda-list &body body)
+ "Define a parameterized type."
+ (discard-docstring body)
+ `(progn
+ (define-type-spec-parser ,type ,lambda-list
+ (make-instance 'foreign-typedef :name ',type
+ :actual-type (parse-type (progn ,@body))))
+ ',type))
+
+(defmacro defctype (name base-type &key (translate-p t) documentation)
+ "Utility macro for simple C-like typedefs. A similar effect could be
+obtained using define-foreign-type."
+ (declare (ignore documentation))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (notice-foreign-type
+ (make-instance 'foreign-typedef :name ',name
+ :actual-type (parse-type ',base-type)
+ :translate-p ,translate-p))))
+
+;;;## Anonymous Type Translators
+;;;
+;;; (:wrapper :to-c some-function :from-c another-function)
+;;;
+;;; TODO: We will need to add a FREE function to this as well I think.
+;;; --james
+
+(defclass foreign-type-wrapper (foreign-typedef)
+ ((to-c :initarg :to-c)
+ (from-c :initarg :from-c))
+ (:documentation "Class for the wrapper type."))
+
+(define-type-spec-parser :wrapper (base-type &key to-c from-c)
+ (make-instance 'foreign-type-wrapper
+ :actual-type (parse-type base-type)
+ :to-c (or to-c 'identity)
+ :from-c (or from-c 'identity)))
+
+(defmethod unparse (name (type foreign-type-wrapper))
+ (declare (ignore name))
+ `(:wrapper ,(name (actual-type type))
+ :to-c ,(slot-value type 'to-c)
+ :from-c ,(slot-value type 'from-c)))
+
+(defmethod translate-type-to-foreign (value (type foreign-type-wrapper))
+ (let ((actual-type (actual-type type)))
+ (translate-type-to-foreign
+ (funcall (slot-value type 'to-c) value) actual-type)))
+
+(defmethod translate-type-from-foreign (value (type foreign-type-wrapper))
+ (let ((actual-type (actual-type type)))
+ (funcall (slot-value type 'from-c)
+ (translate-type-from-foreign value actual-type))))
+
+;;;# Other types
+
+(define-foreign-type :boolean (&optional (base-type :int))
+ "Boolean type. Maps to an :int by default. Only accepts integer types."
+ (ecase (canonicalize-foreign-type base-type)
+ ((:char
+ :unsigned-char
+ :int
+ :unsigned-int
+ :long
+ :unsigned-long) base-type)))
+
+(defmethod unparse ((name (eql :boolean)) type)
+ "Unparser for the :BOOLEAN type."
+ `(:boolean ,(name (actual-type type))))
+
+(defmethod translate-to-foreign (value (name (eql :boolean)))
+ (if value 1 0))
+
+(defmethod translate-from-foreign (value (name (eql :boolean)))
+ (not (zerop value)))
+
+(defmethod expand-to-foreign (value (name (eql :boolean)))
+ "Optimization for the :boolean type."
+ (if (constantp value)
+ (if (eval value) 1 0)
+ `(if ,value 1 0)))
+
+(defmethod expand-from-foreign (value (name (eql :boolean)))
+ "Optimization for the :boolean type."
+ (if (constantp value) ; very unlikely, heh
+ (not (zerop (eval value)))
+ `(not (zerop ,value))))
+
+;;;# Typedefs for built-in types.
+
+(defctype :uchar :unsigned-char :translate-p nil)
+(defctype :ushort :unsigned-short :translate-p nil)
+(defctype :uint :unsigned-int :translate-p nil)
+(defctype :ulong :unsigned-long :translate-p nil)
+
+#-cffi-features:no-long-long
+(progn
+ (defctype :llong :long-long :translate-p nil)
+ (defctype :ullong :unsigned-long-long :translate-p nil))
+
+;;; We try to define the :[u]int{8,16,32,64} types by looking at
+;;; the sizes of the built-in integer types and defining typedefs.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (labels ((find-matching-size (size types)
+ (car (member size types :key #'foreign-type-size)))
+ (notice-foreign-typedef (type actual-type)
+ (notice-foreign-type
+ (make-instance 'foreign-typedef :name type
+ :actual-type (find-type actual-type)
+ :translate-p nil)))
+ (match-types (sized-types builtin-types)
+ (loop for (type . size) in sized-types do
+ (let ((match (find-matching-size size builtin-types)))
+ (when match
+ (notice-foreign-typedef type match))))))
+ ;; signed
+ (match-types '((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8))
+ '(:char :short :int :long
+ #-cffi-features:no-long-long :long-long))
+ ;; unsigned
+ (match-types '((:uint8 . 1) (:uint16 . 2) (:uint32 . 4) (:uint64 . 8))
+ '(:unsigned-char :unsigned-short :unsigned-int :unsigned-long
+ #-cffi-features:no-long-long :unsigned-long-long))))
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/src/utils.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/src/utils.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/src/utils.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,176 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; utils.lisp --- Various utilities.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(defpackage #:cffi-utils
+ (:use #:common-lisp)
+ (:export #:discard-docstring
+ #:parse-body
+ #:with-unique-names
+ #:once-only
+ #:mklist
+ #:make-gensym-list
+ #:symbolicate
+ #:let-when
+ #:bif
+ #:post-incf))
+
+(in-package #:cffi-utils)
+
+;;;# General Utilities
+
+;;; frodef's, see: http://paste.lisp.org/display/2771#1
+(defmacro post-incf (place &optional (delta 1) &environment env)
+ "Increment PLACE by DELTA and return its previous value."
+ (multiple-value-bind (dummies vals new setter getter)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
+ (prog1 ,(car new)
+ (setq ,(car new) (+ ,(car new) ,delta))
+ ,setter))))
+
+;;; On Lisp, IIRC.
+(defun mklist (x)
+ "Make into list if atom."
+ (if (listp x) x (list x)))
+
+;;; My own, hah!
+(defmacro discard-docstring (body-var)
+ "Discards the first element of the list in body-var if it's a
+string and the only element."
+ `(when (and (stringp (car ,body-var)) (cdr ,body-var))
+ (pop ,body-var)))
+
+;;; Parse a body of code, removing an optional documentation string
+;;; and declaration forms. Returns the actual body, docstring, and
+;;; declarations as three multiple values.
+(defun parse-body (body)
+ (let ((docstring nil)
+ (declarations nil))
+ (when (and (stringp (car body)) (cdr body))
+ (setf docstring (pop body)))
+ (loop while (and (consp (car body)) (eql (caar body) 'cl:declare))
+ do (push (pop body) declarations))
+ (values body docstring (nreverse declarations))))
+
+;;; LET-IF (renamed to BIF) and LET-WHEN taken from KMRCL
+(defmacro let-when ((var test-form) &body body)
+ `(let ((,var ,test-form))
+ (when ,var ,@body)))
+
+(defmacro bif ((var test-form) if-true &optional if-false)
+ `(let ((,var ,test-form))
+ (if ,var ,if-true ,if-false)))
+
+;;; ONCE-ONLY macro taken from PAIP
+(defun starts-with (list x)
+ "Is x a list whose first element is x?"
+ (and (consp list) (eql (first list) x)))
+
+(defun side-effect-free? (exp)
+ "Is exp a constant, variable, or function,
+ or of the form (THE type x) where x is side-effect-free?"
+ (or (atom exp) (constantp exp)
+ (starts-with exp 'function)
+ (and (starts-with exp 'the)
+ (side-effect-free? (third exp)))))
+
+(defmacro once-only (variables &rest body)
+ "Returns the code built by BODY. If any of VARIABLES
+ might have side effects, they are evaluated once and stored
+ in temporary variables that are then passed to BODY."
+ (assert (every #'symbolp variables))
+ (let ((temps nil))
+ (dotimes (i (length variables)) (push (gensym "ONCE") temps))
+ `(if (every #'side-effect-free? (list .,variables))
+ (progn .,body)
+ (list 'let
+ ,`(list ,@(mapcar #'(lambda (tmp var)
+ `(list ',tmp ,var))
+ temps variables))
+ (let ,(mapcar #'(lambda (var tmp) `(,var ',tmp))
+ variables temps)
+ .,body)))))
+
+;;;; The following utils were taken from SBCL's
+;;;; src/code/*-extensions.lisp
+
+;;; Automate an idiom often found in macros:
+;;; (LET ((FOO (GENSYM "FOO"))
+;;; (MAX-INDEX (GENSYM "MAX-INDEX-")))
+;;; ...)
+;;;
+;;; "Good notation eliminates thought." -- Eric Siggia
+;;;
+;;; Incidentally, this is essentially the same operator which
+;;; _On Lisp_ calls WITH-GENSYMS.
+(defmacro with-unique-names (symbols &body body)
+ `(let ,(mapcar (lambda (symbol)
+ (let* ((symbol-name (symbol-name symbol))
+ (stem (if (every #'alpha-char-p symbol-name)
+ symbol-name
+ (concatenate 'string symbol-name "-"))))
+ `(,symbol (gensym ,stem))))
+ symbols)
+ ,@body))
+
+(defun make-gensym-list (n)
+ "Return a list of N gensyms."
+ (loop repeat n collect (gensym)))
+
+(defun symbolicate (&rest things)
+ "Concatenate together the names of some strings and symbols,
+producing a symbol in the current package."
+ (let* ((length (reduce #'+ things
+ :key (lambda (x) (length (string x)))))
+ (name (make-array length :element-type 'character)))
+ (let ((index 0))
+ (dolist (thing things (values (intern name)))
+ (let* ((x (string thing))
+ (len (length x)))
+ (replace name x :start1 index)
+ (incf index len))))))
+
+;(defun deprecation-warning (bad-name &optional good-name)
+; (warn "using deprecated ~S~@[, should use ~S instead~]"
+; bad-name
+; good-name))
+
+;;; Anaphoric macros
+;(defmacro awhen (test &body body)
+; `(let ((it ,test))
+; (when it ,@body)))
+
+;(defmacro acond (&rest clauses)
+; (if (null clauses)
+; `()
+; (destructuring-bind ((test &body body) &rest rest) clauses
+; (once-only (test)
+; `(if ,test
+; (let ((it ,test)) (declare (ignorable it)),@body)
+; (acond ,@rest))))))
Added: branches/xml-class-rework/thirdparty/cffi/tests/Makefile
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/Makefile 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/Makefile 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,78 @@
+# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
+#
+# Makefile --- Make targets for various tasks.
+#
+# Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation
+# files (the "Software"), to deal in the Software without
+# restriction, including without limitation the rights to use, copy,
+# modify, merge, publish, distribute, sublicense, and/or sell copies
+# of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+#
+
+OSTYPE = $(shell uname)
+
+CC := gcc
+CFLAGS := -lm -Wall -std=c99 -pedantic
+SHLIB_CFLAGS := -shared
+SHLIB_EXT := .so
+
+ifneq ($(if $(findstring $(OSTYPE),Linux FreeBSD),OK), OK)
+ifeq ($(OSTYPE), Darwin)
+SHLIB_CFLAGS := -bundle
+else
+ifeq ($(OSTYPE), SunOS)
+CFLAGS := -c -Wall -std=c99 -pedantic
+else
+# Let's assume this is win32
+SHLIB_EXT := .dll
+endif
+endif
+endif
+
+ARCH = $(shell uname -m)
+
+ifeq ($(ARCH), x86_64)
+CFLAGS += -fPIC
+endif
+
+# Are all G5s ppc970s?
+ifeq ($(ARCH), ppc970)
+CFLAGS += -m64
+endif
+
+SHLIBS = libtest$(SHLIB_EXT)
+
+ifeq ($(ARCH), x86_64)
+SHLIBS += libtest32$(SHLIB_EXT)
+endif
+
+shlibs: $(SHLIBS)
+
+libtest$(SHLIB_EXT): libtest.c
+ $(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
+
+ifeq ($(ARCH), x86_64)
+libtest32$(SHLIB_EXT): libtest.c
+ $(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
+endif
+
+clean:
+ rm -f *.so *.dylib *.dll *.bundle
+
+# vim: ft=make ts=3 noet
Property changes on: branches/xml-class-rework/thirdparty/cffi/tests/Makefile
___________________________________________________________________
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/tests/bindings.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/bindings.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/bindings.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,63 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; libtest.lisp --- Setup CFFI bindings for libtest.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(define-foreign-library libtest
+ (:unix (:or "libtest.so" "libtest32.so"))
+ (:darwin "libtest.so")
+ (:windows "libtest.dll" "msvcrt.dll"))
+
+;;; Return the directory containing the source when compiling or
+;;; loading this file. We don't use *LOAD-TRUENAME* because the fasl
+;;; file may be in a different directory than the source with certain
+;;; ASDF extensions loaded.
+(defun load-directory ()
+ (let ((here #.(or *compile-file-truename* *load-truename*)))
+ (make-pathname :directory (pathname-directory here))))
+
+(let ((*foreign-library-directories* (list (load-directory))))
+ (load-foreign-library 'libtest))
+
+;;; check libtest version
+(defparameter *required-dll-version* "20060414")
+
+(defcvar "dll_version" :string)
+
+(unless (string= *dll-version* *required-dll-version*)
+ (error (format nil
+ "version check failed: expected ~s but libtest reports ~s"
+ *required-dll-version*
+ *dll-version*)))
+
+;;; The maximum and minimum values for single and double precision C
+;;; floating point values, which may be quite different from the
+;;; corresponding Lisp versions.
+(defcvar "float_max" :float)
+(defcvar "float_min" :float)
+(defcvar "double_max" :double)
+(defcvar "double_min" :double)
Added: branches/xml-class-rework/thirdparty/cffi/tests/callbacks.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/callbacks.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/callbacks.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,491 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; callbacks.lisp --- Tests on callbacks.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcfun "expect_char_sum" :int (f :pointer))
+(defcfun "expect_unsigned_char_sum" :int (f :pointer))
+(defcfun "expect_short_sum" :int (f :pointer))
+(defcfun "expect_unsigned_short_sum" :int (f :pointer))
+(defcfun "expect_int_sum" :int (f :pointer))
+(defcfun "expect_unsigned_int_sum" :int (f :pointer))
+(defcfun "expect_long_sum" :int (f :pointer))
+(defcfun "expect_unsigned_long_sum" :int (f :pointer))
+(defcfun "expect_float_sum" :int (f :pointer))
+(defcfun "expect_double_sum" :int (f :pointer))
+(defcfun "expect_pointer_sum" :int (f :pointer))
+(defcfun "expect_strcat" :int (f :pointer))
+
+#-cffi-features:no-long-long
+(progn
+ (defcfun "expect_long_long_sum" :int (f :pointer))
+ (defcfun "expect_unsigned_long_long_sum" :int (f :pointer)))
+
+#+(and scl long-float)
+(defcfun "expect_long_double_sum" :int (f :pointer))
+
+(defcallback sum-char :char ((a :char) (b :char))
+ "Test if the named block is present and the docstring too."
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (return-from sum-char (+ a b)))
+
+(defcallback sum-unsigned-char :unsigned-char
+ ((a :unsigned-char) (b :unsigned-char))
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (+ a b))
+
+(defcallback sum-short :short ((a :short) (b :short))
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (+ a b))
+
+(defcallback sum-unsigned-short :unsigned-short
+ ((a :unsigned-short) (b :unsigned-short))
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (+ a b))
+
+(defcallback sum-int :int ((a :int) (b :int))
+ (+ a b))
+
+(defcallback sum-unsigned-int :unsigned-int
+ ((a :unsigned-int) (b :unsigned-int))
+ (+ a b))
+
+(defcallback sum-long :long ((a :long) (b :long))
+ (+ a b))
+
+(defcallback sum-unsigned-long :unsigned-long
+ ((a :unsigned-long) (b :unsigned-long))
+ (+ a b))
+
+#-cffi-features:no-long-long
+(progn
+ (defcallback sum-long-long :long-long
+ ((a :long-long) (b :long-long))
+ (+ a b))
+
+ (defcallback sum-unsigned-long-long :unsigned-long-long
+ ((a :unsigned-long-long) (b :unsigned-long-long))
+ (+ a b)))
+
+(defcallback sum-float :float ((a :float) (b :float))
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (+ a b))
+
+(defcallback sum-double :double ((a :double) (b :double))
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (+ a b))
+
+#+(and scl long-float)
+(defcallback sum-long-double :long-double ((a :long-double) (b :long-double))
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (+ a b))
+
+(defcallback sum-pointer :pointer ((ptr :pointer) (offset :int))
+ (inc-pointer ptr offset))
+
+(defcallback lisp-strcat :string ((a :string) (b :string))
+ (concatenate 'string a b))
+
+(deftest callbacks.char
+ (expect-char-sum (get-callback 'sum-char))
+ 1)
+
+(deftest callbacks.unsigned-char
+ (expect-unsigned-char-sum (get-callback 'sum-unsigned-char))
+ 1)
+
+(deftest callbacks.short
+ (expect-short-sum (callback sum-short))
+ 1)
+
+(deftest callbacks.unsigned-short
+ (expect-unsigned-short-sum (callback sum-unsigned-short))
+ 1)
+
+(deftest callbacks.int
+ (expect-int-sum (callback sum-int))
+ 1)
+
+(deftest callbacks.unsigned-int
+ (expect-unsigned-int-sum (callback sum-unsigned-int))
+ 1)
+
+(deftest callbacks.long
+ (expect-long-sum (callback sum-long))
+ 1)
+
+(deftest callbacks.unsigned-long
+ (expect-unsigned-long-sum (callback sum-unsigned-long))
+ 1)
+
+#-cffi-features:no-long-long
+(progn
+ #+openmcl (push 'callbacks.long-long rt::*expected-failures*)
+
+ (deftest callbacks.long-long
+ (expect-long-long-sum (callback sum-long-long))
+ 1)
+
+ (deftest callbacks.unsigned-long-long
+ (expect-unsigned-long-long-sum (callback sum-unsigned-long-long))
+ 1))
+
+(deftest callbacks.float
+ (expect-float-sum (callback sum-float))
+ 1)
+
+(deftest callbacks.double
+ (expect-double-sum (callback sum-double))
+ 1)
+
+#+(and scl long-float)
+(deftest callbacks.long-double
+ (expect-long-double-sum (callback sum-long-double))
+ 1)
+
+(deftest callbacks.pointer
+ (expect-pointer-sum (callback sum-pointer))
+ 1)
+
+(deftest callbacks.string
+ (expect-strcat (callback lisp-strcat))
+ 1)
+
+#-cffi-features:no-foreign-funcall
+(defcallback return-a-string-not-nil :string ()
+ "abc")
+
+#-cffi-features:no-foreign-funcall
+(deftest callbacks.string-not-docstring
+ (foreign-funcall (callback return-a-string-not-nil) :string)
+ "abc")
+
+;;; This one tests mem-aref too.
+(defcfun "qsort" :void
+ (base :pointer)
+ (nmemb :int)
+ (size :int)
+ (fun-compar :pointer))
+
+(defcallback < :int ((a :pointer) (b :pointer))
+ (let ((x (mem-ref a :int))
+ (y (mem-ref b :int)))
+ (cond ((> x y) 1)
+ ((< x y) -1)
+ (t 0))))
+
+(deftest callbacks.qsort
+ (with-foreign-object (array :int 10)
+ ;; Initialize array.
+ (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
+ do (setf (mem-aref array :int i) n))
+ ;; Sort it.
+ (qsort array 10 (foreign-type-size :int) (callback <))
+ ;; Return it as a list.
+ (loop for i from 0 below 10
+ collect (mem-aref array :int i)))
+ (1 2 3 4 5 6 7 8 9 10))
+
+;;; void callback
+(defparameter *int* -1)
+
+(defcfun "pass_int_ref" :void (f :pointer))
+
+;;; CMUCL chokes on this one for some reason.
+#-(and cffi-features:darwin cmu)
+(defcallback read-int-from-pointer :void ((a :pointer))
+ (setq *int* (mem-ref a :int)))
+
+#+(and cffi-features:darwin cmu)
+(pushnew 'callbacks.void rt::*expected-failures*)
+
+(deftest callbacks.void
+ (progn
+ (pass-int-ref (callback read-int-from-pointer))
+ *int*)
+ 1984)
+
+;;; test funcalling of a callback and also declarations inside
+;;; callbacks.
+
+#-cffi-features:no-foreign-funcall
+(progn
+ (defcallback sum-2 :int ((a :int) (b :int) (c :int))
+ (declare (ignore c))
+ (+ a b))
+
+ (deftest callbacks.funcall.1
+ (foreign-funcall (callback sum-2) :int 2 :int 3 :int 1 :int)
+ 5)
+
+ (defctype foo-float :float)
+
+ (defcallback sum-2f foo-float
+ ((a foo-float) (b foo-float) (c foo-float) (d foo-float) (e foo-float))
+ "This one ignores the middle 3 arguments."
+ (declare (ignore b c))
+ (declare (ignore d))
+ (+ a e))
+
+ (deftest callbacks.funcall.2
+ (foreign-funcall (callback sum-2f) foo-float 1.0 foo-float 2.0
+ foo-float 3.0 foo-float 4.0 foo-float 5.0 foo-float)
+ 6.0))
+
+;;; (cb-test :no-long-long t)
+
+(defcfun "call_sum_127_no_ll" :long (cb :pointer))
+
+;;; CMUCL chokes on this one.
+#-cmu
+(defcallback sum-127-no-ll :long
+ ((a1 :unsigned-long) (a2 :pointer) (a3 :long) (a4 :double)
+ (a5 :unsigned-long) (a6 :float) (a7 :float) (a8 :int) (a9 :unsigned-int)
+ (a10 :double) (a11 :double) (a12 :double) (a13 :pointer)
+ (a14 :unsigned-short) (a15 :unsigned-short) (a16 :pointer) (a17 :long)
+ (a18 :long) (a19 :int) (a20 :short) (a21 :unsigned-short)
+ (a22 :unsigned-short) (a23 :char) (a24 :long) (a25 :pointer) (a26 :pointer)
+ (a27 :char) (a28 :unsigned-char) (a29 :unsigned-long) (a30 :short)
+ (a31 :int) (a32 :int) (a33 :unsigned-char) (a34 :short) (a35 :long)
+ (a36 :long) (a37 :pointer) (a38 :unsigned-short) (a39 :char) (a40 :double)
+ (a41 :unsigned-short) (a42 :pointer) (a43 :short) (a44 :unsigned-long)
+ (a45 :unsigned-short) (a46 :float) (a47 :unsigned-char) (a48 :short)
+ (a49 :float) (a50 :short) (a51 :char) (a52 :unsigned-long)
+ (a53 :unsigned-long) (a54 :char) (a55 :float) (a56 :long) (a57 :pointer)
+ (a58 :short) (a59 :float) (a60 :unsigned-int) (a61 :float)
+ (a62 :unsigned-int) (a63 :double) (a64 :unsigned-int) (a65 :unsigned-char)
+ (a66 :int) (a67 :long) (a68 :char) (a69 :short) (a70 :double) (a71 :int)
+ (a72 :pointer) (a73 :char) (a74 :unsigned-short) (a75 :pointer)
+ (a76 :unsigned-short) (a77 :pointer) (a78 :unsigned-long) (a79 :double)
+ (a80 :pointer) (a81 :long) (a82 :float) (a83 :unsigned-short)
+ (a84 :unsigned-short) (a85 :pointer) (a86 :float) (a87 :int)
+ (a88 :unsigned-int) (a89 :double) (a90 :float) (a91 :long) (a92 :pointer)
+ (a93 :unsigned-short) (a94 :float) (a95 :unsigned-char) (a96 :unsigned-char)
+ (a97 :float) (a98 :unsigned-int) (a99 :float) (a100 :unsigned-short)
+ (a101 :double) (a102 :unsigned-short) (a103 :unsigned-long)
+ (a104 :unsigned-int) (a105 :unsigned-long) (a106 :pointer)
+ (a107 :unsigned-char) (a108 :char) (a109 :char) (a110 :unsigned-short)
+ (a111 :unsigned-long) (a112 :float) (a113 :short) (a114 :pointer)
+ (a115 :long) (a116 :unsigned-short) (a117 :short) (a118 :double)
+ (a119 :short) (a120 :int) (a121 :char) (a122 :unsigned-long) (a123 :long)
+ (a124 :int) (a125 :pointer) (a126 :double) (a127 :unsigned-char))
+ (let ((args (list a1 (pointer-address a2) a3 (floor a4) a5 (floor a6)
+ (floor a7) a8 a9 (floor a10) (floor a11) (floor a12)
+ (pointer-address a13) a14 a15 (pointer-address a16) a17 a18
+ a19 a20 a21 a22 a23 a24 (pointer-address a25)
+ (pointer-address a26) a27 a28 a29 a30 a31 a32 a33 a34 a35
+ a36 (pointer-address a37) a38 a39 (floor a40) a41
+ (pointer-address a42) a43 a44 a45 (floor a46) a47 a48
+ (floor a49) a50 a51 a52 a53 a54 (floor a55) a56
+ (pointer-address a57) a58 (floor a59) a60 (floor a61) a62
+ (floor a63) a64 a65 a66 a67 a68 a69 (floor a70) a71
+ (pointer-address a72) a73 a74 (pointer-address a75) a76
+ (pointer-address a77) a78 (floor a79) (pointer-address a80)
+ a81 (floor a82) a83 a84 (pointer-address a85) (floor a86)
+ a87 a88 (floor a89) (floor a90) a91 (pointer-address a92)
+ a93 (floor a94) a95 a96 (floor a97) a98 (floor a99) a100
+ (floor a101) a102 a103 a104 a105 (pointer-address a106) a107
+ a108 a109 a110 a111 (floor a112) a113 (pointer-address a114)
+ a115 a116 a117 (floor a118) a119 a120 a121 a122 a123 a124
+ (pointer-address a125) (floor a126) a127)))
+ #-(and)
+ (loop for i from 1 and arg in args do
+ (format t "a~A: ~A~%" i arg))
+ (reduce #'+ args)))
+
+#+(or openmcl cmu (and cffi-features:darwin (or allegro lispworks)))
+(push 'callbacks.bff.1 regression-test::*expected-failures*)
+
+(deftest callbacks.bff.1
+ (call-sum-127-no-ll (callback sum-127-no-ll))
+ 2008547941)
+
+;;; (cb-test)
+
+#-cffi-features:no-long-long
+(progn
+ (defcfun "call_sum_127" :long-long (cb :pointer))
+
+ ;;; CMUCL chokes on this one.
+ #-cmu
+ (defcallback sum-127 :long-long
+ ((a1 :short) (a2 :char) (a3 :pointer) (a4 :float) (a5 :long) (a6 :double)
+ (a7 :unsigned-long-long) (a8 :unsigned-short) (a9 :unsigned-char)
+ (a10 :char) (a11 :char) (a12 :unsigned-short) (a13 :unsigned-long-long)
+ (a14 :unsigned-short) (a15 :long-long) (a16 :unsigned-short)
+ (a17 :unsigned-long-long) (a18 :unsigned-char) (a19 :unsigned-char)
+ (a20 :unsigned-long-long) (a21 :long-long) (a22 :char) (a23 :float)
+ (a24 :unsigned-int) (a25 :float) (a26 :float) (a27 :unsigned-int)
+ (a28 :float) (a29 :char) (a30 :unsigned-char) (a31 :long) (a32 :long-long)
+ (a33 :unsigned-char) (a34 :double) (a35 :long) (a36 :double)
+ (a37 :unsigned-int) (a38 :unsigned-short) (a39 :long-long)
+ (a40 :unsigned-int) (a41 :int) (a42 :unsigned-long-long) (a43 :long)
+ (a44 :short) (a45 :unsigned-int) (a46 :unsigned-int)
+ (a47 :unsigned-long-long) (a48 :unsigned-int) (a49 :long) (a50 :pointer)
+ (a51 :unsigned-char) (a52 :char) (a53 :long-long) (a54 :unsigned-short)
+ (a55 :unsigned-int) (a56 :float) (a57 :unsigned-char) (a58 :unsigned-long)
+ (a59 :long-long) (a60 :float) (a61 :long) (a62 :float) (a63 :int)
+ (a64 :float) (a65 :unsigned-short) (a66 :unsigned-long-long) (a67 :short)
+ (a68 :unsigned-long) (a69 :long) (a70 :char) (a71 :unsigned-short)
+ (a72 :long-long) (a73 :short) (a74 :double) (a75 :pointer)
+ (a76 :unsigned-int) (a77 :char) (a78 :unsigned-int) (a79 :pointer)
+ (a80 :pointer) (a81 :unsigned-char) (a82 :pointer) (a83 :unsigned-short)
+ (a84 :unsigned-char) (a85 :long) (a86 :pointer) (a87 :char) (a88 :long)
+ (a89 :unsigned-short) (a90 :unsigned-char) (a91 :double)
+ (a92 :unsigned-long-long) (a93 :unsigned-short) (a94 :unsigned-short)
+ (a95 :unsigned-int) (a96 :long) (a97 :char) (a98 :long) (a99 :char)
+ (a100 :short) (a101 :unsigned-short) (a102 :unsigned-long)
+ (a103 :unsigned-long) (a104 :short) (a105 :long-long) (a106 :long-long)
+ (a107 :long-long) (a108 :double) (a109 :unsigned-short)
+ (a110 :unsigned-char) (a111 :short) (a112 :unsigned-char) (a113 :long)
+ (a114 :long-long) (a115 :unsigned-long-long) (a116 :unsigned-int)
+ (a117 :unsigned-long) (a118 :unsigned-char) (a119 :long-long)
+ (a120 :unsigned-char) (a121 :unsigned-long-long) (a122 :double)
+ (a123 :unsigned-char) (a124 :long-long) (a125 :unsigned-char)
+ (a126 :char) (a127 :long-long))
+ (+ a1 a2 (pointer-address a3) (values (floor a4)) a5 (values (floor a6))
+ a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22
+ (values (floor a23)) a24 (values (floor a25)) (values (floor a26))
+ a27 (values (floor a28)) a29 a30 a31 a32 a33 (values (floor a34))
+ a35 (values (floor a36)) a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47
+ a48 a49 (pointer-address a50) a51 a52 a53 a54 a55 (values (floor a56))
+ a57 a58 a59 (values (floor a60)) a61 (values (floor a62)) a63
+ (values (floor a64)) a65 a66 a67 a68 a69 a70 a71 a72 a73
+ (values (floor a74)) (pointer-address a75) a76 a77 a78
+ (pointer-address a79) (pointer-address a80) a81 (pointer-address a82)
+ a83 a84 a85 (pointer-address a86) a87 a88 a89 a90 (values (floor a91))
+ a92 a93 a94 a95 a96 a97 a98 a99 a100 a101 a102 a103 a104 a105 a106 a107
+ (values (floor a108)) a109 a110 a111 a112 a113 a114 a115 a116 a117 a118
+ a119 a120 a121 (values (floor a122)) a123 a124 a125 a126 a127))
+
+ #+(or openmcl cmu)
+ (push 'callbacks.bff.2 rt::*expected-failures*)
+
+ (deftest callbacks.bff.2
+ (call-sum-127 (callback sum-127))
+ 8166570665645582011))
+
+;;; regression test: (callback non-existant-callback) should throw an error
+(deftest callbacks.non-existant
+ (not (null (nth-value 1 (ignore-errors (callback doesnt-exist)))))
+ t)
+
+;;; Handling many arguments of type double. Many lisps (used to) fail
+;;; this one on darwin/ppc. This test might be bogus due to floating
+;;; point arithmetic rounding errors.
+;;;
+;;; CMUCL chokes on this one.
+#-(and cffi-features:darwin cmu)
+(defcallback double26 :double
+ ((a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
+ (a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
+ (a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
+ (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
+ (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
+ (a26 :double))
+ (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
+ a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
+ #-(and)
+ (loop for i from 1 and arg in args do
+ (format t "a~A: ~A~%" i arg))
+ (reduce #'+ args)))
+
+(defcfun "call_double26" :double (f :pointer))
+
+#+(and cffi-features:darwin (or allegro cmu))
+(pushnew 'callbacks.double26 rt::*expected-failures*)
+
+(deftest callbacks.double26
+ (call-double26 (callback double26))
+ 81.64d0)
+
+#+(and cffi-features:darwin cmu)
+(pushnew 'callbacks.double26.funcall rt::*expected-failures*)
+
+#-cffi-features:no-foreign-funcall
+(deftest callbacks.double26.funcall
+ (foreign-funcall (callback double26) :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double)
+ 81.64d0)
+
+;;; Same as above, for floats.
+#-(and cffi-features:darwin cmu)
+(defcallback float26 :float
+ ((a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
+ (a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
+ (a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
+ (a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
+ (a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
+ (a26 :float))
+ (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
+ a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
+ #-(and)
+ (loop for i from 1 and arg in args do
+ (format t "a~A: ~A~%" i arg))
+ (reduce #'+ args)))
+
+(defcfun "call_float26" :float (f :pointer))
+
+#+(and cffi-features:darwin (or lispworks openmcl cmu))
+(pushnew 'callbacks.float26 regression-test::*expected-failures*)
+
+(deftest callbacks.float26
+ (call-float26 (callback float26))
+ 130.0)
+
+#+(and cffi-features:darwin (or lispworks openmcl cmu))
+(pushnew 'callbacks.float26.funcall regression-test::*expected-failures*)
+
+#-cffi-features:no-foreign-funcall
+(deftest callbacks.float26.funcall
+ (foreign-funcall (callback float26) :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float)
+ 130.0)
+
+;;; Defining a callback as a non-toplevel form. Not portable. Doesn't
+;;; work for CMUCL or Allegro.
+#-(and)
+(let ((n 42))
+ (defcallback non-toplevel-cb :int ()
+ n))
+
+#-(and)
+(deftest callbacks.non-toplevel
+ (foreign-funcall (callback non-toplevel-cb) :int)
+ 42)
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/tests/compile.bat
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/compile.bat 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/compile.bat 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,6 @@
+rem
+rem script for compiling the test lib with the free MSVC++ toolkit.
+rem
+
+cl /ML /LD -D_MT /DWIN32=1 libtest.c
+del libtest.obj libtest.exp
Added: branches/xml-class-rework/thirdparty/cffi/tests/defcfun.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/defcfun.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/defcfun.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,357 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; defcfun.lisp --- Tests function definition and calling.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(a)common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+;;;# Calling with built-in c types
+;;;
+;;; Tests calling standard C library functions both passing
+;;; and returning each built-in type. (adapted from funcall.lisp)
+
+(defcfun "toupper" :char
+ (char :char))
+
+(deftest defcfun.char
+ (toupper (char-code #\a))
+ #.(char-code #\A))
+
+
+(defcfun ("abs" c-abs) :int
+ (n :int))
+
+(deftest defcfun.int
+ (c-abs -100)
+ 100)
+
+
+(defcfun "labs" :long
+ (n :long))
+
+(deftest defcfun.long
+ (labs -131072)
+ 131072)
+
+
+#-cffi-features:no-long-long
+(progn
+ (defcfun "my_llabs" :long-long
+ (n :long-long))
+
+ (deftest defcfun.long-long
+ (my-llabs -9223372036854775807)
+ 9223372036854775807))
+
+
+(defcfun "my_sqrtf" :float
+ (n :float))
+
+(deftest defcfun.float
+ (my-sqrtf 16.0)
+ 4.0)
+
+
+(defcfun ("sqrt" c-sqrt) :double
+ (n :double))
+
+(deftest defcfun.double
+ (c-sqrt 36.0d0)
+ 6.0d0)
+
+
+#+(and scl long-float)
+(defcfun ("sqrtl" c-sqrtl) :long-double
+ (n :long-double))
+
+#+(and scl long-float)
+(deftest defcfun.long-double
+ (c-sqrtl 36.0l0)
+ 6.0l0)
+
+
+(defcfun "strlen" :int
+ (n :string))
+
+(deftest defcfun.string.1
+ (strlen "Hello")
+ 5)
+
+
+(defcfun "strcpy" :pointer
+ (dest :pointer)
+ (src :string))
+
+(defcfun "strcat" :pointer
+ (dest :pointer)
+ (src :string))
+
+(deftest defcfun.string.2
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (strcpy s "Hello")
+ (strcat s ", world!"))
+ "Hello, world!")
+
+(defcfun "strerror" :string
+ (n :int))
+
+(deftest defcfun.string.3
+ (typep (strerror 1) 'string)
+ t)
+
+
+;;; Regression test. Allegro would warn on direct calls to
+;;; functions with no arguments.
+;;; Also, let's check if void functions will return NIL.
+
+(defcfun "noargs" :int)
+
+(deftest defcfun.noargs
+ (noargs)
+ 42)
+
+(defcfun "noop" :void)
+
+(deftest defcfun.noop
+ (noop)
+ nil)
+
+;;;# Calling varargs functions
+
+(defcfun "sprintf" :int
+ (str :pointer)
+ (control :string)
+ &rest)
+
+(deftest defcfun.varargs.char
+ (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%c" :char 65))
+ "A")
+
+(deftest defcfun.varargs.short
+ (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%d" :short 42))
+ "42")
+
+(deftest defcfun.varargs.int
+ (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%d" :int 1000))
+ "1000")
+
+(deftest defcfun.varargs.long
+ (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%ld" :long 131072))
+ "131072")
+
+(deftest defcfun.varargs.float
+ (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%.2f" :float (float pi)))
+ "3.14")
+
+(deftest defcfun.varargs.double
+ (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%.2f" :double (float pi 1.0d0)))
+ "3.14")
+
+#+(and scl long-float)
+(deftest defcfun.varargs.long-double
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (sprintf s "%.2Lf" :long-double pi))
+ "3.14")
+
+(deftest defcfun.varargs.string
+ (with-foreign-pointer-as-string (s 100)
+ (sprintf s "%s, %s!" :string "Hello" :string "world"))
+ "Hello, world!")
+
+;;; (let ((rettype (find-type :long))
+;;; (arg-types (n-random-types-no-ll 127)))
+;;; (c-function rettype arg-types)
+;;; (gen-function-test rettype arg-types))
+
+(defcfun "sum_127_no_ll" :long
+ (a1 :long) (a2 :unsigned-long) (a3 :short) (a4 :unsigned-short) (a5 :float)
+ (a6 :double) (a7 :unsigned-long) (a8 :float) (a9 :unsigned-char)
+ (a10 :unsigned-short) (a11 :short) (a12 :unsigned-long) (a13 :double)
+ (a14 :long) (a15 :unsigned-int) (a16 :pointer) (a17 :unsigned-int)
+ (a18 :unsigned-short) (a19 :long) (a20 :float) (a21 :pointer) (a22 :float)
+ (a23 :int) (a24 :int) (a25 :unsigned-short) (a26 :long) (a27 :long)
+ (a28 :double) (a29 :unsigned-char) (a30 :unsigned-int) (a31 :unsigned-int)
+ (a32 :int) (a33 :unsigned-short) (a34 :unsigned-int) (a35 :pointer)
+ (a36 :double) (a37 :double) (a38 :long) (a39 :short) (a40 :unsigned-short)
+ (a41 :long) (a42 :char) (a43 :long) (a44 :unsigned-short) (a45 :pointer)
+ (a46 :int) (a47 :unsigned-int) (a48 :double) (a49 :unsigned-char)
+ (a50 :unsigned-char) (a51 :float) (a52 :int) (a53 :unsigned-short)
+ (a54 :double) (a55 :short) (a56 :unsigned-char) (a57 :unsigned-long)
+ (a58 :float) (a59 :float) (a60 :float) (a61 :pointer) (a62 :pointer)
+ (a63 :unsigned-int) (a64 :unsigned-long) (a65 :char) (a66 :short)
+ (a67 :unsigned-short) (a68 :unsigned-long) (a69 :pointer) (a70 :float)
+ (a71 :double) (a72 :long) (a73 :unsigned-long) (a74 :short)
+ (a75 :unsigned-int) (a76 :unsigned-short) (a77 :int) (a78 :unsigned-short)
+ (a79 :char) (a80 :double) (a81 :short) (a82 :unsigned-char) (a83 :float)
+ (a84 :char) (a85 :int) (a86 :double) (a87 :unsigned-char) (a88 :int)
+ (a89 :unsigned-long) (a90 :double) (a91 :short) (a92 :short)
+ (a93 :unsigned-int) (a94 :unsigned-char) (a95 :float) (a96 :long) (a97 :float)
+ (a98 :long) (a99 :long) (a100 :int) (a101 :int) (a102 :unsigned-int)
+ (a103 :char) (a104 :char) (a105 :unsigned-short) (a106 :unsigned-int)
+ (a107 :unsigned-short) (a108 :unsigned-short) (a109 :int) (a110 :long)
+ (a111 :char) (a112 :double) (a113 :unsigned-int) (a114 :char) (a115 :short)
+ (a116 :unsigned-long) (a117 :unsigned-int) (a118 :short) (a119 :unsigned-char)
+ (a120 :float) (a121 :pointer) (a122 :double) (a123 :int) (a124 :long)
+ (a125 :char) (a126 :unsigned-short) (a127 :float))
+
+(deftest defcfun.bff.1
+ (sum-127-no-ll
+ 1442906394 520035521 -4715 50335 -13557.0 -30892.0d0 24061483 -23737.0 22
+ 2348 4986 104895680 8073.0d0 -571698147 102484400 (make-pointer 507907275)
+ 12733353 7824 -1275845284 13602.0 (make-pointer 286958390) -8042.0
+ -773681663 -1289932452 31199 -154985357 -170994216 16845.0d0 177
+ 218969221 2794350893 6068863 26327 127699339 (make-pointer 184352771)
+ 18512.0d0 -12345.0d0 -179853040 -19981 37268 -792845398 116 -1084653028
+ 50494 (make-pointer 2105239646) -1710519651 1557813312 2839.0d0 90 180
+ 30580.0 -532698978 8623 9537.0d0 -10882 54 184357206 14929.0 -8190.0
+ -25615.0 (make-pointer 235310526) (make-pointer 220476977) 7476055 1576685
+ -117 -11781 31479 23282640 (make-pointer 8627281) -17834.0 10391.0d0
+ -1904504370 114393659 -17062 637873619 16078 -891210259 8107 0 760.0d0
+ -21268 104 14133.0 10 588598141 310.0d0 20 1351785456 16159552 -10121.0d0
+ -25866 24821 68232851 60 -24132.0 -1660411658 13387.0 -786516668 -499825680
+ -1128144619 111849719 2746091587 -2 95 14488 326328135 64781 18204
+ 150716680 -703859275 103 16809.0d0 852235610 -43 21088 242356110 324325428
+ -22380 23 24814.0 (make-pointer 40362014) -14322.0d0 -1864262539 523684371
+ -21 49995 -29175.0)
+ 796447501)
+
+;;; (let ((rettype (find-type :long-long))
+;;; (arg-types (n-random-types 127)))
+;;; (c-function rettype arg-types)
+;;; (gen-function-test rettype arg-types))
+
+#-cffi-features:no-long-long
+(progn
+ (defcfun "sum_127" :long-long
+ (a1 :pointer) (a2 :pointer) (a3 :float) (a4 :unsigned-long) (a5 :pointer)
+ (a6 :long-long) (a7 :double) (a8 :double) (a9 :unsigned-short) (a10 :int)
+ (a11 :long-long) (a12 :long) (a13 :short) (a14 :unsigned-int) (a15 :long)
+ (a16 :unsigned-char) (a17 :int) (a18 :double) (a19 :short) (a20 :short)
+ (a21 :long-long) (a22 :unsigned-int) (a23 :unsigned-short) (a24 :short)
+ (a25 :pointer) (a26 :short) (a27 :unsigned-short) (a28 :unsigned-short)
+ (a29 :int) (a30 :long-long) (a31 :pointer) (a32 :int) (a33 :unsigned-long)
+ (a34 :unsigned-long) (a35 :pointer) (a36 :unsigned-long-long) (a37 :float)
+ (a38 :int) (a39 :short) (a40 :pointer) (a41 :unsigned-long-long)
+ (a42 :long-long) (a43 :unsigned-long) (a44 :unsigned-long)
+ (a45 :unsigned-long-long) (a46 :unsigned-long) (a47 :char) (a48 :double)
+ (a49 :long) (a50 :unsigned-int) (a51 :int) (a52 :short) (a53 :pointer)
+ (a54 :long) (a55 :unsigned-long-long) (a56 :int) (a57 :unsigned-short)
+ (a58 :unsigned-long-long) (a59 :float) (a60 :pointer) (a61 :float)
+ (a62 :unsigned-short) (a63 :unsigned-long) (a64 :float) (a65 :unsigned-int)
+ (a66 :unsigned-long-long) (a67 :pointer) (a68 :double)
+ (a69 :unsigned-long-long) (a70 :double) (a71 :double) (a72 :long-long)
+ (a73 :pointer) (a74 :unsigned-short) (a75 :long) (a76 :pointer) (a77 :short)
+ (a78 :double) (a79 :long) (a80 :unsigned-char) (a81 :pointer)
+ (a82 :unsigned-char) (a83 :long) (a84 :double) (a85 :pointer) (a86 :int)
+ (a87 :double) (a88 :unsigned-char) (a89 :double) (a90 :short) (a91 :long)
+ (a92 :int) (a93 :long) (a94 :double) (a95 :unsigned-short)
+ (a96 :unsigned-int) (a97 :int) (a98 :char) (a99 :long-long) (a100 :double)
+ (a101 :float) (a102 :unsigned-long) (a103 :short) (a104 :pointer)
+ (a105 :float) (a106 :long-long) (a107 :int) (a108 :long-long)
+ (a109 :long-long) (a110 :double) (a111 :unsigned-long-long) (a112 :double)
+ (a113 :unsigned-long) (a114 :char) (a115 :char) (a116 :unsigned-long)
+ (a117 :short) (a118 :unsigned-char) (a119 :unsigned-char) (a120 :int)
+ (a121 :int) (a122 :float) (a123 :unsigned-char) (a124 :unsigned-char)
+ (a125 :double) (a126 :unsigned-long-long) (a127 :char))
+
+ (deftest defcfun.bff.2
+ (sum-127
+ (make-pointer 2746181372) (make-pointer 177623060) -32334.0 3158055028
+ (make-pointer 242315091) 4288001754991016425 -21047.0d0 287.0d0 18722
+ 243379286 -8677366518541007140 581399424 -13872 4240394881 1353358999
+ 226 969197676 -26207.0d0 6484 11150 1241680089902988480 106068320 61865
+ 2253 (make-pointer 866809333) -31613 35616 11715 1393601698
+ 8940888681199591845 (make-pointer 1524606024) 805638893 3315410736
+ 3432596795 (make-pointer 1490355706) 696175657106383698 -25438.0
+ 1294381547 26724 (make-pointer 3196569545) 2506913373410783697
+ -4405955718732597856 4075932032 3224670123 2183829215657835866
+ 1318320964 -22 -3786.0d0 -2017024146 1579225515 -626617701 -1456
+ (make-pointer 3561444187) 395687791 1968033632506257320 -1847773261
+ 48853 142937735275669133 -17974.0 (make-pointer 2791749948) -14140.0
+ 2707 3691328585 3306.0 1132012981 303633191773289330
+ (make-pointer 981183954) 9114.0d0 8664374572369470 -19013.0d0
+ -10288.0d0 -3679345119891954339 (make-pointer 3538786709) 23761
+ -154264605 (make-pointer 2694396308) 7023 997.0d0 1009561368 241
+ (make-pointer 2612292671) 48 1431872408 -32675.0d0
+ (make-pointer 1587599336) 958916472 -9857.0d0 111 -14370.0d0 -7308
+ -967514912 488790941 2146978095 -24111.0d0 13711 86681861 717987770
+ 111 1013402998690933877 17234.0d0 -8772.0 3959216275 -8711
+ (make-pointer 3142780851) 9480.0 -3820453146461186120 1616574376
+ -3336232268263990050 -1906114671562979758 -27925.0d0 9695970875869913114
+ 27033.0d0 1096518219 -12 104 3392025403 -27911 60 89 509297051
+ -533066551 29158.0 110 54 -9802.0d0 593950442165910888 -79)
+ 7758614658402721936))
+
+;;; regression test: defining an undefined foreign function should only
+;;; throw some sort of warning, not signal an error.
+
+#+(or cmu (and sbcl (or (not linkage-table) win32)))
+(pushnew 'defcfun.undefined rt::*expected-failures*)
+
+(deftest defcfun.undefined
+ (progn
+ (eval '(defcfun ("undefined_foreign_function" undefined-foreign-function) :void))
+ (compile 'undefined-foreign-function)
+ t)
+ t)
+
+;;; Test whether all doubles are passed correctly. On some platforms, eg.
+;;; darwin/ppc, some are passed on registers others on the stack.
+(defcfun "sum_double26" :double
+ (a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
+ (a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
+ (a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
+ (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
+ (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
+ (a26 :double))
+
+(deftest defcfun.double26
+ (sum-double26 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
+ 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
+ 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
+ 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0)
+ 81.64d0)
+
+;;; Same as above for floats.
+(defcfun "sum_float26" :float
+ (a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
+ (a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
+ (a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
+ (a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
+ (a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
+ (a26 :float))
+
+(deftest defcfun.float26
+ (sum-float26 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0
+ 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0)
+ 130.0)
Added: branches/xml-class-rework/thirdparty/cffi/tests/enum.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/enum.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/enum.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,65 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; enum.lisp --- Tests on C enums.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcenum numeros
+ (:one 1)
+ :two
+ :three
+ :four
+ (:forty-one 41)
+ :forty-two)
+
+(defcfun "check_enums" :int
+ (one numeros)
+ (two numeros)
+ (three numeros)
+ (four numeros)
+ (forty-one numeros)
+ (forty-two numeros))
+
+(deftest enum.1
+ (check-enums :one :two :three 4 :forty-one :forty-two)
+ 1)
+
+(defcenum another-boolean :false :true)
+(defcfun "return_enum" another-boolean (x :int))
+
+(deftest enum.2
+ (and (eq :false (return-enum 0))
+ (eq :true (return-enum 1)))
+ t)
+
+(defctype yet-another-boolean another-boolean)
+(defcfun ("return_enum" return-enum2) yet-another-boolean
+ (x yet-another-boolean))
+
+(deftest enum.3
+ (and (eq :false (return-enum2 :false))
+ (eq :true (return-enum2 :true)))
+ t)
Added: branches/xml-class-rework/thirdparty/cffi/tests/foreign-globals.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/foreign-globals.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/foreign-globals.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,230 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; foreign-globals.lisp --- Tests on foreign globals.
+;;;
+;;; Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcvar ("var_char" *char-var*) :char)
+(defcvar "var_unsigned_char" :unsigned-char)
+(defcvar "var_short" :short)
+(defcvar "var_unsigned_short" :unsigned-short)
+(defcvar "var_int" :int)
+(defcvar "var_unsigned_int" :unsigned-int)
+(defcvar "var_long" :long)
+(defcvar "var_unsigned_long" :unsigned-long)
+(defcvar "var_float" :float)
+(defcvar "var_double" :double)
+(defcvar "var_pointer" :pointer)
+(defcvar "var_string" :string)
+
+#-cffi-features:no-long-long
+(progn
+ (defcvar "var_long_long" :long-long)
+ (defcvar "var_unsigned_long_long" :unsigned-long-long))
+
+(deftest foreign-globals.ref.char
+ *char-var*
+ -127)
+
+(deftest foreign-globals.ref.unsigned-char
+ *var-unsigned-char*
+ 255)
+
+(deftest foreign-globals.ref.short
+ *var-short*
+ -32767)
+
+(deftest foreign-globals.ref.unsigned-short
+ *var-unsigned-short*
+ 65535)
+
+(deftest foreign-globals.ref.int
+ *var-int*
+ -32767)
+
+(deftest foreign-globals.ref.unsigned-int
+ *var-unsigned-int*
+ 65535)
+
+(deftest foreign-globals.ref.long
+ *var-long*
+ -2147483647)
+
+(deftest foreign-globals.ref.unsigned-long
+ *var-unsigned-long*
+ 4294967295)
+
+(deftest foreign-globals.ref.float
+ *var-float*
+ 42.0)
+
+(deftest foreign-globals.ref.double
+ *var-double*
+ 42.0d0)
+
+(deftest foreign-globals.ref.pointer
+ (null-pointer-p *var-pointer*)
+ t)
+
+(deftest foreign-globals.ref.string
+ *var-string*
+ "Hello, foreign world!")
+
+#-cffi-features:no-long-long
+(progn
+ #+openmcl (push 'foreign-globals.set.long-long rt::*expected-failures*)
+
+ (deftest foreign-globals.ref.long-long
+ *var-long-long*
+ -9223372036854775807)
+
+ (deftest foreign-globals.ref.unsigned-long-long
+ *var-unsigned-long-long*
+ 18446744073709551615))
+
+;; The *.set.* tests restore the old values so that the *.ref.*
+;; don't fail when re-run.
+(defmacro with-old-value-restored ((place) &body body)
+ (let ((old (gensym)))
+ `(let ((,old ,place))
+ (prog1
+ (progn ,@body)
+ (setq ,place ,old)))))
+
+(deftest foreign-globals.set.int
+ (with-old-value-restored (*var-int*)
+ (setq *var-int* 42)
+ *var-int*)
+ 42)
+
+(deftest foreign-globals.set.string
+ (with-old-value-restored (*var-string*)
+ (setq *var-string* "Ehxosxangxo")
+ (prog1
+ *var-string*
+ ;; free the string we just allocated
+ (foreign-free (mem-ref (get-var-pointer '*var-string*) :pointer))))
+ "Ehxosxangxo")
+
+#-cffi-features:no-long-long
+(deftest foreign-globals.set.long-long
+ (with-old-value-restored (*var-long-long*)
+ (setq *var-long-long* -9223000000000005808)
+ *var-long-long*)
+ -9223000000000005808)
+
+(deftest foreign-globals.get-var-pointer.1
+ (pointerp (get-var-pointer '*char-var*))
+ t)
+
+(deftest foreign-globals.get-var-pointer.2
+ (mem-ref (get-var-pointer '*char-var*) :char)
+ -127)
+
+;;; Symbol case.
+
+(defcvar "UPPERCASEINT1" :int)
+(defcvar "UPPER_CASE_INT1" :int)
+(defcvar "MiXeDCaSeInT1" :int)
+(defcvar "MiXeD_CaSe_InT1" :int)
+
+(deftest foreign-globals.ref.uppercaseint1
+ *uppercaseint1*
+ 12345)
+
+(deftest foreign-globals.ref.upper-case-int1
+ *upper-case-int1*
+ 23456)
+
+(deftest foreign-globals.ref.mixedcaseint1
+ *mixedcaseint1*
+ 34567)
+
+(deftest foreign-globals.ref.mixed-case-int1
+ *mixed-case-int1*
+ 45678)
+
+(when (string= (symbol-name 'nil) "NIL")
+ (let ((*readtable* (copy-readtable)))
+ (setf (readtable-case *readtable*) :invert)
+ (eval (read-from-string "(defcvar \"UPPERCASEINT2\" :int)"))
+ (eval (read-from-string "(defcvar \"UPPER_CASE_INT2\" :int)"))
+ (eval (read-from-string "(defcvar \"MiXeDCaSeInT2\" :int)"))
+ (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT2\" :int)"))
+ (setf (readtable-case *readtable*) :preserve)
+ (eval (read-from-string "(DEFCVAR \"UPPERCASEINT3\" :INT)"))
+ (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT3\" :INT)"))
+ (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT3\" :INT)"))
+ (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT3\" :INT)"))))
+
+
+(when (string= (symbol-name 'nil) "nil")
+ (let ((*readtable* (copy-readtable)))
+ (setf (readtable-case *readtable*) :invert)
+ (eval (read-from-string "(DEFCVAR \"UPPERCASEINT2\" :INT)"))
+ (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT2\" :INT)"))
+ (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT2\" :INT)"))
+ (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT2\" :INT)"))
+ (setf (readtable-case *readtable*) :downcase)
+ (eval (read-from-string "(defcvar \"UPPERCASEINT3\" :int)"))
+ (eval (read-from-string "(defcvar \"UPPER_CASE_INT3\" :int)"))
+ (eval (read-from-string "(defcvar \"MiXeDCaSeInT3\" :int)"))
+ (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT3\" :int)"))))
+
+(deftest foreign-globals.ref.uppercaseint2
+ *uppercaseint2*
+ 12345)
+
+(deftest foreign-globals.ref.upper-case-int2
+ *upper-case-int2*
+ 23456)
+
+(deftest foreign-globals.ref.mixedcaseint2
+ *mixedcaseint2*
+ 34567)
+
+(deftest foreign-globals.ref.mixed-case-int2
+ *mixed-case-int2*
+ 45678)
+
+(deftest foreign-globals.ref.uppercaseint3
+ *uppercaseint3*
+ 12345)
+
+(deftest foreign-globals.ref.upper-case-int3
+ *upper-case-int3*
+ 23456)
+
+(deftest foreign-globals.ref.mixedcaseint3
+ *mixedcaseint3*
+ 34567)
+
+(deftest foreign-globals.ref.mixed-case-int3
+ *mixed-case-int3*
+ 45678)
+
+
+
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/tests/funcall.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/funcall.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/funcall.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,173 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; funcall.lisp --- Tests function calling.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+;;;# Calling with Built-In C Types
+;;;
+;;; Tests calling standard C library functions both passing and
+;;; returning each built-in type.
+
+;;; Don't run these tests if the implementation does not support
+;;; foreign-funcall.
+#-cffi-features:no-foreign-funcall
+(progn
+
+(deftest funcall.char
+ (foreign-funcall "toupper" :char (char-code #\a) :char)
+ #.(char-code #\A))
+
+(deftest funcall.int.1
+ (foreign-funcall "abs" :int -100 :int)
+ 100)
+
+(defun funcall-abs (n)
+ (foreign-funcall "abs" :int n :int))
+
+;;; regression test: lispworks's %foreign-funcall based on creating
+;;; and chaching foreign-funcallables at macro-expansion time.
+(deftest funcall.int.2
+ (funcall-abs -42)
+ 42)
+
+(deftest funcall.long
+ (foreign-funcall "labs" :long -131072 :long)
+ 131072)
+
+#-cffi-features:no-long-long
+(deftest funcall.long-long
+ (foreign-funcall "my_llabs" :long-long -9223372036854775807 :long-long)
+ 9223372036854775807)
+
+(deftest funcall.float
+ (foreign-funcall "my_sqrtf" :float 16.0 :float)
+ 4.0)
+
+(deftest funcall.double
+ (foreign-funcall "sqrt" :double 36.0d0 :double)
+ 6.0d0)
+
+#+(and scl long-float)
+(deftest funcall.long-double
+ (foreign-funcall "sqrtl" :long-double 36.0l0 :long-double)
+ 6.0l0)
+
+(deftest funcall.string.1
+ (foreign-funcall "strlen" :string "Hello" :int)
+ 5)
+
+(deftest funcall.string.2
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "strcpy" :pointer s :string "Hello" :pointer)
+ (foreign-funcall "strcat" :pointer s :string ", world!" :pointer))
+ "Hello, world!")
+
+(deftest funcall.string.3
+ (with-foreign-pointer (ptr 100)
+ (lisp-string-to-foreign "Hello, " ptr 8)
+ (foreign-funcall "strcat" :pointer ptr :string "world!" :string))
+ "Hello, world!")
+
+;;;# Calling Varargs Functions
+
+;; The CHAR argument must be passed as :INT because chars are promoted
+;; to ints when passed as variable arguments.
+(deftest funcall.varargs.char
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "sprintf" :pointer s :string "%c" :int 65 :int))
+ "A")
+
+(deftest funcall.varargs.int
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "sprintf" :pointer s :string "%d" :int 1000 :int))
+ "1000")
+
+(deftest funcall.varargs.long
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "sprintf" :pointer s :string "%ld" :long 131072 :int))
+ "131072")
+
+;;; There is no FUNCALL.VARARGS.FLOAT as floats are promoted to double
+;;; when passed as variable arguments. Currently this fails in SBCL
+;;; and CMU CL on Darwin/ppc.
+(deftest funcall.varargs.double
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "sprintf" :pointer s :string "%.2f"
+ :double (coerce pi 'double-float) :int))
+ "3.14")
+
+#+(and scl long-float)
+(deftest funcall.varargs.long-double
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "sprintf" :pointer s :string "%.2Lf"
+ :long-double pi :int))
+ "3.14")
+
+(deftest funcall.varargs.string
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "sprintf" :pointer s :string "%s, %s!"
+ :string "Hello" :string "world" :int))
+ "Hello, world!")
+
+;;; See DEFCFUN.DOUBLE26.
+(deftest funcall.double26
+ (foreign-funcall "sum_double26"
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double 3.14d0
+ :double 3.14d0 :double 3.14d0 :double)
+ 81.64d0)
+
+;;; See DEFCFUN.FLOAT26.
+(deftest funcall.float26
+ (foreign-funcall "sum_float26"
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+ :float 5.0 :float)
+ 130.0)
+
+;;; Funcalling a pointer.
+(deftest funcall.f-s-p.1
+ (foreign-funcall (foreign-symbol-pointer "abs") :int -42 :int)
+ 42)
+
+) ;; #-cffi-features:no-foreign-funcall
Added: branches/xml-class-rework/thirdparty/cffi/tests/libtest.c
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/libtest.c 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/libtest.c 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,778 @@
+/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
+ *
+ * libtest.c --- auxiliary C lib for testing purposes
+ *
+ * Copyright (C) 2005, Luis Oliveira <loliveira((a))common-lisp.net>
+ *
+ * Permission is hereby granted, free of charge, to any person
+ * obtaining a copy of this software and associated documentation
+ * files (the "Software"), to deal in the Software without
+ * restriction, including without limitation the rights to use, copy,
+ * modify, merge, publish, distribute, sublicense, and/or sell copies
+ * of the Software, and to permit persons to whom the Software is
+ * furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be
+ * included in all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ */
+
+#ifdef WIN32
+#define DLLEXPORT __declspec(dllexport)
+#else
+#define DLLEXPORT
+#endif
+
+#include <stdio.h>
+#include <limits.h>
+#include <string.h>
+#include <stdlib.h>
+#include <math.h>
+#include <float.h>
+
+/*
+ * Some functions that aren't avaiable on WIN32
+ */
+
+DLLEXPORT
+float my_sqrtf(float n)
+{
+ return (float) sqrt((double) n);
+}
+
+DLLEXPORT
+char *my_strdup(const char *str)
+{
+ char *p = malloc(strlen(str) + 1);
+ strcpy(p, str);
+ return p;
+}
+
+DLLEXPORT
+long long my_llabs(long long n)
+{
+ return n < 0 ? -n : n;
+}
+
+/*
+ * Foreign Globals
+ *
+ * (var_int is used in MISC-TYPES.EXPAND.3 as well)
+ */
+
+DLLEXPORT char * dll_version = "20060414";
+
+/* TODO: look into signed char vs. unsigned char issue */
+DLLEXPORT char var_char = -127;
+DLLEXPORT unsigned char var_unsigned_char = 255;
+DLLEXPORT short var_short = -32767;
+DLLEXPORT unsigned short var_unsigned_short = 65535;
+DLLEXPORT int var_int = -32767;
+DLLEXPORT unsigned int var_unsigned_int = 65535;
+DLLEXPORT long var_long = -2147483647L;
+DLLEXPORT unsigned long var_unsigned_long = 4294967295UL;
+DLLEXPORT float var_float = 42.0f;
+DLLEXPORT double var_double = 42.0;
+DLLEXPORT void * var_pointer = NULL;
+DLLEXPORT char * var_string = "Hello, foreign world!";
+
+DLLEXPORT long long var_long_long = -9223372036854775807LL;
+DLLEXPORT unsigned long long var_unsigned_long_long = 18446744073709551615ULL;
+
+DLLEXPORT float float_max = FLT_MAX;
+DLLEXPORT float float_min = FLT_MIN;
+DLLEXPORT double double_max = DBL_MAX;
+DLLEXPORT double double_min = DBL_MIN;
+
+/*
+ * Callbacks
+ */
+
+DLLEXPORT
+int expect_char_sum(char (*f)(char, char))
+{
+ return f('a', 3) == 'd';
+}
+
+DLLEXPORT
+int expect_unsigned_char_sum(unsigned char (*f)(unsigned char, unsigned char))
+{
+ return f(UCHAR_MAX-1, 1) == UCHAR_MAX;
+}
+
+DLLEXPORT
+int expect_short_sum(short (*f)(short a, short b))
+{
+ return f(SHRT_MIN+1, -1) == SHRT_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_short_sum(unsigned short (*f)(unsigned short,
+ unsigned short))
+{
+ return f(USHRT_MAX-1, 1) == USHRT_MAX;
+}
+
+/* used in MISC-TYPES.EXPAND.4 as well */
+DLLEXPORT
+int expect_int_sum(int (*f)(int, int))
+{
+ return f(INT_MIN+1, -1) == INT_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_int_sum(unsigned int (*f)(unsigned int, unsigned int))
+{
+ return f(UINT_MAX-1, 1) == UINT_MAX;
+}
+
+DLLEXPORT
+int expect_long_sum(long (*f)(long, long))
+{
+ return f(LONG_MIN+1, -1) == LONG_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_long_sum(unsigned long (*f)(unsigned long, unsigned long))
+{
+ return f(ULONG_MAX-1, 1) == ULONG_MAX;
+}
+
+DLLEXPORT
+int expect_long_long_sum(long long (*f)(long long, long long))
+{
+ return f(LLONG_MIN+1, -1) == LLONG_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_long_long_sum (unsigned long long
+ (*f)(unsigned long long, unsigned long long))
+{
+ return f(ULLONG_MAX-1, 1) == ULLONG_MAX;
+}
+
+DLLEXPORT
+int expect_float_sum(float (*f)(float, float))
+{
+ /*printf("\n>>> FLOAT: %f <<<\n", f(20.0f, 22.0f));*/
+ return f(20.0f, 22.0f) == 42.0f;
+}
+
+DLLEXPORT
+int expect_double_sum(double (*f)(double, double))
+{
+ /*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
+ return f(-20.0, -22.0) == -42.0;
+}
+
+DLLEXPORT
+int expect_long_double_sum(long double (*f)(long double, long double))
+{
+ /*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
+ return f(-20.0, -22.0) == -42.0;
+}
+
+DLLEXPORT
+int expect_pointer_sum(void* (*f)(void*, int))
+{
+ return f(NULL, 0xDEAD) == (void *) 0xDEAD;
+}
+
+DLLEXPORT
+int expect_strcat(char* (*f)(char*, char*))
+{
+ char *ret = f("Hello, ", "C world!");
+ int res = strcmp(ret, "Hello, C world!") == 0;
+ /* commented out as a quick fix on platforms that don't
+ foreign allocate in C malloc space. */
+ /*free(ret);*/ /* is this allowed? */
+ return res;
+}
+
+DLLEXPORT
+void pass_int_ref(void (*f)(int*))
+{
+ int x = 1984;
+ f(&x);
+}
+
+/*
+ * Enums
+ */
+
+typedef enum {
+ ONE = 1,
+ TWO,
+ THREE,
+ FOUR,
+ FORTY_ONE = 41,
+ FORTY_TWO
+} numeros;
+
+DLLEXPORT
+int check_enums(numeros one, numeros two, numeros three, numeros four,
+ numeros forty_one, numeros forty_two)
+{
+ if (one == ONE && two == TWO && three == THREE && four == FOUR &&
+ forty_one == FORTY_ONE && forty_two == FORTY_TWO)
+ return 1;
+
+ return 0;
+}
+
+typedef enum { FALSE, TRUE } another_boolean;
+
+DLLEXPORT
+another_boolean return_enum(int x)
+{
+ if (x == 0)
+ return FALSE;
+ else
+ return TRUE;
+}
+
+/*
+ * Booleans
+ */
+
+DLLEXPORT
+int equalequal(int a, unsigned int b)
+{
+ return ((unsigned int) a) == b;
+}
+
+DLLEXPORT
+char bool_and(unsigned char a, char b)
+{
+ return a && b;
+}
+
+DLLEXPORT
+unsigned long bool_xor(long a, unsigned long b)
+{
+ return (a && !b) || (!a && b);
+}
+
+/*
+ * Test struct alignment issues. These comments assume the x86 gABI.
+ * Hopefully these tests will spot alignment issues in others archs
+ * too.
+ */
+
+/*
+ * STRUCT.ALIGNMENT.1
+ */
+
+struct s_ch {
+ char a_char;
+};
+
+/* This struct's size should be 2 bytes */
+struct s_s_ch {
+ char another_char;
+ struct s_ch a_s_ch;
+};
+
+DLLEXPORT
+struct s_s_ch the_s_s_ch = { 2, { 1 } };
+
+/*
+ * STRUCT.ALIGNMENT.2
+ */
+
+/* This one should be alignment should be the same as short's alignment. */
+struct s_short {
+ char a_char;
+ char another_char;
+ short a_short;
+};
+
+struct s_s_short {
+ char yet_another_char;
+ struct s_short a_s_short; /* so this should be 2-byte aligned */
+}; /* size: 6 bytes */
+
+DLLEXPORT
+struct s_s_short the_s_s_short = { 4, { 1, 2, 3 } };
+
+/*
+ * STRUCT.ALIGNMENT.3
+ */
+
+/* This test will, among other things, check for the existence tail padding. */
+
+struct s_double {
+ char a_char; /* 1 byte */
+ /* padding: 3 bytes */
+ double a_double; /* 8 bytes */
+ char another_char; /* 1 byte */
+ /* padding: 3 bytes */
+}; /* total size: 16 bytes */
+
+struct s_s_double {
+ char yet_another_char; /* 1 byte */
+ /* 3 bytes padding */
+ struct s_double a_s_double; /* 16 bytes */
+ short a_short; /* 2 byte */
+ /* 2 bytes padding */
+}; /* total size: 24 bytes */
+
+DLLEXPORT
+struct s_s_double the_s_s_double = { 4, { 1, 2.0, 3 }, 5 };
+
+/*
+ * STRUCT.ALIGNMENT.4
+ */
+struct s_s_s_double {
+ short another_short; /* 2 bytes */
+ /* 2 bytes padding */
+ struct s_s_double a_s_s_double; /* 24 bytes */
+ char last_char; /* 1 byte */
+ /* 3 bytes padding */
+}; /* total size: 32 */
+
+DLLEXPORT
+struct s_s_s_double the_s_s_s_double = { 6, { 4, { 1, 2.0, 3 }, 5 }, 7 };
+
+/*
+ * STRUCT.ALIGNMENT.5
+ */
+
+/* MacOSX ABI says: "The embedding alignment of the first element in a data
+ structure is equal to the element's natural alignment." and "For subsequent
+ elements that have a natural alignment greater than 4 bytes, the embedding
+ alignment is 4, unless the element is a vector." */
+
+/* note: these rules will apply to the structure itself. So, unless it is
+ the first element of another structure, its alignment will be 4. */
+
+/* the following offsets and sizes are specific to darwin/ppc32 */
+
+struct s_double2 {
+ double a_double; /* 8 bytes (alignment 8) */
+ short a_short; /* 2 bytes */
+ /* 6 bytes padding */
+}; /* total size: 16 */
+
+struct s_s_double2 {
+ char a_char; /* 1 byte */
+ /* 3 bytes padding */
+ struct s_double2 a_s_double2; /* 16 bytes, alignment 4 */
+ short another_short; /* 2 bytes */
+ /* 2 bytes padding */
+}; /* total size: 24 bytes */
+ /* alignment: 4 */
+
+DLLEXPORT
+struct s_s_double2 the_s_s_double2 = { 3, { 1.0, 2 }, 4 };
+
+/*
+ * STRUCT.ALIGNMENT.6
+ */
+
+/* Same as STRUCT.ALIGNMENT.5 but with long long. */
+
+struct s_long_long {
+ long long a_long_long; /* 8 bytes (alignment 8) */
+ short a_short; /* 2 bytes */
+ /* 6 bytes padding */
+}; /* total size: 16 */
+
+struct s_s_long_long {
+ char a_char; /* 1 byte */
+ /* 3 bytes padding */
+ struct s_long_long a_s_long_long; /* 16 bytes, alignment 4 */
+ short a_short; /* 2 bytes */
+ /* 2 bytes padding */
+}; /* total size: 24 bytes */
+ /* alignment: 4 */
+
+DLLEXPORT
+struct s_s_long_long the_s_s_long_long = { 3, { 1, 2 }, 4 };
+
+/*
+ * STRUCT.ALIGNMENT.7
+ */
+
+/* Another test for Darwin's PPC32 ABI. */
+
+struct s_s_double3 {
+ struct s_double2 a_s_double2; /* 16 bytes, alignment 8*/
+ short another_short; /* 2 bytes */
+ /* 6 bytes padding */
+}; /* total size: 24 */
+
+struct s_s_s_double3 {
+ struct s_s_double3 a_s_s_double3; /* 24 bytes */
+ char a_char; /* 1 byte */
+ /* 7 bytes padding */
+}; /* total size: 32 */
+
+DLLEXPORT
+struct s_s_s_double3 the_s_s_s_double3 = { { { 1.0, 2 }, 3 }, 4 };
+
+/* STRUCT.ALIGNMENT.x */
+
+/* commented this test out because this is not standard C
+ and MSVC++ (or some versions of it at least) won't compile it. */
+
+/*
+struct empty_struct {};
+
+struct with_empty_struct {
+ struct empty_struct foo;
+ int an_int;
+};
+
+DLLEXPORT
+struct with_empty_struct the_with_empty_struct = { {}, 42 };
+*/
+
+/*
+ * DEFCFUN.NOARGS and DEFCFUN.NOOP
+ */
+
+DLLEXPORT
+int noargs()
+{
+ return 42;
+}
+
+DLLEXPORT
+void noop()
+{
+ return;
+}
+
+/*
+ * DEFCFUN.BFF.1
+ *
+ * (let ((rettype (find-type :long))
+ * (arg-types (n-random-types-no-ll 127)))
+ * (c-function rettype arg-types)
+ * (gen-function-test rettype arg-types))
+ */
+
+DLLEXPORT long sum_127_no_ll
+ (long a1, unsigned long a2, short a3, unsigned short a4, float a5,
+ double a6, unsigned long a7, float a8, unsigned char a9, unsigned
+ short a10, short a11, unsigned long a12, double a13, long a14,
+ unsigned int a15, void* a16, unsigned int a17, unsigned short a18,
+ long a19, float a20, void* a21, float a22, int a23, int a24, unsigned
+ short a25, long a26, long a27, double a28, unsigned char a29, unsigned
+ int a30, unsigned int a31, int a32, unsigned short a33, unsigned int
+ a34, void* a35, double a36, double a37, long a38, short a39, unsigned
+ short a40, long a41, char a42, long a43, unsigned short a44, void*
+ a45, int a46, unsigned int a47, double a48, unsigned char a49,
+ unsigned char a50, float a51, int a52, unsigned short a53, double a54,
+ short a55, unsigned char a56, unsigned long a57, float a58, float a59,
+ float a60, void* a61, void* a62, unsigned int a63, unsigned long a64,
+ char a65, short a66, unsigned short a67, unsigned long a68, void* a69,
+ float a70, double a71, long a72, unsigned long a73, short a74,
+ unsigned int a75, unsigned short a76, int a77, unsigned short a78,
+ char a79, double a80, short a81, unsigned char a82, float a83, char
+ a84, int a85, double a86, unsigned char a87, int a88, unsigned long
+ a89, double a90, short a91, short a92, unsigned int a93, unsigned char
+ a94, float a95, long a96, float a97, long a98, long a99, int a100, int
+ a101, unsigned int a102, char a103, char a104, unsigned short a105,
+ unsigned int a106, unsigned short a107, unsigned short a108, int a109,
+ long a110, char a111, double a112, unsigned int a113, char a114, short
+ a115, unsigned long a116, unsigned int a117, short a118, unsigned char
+ a119, float a120, void* a121, double a122, int a123, long a124, char
+ a125, unsigned short a126, float a127)
+{
+ return (long) a1 + a2 + a3 + a4 + ((long) a5) + ((long) a6) + a7 +
+ ((long) a8) + a9 + a10 + a11 + a12 + ((long) a13) + a14 + a15 +
+ ((unsigned int) a16) + a17 + a18 + a19 + ((long) a20) +
+ ((unsigned int) a21) + ((long) a22) + a23 + a24 + a25 + a26 + a27 +
+ ((long) a28) + a29 + a30 + a31 + a32 + a33 + a34 + ((unsigned int) a35) +
+ ((long) a36) + ((long) a37) + a38 + a39 + a40 + a41 + a42 + a43 + a44 +
+ ((unsigned int) a45) + a46 + a47 + ((long) a48) + a49 + a50 +
+ ((long) a51) + a52 + a53 + ((long) a54) + a55 + a56 + a57 + ((long) a58) +
+ ((long) a59) + ((long) a60) + ((unsigned int) a61) +
+ ((unsigned int) a62) + a63 + a64 + a65 + a66 + a67 + a68 +
+ ((unsigned int) a69) + ((long) a70) + ((long) a71) + a72 + a73 + a74 +
+ a75 + a76 + a77 + a78 + a79 + ((long) a80) + a81 + a82 + ((long) a83) +
+ a84 + a85 + ((long) a86) + a87 + a88 + a89 + ((long) a90) + a91 + a92 +
+ a93 + a94 + ((long) a95) + a96 + ((long) a97) + a98 + a99 + a100 + a101 +
+ a102 + a103 + a104 + a105 + a106 + a107 + a108 + a109 + a110 + a111 +
+ ((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 +
+ ((long) a120) + ((unsigned int) a121) + ((long) a122) + a123 + a124 +
+ a125 + a126 + ((long) a127);
+}
+
+/*
+ * DEFCFUN.BFF.2
+ *
+ * (let ((rettype (find-type :long-long))
+ * (arg-types (n-random-types 127)))
+ * (c-function rettype arg-types)
+ * (gen-function-test rettype arg-types))
+ */
+
+DLLEXPORT long long sum_127
+ (void* a1, void* a2, float a3, unsigned long a4, void* a5, long long
+ a6, double a7, double a8, unsigned short a9, int a10, long long a11,
+ long a12, short a13, unsigned int a14, long a15, unsigned char a16,
+ int a17, double a18, short a19, short a20, long long a21, unsigned
+ int a22, unsigned short a23, short a24, void* a25, short a26,
+ unsigned short a27, unsigned short a28, int a29, long long a30,
+ void* a31, int a32, unsigned long a33, unsigned long a34, void* a35,
+ unsigned long long a36, float a37, int a38, short a39, void* a40,
+ unsigned long long a41, long long a42, unsigned long a43, unsigned
+ long a44, unsigned long long a45, unsigned long a46, char a47,
+ double a48, long a49, unsigned int a50, int a51, short a52, void*
+ a53, long a54, unsigned long long a55, int a56, unsigned short a57,
+ unsigned long long a58, float a59, void* a60, float a61, unsigned
+ short a62, unsigned long a63, float a64, unsigned int a65, unsigned
+ long long a66, void* a67, double a68, unsigned long long a69, double
+ a70, double a71, long long a72, void* a73, unsigned short a74, long
+ a75, void* a76, short a77, double a78, long a79, unsigned char a80,
+ void* a81, unsigned char a82, long a83, double a84, void* a85, int
+ a86, double a87, unsigned char a88, double a89, short a90, long a91,
+ int a92, long a93, double a94, unsigned short a95, unsigned int a96,
+ int a97, char a98, long long a99, double a100, float a101, unsigned
+ long a102, short a103, void* a104, float a105, long long a106, int
+ a107, long long a108, long long a109, double a110, unsigned long
+ long a111, double a112, unsigned long a113, char a114, char a115,
+ unsigned long a116, short a117, unsigned char a118, unsigned char
+ a119, int a120, int a121, float a122, unsigned char a123, unsigned
+ char a124, double a125, unsigned long long a126, char a127)
+{
+ return (long long) ((unsigned int) a1) + ((unsigned int) a2) + ((long) a3) +
+ a4 + ((unsigned int) a5) + a6 + ((long) a7) + ((long) a8) + a9 + a10 +
+ a11 + a12 + a13 + a14 + a15 + a16 + a17 + ((long) a18) + a19 + a20 +
+ a21 + a22 + a23 + a24 + ((unsigned int) a25) + a26 + a27 + a28 + a29 +
+ a30 + ((unsigned int) a31) + a32 + a33 + a34 + ((unsigned int) a35) +
+ a36 + ((long) a37) + a38 + a39 + ((unsigned int) a40) + a41 + a42 + a43 +
+ a44 + a45 + a46 + a47 + ((long) a48) + a49 + a50 + a51 + a52 +
+ ((unsigned int) a53) + a54 + a55 + a56 + a57 + a58 + ((long) a59) +
+ ((unsigned int) a60) + ((long) a61) + a62 + a63 + ((long) a64) + a65 + a66
+ + ((unsigned int) a67) + ((long) a68) + a69 + ((long) a70) + ((long) a71) +
+ a72 + ((unsigned int) a73) + a74 + a75 + ((unsigned int) a76) + a77 +
+ ((long) a78) + a79 + a80 + ((unsigned int) a81) + a82 + a83 + ((long) a84)
+ + ((unsigned int) a85) + a86 + ((long) a87) + a88 + ((long) a89) + a90 +
+ a91 + a92 + a93 + ((long) a94) + a95 + a96 + a97 + a98 + a99 +
+ ((long) a100) + ((long) a101) + a102 + a103 + ((unsigned int) a104) +
+ ((long) a105) + a106 + a107 + a108 + a109 + ((long) a110) + a111 +
+ ((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 + a120 +
+ a121 + ((long) a122) + a123 + a124 + ((long) a125) + a126 + a127;
+}
+
+/*
+ * CALLBACKS.BFF.1 (cb-test :no-long-long t)
+ */
+
+DLLEXPORT long call_sum_127_no_ll
+ (long (*func)
+ (unsigned long, void*, long, double, unsigned long, float, float,
+ int, unsigned int, double, double, double, void*, unsigned short,
+ unsigned short, void*, long, long, int, short, unsigned short,
+ unsigned short, char, long, void*, void*, char, unsigned char,
+ unsigned long, short, int, int, unsigned char, short, long, long,
+ void*, unsigned short, char, double, unsigned short, void*, short,
+ unsigned long, unsigned short, float, unsigned char, short, float,
+ short, char, unsigned long, unsigned long, char, float, long, void*,
+ short, float, unsigned int, float, unsigned int, double, unsigned int,
+ unsigned char, int, long, char, short, double, int, void*, char,
+ unsigned short, void*, unsigned short, void*, unsigned long, double,
+ void*, long, float, unsigned short, unsigned short, void*, float, int,
+ unsigned int, double, float, long, void*, unsigned short, float,
+ unsigned char, unsigned char, float, unsigned int, float, unsigned
+ short, double, unsigned short, unsigned long, unsigned int, unsigned
+ long, void*, unsigned char, char, char, unsigned short, unsigned long,
+ float, short, void*, long, unsigned short, short, double, short, int,
+ char, unsigned long, long, int, void*, double, unsigned char))
+{
+ return
+ func(948223085, (void *) 803308438, -465723152, 20385,
+ 219679466, -10035, 13915, -1193455756, 1265303699, 27935, -18478,
+ -10508, (void *) 215389089, 55561, 55472, (void *) 146070433,
+ -1040819989, -17851453, -1622662247, -19473, 20837, 30216, 79,
+ 986800400, (void *) 390281604, (void *) 1178532858, 19, 117,
+ 78337699, -5718, -991300738, 872160910, 184, 926, -1487245383,
+ 1633973783, (void *) 33738609, 53985, -116, 31645, 27196, (void *)
+ 145569903, -6960, 17252220, 47404, -10491, 88, -30438, -21212,
+ -1982, -16, 1175270, 7949380, -121, 8559, -432968526, (void *)
+ 293455312, 11894, -8394, 142421516, -25758, 3422998, 4004,
+ 15758212, 198, -1071899743, -1284904617, -11, -17219, -30039,
+ 311589092, (void *) 541468577, 123, 63517, (void *) 1252504506,
+ 39368, (void *) 10057868, 134781408, -7143, (void *) 72825877,
+ -1190798667, -30862, 63757, 14965, (void *) 802391252, 22008,
+ -517289619, 806091099, 1125, 451, -498145176, (void *) 55960931,
+ 15379, 4629, 184, 254, 22532, 465856451, -1669, 49416, -16546,
+ 2983, 4337541, 65292495, 39253529, (void *) 669025, 211, 85, -19,
+ 24298, 65358, 16776, -29957, (void *) 124311, -163231228, 2610,
+ -7806, 26434, -21913, -753615541, 120, 358697932, -1198889034,
+ -2131350926, (void *) 3749492036, -13413, 17);
+}
+
+/*
+ * CALLBACKS.BFF.2 (cb-test)
+ */
+
+DLLEXPORT long long call_sum_127
+ (long long (*func)
+ (short, char, void*, float, long, double, unsigned long long,
+ unsigned short, unsigned char, char, char, unsigned short, unsigned
+ long long, unsigned short, long long, unsigned short, unsigned long
+ long, unsigned char, unsigned char, unsigned long long, long long,
+ char, float, unsigned int, float, float, unsigned int, float, char,
+ unsigned char, long, long long, unsigned char, double, long,
+ double, unsigned int, unsigned short, long long, unsigned int, int,
+ unsigned long long, long, short, unsigned int, unsigned int,
+ unsigned long long, unsigned int, long, void*, unsigned char, char,
+ long long, unsigned short, unsigned int, float, unsigned char,
+ unsigned long, long long, float, long, float, int, float, unsigned
+ short, unsigned long long, short, unsigned long, long, char,
+ unsigned short, long long, short, double, void*, unsigned int,
+ char, unsigned int, void*, void*, unsigned char, void*, unsigned
+ short, unsigned char, long, void*, char, long, unsigned short,
+ unsigned char, double, unsigned long long, unsigned short, unsigned
+ short, unsigned int, long, char, long, char, short, unsigned short,
+ unsigned long, unsigned long, short, long long, long long, long
+ long, double, unsigned short, unsigned char, short, unsigned char,
+ long, long long, unsigned long long, unsigned int, unsigned long,
+ unsigned char, long long, unsigned char, unsigned long long,
+ double, unsigned char, long long, unsigned char, char, long long))
+{
+ return
+ func(-8573, 14, (void *) 832601021, -32334, -1532040888,
+ -18478, 2793023182591311826, 2740, 230, 103, 97, 13121,
+ 5112369026351511084, 7763, -8134147951003417418, 34348,
+ 5776613699556468853, 19, 122, 1431603726926527625,
+ 439503521880490337, -112, -21557, 1578969190, -22008, -4953,
+ 2127745975, -7262, -6, 180, 226352974, -3928775366167459219, 134,
+ -17730, -1175042526, 23868, 3494181009, 57364,
+ 3134876875147518682, 104531655, -1286882727, 803577887579693487,
+ 1349268803, 24912, 3313099419, 3907347884, 1738833249233805034,
+ 2794230885, 1008818752, (void *) 1820044575, 189, 61,
+ -931654560961745071, 57531, 3096859985, 10405, 220, 3631311224,
+ -8531370353478907668, 31258, 678896693, -32150, -1869057813,
+ -19877, 62841, 4161660185772906873, -23869, 4016251006, 610353435,
+ 105, 47315, -1051054492535331660, 6846, -15163, (void *)
+ 736672359, 2123928476, -122, 3859258652, (void *) 3923394833,
+ (void *) 1265031970, 161, (void *) 1993867800, 55056, 122,
+ 1562112760, (void *) 866615125, -79, -1261399547, 31737, 254,
+ -31279, 5462649659172897980, 5202, 7644, 174224940, -337854382,
+ -45, -583502442, -37, -13266, 24520, 2198606699, 2890453969,
+ -8282, -2295716637858246075, -1905178488651598878,
+ -6384652209316714643, 14841, 35443, 132, 15524, 187, 2138878229,
+ -5153032566879951000, 9056545530140684207, 4124632010, 276167701,
+ 56, -2307310370663738730, 66, 9113015627153789746, -9618, 167,
+ 755753399701306200, 119, -28, -990561962725435433);
+}
+
+/*
+ * CALLBACKS.DOUBLE26
+ */
+
+DLLEXPORT double call_double26
+ (double (*f)(double, double, double, double, double, double, double, double,
+ double, double, double, double, double, double, double, double,
+ double, double, double, double, double, double, double, double,
+ double, double))
+{
+ return f(3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
+ 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
+ 3.14, 3.14, 3.14, 3.14);
+}
+
+/*
+ * DEFCFUN.DOUBLE26 and FUNCALL.DOUBLE26
+ */
+
+DLLEXPORT
+double sum_double26(double a1, double a2, double a3, double a4, double a5,
+ double a6, double a7, double a8, double a9, double a10,
+ double a11, double a12, double a13, double a14, double a15,
+ double a16, double a17, double a18, double a19, double a20,
+ double a21, double a22, double a23, double a24, double a25,
+ double a26)
+{
+ return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
+ a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
+ a26;
+}
+
+/*
+ * CALLBACKS.FLOAT26
+ */
+
+DLLEXPORT float call_float26
+ (float (*f)(float, float, float, float, float, float, float, float,
+ float, float, float, float, float, float, float, float,
+ float, float, float, float, float, float, float, float,
+ float, float))
+{
+ return f(5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
+ 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
+ 5.0, 5.0, 5.0, 5.0);
+}
+
+/*
+ * DEFCFUN.FLOAT26 and FUNCALL.FLOAT26
+ */
+
+DLLEXPORT
+float sum_float26(float a1, float a2, float a3, float a4, float a5,
+ float a6, float a7, float a8, float a9, float a10,
+ float a11, float a12, float a13, float a14, float a15,
+ float a16, float a17, float a18, float a19, float a20,
+ float a21, float a22, float a23, float a24, float a25,
+ float a26)
+{
+ return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
+ a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
+ a26;
+}
+
+/*
+ * Symbol case.
+ */
+
+DLLEXPORT int UPPERCASEINT1 = 12345;
+DLLEXPORT int UPPER_CASE_INT1 = 23456;
+DLLEXPORT int MiXeDCaSeInT1 = 34567;
+DLLEXPORT int MiXeD_CaSe_InT1 = 45678;
+
+DLLEXPORT int UPPERCASEINT2 = 12345;
+DLLEXPORT int UPPER_CASE_INT2 = 23456;
+DLLEXPORT int MiXeDCaSeInT2 = 34567;
+DLLEXPORT int MiXeD_CaSe_InT2 = 45678;
+
+DLLEXPORT int UPPERCASEINT3 = 12345;
+DLLEXPORT int UPPER_CASE_INT3 = 23456;
+DLLEXPORT int MiXeDCaSeInT3 = 34567;
+DLLEXPORT int MiXeD_CaSe_InT3 = 45678;
+
+/*
+ * FOREIGN-SYMBOL-POINTER.1
+ */
+
+DLLEXPORT int compare_against_abs(intptr_t p)
+{
+ return p == (intptr_t) abs;
+}
+
+/*
+ * FOREIGN-SYMBOL-POINTER.2
+ */
+
+DLLEXPORT void xpto_fun() {}
+
+DLLEXPORT int compare_against_xpto_fun(intptr_t p)
+{
+ return p == (intptr_t) xpto_fun;
+}
+
+/* vim: ts=4 et
+*/
Property changes on: branches/xml-class-rework/thirdparty/cffi/tests/libtest.c
___________________________________________________________________
Name: svn:eol-style
+ native
Added: branches/xml-class-rework/thirdparty/cffi/tests/memory.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/memory.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/memory.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,513 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; memory.lisp --- Tests for memory referencing.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(deftest deref.char
+ (with-foreign-object (p :char)
+ (setf (mem-ref p :char) -127)
+ (mem-ref p :char))
+ -127)
+
+(deftest deref.unsigned-char
+ (with-foreign-object (p :unsigned-char)
+ (setf (mem-ref p :unsigned-char) 255)
+ (mem-ref p :unsigned-char))
+ 255)
+
+(deftest deref.short
+ (with-foreign-object (p :short)
+ (setf (mem-ref p :short) -32767)
+ (mem-ref p :short))
+ -32767)
+
+(deftest deref.unsigned-short
+ (with-foreign-object (p :unsigned-short)
+ (setf (mem-ref p :unsigned-short) 65535)
+ (mem-ref p :unsigned-short))
+ 65535)
+
+(deftest deref.int
+ (with-foreign-object (p :int)
+ (setf (mem-ref p :int) -131072)
+ (mem-ref p :int))
+ -131072)
+
+(deftest deref.unsigned-int
+ (with-foreign-object (p :unsigned-int)
+ (setf (mem-ref p :unsigned-int) 262144)
+ (mem-ref p :unsigned-int))
+ 262144)
+
+(deftest deref.long
+ (with-foreign-object (p :long)
+ (setf (mem-ref p :long) -536870911)
+ (mem-ref p :long))
+ -536870911)
+
+(deftest deref.unsigned-long
+ (with-foreign-object (p :unsigned-long)
+ (setf (mem-ref p :unsigned-long) 536870912)
+ (mem-ref p :unsigned-long))
+ 536870912)
+
+#-cffi-features:no-long-long
+(progn
+ #+(and cffi-features:darwin openmcl)
+ (pushnew 'deref.long-long rt::*expected-failures*)
+
+ (deftest deref.long-long
+ (with-foreign-object (p :long-long)
+ (setf (mem-ref p :long-long) -9223372036854775807)
+ (mem-ref p :long-long))
+ -9223372036854775807)
+
+ (deftest deref.unsigned-long-long
+ (with-foreign-object (p :unsigned-long-long)
+ (setf (mem-ref p :unsigned-long-long) 18446744073709551615)
+ (mem-ref p :unsigned-long-long))
+ 18446744073709551615))
+
+(deftest deref.float.1
+ (with-foreign-object (p :float)
+ (setf (mem-ref p :float) 0.0)
+ (mem-ref p :float))
+ 0.0)
+
+(deftest deref.float.2
+ (with-foreign-object (p :float)
+ (setf (mem-ref p :float) *float-max*)
+ (mem-ref p :float))
+ #.*float-max*)
+
+(deftest deref.float.3
+ (with-foreign-object (p :float)
+ (setf (mem-ref p :float) *float-min*)
+ (mem-ref p :float))
+ #.*float-min*)
+
+(deftest deref.double.1
+ (with-foreign-object (p :double)
+ (setf (mem-ref p :double) 0.0d0)
+ (mem-ref p :double))
+ 0.0d0)
+
+(deftest deref.double.2
+ (with-foreign-object (p :double)
+ (setf (mem-ref p :double) *double-max*)
+ (mem-ref p :double))
+ #.*double-max*)
+
+(deftest deref.double.3
+ (with-foreign-object (p :double)
+ (setf (mem-ref p :double) *double-min*)
+ (mem-ref p :double))
+ #.*double-min*)
+
+;;; TODO: use something like *DOUBLE-MIN/MAX* above once we actually
+;;; have an available lisp that supports long double.
+;#-cffi-features:no-long-float
+#+(and scl long-double)
+(progn
+ (deftest deref.long-double.1
+ (with-foreign-object (p :long-double)
+ (setf (mem-ref p :long-double) 0.0l0)
+ (mem-ref p :long-double))
+ 0.0l0)
+
+ (deftest deref.long-double.2
+ (with-foreign-object (p :long-double)
+ (setf (mem-ref p :long-double) most-positive-long-float)
+ (mem-ref p :long-double))
+ #.most-positive-long-float)
+
+ (deftest deref.long-double.3
+ (with-foreign-object (p :long-double)
+ (setf (mem-ref p :long-double) least-positive-long-float)
+ (mem-ref p :long-double))
+ #.least-positive-long-float))
+
+;;; make sure the lisp doesn't convert NULL to NIL
+(deftest deref.pointer.null
+ (with-foreign-object (p :pointer)
+ (setf (mem-ref p :pointer) (null-pointer))
+ (null-pointer-p (mem-ref p :pointer)))
+ t)
+
+;;; regression test. lisp-string-to-foreign should handle empty strings
+(deftest lisp-string-to-foreign.empty
+ (with-foreign-pointer (str 2)
+ (setf (mem-ref str :unsigned-char) 42)
+ (lisp-string-to-foreign "" str 1)
+ (mem-ref str :unsigned-char))
+ 0)
+
+;; regression test. with-foreign-pointer shouldn't evaluate
+;; the size argument twice.
+(deftest with-foreign-pointer.evalx2
+ (let ((count 0))
+ (with-foreign-pointer (x (incf count) size-var)
+ (values count size-var)))
+ 1 1)
+
+(deftest mem-ref.left-to-right
+ (let ((i 0))
+ (with-foreign-object (p :char 3)
+ (setf (mem-ref p :char 0) 66 (mem-ref p :char 1) 92)
+ (setf (mem-ref p :char (incf i)) (incf i))
+ (values (mem-ref p :char 0) (mem-ref p :char 1) i)))
+ 66 2 2)
+
+;;; This needs to be in a real function for at least Allegro CL or the
+;;; compiler macro on %MEM-REF is not expanded and the test doesn't
+;;; actually test anything!
+(defun %mem-ref-left-to-right ()
+ (let ((result nil))
+ (with-foreign-object (p :char)
+ (%mem-set 42 p :char)
+ (%mem-ref (progn (push 1 result) p) :char (progn (push 2 result) 0))
+ (nreverse result))))
+
+;;; Test left-to-right evaluation of the arguments to %MEM-REF when
+;;; optimized by the compiler macro.
+(deftest %mem-ref.left-to-right
+ (%mem-ref-left-to-right)
+ (1 2))
+
+;;; This needs to be in a top-level function for at least Allegro CL
+;;; or the compiler macro on %MEM-SET is not expanded and the test
+;;; doesn't actually test anything!
+(defun %mem-set-left-to-right ()
+ (let ((result nil))
+ (with-foreign-object (p :char)
+ (%mem-set (progn (push 1 result) 0)
+ (progn (push 2 result) p)
+ :char
+ (progn (push 3 result) 0))
+ (nreverse result))))
+
+;;; Test left-to-right evaluation of the arguments to %MEM-SET when
+;;; optimized by the compiler macro.
+(deftest %mem-set.left-to-right
+ (%mem-set-left-to-right)
+ (1 2 3))
+
+;; regression test. mem-aref's setf expansion evaluated its type argument twice.
+(deftest mem-aref.eval-type-x2
+ (let ((count 0))
+ (with-foreign-pointer (p 1)
+ (setf (mem-aref p (progn (incf count) :char) 0) 127))
+ count)
+ 1)
+
+(deftest mem-aref.left-to-right
+ (let ((count -1))
+ (with-foreign-pointer (p 2)
+ (values
+ (setf (mem-aref p (progn (incf count) :char) (incf count)) (incf count))
+ (setq count -1)
+ (mem-aref (progn (incf count) p) :char (incf count))
+ count)))
+ 2 -1 2 1)
+
+;; regression tests. nested mem-ref's and mem-aref's had bogus getters
+(deftest mem-ref.nested
+ (with-foreign-object (p :pointer)
+ (with-foreign-object (i :int)
+ (setf (mem-ref p :pointer) i)
+ (setf (mem-ref i :int) 42)
+ (setf (mem-ref (mem-ref p :pointer) :int) 1984)
+ (mem-ref i :int)))
+ 1984)
+
+(deftest mem-aref.nested
+ (with-foreign-object (p :pointer)
+ (with-foreign-object (i :int 2)
+ (setf (mem-aref p :pointer 0) i)
+ (setf (mem-aref i :int 1) 42)
+ (setf (mem-aref (mem-ref p :pointer 0) :int 1) 1984)
+ (mem-aref i :int 1)))
+ 1984)
+
+;;; regression tests. dereferencing an aggregate type. dereferencing a
+;;; struct should return a pointer to the struct itself, not return the
+;;; first 4 bytes (or whatever the size of :pointer is) as a pointer.
+;;;
+;;; This important for accessing an array of structs, which is
+;;; what the deref.array-of-aggregates test does.
+(defcstruct some-struct (x :int))
+
+(deftest deref.aggregate
+ (with-foreign-object (s 'some-struct)
+ (pointer-eq s (mem-ref s 'some-struct)))
+ t)
+
+(deftest deref.array-of-aggregates
+ (with-foreign-object (arr 'some-struct 3)
+ (loop for i below 3
+ do (setf (foreign-slot-value (mem-aref arr 'some-struct i)
+ 'some-struct 'x)
+ 112))
+ (loop for i below 3
+ collect (foreign-slot-value (mem-aref arr 'some-struct i)
+ 'some-struct 'x)))
+ (112 112 112))
+
+;;; pointer operations
+(deftest pointer.1
+ (pointer-address (make-pointer 42))
+ 42)
+
+;;; I suppose this test is not very good. --luis
+(deftest pointer.2
+ (pointer-address (null-pointer))
+ 0)
+
+;;; Ensure that a pointer to the highest possible address can be
+;;; created using MAKE-POINTER. Regression test for CLISP/X86-64.
+(deftest make-pointer.high
+ (let* ((pointer-length (foreign-type-size :pointer))
+ (high-address (1- (expt 2 (* pointer-length 8))))
+ (pointer (make-pointer high-address)))
+ (- high-address (pointer-address pointer)))
+ 0)
+
+;;; Ensure that incrementing a pointer by zero bytes returns an
+;;; equivalent pointer.
+(deftest inc-pointer.zero
+ (with-foreign-object (x :int)
+ (pointer-eq x (inc-pointer x 0)))
+ t)
+
+;;; Test the INITIAL-ELEMENT keyword argument to FOREIGN-ALLOC.
+(deftest foreign-alloc.1
+ (let ((ptr (foreign-alloc :int :initial-element 42)))
+ (unwind-protect
+ (mem-ref ptr :int)
+ (foreign-free ptr)))
+ 42)
+
+;;; Test the INITIAL-ELEMENT and COUNT arguments to FOREIGN-ALLOC.
+(deftest foreign-alloc.2
+ (let ((ptr (foreign-alloc :int :count 4 :initial-element 100)))
+ (unwind-protect
+ (loop for i from 0 below 4
+ collect (mem-aref ptr :int i))
+ (foreign-free ptr)))
+ (100 100 100 100))
+
+;;; Test the INITIAL-CONTENTS and COUNT arguments to FOREIGN-ALLOC,
+;;; passing a list of initial values.
+(deftest foreign-alloc.3
+ (let ((ptr (foreign-alloc :int :count 4 :initial-contents '(4 3 2 1))))
+ (unwind-protect
+ (loop for i from 0 below 4
+ collect (mem-aref ptr :int i))
+ (foreign-free ptr)))
+ (4 3 2 1))
+
+;;; Test INITIAL-CONTENTS and COUNT with FOREIGN-ALLOC passing a
+;;; vector of initial values.
+(deftest foreign-alloc.4
+ (let ((ptr (foreign-alloc :int :count 4 :initial-contents #(10 20 30 40))))
+ (unwind-protect
+ (loop for i from 0 below 4
+ collect (mem-aref ptr :int i))
+ (foreign-free ptr)))
+ (10 20 30 40))
+
+;;; Ensure calling FOREIGN-ALLOC with both INITIAL-ELEMENT and
+;;; INITIAL-CONTENTS signals an error.
+(deftest foreign-alloc.5
+ (values
+ (ignore-errors
+ (let ((ptr (foreign-alloc :int :initial-element 1 :initial-contents '(1))))
+ (foreign-free ptr))
+ t))
+ nil)
+
+;;; Regression test: FOREIGN-ALLOC shouldn't actually perform translation
+;;; on initial-element/initial-contents since MEM-AREF will do that already.
+(defctype not-an-int :int)
+
+(defmethod translate-to-foreign (value (name (eql 'not-an-int)))
+ (assert (not (integerp value)))
+ 0)
+
+(deftest foreign-alloc.6
+ (let ((ptr (foreign-alloc 'not-an-int :initial-element 'foooo)))
+ (foreign-free ptr)
+ t)
+ t)
+
+;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P and a non-pointer
+;;; type signals an error.
+(deftest foreign-alloc.7
+ (values
+ (ignore-errors
+ (let ((ptr (foreign-alloc :int :null-terminated-p t)))
+ (foreign-free ptr))
+ t))
+ nil)
+
+;;; The opposite of the above test.
+(defctype pointer-alias :pointer)
+
+(deftest foreign-alloc.8
+ (progn
+ (foreign-free (foreign-alloc 'pointer-alias :count 0 :null-terminated-p t))
+ t)
+ t)
+
+;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P actually places
+;;; a null pointer at the end. Not a very reliable test apparently.
+(deftest foreign-alloc.9
+ (let ((ptr (foreign-alloc :pointer :count 0 :null-terminated-p t)))
+ (unwind-protect
+ (null-pointer-p (mem-ref ptr :pointer))
+ (foreign-free ptr)))
+ t)
+
+;;; Tests for mem-ref with a non-constant type. This is a way to test
+;;; the functional interface (without compiler macros).
+
+(deftest deref.nonconst.char
+ (let ((type :char))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) -127)
+ (mem-ref p type)))
+ -127)
+
+(deftest deref.nonconst.unsigned-char
+ (let ((type :unsigned-char))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) 255)
+ (mem-ref p type)))
+ 255)
+
+(deftest deref.nonconst.short
+ (let ((type :short))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) -32767)
+ (mem-ref p type)))
+ -32767)
+
+(deftest deref.nonconst.unsigned-short
+ (let ((type :unsigned-short))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) 65535)
+ (mem-ref p type)))
+ 65535)
+
+(deftest deref.nonconst.int
+ (let ((type :int))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) -131072)
+ (mem-ref p type)))
+ -131072)
+
+(deftest deref.nonconst.unsigned-int
+ (let ((type :unsigned-int))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) 262144)
+ (mem-ref p type)))
+ 262144)
+
+(deftest deref.nonconst.long
+ (let ((type :long))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) -536870911)
+ (mem-ref p type)))
+ -536870911)
+
+(deftest deref.nonconst.unsigned-long
+ (let ((type :unsigned-long))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) 536870912)
+ (mem-ref p type)))
+ 536870912)
+
+#-cffi-features:no-long-long
+(progn
+ #+(and cffi-features:darwin openmcl)
+ (pushnew 'deref.nonconst.long-long rt::*expected-failures*)
+
+ (deftest deref.nonconst.long-long
+ (let ((type :long-long))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) -9223372036854775807)
+ (mem-ref p type)))
+ -9223372036854775807)
+
+ (deftest deref.nonconst.unsigned-long-long
+ (let ((type :unsigned-long-long))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) 18446744073709551615)
+ (mem-ref p type)))
+ 18446744073709551615))
+
+(deftest deref.nonconst.float.1
+ (let ((type :float))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) 0.0)
+ (mem-ref p type)))
+ 0.0)
+
+(deftest deref.nonconst.float.2
+ (let ((type :float))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) *float-max*)
+ (mem-ref p type)))
+ #.*float-max*)
+
+(deftest deref.nonconst.float.3
+ (let ((type :float))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) *float-min*)
+ (mem-ref p type)))
+ #.*float-min*)
+
+(deftest deref.nonconst.double.1
+ (let ((type :double))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) 0.0d0)
+ (mem-ref p type)))
+ 0.0d0)
+
+(deftest deref.nonconst.double.2
+ (let ((type :double))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) *double-max*)
+ (mem-ref p type)))
+ #.*double-max*)
+
+(deftest deref.nonconst.double.3
+ (let ((type :double))
+ (with-foreign-object (p type)
+ (setf (mem-ref p type) *double-min*)
+ (mem-ref p type)))
+ #.*double-min*)
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/tests/misc-types.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/misc-types.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/misc-types.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,233 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; misc-types.lisp --- Various tests on the type system.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcfun ("my_strdup" strdup) :string+ptr (str :string))
+
+(deftest misc-types.string+ptr
+ (destructuring-bind (string pointer)
+ (strdup "foo")
+ (foreign-free pointer)
+ string)
+ "foo")
+
+(defcfun "equalequal" :boolean
+ (a (:boolean :int))
+ (b (:boolean :unsigned-int)))
+
+(defcfun "bool_and" (:boolean :char)
+ (a (:boolean :unsigned-char))
+ (b (:boolean :char)))
+
+(defcfun "bool_xor" (:boolean :unsigned-long)
+ (a (:boolean :long))
+ (b (:boolean :unsigned-long)))
+
+(deftest misc-types.boolean.1
+ (list (equalequal nil nil)
+ (equalequal t t)
+ (equalequal t 23)
+ (bool-and 'a 'b)
+ (bool-and "foo" nil)
+ (bool-xor t nil)
+ (bool-xor nil nil))
+ (t t t t nil t nil))
+
+
+;;; Regression test: boolean type only worked with canonicalized
+;;; built-in integer types. Should work for any type that canonicalizes
+;;; to a built-in integer type.
+(defctype int-for-bool :int)
+(defcfun ("equalequal" equalequal2) :boolean
+ (a (:boolean int-for-bool))
+ (b (:boolean :uint)))
+
+(deftest misc-types.boolean.2
+ (equalequal2 nil t)
+ nil)
+
+(defctype my-string :string+ptr)
+
+(defun funkify (str)
+ (concatenate 'string "MORE " (string-upcase str)))
+
+(defun 3rd-person (value)
+ (list (concatenate 'string "Strdup says: " (first value))
+ (second value)))
+
+;; (defctype funky-string
+;; (:wrapper my-string
+;; :to-c #'funkify
+;; :from-c (lambda (value)
+;; (list
+;; (concatenate 'string "Strdup says: "
+;; (first value))
+;; (second value))))
+;; "A useful type.")
+
+(defctype funky-string (:wrapper my-string :to-c funkify :from-c 3rd-person))
+
+(defcfun ("my_strdup" funky-strdup) funky-string
+ (str funky-string))
+
+(deftest misc-types.wrapper
+ (destructuring-bind (string ptr)
+ (funky-strdup "code")
+ (foreign-free ptr)
+ string)
+ "Strdup says: MORE CODE")
+
+(deftest misc-types.sized-ints
+ (mapcar #'foreign-type-size '(:int8 :uint8 :int16 :uint16 :int32 :uint32
+ #-cffi-features:no-long-long :int64
+ #-cffi-features:no-long-long :uint64))
+ (1 1 2 2 4 4
+ #-cffi-features:no-long-long 8
+ #-cffi-features:no-long-long 8))
+
+(defctype untranslated-int :int :translate-p nil)
+
+(defmethod translate-to-foreign (value (type (eql 'untranslated-int)))
+ (+ value 42))
+
+(defmethod translate-from-foreign (value (type (eql 'untranslated-int)))
+ (+ value 666))
+
+(defcfun ("abs" untranslated-abs) untranslated-int
+ (value untranslated-int))
+
+;;; Ensure that type translators are not called on non-translatable
+;;; typedefs when passing arguments or returning values to foreign
+;;; functions.
+(deftest misc-types.untranslated-typedef
+ (untranslated-abs 1)
+ 1)
+
+;;; Ensure that type translators are not called on non-translatable
+;;; typedefs when passing values or returning from a callback.
+#-cffi-features:no-foreign-funcall
+(progn
+ (defcallback untranslated-callback untranslated-int ((x untranslated-int))
+ x)
+ (deftest misc-types.untranslated-callback
+ (foreign-funcall (callback untranslated-callback) :int 1 :int)
+ 1))
+
+(defctype error-error :int)
+
+(defmethod translate-to-foreign (value (name (eql 'error-error)))
+ (declare (ignore value))
+ (error "translate-to-foreign invoked."))
+
+(defmethod translate-from-foreign (value (name (eql 'error-error)))
+ (declare (ignore value))
+ (error "translate-from-foreign invoked."))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (defmethod expand-to-foreign (value (name (eql 'error-error)))
+ value)
+
+ (defmethod expand-from-foreign (value (name (eql 'error-error)))
+ value))
+
+(defcfun ("abs" expand-abs) error-error
+ (n error-error))
+
+(defcvar ("var_int" *expand-var-int*) error-error)
+
+(defcfun ("expect_int_sum" expand-expect-int-sum) :boolean
+ (cb :pointer))
+
+(defcallback expand-int-sum error-error ((x error-error) (y error-error))
+ (+ x y))
+
+;;; Ensure that macroexpansion-time translators are called where this
+;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback)
+(deftest misc-types.expand.1
+ (expand-abs -1)
+ 1)
+
+#-cffi-features:no-foreign-funcall
+(deftest misc-types.expand.2
+ (foreign-funcall "abs" error-error -1 error-error)
+ 1)
+
+(deftest misc-types.expand.3
+ (let ((old (mem-ref (get-var-pointer '*expand-var-int*) :int)))
+ (unwind-protect
+ (progn
+ (setf *expand-var-int* 42)
+ *expand-var-int*)
+ (setf (mem-ref (get-var-pointer '*expand-var-int*) :int) old)))
+ 42)
+
+(deftest misc-types.expand.4
+ (expand-expect-int-sum (callback expand-int-sum))
+ t)
+
+(defctype translate-tracker :int)
+
+(declaim (special .fto-called.))
+
+(defmethod free-translated-object (value (type-name (eql 'translate-tracker))
+ param)
+ (declare (ignore value param))
+ (setf .fto-called. t))
+
+(defctype expand-tracker :int)
+
+(defmethod free-translated-object (value (type-name (eql 'expand-tracker))
+ param)
+ (declare (ignore value param))
+ (setf .fto-called. t))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmethod expand-to-foreign (value (type-name (eql 'expand-tracker)))
+ (declare (ignore value))
+ (call-next-method)))
+
+(defcfun ("abs" ttracker-abs) :int
+ (n translate-tracker))
+
+(defcfun ("abs" etracker-abs) :int
+ (n expand-tracker))
+
+;; free-translated-object must be called when there is no etf
+(deftest misc-types.expand.5
+ (let ((.fto-called. nil))
+ (ttracker-abs -1)
+ .fto-called.)
+ t)
+
+;; free-translated-object must not be called when there is an etf, but
+;; they answer *runtime-translator-form*
+(deftest misc-types.expand.6
+ (let ((.fto-called. nil))
+ (etracker-abs -1)
+ .fto-called.)
+ nil)
Added: branches/xml-class-rework/thirdparty/cffi/tests/misc.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/misc.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/misc.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,89 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; misc.lisp --- Miscellaneous tests.
+;;;
+;;; Copyright (C) 2006, Luis Oliveira <loliveira(a)common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+;;; From CLRFI-1
+(defun featurep (feature-expression)
+ (etypecase feature-expression
+ (symbol (not (null (member feature-expression *features*))))
+ (cons ; Not LIST, as we've already eliminated NIL.
+ (ecase (first feature-expression)
+ (:and (every #'featurep (rest feature-expression)))
+ (:or (some #'featurep (rest feature-expression)))
+ (:not (not (featurep (cadr feature-expression))))))))
+
+;;; Test relations between OS features.
+
+(deftest features.os.1
+ (if (featurep 'cffi-features:windows)
+ (not (or (featurep 'cffi-features:unix)
+ (featurep 'cffi-features:darwin)))
+ t)
+ t)
+
+(deftest features.os.2
+ (if (featurep 'cffi-features:darwin)
+ (and (not (featurep 'cffi-features:windows))
+ (featurep 'cffi-features:unix))
+ t)
+ t)
+
+(deftest features.os.3
+ (if (featurep 'cffi-features:unix)
+ (not (featurep 'cffi-features:windows))
+ t)
+ t)
+
+;;; Test mutual exclusiveness of CPU features.
+
+(defparameter *cpu-features*
+ '(cffi-features:x86
+ cffi-features:x86-64
+ cffi-features:ppc32))
+
+(deftest features.cpu.1
+ (loop for feature in *cpu-features*
+ when (featurep feature)
+ sum 1)
+ 1)
+
+;;;; foreign-symbol-pointer tests
+
+;;; This might be useful for some libraries that compare function
+;;; pointers. http://thread.gmane.org/gmane.lisp.cffi.devel/694
+(defcfun "compare_against_abs" :boolean (p :pointer))
+
+(deftest foreign-symbol-pointer.1
+ (compare-against-abs (foreign-symbol-pointer "abs"))
+ t)
+
+(defcfun "compare_against_xpto_fun" :boolean (p :pointer))
+
+(deftest foreign-symbol-pointer.2
+ (compare-against-xpto-fun (foreign-symbol-pointer "xpto_fun"))
+ t)
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/tests/package.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/package.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/package.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,32 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; package.lisp --- CFFI-TESTS package definition.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(defpackage #:cffi-tests
+ (:use #:cl #:cffi #:cffi-sys #:regression-test)
+ (:export #:do-tests))
Added: branches/xml-class-rework/thirdparty/cffi/tests/random-tester.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/random-tester.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/random-tester.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,246 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; random-tester.lisp --- Random test generator.
+;;;
+;;; Copyright (C) 2006, Luis Oliveira <loliveira((a))common-lisp.net>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; This code was used to generate the C and Lisp source code for
+;;; the CALLBACKS.BFF.[12] and DEFCFUN.BFF.[12] tests.
+;;;
+;;; The original idea was to test all combinations of argument types
+;;; but obviously as soon as you do the maths that it's not quite
+;;; feasable for more that 4 or 5 arguments.
+;;;
+;;; TODO: actually run random tests, ie compile/load/run the tests
+;;; this code can generate.
+
+(defpackage #:cffi-random-tester
+ (:use #:cl #:cffi #:regression-test))
+(in-package #:cffi-random-tester)
+
+(defstruct (c-type (:conc-name type-))
+ keyword
+ name
+ abbrev
+ min
+ max)
+
+(defparameter +types+
+ (mapcar (lambda (type)
+ (let ((keyword (first type))
+ (name (second type)))
+ (multiple-value-bind (min max)
+ ;; assume we can represent an integer in the range
+ ;; [-2^16 2^16-1] in a float/double without causing
+ ;; rounding errors (probably a lame assumption)
+ (let ((type-size (if (or (eq keyword :float)
+ (eq keyword :double))
+ 16
+ (* 8 (foreign-type-size keyword)))))
+ (if (or (eql (char name 0) #\u) (eq keyword :pointer))
+ (values 0 (1- (expt 2 type-size)))
+ (values (- (expt 2 (1- type-size)))
+ (1- (expt 2 (1- type-size))))))
+ (make-c-type :keyword keyword :name name :abbrev (third type)
+ :min min :max max))))
+ '((:char "char" "c")
+ (:unsigned-char "unsigned char" "uc")
+ (:short "short" "s")
+ (:unsigned-short "unsigned short" "us")
+ (:int "int" "i")
+ (:unsigned-int "unsigned int" "ui")
+ (:long "long" "l")
+ (:unsigned-long "unsigned long" "ul")
+ (:float "float" "f")
+ (:double "double" "d")
+ (:pointer "void*" "p")
+ (:long-long "long long" "ll")
+ (:unsigned-long-long "unsigned long long" "ull"))))
+
+(defun find-type (keyword)
+ (find keyword +types+ :key #'type-keyword))
+
+(defun n-random-types (n)
+ (loop repeat n collect (nth (random (length +types+)) +types+)))
+
+;;; same as above, without the long long types
+(defun n-random-types-no-ll (n)
+ (loop repeat n collect (nth (random (- (length +types+) 2)) +types+)))
+
+(defun random-range (x y)
+ (+ x (random (+ (- y x) 2))))
+
+(defun random-sum (rettype arg-types)
+ "Returns a list of integers that fit in the respective types in the
+ARG-TYPES list and whose sum fits in RETTYPE."
+ (loop with sum = 0
+ for type in arg-types
+ for x = (random-range (max (- (type-min rettype) sum) (type-min type))
+ (min (- (type-max rettype) sum) (type-max type)))
+ do (incf sum x)
+ collect x))
+
+(defun combinations (n items)
+ (let ((combs '()))
+ (labels ((rec (n accum)
+ (if (= n 0)
+ (push accum combs)
+ (loop for item in items
+ do (rec (1- n) (cons item accum))))))
+ (rec n '())
+ combs)))
+
+(defun function-name (rettype arg-types)
+ (format nil "sum_~A_~{_~A~}"
+ (type-abbrev rettype)
+ (mapcar #'type-abbrev arg-types)))
+
+(defun c-function (rettype arg-types)
+ (let ((args (loop for type in arg-types and i from 1
+ collect (list (type-name type) (format nil "a~A" i)))))
+ (format t "DLLEXPORT ~A ~A(~{~{~A ~A~}~^, ~})~%~
+ { return ~A(~A) ~{~A~^ + ~}~A; }"
+ (type-name rettype) (function-name rettype arg-types) args
+ (if (eq (type-keyword rettype) :pointer)
+ "(void *)((unsigned int)("
+ "")
+ (type-name rettype)
+ (loop for arg-pair in args collect
+ (format nil "~A~A~A"
+ (cond ((string= (first arg-pair) "void*")
+ "(unsigned int) ")
+ ((or (string= (first arg-pair) "double")
+ (string= (first arg-pair) "float"))
+ "((int) ")
+ (t ""))
+ (second arg-pair)
+ (if (member (first arg-pair)
+ '("void*" "double" "float")
+ :test #'string=)
+ ")"
+ "")))
+ (if (eq (type-keyword rettype) :pointer) "))" ""))))
+
+(defun c-callback (rettype arg-types args)
+ (format t "DLLEXPORT ~A call_~A(~A (*func)(~{~A~^, ~}~^))~%~
+ { return func(~{~A~^, ~}); }"
+ (type-name rettype) (function-name rettype arg-types)
+ (type-name rettype) (mapcar #'type-name arg-types)
+ (loop for type in arg-types and value in args collect
+ (format nil "~A~A"
+ (if (eq (type-keyword type) :pointer)
+ "(void *) "
+ "")
+ value))))
+
+;;; (output-c-code #p"generated.c" 3 5)
+(defun output-c-code (file min max)
+ (with-open-file (stream file :direction :output :if-exists :error)
+ (let ((*standard-output* stream))
+ (format t "/* automatically generated functions and callbacks */~%~%")
+ (loop for n from min upto max do
+ (format t "/* ~A args */" (1- n))
+ (loop for comb in (combinations n +types+) do
+ (terpri) (c-function (car comb) (cdr comb))
+ (terpri) (c-callback (car comb) (cdr comb)))))))
+
+(defmacro with-conversion (type form)
+ (case type
+ (:double `(float ,form 1.0d0))
+ (:float `(float ,form))
+ (:pointer `(make-pointer ,form))
+ (t form)))
+
+(defun integer-conversion (type form)
+ (case type
+ ((:double :float) `(values (floor ,form)))
+ (:pointer `(pointer-address ,form))
+ (t form)))
+
+(defun gen-arg-values (rettype arg-types)
+ (let ((numbers (random-sum rettype arg-types)))
+ (values
+ (reduce #'+ numbers)
+ (loop for type in arg-types and n in numbers
+ collect (case (type-keyword type)
+ (:double (float n 1.0d0))
+ (:float (float n))
+ (:pointer `(make-pointer ,n))
+ (t n))))))
+
+(defun gen-function-test (rettype arg-types)
+ (let* ((fun-name (function-name rettype arg-types))
+ (fun-sym (cffi::lisp-function-name fun-name)))
+ (multiple-value-bind (sum value-forms)
+ (gen-arg-values rettype arg-types)
+ `(progn
+ (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype)
+ ,@(loop for type in arg-types and i from 1 collect
+ (list (cffi-utils:symbolicate '#:a (format nil "~A" i))
+ (type-keyword type))))
+ (deftest ,(cffi-utils:symbolicate '#:defcfun. fun-sym)
+ ,(integer-conversion (type-keyword rettype)
+ `(,fun-sym ,@value-forms))
+ ,sum)))))
+
+(defun gen-callback-test (rettype arg-types sum)
+ (let* ((fname (function-name rettype arg-types))
+ (cb-sym (cffi::lisp-function-name fname))
+ (fun-name (concatenate 'string "call_" fname))
+ (fun-sym (cffi::lisp-function-name fun-name))
+ (arg-names (loop for i from 1 upto (length arg-types) collect
+ (cffi-utils:symbolicate '#:a (format nil "~A" i)))))
+ `(progn
+ (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) (cb :pointer))
+ (defcallback ,cb-sym ,(type-keyword rettype)
+ ,(loop for type in arg-types and name in arg-names
+ collect (list name (type-keyword type)))
+ ,(integer-conversion
+ (type-keyword rettype)
+ `(+ ,@(mapcar (lambda (tp n)
+ (integer-conversion (type-keyword tp) n))
+ arg-types arg-names))))
+ (deftest ,(cffi-utils:symbolicate '#:callbacks. cb-sym)
+ ,(integer-conversion (type-keyword rettype)
+ `(,fun-sym (callback ,cb-sym)))
+ ,sum))))
+
+(defun cb-test (&key no-long-long)
+ (let* ((rettype (find-type (if no-long-long :long :long-long)))
+ (arg-types (if no-long-long
+ (n-random-types-no-ll 127)
+ (n-random-types 127)))
+ (args (random-sum rettype arg-types))
+ (sum (reduce #'+ args)))
+ (c-callback rettype arg-types args)
+ (gen-callback-test rettype arg-types sum)))
+
+;; (defmacro define-function-and-callback-tests (min max)
+;; `(progn
+;; ,@(loop for n from min upto max appending
+;; (loop for comb in (combinations n +types+)
+;; collect (gen-function-test (car comb) (cdr comb))
+;; collect (gen-callback-test (car comb) (cdr comb))))))
+
+;; (define-function-and-callback-tests 3 5)
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/tests/run-tests.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/run-tests.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/run-tests.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,54 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; run-tests.lisp --- Simple script to run the unit tests.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(format t "~&-------- Running tests in ~A --------~%"
+ (lisp-implementation-type))
+
+(setf *load-verbose* nil *compile-verbose* nil *compile-print* nil)
+#+cmu (setf ext:*gc-verbose* nil)
+
+#+(and (not asdf) (or sbcl openmcl ecl))
+(require "asdf")
+
+(asdf:operate 'asdf:load-op 'cffi-tests :verbose nil)
+(in-package #:cffi-tests)
+(do-tests)
+
+(defparameter *repeat* 0)
+(format t "~2&How many times shall we repeat the tests? [~D]: " *repeat*)
+(force-output *standard-output*)
+(let ((ntimes (or (ignore-errors (parse-integer (read-line))) *repeat*)))
+ (unless (eql ntimes 0)
+ (loop repeat ntimes do (do-tests))
+ (format t "~&Finished running tests ~D times." ntimes)))
+
+(in-package #:cl-user)
+(terpri)
+(force-output)
+
+#-allegro (quit)
+#+allegro (exit)
Added: branches/xml-class-rework/thirdparty/cffi/tests/struct.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/struct.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/struct.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,296 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; struct.lisp --- Foreign structure type tests.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcstruct timeval
+ (tv-secs :long)
+ (tv-usecs :long))
+
+(defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
+ (foreign-type-alignment :long))))
+
+;;;# Basic Structure Tests
+
+(deftest struct.1
+ (- (foreign-type-size 'timeval) *timeval-size*)
+ 0)
+
+(deftest struct.2
+ (with-foreign-object (tv 'timeval)
+ (setf (foreign-slot-value tv 'timeval 'tv-secs) 0)
+ (setf (foreign-slot-value tv 'timeval 'tv-usecs) 1)
+ (values (foreign-slot-value tv 'timeval 'tv-secs)
+ (foreign-slot-value tv 'timeval 'tv-usecs)))
+ 0 1)
+
+(deftest struct.3
+ (with-foreign-object (tv 'timeval)
+ (with-foreign-slots ((tv-secs tv-usecs) tv timeval)
+ (setf tv-secs 100 tv-usecs 200)
+ (values tv-secs tv-usecs)))
+ 100 200)
+
+;; regression test: accessing a struct through a typedef
+
+(defctype xpto timeval)
+
+(deftest struct.4
+ (with-foreign-object (tv 'xpto)
+ (setf (foreign-slot-value tv 'xpto 'tv-usecs) 1)
+ (values (foreign-slot-value tv 'xpto 'tv-usecs)
+ (foreign-slot-value tv 'timeval 'tv-usecs)))
+ 1 1)
+
+(deftest struct.names
+ (sort (foreign-slot-names 'xpto) #'<
+ :key (lambda (x) (foreign-slot-offset 'xpto x)))
+ (tv-secs tv-usecs))
+
+;; regression test: compiler macro not quoting the type in the
+;; resulting mem-ref form. The compiler macro on foreign-slot-value
+;; is not guaranteed to be expanded though.
+
+(defctype my-int :int)
+(defcstruct s5 (a my-int))
+
+(deftest struct.5
+ (with-foreign-object (s 's5)
+ (setf (foreign-slot-value s 's5 'a) 42)
+ (foreign-slot-value s 's5 'a))
+ 42)
+
+;;;# Structs with type translators
+
+(defcstruct struct-string
+ (s :string))
+
+(deftest struct.string.1
+ (with-foreign-object (ptr 'struct-string)
+ (with-foreign-slots ((s) ptr struct-string)
+ (setf s "So long and thanks for all the fish!")
+ s))
+ "So long and thanks for all the fish!")
+
+(deftest struct.string.2
+ (with-foreign-object (ptr 'struct-string)
+ (setf (foreign-slot-value ptr 'struct-string 's) "Cha")
+ (foreign-slot-value ptr 'struct-string 's))
+ "Cha")
+
+;;;# Structure Alignment Tests
+;;;
+;;; See libtest.c and types.lisp for some comments about alignments.
+
+(defcstruct s-ch
+ (a-char :char))
+
+(defcstruct s-s-ch
+ (another-char :char)
+ (a-s-ch s-ch))
+
+(defcvar "the_s_s_ch" s-s-ch)
+
+(deftest struct.alignment.1
+ (list 'a-char (foreign-slot-value
+ (foreign-slot-value *the-s-s-ch* 's-s-ch 'a-s-ch)
+ 's-ch 'a-char)
+ 'another-char (foreign-slot-value *the-s-s-ch* 's-s-ch 'another-char))
+ (a-char 1 another-char 2))
+
+
+(defcstruct s-short
+ (a-char :char)
+ (another-char :char)
+ (a-short :short))
+
+(defcstruct s-s-short
+ (yet-another-char :char)
+ (a-s-short s-short))
+
+(defcvar "the_s_s_short" s-s-short)
+
+(deftest struct.alignment.2
+ (with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-s-short)
+ (with-foreign-slots ((a-char another-char a-short) a-s-short s-short)
+ (list 'a-char a-char
+ 'another-char another-char
+ 'a-short a-short
+ 'yet-another-char yet-another-char)))
+ (a-char 1 another-char 2 a-short 3 yet-another-char 4))
+
+
+(defcstruct s-double
+ (a-char :char)
+ (a-double :double)
+ (another-char :char))
+
+(defcstruct s-s-double
+ (yet-another-char :char)
+ (a-s-double s-double)
+ (a-short :short))
+
+(defcvar "the_s_s_double" s-s-double)
+
+(deftest struct.alignment.3
+ (with-foreign-slots
+ ((yet-another-char a-s-double a-short) *the-s-s-double* s-s-double)
+ (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
+ (list 'a-char a-char
+ 'a-double a-double
+ 'another-char another-char
+ 'yet-another-char yet-another-char
+ 'a-short a-short)))
+ (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5))
+
+
+(defcstruct s-s-s-double
+ (another-short :short)
+ (a-s-s-double s-s-double)
+ (last-char :char))
+
+(defcvar "the_s_s_s_double" s-s-s-double)
+
+(deftest struct.alignment.4
+ (with-foreign-slots
+ ((another-short a-s-s-double last-char) *the-s-s-s-double* s-s-s-double)
+ (with-foreign-slots
+ ((yet-another-char a-s-double a-short) a-s-s-double s-s-double)
+ (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
+ (list 'a-char a-char
+ 'a-double a-double
+ 'another-char another-char
+ 'yet-another-char yet-another-char
+ 'a-short a-short
+ 'another-short another-short
+ 'last-char last-char))))
+ (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5
+ another-short 6 last-char 7))
+
+
+(defcstruct s-double2
+ (a-double :double)
+ (a-short :short))
+
+(defcstruct s-s-double2
+ (a-char :char)
+ (a-s-double2 s-double2)
+ (another-short :short))
+
+(defcvar "the_s_s_double2" s-s-double2)
+
+(deftest struct.alignment.5
+ (with-foreign-slots
+ ((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double2)
+ (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
+ (list 'a-double a-double
+ 'a-short a-short
+ 'a-char a-char
+ 'another-short another-short)))
+ (a-double 1.0d0 a-short 2 a-char 3 another-short 4))
+
+
+#-cffi-features:no-long-long
+(progn
+ (defcstruct s-long-long
+ (a-long-long :long-long)
+ (a-short :short))
+
+ (defcstruct s-s-long-long
+ (a-char :char)
+ (a-s-long-long s-long-long)
+ (another-short :short))
+
+ (defcvar "the_s_s_long_long" s-s-long-long)
+
+ (deftest struct.alignment.6
+ (with-foreign-slots
+ ((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
+ (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
+ (list 'a-long-long a-long-long
+ 'a-short a-short
+ 'a-char a-char
+ 'another-short another-short)))
+ (a-long-long 1 a-short 2 a-char 3 another-short 4)))
+
+
+(defcstruct s-s-double3
+ (a-s-double2 s-double2)
+ (another-short :short))
+
+(defcstruct s-s-s-double3
+ (a-s-s-double3 s-s-double3)
+ (a-char :char))
+
+(defcvar "the_s_s_s_double3" s-s-s-double3)
+
+(deftest struct.alignment.7
+ (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
+ (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
+ (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
+ (list 'a-double a-double
+ 'a-short a-short
+ 'another-short another-short
+ 'a-char a-char))))
+ (a-double 1.0d0 a-short 2 another-short 3 a-char 4))
+
+
+(defcstruct empty-struct)
+
+(defcstruct with-empty-struct
+ (foo empty-struct)
+ (an-int :int))
+
+;; commented out this test because an empty struct is not valid/standard C
+;; left the struct declarations anyway because they should be handled
+;; gracefuly anyway.
+
+; (defcvar "the_with_empty_struct" with-empty-struct)
+;
+; (deftest struct.alignment.5
+; (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
+; an-int)
+; 42)
+
+
+;; regression test, setf-ing nested foreign-slot-value forms
+;; the setf expander used to return a bogus getter
+
+(defcstruct s1
+ (an-int :int))
+
+(defcstruct s2
+ (an-s1 s1))
+
+(deftest struct.nested-setf
+ (with-foreign-object (an-s2 's2)
+ (setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
+ 's1 'an-int)
+ 1984)
+ (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
+ 's1 'an-int))
+ 1984)
\ No newline at end of file
Added: branches/xml-class-rework/thirdparty/cffi/tests/union.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/tests/union.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/tests/union.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,50 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; union.lisp --- Tests on C unions.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcunion uint32-bytes
+ (int-value :unsigned-int)
+ (bytes :unsigned-char :count 4))
+
+(defun int-to-bytes (n)
+ "Convert N to a list of bytes using a union."
+ (with-foreign-object (obj 'uint32-bytes)
+ (setf (foreign-slot-value obj 'uint32-bytes 'int-value) n)
+ (loop for i from 0 below 4
+ collect (mem-aref
+ (foreign-slot-value obj 'uint32-bytes 'bytes)
+ :unsigned-char i))))
+
+(deftest union.1
+ (let ((bytes (int-to-bytes #x12345678)))
+ (cond ((equal bytes '(#x12 #x34 #x56 #x78))
+ t)
+ ((equal bytes '(#x78 #x56 #x34 #x12))
+ t)
+ (t bytes)))
+ t)
Added: branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp 2006-10-21 16:14:15 UTC (rev 2022)
+++ branches/xml-class-rework/thirdparty/cffi/uffi-compat/uffi-compat.lisp 2006-10-22 15:57:04 UTC (rev 2023)
@@ -0,0 +1,619 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; uffi-compat.lisp --- UFFI compatibility layer for CFFI.
+;;;
+;;; Copyright (C) 2005, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg.
+
+(defpackage #:cffi-uffi-compat
+ (:nicknames #:uffi) ;; is this a good idea?
+ (:use #:cl)
+ (:export
+
+ ;; immediate types
+ #:def-constant
+ #:def-foreign-type
+ #:def-type
+ #:null-char-p
+
+ ;; aggregate types
+ #:def-enum
+ #:def-struct
+ #:get-slot-value
+ #:get-slot-pointer
+ #:def-array-pointer
+ #:deref-array
+ #:def-union
+
+ ;; objects
+ #:allocate-foreign-object
+ #:free-foreign-object
+ #:with-foreign-object
+ #:with-foreign-objects
+ #:size-of-foreign-type
+ #:pointer-address
+ #:deref-pointer
+ #:ensure-char-character
+ #:ensure-char-integer
+ #:ensure-char-storable
+ #:null-pointer-p
+ #:make-null-pointer
+ #:make-pointer
+ #:+null-cstring-pointer+
+ #:char-array-to-pointer
+ #:with-cast-pointer
+ #:def-foreign-var
+ #:convert-from-foreign-usb8
+
+ ;; string functions
+ #:convert-from-cstring
+ #:convert-to-cstring
+ #:free-cstring
+ #:with-cstring
+ #:with-cstrings
+ #:convert-from-foreign-string
+ #:convert-to-foreign-string
+ #:allocate-foreign-string
+ #:with-foreign-string
+ #:with-foreign-strings
+ #:foreign-string-length ; not implemented
+
+ ;; function call
+ #:def-function
+
+ ;; libraries
+ #:find-foreign-library
+ #:load-foreign-library
+ #:default-foreign-library-type
+ #:foreign-library-types
+
+ ;; os
+ #:getenv
+ #:run-shell-command
+ ))
+
+(in-package #:cffi-uffi-compat)
+
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (equal (machine-type) "POWER MACINTOSH")
+ (pushnew :ppc *features*)))
+
+(defun convert-uffi-type (uffi-type)
+ "Convert a UFFI primitive type to a CFFI type."
+ ;; Many CFFI types are the same as UFFI. This list handles the
+ ;; exceptions only.
+ (case uffi-type
+ (:cstring :pointer)
+ (:pointer-void :pointer)
+ (:pointer-self :pointer)
+ (:char '(uffi-char :char))
+ (:unsigned-char '(uffi-char :unsigned-char))
+ (:byte :char)
+ (:unsigned-byte :unsigned-char)
+ (t
+ (if (listp uffi-type)
+ (case (car uffi-type)
+ ;; this is imho gross but it is what uffi does
+ (quote (convert-uffi-type (second uffi-type)))
+ (* :pointer)
+ (:array `(uffi-array ,(convert-uffi-type (second uffi-type))
+ ,(third uffi-type)))
+ (:union (second uffi-type))
+ (:struct (convert-uffi-type (second uffi-type)))
+ (:struct-pointer :pointer))
+ uffi-type))))
+
+(defclass uffi-array-type (cffi::foreign-typedef)
+ ;; ELEMENT-TYPE should be /unparsed/, suitable for passing to mem-aref.
+ ((element-type :initform (error "An element-type is required.")
+ :accessor element-type :initarg :element-type)
+ (nelems :initform (error "nelems is required.")
+ :accessor nelems :initarg :nelems))
+ (:documentation "UFFI's :array type."))
+
+(defmethod initialize-instance :after ((self uffi-array-type) &key)
+ (setf (cffi::actual-type self) (cffi::find-type :pointer)))
+
+(defmethod cffi:foreign-type-size ((type uffi-array-type))
+ (* (cffi:foreign-type-size (element-type type)) (nelems type)))
+
+(defmethod cffi::aggregatep ((type uffi-array-type))
+ t)
+
+(cffi::define-type-spec-parser uffi-array (element-type count)
+ (make-instance 'uffi-array-type :element-type element-type
+ :nelems (or count 1)))
+
+;; UFFI's :(unsigned-)char
+(cffi:define-foreign-type uffi-char (base-type)
+ base-type)
+
+(defmethod cffi:translate-to-foreign ((value character) (name (eql 'uffi-char)))
+ (char-code value))
+
+(defmethod cffi:translate-from-foreign (obj (name (eql 'uffi-char)))
+ (code-char obj))
+
+(defmacro def-type (name type)
+ "Define a Common Lisp type NAME for UFFI type TYPE."
+ (declare (ignore type))
+ `(deftype ,name () t))
+
+(defmacro def-foreign-type (name type)
+ "Define a new foreign type."
+ `(cffi:defctype ,name ,(convert-uffi-type type)))
+
+(defmacro def-constant (name value &key export)
+ "Define a constant and conditionally export it."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,name ,value)
+ ,@(when export `((export ',name)))
+ ',name))
+
+(defmacro null-char-p (val)
+ "Return true if character is null."
+ `(zerop (char-code ,val)))
+
+(defmacro def-enum (enum-name args &key (separator-string "#"))
+ "Creates a constants for a C type enum list, symbols are
+created in the created in the current package. The symbol is the
+concatenation of the enum-name name, separator-string, and
+field-name"
+ (let ((counter 0)
+ (cmds nil)
+ (constants nil))
+ (declare (fixnum counter))
+ (dolist (arg args)
+ (let ((name (if (listp arg) (car arg) arg))
+ (value (if (listp arg)
+ (prog1
+ (setq counter (cadr arg))
+ (incf counter))
+ (prog1
+ counter
+ (incf counter)))))
+ (setq name (intern (concatenate 'string
+ (symbol-name enum-name)
+ separator-string
+ (symbol-name name))))
+ (push `(def-constant ,name ,value) constants)))
+ (setf cmds (append '(progn) `((cffi:defctype ,enum-name :int))
+ (nreverse constants)))
+ cmds))
+
+(defmacro def-struct (name &body fields)
+ "Define a C structure."
+ `(cffi:defcstruct ,name
+ ,@(loop for (name uffi-type) in fields
+ for cffi-type = (convert-uffi-type uffi-type)
+ collect (list name cffi-type))))
+
+;; TODO: figure out why the compiler macro is kicking in before
+;; the setf expander.
+(defun %foreign-slot-value (obj type field)
+ (cffi:foreign-slot-value obj type field))
+
+(defun (setf %foreign-slot-value) (value obj type field)
+ (setf (cffi:foreign-slot-value obj type field) value))
+
+(defmacro get-slot-value (obj type field)
+ "Access a slot value from a structure."
+ `(%foreign-slot-value ,obj ,type ,field))
+
+;; UFFI uses a different function when accessing a slot whose
+;; type is a pointer. We don't need that in CFFI so we use
+;; foreign-slot-value too.
+(defmacro get-slot-pointer (obj type field)
+ "Access a pointer slot value from a structure."
+ `(cffi:foreign-slot-value ,obj ,type ,field))
+
+(defmacro def-array-pointer (name type)
+ "Define a foreign array type."
+ `(cffi:defctype ,name (uffi-array ,(convert-uffi-type type))))
+
+(defmacro deref-array (array type position)
+ "Dereference an array."
+ `(cffi:mem-aref ,array
+ ,(if (constantp type)
+ `',(element-type (cffi::parse-type
+ (convert-uffi-type (eval type))))
+ `(element-type (cffi::parse-type
+ (convert-uffi-type ,type))))
+ ,position))
+
+;; UFFI's documentation on DEF-UNION is a bit scarce, I'm not sure
+;; if DEFCUNION and DEF-UNION are strictly compatible.
+(defmacro def-union (name &body fields)
+ "Define a foreign union type."
+ `(cffi:defcunion ,name
+ ,@(loop for (name uffi-type) in fields
+ for cffi-type = (convert-uffi-type uffi-type)
+ collect (list name cffi-type))))
+
+(defmacro allocate-foreign-object (type &optional (size 1))
+ "Allocate one or more instance of a foreign type."
+ `(cffi:foreign-alloc ,(if (constantp type)
+ `',(convert-uffi-type (eval type))
+ `(convert-uffi-type ,type))
+ :count ,size))
+
+(defmacro free-foreign-object (ptr)
+ "Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT."
+ `(cffi:foreign-free ,ptr))
+
+(defmacro with-foreign-object ((var type) &body body)
+ "Wrap the allocation of a foreign object around BODY."
+ `(cffi:with-foreign-object (,var (convert-uffi-type ,type))
+ ,@body))
+
+;; Taken from UFFI's src/objects.lisp
+(defmacro with-foreign-objects (bindings &rest body)
+ (if bindings
+ `(with-foreign-object ,(car bindings)
+ (with-foreign-objects ,(cdr bindings)
+ ,@body))
+ `(progn ,@body)))
+
+(defmacro size-of-foreign-type (type)
+ "Return the size in bytes of a foreign type."
+ `(cffi:foreign-type-size (convert-uffi-type ,type)))
+
+(defmacro pointer-address (ptr)
+ "Return the address of a pointer."
+ `(cffi:pointer-address ,ptr))
+
+;; Hmm, we need to translate chars, so translations are necessary here.
+(defun %deref-pointer (ptr type)
+ (cffi::translate-type-from-foreign (cffi:mem-ref ptr type) (cffi::parse-type type)))
+
+(defun (setf %deref-pointer) (value ptr type)
+ (setf (cffi:mem-ref ptr type)
+ (cffi::translate-type-to-foreign value (cffi::parse-type type))))
+
+(defmacro deref-pointer (ptr type)
+ "Dereference a pointer."
+ `(%deref-pointer ,ptr (convert-uffi-type ,type)))
+
+(defmacro ensure-char-character (obj &environment env)
+ "Convert OBJ to a character if it is an integer."
+ (if (constantp obj env)
+ (if (characterp obj) obj (code-char obj))
+ (let ((obj-var (gensym)))
+ `(let ((,obj-var ,obj))
+ (if (characterp ,obj-var)
+ ,obj-var
+ (code-char ,obj-var))))))
+
+(defmacro ensure-char-integer (obj &environment env)
+ "Convert OBJ to an integer if it is a character."
+ (if (constantp obj env)
+ (let ((the-obj (eval obj)))
+ (if (characterp the-obj) (char-code the-obj) the-obj))
+ (let ((obj-var (gensym)))
+ `(let ((,obj-var ,obj))
+ (if (characterp ,obj-var)
+ (char-code ,obj-var)
+ ,obj-var)))))
+
+(defmacro ensure-char-storable (obj)
+ "Ensure OBJ is storable as a character."
+ `(ensure-char-integer ,obj))
+
+(defmacro make-null-pointer (type)
+ "Create a NULL pointer."
+ (declare (ignore type))
+ `(cffi:null-pointer))
+
+(defmacro make-pointer (address type)
+ "Create a pointer to ADDRESS."
+ (declare (ignore type))
+ `(cffi:make-pointer ,address))
+
+(defmacro null-pointer-p (ptr)
+ "Return true if PTR is a null pointer."
+ `(cffi:null-pointer-p ,ptr))
+
+(defparameter +null-cstring-pointer+ (cffi:null-pointer)
+ "A constant NULL string pointer.")
+
+(defmacro char-array-to-pointer (obj)
+ obj)
+
+(defmacro with-cast-pointer ((var ptr type) &body body)
+ "Cast a pointer, does nothing in CFFI."
+ (declare (ignore type))
+ `(let ((,var ,ptr))
+ ,@body))
+
+(defmacro def-foreign-var (name type module)
+ "Define a symbol macro to access a foreign variable."
+ (declare (ignore module))
+ (flet ((lisp-name (name)
+ (intern (cffi-sys:canonicalize-symbol-name-case
+ (substitute #\- #\_ name)))))
+ `(cffi:defcvar ,(if (listp name)
+ name
+ (list name (lisp-name name)))
+ ,(convert-uffi-type type))))
+
+(defmacro convert-from-cstring (s)
+ "Convert a cstring to a Lisp string."
+ (let ((ret (gensym)))
+ `(let ((,ret (cffi:foreign-string-to-lisp ,s)))
+ (if (equal ,ret "")
+ nil
+ ,ret))))
+
+(defmacro convert-to-cstring (obj)
+ "Convert a Lisp string to a cstring."
+ (let ((str (gensym)))
+ `(let ((,str ,obj))
+ (if (null ,str)
+ (cffi:null-pointer)
+ (cffi:foreign-string-alloc ,str)))))
+
+(defmacro free-cstring (ptr)
+ "Free a cstring."
+ `(cffi:foreign-string-free ,ptr))
+
+(defmacro with-cstring ((foreign-string lisp-string) &body body)
+ "Binds a newly creating string."
+ (let ((str (gensym)))
+ `(let ((,str ,lisp-string))
+ (if (null ,str)
+ (let ((,foreign-string (cffi:null-pointer)))
+ ,@body)
+ (cffi:with-foreign-string (,foreign-string ,str)
+ ,@body)))))
+
+;; Taken from UFFI's src/strings.lisp
+(defmacro with-cstrings (bindings &rest body)
+ (if bindings
+ `(with-cstring ,(car bindings)
+ (with-cstrings ,(cdr bindings)
+ ,@body))
+ `(progn ,@body)))
+
+(defmacro def-function (name args &key module (returning :void))
+ "Define a foreign function."
+ (declare (ignore module))
+ `(cffi:defcfun ,name ,(convert-uffi-type returning)
+ ,@(loop for (name type) in args
+ collect `(,name ,(convert-uffi-type type)))))
+
+;;; Taken from UFFI's src/libraries.lisp
+
+(defvar *loaded-libraries* nil
+ "List of foreign libraries loaded. Used to prevent reloading a library")
+
+(defun default-foreign-library-type ()
+ "Returns string naming default library type for platform"
+ #+(or win32 mswindows) "dll"
+ #+(or macos macosx darwin ccl-5.0) "dylib"
+ #-(or win32 mswindows macos macosx darwin ccl-5.0) "so")
+
+(defun foreign-library-types ()
+ "Returns list of string naming possible library types for platform,
+sorted by preference"
+ #+(or win32 mswindows) '("dll" "lib")
+ #+(or macos macosx darwin ccl-5.0) '("dylib" "bundle")
+ #-(or win32 mswindows macos macosx darwin ccl-5.0) '("so" "a" "o"))
+
+(defun find-foreign-library (names directories &key types drive-letters)
+ "Looks for a foreign library. directories can be a single
+string or a list of strings of candidate directories. Use default
+library type if type is not specified."
+ (unless types
+ (setq types (foreign-library-types)))
+ (unless (listp types)
+ (setq types (list types)))
+ (unless (listp names)
+ (setq names (list names)))
+ (unless (listp directories)
+ (setq directories (list directories)))
+ #+(or win32 mswindows)
+ (unless (listp drive-letters)
+ (setq drive-letters (list drive-letters)))
+ #-(or win32 mswindows)
+ (setq drive-letters '(nil))
+ (dolist (drive-letter drive-letters)
+ (dolist (name names)
+ (dolist (dir directories)
+ (dolist (type types)
+ (let ((path (make-pathname
+ #+lispworks :host
+ #+lispworks (when drive-letter drive-letter)
+ #-lispworks :device
+ #-lispworks (when drive-letter drive-letter)
+ :name name
+ :type type
+ :directory
+ (etypecase dir
+ (pathname
+ (pathname-directory dir))
+ (list
+ dir)
+ (string
+ (pathname-directory
+ (parse-namestring dir)))))))
+ (when (probe-file path)
+ (return-from find-foreign-library path)))))))
+ nil)
+
+(defun convert-supporting-libraries-to-string (libs)
+ (let (lib-load-list)
+ (dolist (lib libs)
+ (push (format nil "-l~A" lib) lib-load-list))
+ (nreverse lib-load-list)))
+
+(defun load-foreign-library (filename &key module supporting-libraries
+ force-load)
+ #+(or allegro mcl sbcl clisp) (declare (ignore module supporting-libraries))
+ #+(or cmu scl sbcl) (declare (ignore module))
+
+ (when (and filename (probe-file filename))
+ (if (pathnamep filename) ;; ensure filename is a string to check if
+ (setq filename (namestring filename))) ; already loaded
+
+ (if (and (not force-load)
+ (find filename *loaded-libraries* :test #'string-equal))
+ t ;; return T, but don't reload library
+ (progn
+ #+cmu
+ (let ((type (pathname-type (parse-namestring filename))))
+ (if (string-equal type "so")
+ (sys::load-object-file filename)
+ (alien:load-foreign filename
+ :libraries
+ (convert-supporting-libraries-to-string
+ supporting-libraries))))
+ #+scl
+ (let ((type (pathname-type (parse-namestring filename))))
+ (if (string-equal type "so")
+ (sys::load-dynamic-object filename)
+ (alien:load-foreign filename
+ :libraries
+ (convert-supporting-libraries-to-string
+ supporting-libraries))))
+
+ #-cmu
+ (cffi:load-foreign-library filename)
+
+ (push filename *loaded-libraries*)
+ t))))
+
+;; Taken from UFFI's src/os.lisp
+(defun getenv (var)
+ "Return the value of the environment variable."
+ #+allegro (sys::getenv (string var))
+ #+clisp (sys::getenv (string var))
+ #+(or cmu scl) (cdr (assoc (string var) ext:*environment-list* :test #'equalp
+ :key #'string))
+ #+gcl (si:getenv (string var))
+ #+lispworks (lw:environment-variable (string var))
+ #+lucid (lcl:environment-variable (string var))
+ #+mcl (ccl::getenv var)
+ #+sbcl (sb-ext:posix-getenv var)
+ #-(or allegro clisp cmu scl gcl lispworks lucid mcl sbcl)
+ (error 'not-implemented :proc (list 'getenv var)))
+
+;; Taken from UFFI's src/os.lisp
+;; modified from function ASDF -- Copyright Dan Barlow and Contributors
+(defun run-shell-command (control-string &rest args &key output)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *trace-output*. Returns the shell's exit code."
+ (unless output
+ (setq output *trace-output*))
+
+ (let ((command (apply #'format nil control-string args)))
+ #+sbcl
+ (sb-impl::process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output output))
+
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output output))
+
+ #+allegro
+ (excl:run-shell-command command :input nil :output output)
+
+ #+lispworks
+ (system:call-system-showing-output
+ command
+ :shell-type "/bin/sh"
+ :output-stream output)
+
+ #+clisp ;XXX not exactly *trace-output*, I know
+ (ext:run-shell-command command :output :terminal :wait t)
+
+ #+openmcl
+ (nth-value 1
+ (ccl:external-process-status
+ (ccl:run-program "/bin/sh" (list "-c" command)
+ :input nil :output output
+ :wait t)))
+
+ #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+ (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+ ))
+
+;;; Some undocumented UFFI operators...
+
+(defmacro convert-from-foreign-string (obj &key (length most-positive-fixnum)
+ (locale :default)
+ (null-terminated-p t))
+ (declare (ignore locale))
+ (let ((ret (gensym)))
+ `(let ((,ret (cffi:foreign-string-to-lisp ,obj ,length ,null-terminated-p)))
+ (if (equal ,ret "")
+ nil
+ ,ret))))
+
+;; What's the difference between this and convert-to-cstring?
+(defmacro convert-to-foreign-string (obj)
+ (let ((str (gensym)))
+ `(let ((,str ,obj))
+ (if (null ,str)
+ (cffi:null-pointer)
+ (cffi:foreign-string-alloc ,str)))))
+
+(defmacro allocate-foreign-string (size &key unsigned)
+ (declare (ignore unsigned))
+ `(cffi:foreign-alloc :char :count ,size))
+
+;; Ditto.
+(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
+ (let ((str (gensym)))
+ `(let ((,str ,lisp-string))
+ (if (null ,str)
+ (let ((,foreign-string (cffi:null-pointer)))
+ ,@body)
+ (cffi:with-foreign-string (,foreign-string ,str)
+ ,@body)))))
+
+(defmacro with-foreign-strings (bindings &body body)
+ `(with-foreign-string ,(car bindings)
+ ,@(if (cdr bindings)
+ `((with-foreign-strings ,(cdr bindings) ,@body))
+ body)))
+
+;; This function returns a form? Where is this used in user-code?
+(defun foreign-string-length (foreign-string)
+ (declare (ignore foreign-string))
+ (error "FOREIGN-STRING-LENGTH not implemented."))
+
+;; This should be optimized.
+(defun convert-from-foreign-usb8 (s len)
+ (let ((a (make-array len :element-type '(unsigned-byte 8))))
+ (dotimes (i len a)
+ (setf (aref a i) (cffi:mem-ref s :unsigned-char i)))))
1
0
21 Oct '06
Author: hhubner
Date: 2006-10-21 12:14:15 -0400 (Sat, 21 Oct 2006)
New Revision: 2022
Modified:
branches/xml-class-rework/thirdparty/iconv/iconv.lisp
Log:
FreeBSD fixes
Add string mode to convert strings directly
Create output buffer with correct size (after conversion)
Modified: branches/xml-class-rework/thirdparty/iconv/iconv.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/iconv/iconv.lisp 2006-10-21 15:32:24 UTC (rev 2021)
+++ branches/xml-class-rework/thirdparty/iconv/iconv.lisp 2006-10-21 16:14:15 UTC (rev 2022)
@@ -19,7 +19,7 @@
(sb-alien:get-errno)
)
-(uffi:def-constant EILSEQ 84) ;invalid multibyte
+(uffi:def-constant EILSEQ #+freebsd 86 #-freebsd 84) ;invalid multibyte
(uffi:def-constant EINVAL 22) ;imcomplete multibyte
(uffi:def-constant E2BIG 7) ;not enough outbuf
@@ -53,19 +53,15 @@
(defun iconv (from-code to-code from-vector
&optional error-p (error-value #.(char-code #\?)))
- (declare (type (vector (unsigned-byte 8)) from-vector))
(with-iconv-cd (cd from-code to-code)
(let* ((from-len (length from-vector))
(to-len (* from-len 2))
- (out (make-array to-len
- :element-type '(unsigned-byte 8)
- :fill-pointer 0
- :adjustable t))
(remain (make-array 3
:element-type '(unsigned-byte 8)
:fill-pointer 0
:adjustable t))
- (inbuffer (uffi:allocate-foreign-string from-len :unsigned t))
+ (string-mode (characterp (aref from-vector 0)))
+ inbuffer
(outbuffer (uffi:allocate-foreign-string to-len :unsigned t))
(in-ptr (uffi:allocate-foreign-object 'char-ptr))
(out-ptr (uffi:allocate-foreign-object 'char-ptr))
@@ -73,46 +69,52 @@
(outbytesleft (uffi:allocate-foreign-object :unsigned-int)))
(unwind-protect
(progn
- (loop for i from 0 below from-len
- do (setf (uffi:deref-array inbuffer :unsigned-char i)
- (aref from-vector i)))
+ (if string-mode
+ (setf inbuffer (uffi:convert-to-foreign-string from-vector))
+ (progn
+ (setf inbuffer (uffi:allocate-foreign-string from-len :unsigned t))
+ (loop for i from 0 below from-len
+ do (setf (uffi:deref-array inbuffer :unsigned-char i)
+ (aref from-vector i)))))
(setf (uffi:deref-pointer in-ptr 'char-ptr) inbuffer
(uffi:deref-pointer out-ptr 'char-ptr) outbuffer
(uffi:deref-pointer inbytesleft :unsigned-int) from-len
(uffi:deref-pointer outbytesleft :unsigned-int) to-len)
- (labels ((current ()
- (- from-len (uffi:deref-pointer
- inbytesleft :unsigned-int)))
- (self ()
- (when (= (%iconv cd
- in-ptr inbytesleft
- out-ptr outbytesleft)
- #xffffffff)
- (if (= (get-errno) EILSEQ)
- (if error-p
- (error "invalid multibyte(~X)."
- (uffi:deref-array
- inbuffer :unsigned-byte (current)))
- (progn
- (setf (uffi:deref-array
- inbuffer :unsigned-byte (current))
- error-value)
- (self)))
- (loop for i from (current)
- below from-len
- do (vector-push-extend
- (aref from-vector i) remain))))))
+ (labels
+ ((current ()
+ (- from-len (uffi:deref-pointer
+ inbytesleft :unsigned-int)))
+ (self ()
+ (when (= (%iconv cd
+ in-ptr inbytesleft
+ out-ptr outbytesleft)
+ #xffffffff)
+ (if (= (get-errno) EILSEQ)
+ (if error-p
+ (error "invalid multibyte(~X)."
+ (uffi:deref-array
+ inbuffer :unsigned-byte (current)))
+ (progn
+ (setf (uffi:deref-array
+ inbuffer :unsigned-byte (current))
+ error-value)
+ (self)))
+ (loop for i from (current)
+ below from-len
+ do (vector-push-extend
+ (aref from-vector i) remain))))))
(self))
- (loop for i from 0
- below (- to-len
- (uffi:deref-pointer outbytesleft :unsigned-int))
- do (vector-push-extend
- (uffi:deref-array outbuffer :unsigned-byte i)
- out)))
+ (let* ((out-length (- to-len (uffi:deref-pointer outbytesleft :unsigned-int)))
+ (out (make-array out-length
+ :element-type (array-element-type from-vector))))
+ (dotimes (i out-length)
+ (setf (aref out i) (if string-mode
+ (code-char (uffi:deref-array outbuffer :unsigned-byte i))
+ (uffi:deref-array outbuffer :unsigned-byte i))))
+ (values out remain)))
(progn (uffi:free-foreign-object outbytesleft)
(uffi:free-foreign-object inbytesleft)
(uffi:free-foreign-object out-ptr)
(uffi:free-foreign-object in-ptr)
(uffi:free-foreign-object outbuffer)
- (uffi:free-foreign-object inbuffer)))
- (values out remain))))
+ (uffi:free-foreign-object inbuffer))))))
1
0
21 Oct '06
Author: hhubner
Date: 2006-10-21 11:32:24 -0400 (Sat, 21 Oct 2006)
New Revision: 2021
Modified:
branches/xml-class-rework/thirdparty/iconv/iconv.lisp
Log:
Fix memory leak, make it run with current UFFI.
Modified: branches/xml-class-rework/thirdparty/iconv/iconv.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/iconv/iconv.lisp 2006-10-21 13:34:15 UTC (rev 2020)
+++ branches/xml-class-rework/thirdparty/iconv/iconv.lisp 2006-10-21 15:32:24 UTC (rev 2021)
@@ -23,23 +23,24 @@
(uffi:def-constant EINVAL 22) ;imcomplete multibyte
(uffi:def-constant E2BIG 7) ;not enough outbuf
-(uffi:def-foreign-type iconv-t '(* :void))
+(uffi:def-foreign-type char-ptr (* :unsigned-char))
+(uffi:def-foreign-type iconv-t :pointer-void)
(uffi:def-function ("iconv_open" iconv-open)
((tocode :cstring)
(fromcode :cstring))
- :returning iconv-t)
+ :returning 'iconv-t)
(uffi:def-function ("iconv_close" iconv-close)
- ((cd iconv-t))
+ ((cd 'iconv-t))
:returning :int)
(uffi:def-function ("iconv" %iconv)
- ((cd iconv-t)
- (inbuf (* :unsigned-long))
- (inbytesleft (* :unsigned-int))
- (outbuf (* :unsigned-long))
- (outbytesleft (* :unsigned-int)))
+ ((cd 'iconv-t)
+ (inbuf (* char-ptr))
+ (inbytesleft (* :unsigned-long))
+ (outbuf (* char-ptr))
+ (outbytesleft (* :unsigned-long)))
:returning :unsigned-int)
(defmacro with-iconv-cd ((cd from to) &body body)
@@ -64,30 +65,29 @@
:element-type '(unsigned-byte 8)
:fill-pointer 0
:adjustable t))
- (inbuffer (uffi:allocate-foreign-object :unsigned-byte from-len))
- (outbuffer (uffi:allocate-foreign-object :unsigned-byte to-len))
- (in-ptr (uffi:allocate-foreign-object :unsigned-long))
- (out-ptr (uffi:allocate-foreign-object :unsigned-long))
+ (inbuffer (uffi:allocate-foreign-string from-len :unsigned t))
+ (outbuffer (uffi:allocate-foreign-string to-len :unsigned t))
+ (in-ptr (uffi:allocate-foreign-object 'char-ptr))
+ (out-ptr (uffi:allocate-foreign-object 'char-ptr))
(inbytesleft (uffi:allocate-foreign-object :unsigned-int))
(outbytesleft (uffi:allocate-foreign-object :unsigned-int)))
(unwind-protect
(progn
(loop for i from 0 below from-len
- do (setf (uffi:deref-array inbuffer :unsigned-byte i)
+ do (setf (uffi:deref-array inbuffer :unsigned-char i)
(aref from-vector i)))
- (setf (uffi:deref-pointer in-ptr :unsigned-long)
- (uffi:pointer-address inbuffer)
- (uffi:deref-pointer out-ptr :unsigned-long)
- (uffi:pointer-address outbuffer)
+ (setf (uffi:deref-pointer in-ptr 'char-ptr) inbuffer
+ (uffi:deref-pointer out-ptr 'char-ptr) outbuffer
(uffi:deref-pointer inbytesleft :unsigned-int) from-len
(uffi:deref-pointer outbytesleft :unsigned-int) to-len)
(labels ((current ()
(- from-len (uffi:deref-pointer
inbytesleft :unsigned-int)))
(self ()
- (if (= (%iconv cd in-ptr inbytesleft out-ptr
- outbytesleft)
- #xffffffff)
+ (when (= (%iconv cd
+ in-ptr inbytesleft
+ out-ptr outbytesleft)
+ #xffffffff)
(if (= (get-errno) EILSEQ)
(if error-p
(error "invalid multibyte(~X)."
@@ -99,9 +99,9 @@
error-value)
(self)))
(loop for i from (current)
- below from-len
- do (vector-push-extend
- (aref from-vector i) remain))))))
+ below from-len
+ do (vector-push-extend
+ (aref from-vector i) remain))))))
(self))
(loop for i from 0
below (- to-len
@@ -111,6 +111,8 @@
out)))
(progn (uffi:free-foreign-object outbytesleft)
(uffi:free-foreign-object inbytesleft)
+ (uffi:free-foreign-object out-ptr)
+ (uffi:free-foreign-object in-ptr)
(uffi:free-foreign-object outbuffer)
(uffi:free-foreign-object inbuffer)))
(values out remain))))
1
0
21 Oct '06
Author: hhubner
Date: 2006-10-21 09:34:15 -0400 (Sat, 21 Oct 2006)
New Revision: 2020
Modified:
branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp
branches/xml-class-rework/thirdparty/cl-mime/package.lisp
Log:
fix quoted-printable encoding (did not work)
use cl-base64 instead of base64
Modified: branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp 2006-10-21 13:33:42 UTC (rev 2019)
+++ branches/xml-class-rework/thirdparty/cl-mime/encoding.lisp 2006-10-21 13:34:15 UTC (rev 2020)
@@ -35,7 +35,7 @@
(string (string-to-base64-string content :columns 75))
((array (unsigned-byte 8))
(usb8-array-to-base64-string content :columns 75))))
- (:quoted-printable (qprint:encode content 75))))))
+ (:quoted-printable (qprint:encode content))))))
(defun decode-content (mime)
Modified: branches/xml-class-rework/thirdparty/cl-mime/package.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-mime/package.lisp 2006-10-21 13:33:42 UTC (rev 2019)
+++ branches/xml-class-rework/thirdparty/cl-mime/package.lisp 2006-10-21 13:34:15 UTC (rev 2020)
@@ -24,7 +24,7 @@
(:documentation "A package for constructing MIME objects for printing and
parsing MIME formatted strings or streams.")
(:nicknames :mime)
- (:use :cl :cl-ppcre :base64)
+ (:use :cl :cl-ppcre :cl-base64)
(:export :text-mime
:multipart-mime
:mime
1
0
21 Oct '06
Author: hhubner
Date: 2006-10-21 09:33:42 -0400 (Sat, 21 Oct 2006)
New Revision: 2019
Modified:
branches/xml-class-rework/thirdparty/cl-qprint/base.lisp
Log:
Optionally encode newlines
Modified: branches/xml-class-rework/thirdparty/cl-qprint/base.lisp
===================================================================
--- branches/xml-class-rework/thirdparty/cl-qprint/base.lisp 2006-10-21 13:33:20 UTC (rev 2018)
+++ branches/xml-class-rework/thirdparty/cl-qprint/base.lisp 2006-10-21 13:33:42 UTC (rev 2019)
@@ -68,7 +68,7 @@
(princ #\linefeed stream))
-(defun encode (input)
+(defun encode (input &key encode-newlines)
"INPUT must be either a string or a stream. Reads from INPUT and produces
a quoted-printable encoded string"
(let ((out-stream (make-string-output-stream))
@@ -101,7 +101,9 @@
;; Ensure newlines are CR-LF
((char= c #\newline)
- (cr-lf out-stream)
+ (if encode-newlines
+ (format out-stream "=0A=0D")
+ (cr-lf out-stream))
(setf last-line-break position))
;; Keep track of whitespace in case of following newlines
1
0