home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Environments / AllegroCL11 / Library / object-extensions.lisp < prev    next >
Encoding:
Text File  |  1987-10-27  |  7.5 KB  |  241 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;Object-extensions.lisp
  3. ;;
  4. ;;  Copyright © Coral Software Corporation, 1986, 1987 All rights reserved.
  5. ;;
  6. ;;  this file provides extensions to the basic Object Lisp system.
  7.  
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10. ;;ask-funcall
  11. ;;
  12. ;; ask-funcall is a modified version of ask.
  13. ;; it takes as arguments an object, a function, and arguments to the function
  14. ;; the arguments are eval’ed in the calling object, and then passed
  15. ;; to the function in the called object.
  16. ;;
  17. ;;  ask-funcall is useful when a function is defined in one object
  18. ;;  but the arguments to the function are found in another object
  19. ;;
  20. ;;for example:
  21. ;; 
  22. ;;(defobject foo)
  23. ;;(ask foo (have 'num 1))
  24. ;;(defobject bar)
  25. ;;(ask bar (have 'num 2))
  26. ;;(defobfun (double bar) (n) (+ n n))
  27. ;;(ask foo (double num))   ==>>  error, double not defined
  28. ;;(ask bar (double num))  ==>>  error, num not bound
  29. ;;(ask foo (ask bar (double num))) ==>> error, num not bound
  30. ;;(ask foo (ask-funcall bar double num)) ==>>  2
  31.  
  32.  
  33. (defmacro ask-funcall (object symbol &rest args 
  34.                               &aux 
  35.                               gensyms 
  36.                               letlist
  37.                               g)
  38.   (dolist (arg args)
  39.     (setq g (gensym))
  40.     (push g gensyms)
  41.     (push (list g arg) letlist))
  42.   `(let ,(nreverse letlist)
  43.      (ask ,object (,symbol ,@(nreverse gensyms)))))
  44.  
  45.  
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48. ;;mapc-ask
  49. ;;
  50. ;;  mapc-ask asks each object in a list to evaluate a set of forms.
  51. ;;  It returns the list of objects which it was passed
  52. ;;
  53. ;;for example
  54. ;;
  55. ;;(mapc-ask (windows) (print (window-title)) (ed-beep))
  56. ;;
  57. ;;will ask of the windows to print its title and beep.
  58. ;;
  59.  
  60.  
  61. (defmacro mapc-ask (objlist-form &rest forms)
  62.   (let ((objects (gensym))
  63.         (obj (gensym)))
  64.   `(let ((,objects ,objlist-form))
  65.         (dolist (,obj ,objects ,objects)
  66.                 (ask ,obj ,@forms)))))
  67.  
  68.  
  69.  
  70. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72. ;;mapcar-ask
  73. ;;
  74. ;;  mapcar-ask is the same as mapc-ask except that it returns a list
  75. ;;  of the values returned by each ask.
  76. ;;
  77. ;;for example
  78. ;;
  79. ;;(mapcar-ask (windows) (window-title))
  80. ;;
  81. ;;returns a list of the titles of each of the open windows
  82. ;;
  83.  
  84.  
  85. (defmacro mapcar-ask (objlist-form &rest forms)
  86.   (let ((objects (gensym))
  87.         (results (gensym))
  88.         (obj (gensym)))
  89.   `(let ((,objects ,objlist-form)
  90.          (,results nil))
  91.      (dolist (,obj ,objects (nreverse ,results))
  92.        (push (ask ,obj ,@forms) ,results)))))
  93.  
  94.  
  95.  
  96. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98. ;;class-objectp
  99. ;;
  100. ;;  class-objectp returns t if its argument appears to be set up as
  101. ;;  a class.  This will generally be the case if the object was
  102. ;;  defined with defobject.
  103. ;;
  104. ;;  Specifically, the argument must pass the following tests:
  105. ;;
  106. ;;    the argument is an object
  107. ;;    it has an instance variable 'object-name
  108. ;;    this instance variable is a symbol
  109. ;;    and the symbol is bound globally to the object
  110. ;;
  111. ;;  If no argument is given, the current object is used.
  112. ;;
  113. ;;for example
  114. ;;
  115. ;;(class-objectp *window*)  ===>>  t
  116. ;;(defobject foo)
  117. ;;(class-objectp foo)   ===>> t
  118. ;;(ask foo (class-objectp))   ===>> t
  119. ;;(setq bar (kindof))
  120. ;;(class-objectp bar)  ===>> nil
  121. ;;
  122.  
  123.  
  124. (defun class-objectp (&optional (obj (self)))
  125.   (declare (object-variable object-name))
  126.    (if (objectp obj)
  127.        (or (eq obj (ask nil (self)))
  128.            (ask obj (and (ownp 'object-name)
  129.                          (symbolp object-name)
  130.                          (boundp object-name)
  131.                          (eq (symbol-value object-name) obj))))))
  132.  
  133.  
  134.  
  135. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  136. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  137. ;;defclassvars
  138. ;;
  139. ;;  defclassvars adds a bunch of class variables to an object
  140. ;;
  141. ;;  its first argument should be a symbol bound to a class-object
  142. ;;  the rest should be symbols or lists of the form (symbol value)
  143. ;;
  144. ;;for example
  145. ;;
  146. ;;(defclassvars foo (a 10) (b 20) c)
  147. ;;(ask foo a)  ===>> 10
  148. ;;(ask foo b)  ===>> 20
  149. ;;(ask foo c)  ===>> nil
  150. ;;
  151.  
  152.  
  153. (defmacro defclassvars (objsym &rest var-inits)
  154.   (unless (and (symbolp objsym)
  155.                (boundp objsym)
  156.                (class-objectp (symbol-value objsym)))
  157.     (error "~S is not a symbol bound to a class object." objsym))
  158.   `(define-class-variables ,objsym ',var-inits))
  159.  
  160. ;;define-class-variables is a function used by defclassvars
  161. (defun define-class-variables (object var-init-list)
  162.   (let ((sym nil)
  163.         (valform nil))
  164.     (ask object
  165.       (dolist (def var-init-list)
  166.         (setq sym nil)
  167.         (if (atom def)
  168.           (setq sym def valform nil)
  169.           (if (and (consp (cdr def)) (null (cddr def)))
  170.             (setq sym (car def) valform (cadr def))))
  171.         (unless (and sym (symbolp sym))
  172.           (error "Invalid var-init-form in ~S."  var-init-list))
  173.         (have sym (eval valform))))))
  174.  
  175.  
  176. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  177. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  178. ;;definstancevars
  179. ;;
  180. ;;  definstancevars is used to set up a class so that it always gives
  181. ;;  certain instance variables to its instances.
  182. ;;
  183. ;;  the first argument to definstancevars should be a symbol bound to a
  184. ;;  class-object the rest should be symbols or lists of the form (symbol value).
  185. ;;
  186. ;;definstancevars depends on the definition of exist given below.
  187. ;;
  188. ;;for example
  189. ;;
  190. ;;(defobject foo)
  191. ;;(defclassvars foo (a 1) (b 2))
  192. ;;(definstancevars foo (ia 10) ib)
  193. ;;(setq bar (oneof foo))
  194. ;;(setq quux (oneof foo))
  195. ;;(ask bar a)   ==>> 1
  196. ;;(ask quux a)  ==>> 1
  197. ;;(ask bar (setq a 2))
  198. ;;(ask quux a)  ==>>  2 defined with defclassvars, so common to all instances
  199. ;;(ask bar ia)  ==>>  10
  200. ;;(ask quux ia)  ==>>  10
  201. ;;(ask bar (setq ia 20))
  202. ;;(ask quux ia)  ==>> 10 defined with defclassvars, so each has its own
  203.  
  204. (defmacro definstancevars (objsym &rest var-inits)
  205.   (unless (and (symbolp objsym)
  206.                (boundp objsym)
  207.                (class-objectp (symbol-value objsym)))
  208.     (error "~S is not a symbol bound to a class object." objsym))
  209.   `(define-instance-vars ',objsym ',var-inits))
  210.  
  211. ;;this function is used by definstancevars
  212. (defun define-instance-vars (objsym var-init-list)
  213.   (let ((normalized-defs nil)
  214.         (sym nil)
  215.         (valform nil))
  216.     (dolist (def var-init-list)
  217.       (setq sym nil)
  218.       (if (atom def)
  219.         (setq sym def valform nil)
  220.         (if (and (consp (cdr def)) (null (cddr def)))
  221.           (setq sym (car def) valform (cadr def))))
  222.       (unless (and sym (symbolp sym))
  223.         (error "Invalid var-init-form in ~S."  var-init-list))
  224.       (push (list sym valform) normalized-defs))
  225.     (ask (symbol-value objsym) (have '%iv-defs (nreverse normalized-defs)))))
  226.  
  227.  
  228. ;;this version of exist supporst definstancevars
  229. (defobfun exist (args)
  230.   (declare (ignore args) (object-variable %iv-defs))
  231.   (dolist (obj (object-ancestors (self)))
  232.     (when (ask obj (ownp '%iv-defs))
  233.       (let ((ivdefs (ask obj %iv-defs)))
  234.         (dolist (ivdef ivdefs)
  235.           (let ((sym (car ivdef)))
  236.             (unless (ownp sym)                
  237.               (have sym (eval (cadr ivdef)))))))))
  238.   nil)
  239.  
  240. (provide 'object-extensions)
  241. (pushnew :object-extensions *features*)