src/lsp/objects.lsp

   1 ;;;;
   2 ;;;; objects.lsp XLISP-STAT additional objects and object functions
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9 (in-package "XLISP")
  10 (provide "objects")
  11
  12 ;;**** check over exports
  13 (export '(edit-text-item-proto modal-dialog-proto modal-button-proto dash-item-proto))
  14
  15 (defsetf slot-value slot-value)
  16
  17 (defmeth *object* :new (&rest args)
  18 "Method args: (&rest args)
  19 Creates new object using self as prototype."
  20   (let* ((object (make-object self)))
  21     (if (slot-value 'instance-slots)
  22         (dolist (s (slot-value 'instance-slots))
  23                 (send object :add-slot s (slot-value s))))
  24     (apply #'send object :isnew args)
  25     object))
  26
  27 (defmeth *object* :retype (proto &rest args)
  28 "Method args: (proto &rest args)
  29 Changes object to inherit directly from prototype PROTO. PROTO
  30 must be a prototype and SELF must not be one."
  31   (if (send self :has-slot 'instance-slots :own t)
  32       (error "can't retype a prototype"))
  33   (if (not (send proto :has-slot 'instance-slots :own t))
  34       (error "not a prototype - ~a" proto))
  35   (send self :reparent proto)
  36   (dolist (s (send proto :slot-value 'instance-slots))
  37     (send self :add-slot s (slot-value s)))
  38   (apply #'send self :isnew args)
  39   self)
  40
  41 (defmeth *object* :print (&optional (stream *standard-output*))
  42 "Method args: (&optional (stream *standard-output*))
  43 Default object printing method."
  44   (when *print-readably*
  45         (if (send self :has-method :save)
  46             (format stream "#.~s" (send self :save))
  47             (error "default :PRINT output is not readable")))
  48   (cond
  49     ((send self :has-slot 'proto-name)
  50      (format stream
  51              "#<Object: ~D, prototype = ~A>"
  52              (address-of self)
  53              (slot-value 'proto-name)))
  54     (t (format stream "#<Object: ~D>" (address-of self)))))
  55
  56 (defmeth *object* :slot-value (sym &optional (val nil set))
  57 "Method args: (sym &optional val)
  58 Sets and retrieves value of slot named SYM. Sugnals an error if slot
  59 does not exist."
  60   (if set (setf (slot-value sym) val))
  61   (slot-value sym))
  62
  63 (defmeth *object* :slot-names ()
  64 "Method args: ()
  65 Returns list of slots available to the object."
  66   (apply #'append
  67          (mapcar #'(lambda (x) (send x :own-slots))
  68                  (send self :precedence-list))))
  69
  70 (defmeth *object* :method-selectors ()
  71 "Method args: ()
  72 Returns list of method selectors available to object."
  73   (apply #'append
  74          (mapcar #'(lambda (x) (send x :own-methods))
  75                  (send self :precedence-list))))
  76
  77 ;;;;
  78 ;;;; More Hardware Object Methods
  79 ;;;;
  80 (defmeth hardware-object-proto :remove () (send self :dispose))
  81 (defmeth hardware-object-proto :allocated-p () (slot-value 'hardware-address))
  82
  83 (defmeth hardware-object-proto :add-subordinate (d)
  84   (setf (slot-value 'subordinates) (adjoin d (slot-value 'subordinates))))
  85
  86 (defmeth hardware-object-proto :delete-subordinate (d)
  87   (setf (slot-value 'subordinates) (remove d (slot-value 'subordinates))))
  88
  89 (defmeth hardware-object-proto :clobber ()
  90   (if (slot-value 'subordinates)
  91       (dolist (i (slot-value 'subordinates)) (send i :remove))))
  92
  93 #+macintosh
  94 (progn
  95   (export 'display-window-proto)
  96
  97   ;; DISPLAY-WINDOW-PROTO
  98   (defproto display-window-proto '() '() edit-window-proto)
  99
 100   (defmeth display-window-proto :isnew (&rest args)
 101     (apply #'call-next-method args)
 102     (setf (slot-value 'input-enabled) nil)))
 103
 104 (export 'active-windows)
 105
 106 (defun active-windows ()
 107 "Args: ()
 108 Returns list of active windows."
 109     (remove-if-not #'(lambda (x) (kind-of-p x window-proto))
 110                    (mapcar #'third *hardware-objects*)))
 111
 112 ;;;;
 113 ;;;; More Dialogs and Menu Items
 114 ;;;;
 115
 116 (send dialog-proto :slot-value 'type 'modeless)
 117 (send dialog-proto :slot-value 'go-away t)
 118
 119 (defmeth dialog-proto :items () (slot-value 'items))
 120
 121 (defmeth dialog-item-proto :dialog () (slot-value 'dialog))
 122
 123 (defproto edit-text-item-proto () () text-item-proto)
 124 (send edit-text-item-proto :slot-value 'editable t)
 125
 126 ;;; MODAL-DIALOG-PROTO
 127 (defproto modal-dialog-proto '(modal-throw-target) () dialog-proto)
 128 (send modal-dialog-proto :slot-value 'type 'modal)
 129 (send modal-dialog-proto :slot-value 'go-away nil)
 130
 131 (defmeth modal-dialog-proto :modal-dialog (&optional (remove t))
 132 "Metod args: (&optional (remove t))
 133 Runs the modal dialog loop until the :modal-dialog-return message
 134 is sent. Returns the argument to :modal-dialog-return. If REMOVE
 135 is not NIL, dialog is sent the :remove message before returning."
 136   (let ((target self))
 137     (unless (slot-value 'modal-throw-target)
 138             (setf (slot-value 'modal-throw-target) target)
 139             (send self :show-window)
 140             (unwind-protect (catch target
 141                                    (loop (send (call-next-method) :do-action)))
 142                             (setf (slot-value 'modal-throw-target) nil)
 143                             (if remove (send self :remove))))))
 144
 145 (defmeth modal-dialog-proto :modal-dialog-return (value)
 146 "Method Args: (value)
 147 Ends modal dialog loop and has :modal-dialog return VALUE."
 148   (let ((target (slot-value 'modal-throw-target)))
 149     (if target (throw target value))))
 150
 151 ;;; MODAL-BUTTON-PROTO
 152 (defproto modal-button-proto '() () button-item-proto)
 153
 154 (defmeth modal-button-proto :do-action ()
 155   (let ((action (slot-value 'action))
 156         (dialog (slot-value 'dialog)))
 157     (if dialog
 158         (send dialog :modal-dialog-return (if action (funcall action))))))
 159
 160 ;; DASH-ITEM-PROTO. Disabled line item for separation
 161 (defproto dash-item-proto () () menu-item-proto "Disabled separator line")
 162
 163 (defmeth dash-item-proto :isnew () (call-next-method "-" :enabled nil))
 164
 165 (defmeth menu-item-proto :menu ()
 166 "Method args: ()
 167 Returns menu if item is installed, NIL otherwise."
 168   (slot-value 'menu))
 169
 170 (defmeth menu-proto :print (&optional (stream t))
 171   (format stream "#<Object: ~d, prototype = ~a, title = ~s>"
 172           (address-of self)
 173           (slot-value 'proto-name)
 174           (slot-value 'title)))
 175
 176 (defmeth menu-item-proto :print (&optional stream)
 177   (format stream "#<Object: ~d, prototype = ~a, title = ~s>"
 178           (address-of self)
 179           (slot-value 'proto-name)
 180           (slot-value 'title)))
 181
 182 (defmeth graph-window-proto :erase-window ()
 183 "Method args: ()
 184 Erases the entire window canvas."
 185   (let ((w (send self :canvas-width))
 186         (h (send self :canvas-height)))
 187     (send self :erase-rect 0 0 w h)))