+ (defun %find-types-in-library (pathname prefixes ignore)
+ (let ((outname (tmpname "types")))
+ (unwind-protect
+ (let ((asdf::*verbose-out* nil))
+ #-win32
+ (asdf:run-shell-command "nm ~A ~A > ~A"
+ #-darwin "--defined-only --dynamic --extern-only"
+ #+darwin "-f -s __TEXT __text"
+ (namestring (truename pathname)) outname)
+ ;; Note about win32 port:
+ ;; 1. (TRUENAME PATHNAME) will bomb.
+ ;; 2. either
+ ;; pexports "d:\\whatever\\bin\\zlib1.dll"
+ ;; or
+ ;; pexports d:/whatever/bin/zlib1.dll
+ ;; anything else will bomb. this is why ~S is used below.
+ #+win32
+ (asdf:run-shell-command "pexports ~S > ~A"
+ (namestring pathname) outname)
+
+ (with-open-file (output outname)
+ (loop
+ as line = (read-line output nil)
+ as symbol = (when line
+ #-win32
+ (let ((pos (position #\space line :from-end t)))
+ #-darwin(subseq line (1+ pos))
+ #+darwin
+ (when (char= (char line (1- pos)) #\T)
+ (subseq line (+ pos 2))))
+ #+win32
+ (subseq line 0 (1- (length line))))
+ while line
+ when (and
+ symbol (> (length symbol) 9)
+ (not (char= (char symbol 0) #\_))
+ (or
+ (not prefixes)
+ (some #'(lambda (prefix)
+ (and
+ (> (length symbol) (length prefix))
+ (string= prefix symbol :end2 (length prefix))))
+ (mklist prefixes)))
+ (string= "_get_type" symbol :start2 (- (length symbol) 9))
+ (not (member symbol ignore :test #'string=)))
+ collect symbol)))
+ (delete-file outname)))))
+
+
+(defun car-eq-p (ob1 ob2)
+ (eq (car ob1) (car ob2)))
+
+(defmacro init-types-in-library (system library &key prefix ignore)
+ (let* ((filename (library-filename system library))
+ (names (%find-types-in-library filename prefix ignore)))
+ `(progn
+ ,@(mapcar
+ #'(lambda (name)
+ `(progn
+ (defbinding (,(intern name) ,name) () type-number)
+ (,(intern name))
+ (pushnew (cons ',(intern name) ,filename) *type-initializers*
+ :test #'car-eq-p)))
+ names))))
+
+(defun find-type-init-function (type-number)
+ (loop
+ for (type-init) in *type-initializers*
+ when (= type-number (funcall type-init))
+ do (return type-init)))
+
+(defun register-type-as (type-number)
+ (or
+ (find-type-init-function type-number)
+ (find-foreign-type-name type-number)
+ (error "Unknown type-number: ~A" type-number)))
+
+(defun default-type-init-name (type)
+ (find-symbol (format nil "~A_~A_get_type"
+ (package-prefix *package*)
+ (substitute #\_ #\- (string-downcase type)))))