home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / lib / X11 / clx-patch.lisp next >
Encoding:
Text File  |  1994-09-27  |  2.1 KB  |  40 lines  |  [TEXT/CCL2]
  1. (lisp:in-package 'xlib)
  2. (defmacro generate-lookup-functions (useless-name &body types)
  3.             `(within-definition (,useless-name generate-lookup-functions)
  4.                ,@(mapcar
  5.                    #'(lambda (type)
  6.                        `(defun ,(xintern 'lookup- type)
  7.                                (display id)
  8.                           (declare (type display display)
  9.                                    (type resource-id id))
  10.                           (declare (values ,type))
  11.                           ,(if (member type *clx-cached-types*)
  12.                                `(let ((,type (lookup-resource-id display id)))
  13.                                   (cond ((null ,type) ;; Not found, create and s
  14. ave it.
  15.                                          (setq ,type (,(xintern 'make- type)
  16.                                                       :display display :id id))
  17.                                          (save-id display id ,type))
  18.                                         ;; Found.  Check the type
  19.                                         ,(cond ((null '()) ;*type-check?*)
  20.                                                 `(t ,type))
  21.                                                ((member type '(window pixmap))
  22.                                                 `((type? ,type 'drawable) ,type)
  23. )
  24.                                                (t `((type? ,type ',type) ,type))
  25. )
  26.                                         ,@(when '() ;*type-check?*
  27.                                             `((t (x-error 'lookup-error
  28.                                                           :id id
  29.                                                           :display display
  30.                                                           :type ',type
  31.                                                           :object ,type))))))
  32.                                ;; Not being cached.  Create a new one each time.
  33.                                `(,(xintern 'make- type)
  34.                                  :display display :id id))))
  35.                    types)))
  36. (macroexpand 
  37.   (generate-lookup-functions ignore
  38.     window))
  39.  
  40.