From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 progs/lib/X11/clx-patch.lisp | 39 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 39 insertions(+)
 create mode 100644 progs/lib/X11/clx-patch.lisp

(limited to 'progs/lib/X11/clx-patch.lisp')

diff --git a/progs/lib/X11/clx-patch.lisp b/progs/lib/X11/clx-patch.lisp
new file mode 100644
index 0000000..fe2a5e3
--- /dev/null
+++ b/progs/lib/X11/clx-patch.lisp
@@ -0,0 +1,39 @@
+(lisp:in-package 'xlib)
+(defmacro generate-lookup-functions (useless-name &body types)
+            `(within-definition (,useless-name generate-lookup-functions)
+               ,@(mapcar
+                   #'(lambda (type)
+                       `(defun ,(xintern 'lookup- type)
+                               (display id)
+                          (declare (type display display)
+                                   (type resource-id id))
+                          (declare (values ,type))
+                          ,(if (member type *clx-cached-types*)
+                               `(let ((,type (lookup-resource-id display id)))
+                                  (cond ((null ,type) ;; Not found, create and s
+ave it.
+                                         (setq ,type (,(xintern 'make- type)
+                                                      :display display :id id))
+                                         (save-id display id ,type))
+                                        ;; Found.  Check the type
+                                        ,(cond ((null '()) ;*type-check?*)
+                                                `(t ,type))
+                                               ((member type '(window pixmap))
+                                                `((type? ,type 'drawable) ,type)
+)
+                                               (t `((type? ,type ',type) ,type))
+)
+                                        ,@(when '() ;*type-check?*
+                                            `((t (x-error 'lookup-error
+                                                          :id id
+                                                          :display display
+                                                          :type ',type
+                                                          :object ,type))))))
+                               ;; Not being cached.  Create a new one each time.
+                               `(,(xintern 'make- type)
+                                 :display display :id id))))
+                   types)))
+(macroexpand 
+  (generate-lookup-functions ignore
+    window))
+
-- 
cgit v1.2.3