;;; -*- Mode:Common-Lisp; Package:MACTOOLBOX; Base:10; Fonts:(CPTFONT HL10B HL12I CPTFONT CPTFONTB) -*-

;;;			    RESTRICTED RIGHTS LEGEND
;;; Use, duplication, or disclosure by the Government is subject to restrictions as
;;; set forth in subdivision (c)(1)(ii) of the Rights in Technical Data and 
;;; Computer Software clause at 52.227-7013.
;;; 	 TEXAS INSTRUMENTS INCORPORATED, P.O. BOX 2909, AUSTIN, TEXAS 78769
;;; Ï1     Ï*Copyright (C) 1989 Texas Instruments Incorporated. Ï1 Ï*All rights reserved.

(require "TOOLBOX-AUX-FUNCTIONS" "SYS:PUBLIC-MX;TOOLBOX-AUX-FUNCTIONS")


(defun Ï4VALIDATE-MACRO-KEYWORDS Ï*(macro-name keyword-list &rest valid-keywords)
  "Ï2Warn is there is any keyword in KEYWORD-LIST which is not in VALID-KEYWORDSÏ*"
  (do ((arg keyword-list (cddr arg)))
      ((null arg))
    (when (not (member (first arg) valid-keywords))
      (compiler:warn :INVALID-KEYWORD-ARG :probable-error
	"Ï3~S is an invalid keyword to the ~A macro.Ï*"
	(first arg) macro-name)))
  );Ï1;validate-macro-keywordsÏ*

(defmacro Ï4signaling-oserrs Ï*(&body body)
  "Ï2Traps will signal their OSErrs during the execution of BODY regardless of the
global setting of TB:*SIGNAL-MAC-OSERR*/Ï*"
  `(let ((*signal-mac-oserr* t))
     ,@body))


;Ï1;; Use the following macros to establish the various locks around the body of your code.Ï*
;Ï1;; These macros use UNWIND-PROTECTs to guarantee that the lock is never left lockedÏ*
;Ï1;; even in case of a error inside the body or the user pressing ABORT.Ï*


(defmacro Ï4WITH-HANDLE-LOCK Ï*((&rest handles) &body body)
  "Ï2For each handle in HANDLES, calls !MoveHHi and then locks the handle using
!HLOCK during execution of BODY.  Uncondiitonally unlock it using !HUNLOCK upon
normal or abnormal exit from BODY. Returns value(s) returned by BODY.

BODY is executed with the prevailing value of TB:*SIGNAL-MAC-OSERR* but
moving, locking, and unlocking will unconditionally signal errors.Ï*"
  (declare (values values-of-body))
  (let ((old-*signal-mac-oserr* (gensym)))
    (labels ((Ï4WITH-HLOCK-INTERNALÏ* (hndls)
	       (if (null hndls)
		   `((setf *signal-mac-oserr* ,old-*signal-mac-oserr*)
		     ,@body)
		   `((unwind-protect
			(progn (!movhhi ,(first hndls))
			       (!hlock ,(first hndls))			   
			       ,@(with-hlock-internal (rest hndls)))
		       ,@(when (= (length hndls) 1)
			  '((setf *signal-mac-oserr* t)))
		       (!hunlock ,(first hndls))))))
	     );Ï1;labels bindingsÏ*	     
	`(let* ((,old-*signal-mac-oserr* *signal-mac-oserr*)
		(*signal-mac-oserr* t))
	   ,@(with-hlock-internal handles))
      );Ï1;labelsÏ*
    );Ï1;letÏ*
  );Ï1;with-handle-lockÏ*


(defmacro Ï4with-font-lock Ï*(&body body)
  "Ï2Uses !SetFontLock to lock the most recently used font recourse during execution
 of BODY. The font is uncnditionally unlocked upon normal or abnormal exit from
BODY.  Returns value(s) returned by BODY.Ï*"
  (declare (values values-of-body))
  `(unwind-protect
       (progn (!setfontlock t)
	      ,@body)
     (!setfontlock nil))
  );Ï1;with-font-lockÏ*
 

(defmacro Ï4with-file-lock Ï*((fileparam) &body body)
  "Ï2Uses !SetFilLock to lock the file represented by ioNamePtr on volume reference 
ioVRefNum in paramBlock.  The file is unconditionally unlocked using !RstFilLock 
upon normal or abnormal  exit from BODY. Returns value(s) returned by BODY.  If 
fileParam is an expression, it will be evaluatedÏ* Ï2only once.

BODY is executed with the prevailing value of TB:*SIGNAL-MAC-OSERR* but
moving, locking, and unlocking will unconditionally signal errors.Ï*"
  (declare (arglist |Ï3fileParam|Ï*)
	   (values values-of-body))
  (let ((old-*signal-mac-oserr* (gensym)))
    (once-only (fileparam)
      `(let* ((,old-*signal-mac-oserr* *signal-mac-oserr*)
	      (*signal-mac-oserr*      t))
	 (unwind-protect
	     (progn (!setfillock ,fileparam)
		    (setf *signal-mac-oserr* ,old-*signal-mac-oserr*)
		    ,@body)
	   (setf *signal-mac-oserr* t)
	   (!rstfillock ,fileparam)))))
  );Ï1;with-file-lockÏ*
 

(defmacro Ï4with-hfile-lock Ï*((fileParam) &body body)
  "Ï2Uses !HSetFLock to lock the file represented by  fileParam.  The file is
uncondiitonally unlocked with !HRstFLock upon normal or abnormal exit from
BODY.  Returns value(s) returned by BODY.  IF fileParam is an expression,
it will be evaluated only once.

BODY is executed with the prevailing value of TB:*SIGNAL-MAC-OSERR* but
locking and unlocking will unconditionally signal errors.Ï*"
  (declare (arglist |Ï3fileParam|Ï*)
	   (values values-of-body))
  (let ((old-*signal-mac-oserr* (gensym)))
    (once-only (fileparam)
      `(let* ((,old-*signal-mac-oserr* *signal-mac-oserr*)
	      (*signal-mac-oserr*      t))
	 (unwind-protect
	     (progn (!hsetflock ,fileparam)
		    (setf *signal-mac-oserr* ,old-*signal-mac-oserr*)
		    ,@body)
	   (setf *signal-mac-oserr* t)
	   (!hrstflock ,fileparam)))))
  );Ï1;with-hfile-lockÏ*



;Ï4;;; HANDLE & POINTER MACROSÏ*
(defsignal Ï4NIL-HANDLE-ERROR Ï*(toolbox-error nil-handle-error) (function)
  "Ï2a trap  which should have returned a TB:MAC-HANDLE instance returned NIL.Ï*"
  :format-string "~A returned a NIL handle.")

(defmacro Ï4WITH-HANDLE Ï*((handle |Ï3logicalSize|Ï*) &body body)
  "Ï2Uses !NewHandle to allocate a new handle named HANDLE of size logicalSize
and then executes BODY. Upon normal or abnormal exit from BODY, !DisposHandle
is called to dispose of HANDLE.  If logicalSize is an expression, it will be evaluated
only once.

BODY is executed with the prevailing value of TB:*SIGNAL-MAC-OSERR* but
creating and disposing will unconditionally signal errors.Ï*"
  (declare (values values-of-body))
    (once-only (|Ï3logicalSize|Ï*)
      `(let* ((,handle nil))
	 (unwind-protect
	     (progn
	       (signaling-oserr
		 (setf ,handle (or (!newhandle ,|Ï3logicalSize|Ï*)
				   (signal 'nil-handle-error nil '!NEWHANDLE))))
	       ,@body)
	   (signaling-oserr (dispose-handle-maybe ,handle)))))
  );Ï1;with-handleÏ*


(defsignal Ï4NIL-POINTER-ERROR Ï*(toolbox-error nil-pointer-error) (function)
  "Ï2a trap  which should have returned a TB:MAC-POINTER instance returned NIL.Ï*"
  :format-string "~A returned a NIL pointer.")

(defmacro Ï4WITH-POINTER Ï*((pointer |Ï3logicalSize|Ï*) &body body)
  "Ï2Gets a new handle, floats it into high memory to avoid fragmentation,
locks it, derefs it, and binds it to POINTER for the duration of BODY.  Upon
normal or abnormal exit from BODY, it disposes of everything.  If logicalSize
is an expression, it will be evaluated only once.

BODY is executed with the prevailing value of TB:*SIGNAL-MAC-OSERR* but
creating, moving, and disposing will unconditionally signal errors.Ï*"
  (declare (values values-of-body))
  (let ((old-*signal-mac-oserr* (gensym))
	(handle                 (gensym)))
    (once-only (|Ï3logicalSize|Ï*)
      `(let* ((,old-*signal-mac-oserr* *signal-mac-oserr* )
	      (*signal-mac-oserr*      t)
	      (,pointer                nil)
	      (,handle                 nil))
	 (unwind-protect
	     (progn
	       (setf ,handle (or (!newhandle ,|Ï3logicalSize|Ï*)
				 (signal 'nil-handle-error nil 'NEWHANDLE)))
	       (!movehhi ,handle)
	       (unwind-protect
		   (progn (!hlock ,handle)
			  (unwind-protect
			      (progn
				(setf ,pointer (deref ,handle))
				(setf *signal-mac-oserr* ,old-*signal-mac-oserr*)  
				,@body)
			    (setf *signal-mac-oserr* t)
			    (dispose-pointer-maybe ,pointer)))
		 (!hunlock ,handle)))
	   (dispose-handle-maybe ,handle)))))
  );Ï1;with-newpointerÏ*


Ï4;;;; TEXT EDIT MACROSÏ*
(defmacro Ï4WITH-TEXT-PTR Ï*((pointer text) &body body)
  "Ï2POINTER is bound to a value derived from TEXT which is suitable for use as the
'text' argument to various TextEdit functions.  If TEXT is an expression which
might have side effects, then it is evaluated only once. 

If TEXT is a TB:MAC-POINTER, then it is used as-is.

If it is a TB:MAC-HANDLE, then it is  converted into a TB:MAC-POINTER (i.e., locked
and derefed) during the execution of the BODY. 

If it is a Lisp string (or anything acceptable to the STRING function), then it is 
converted into a TB:MAC-POINTER to a string on the Macintosh side during the 
execution of BODY.

Upon normal or abnormal exit from BODY, any temporary locks are unlocked and 
temporary Macintosh strings are disposed of.Ï*"
  (declare (values values-of-body))
  (once-only (text)
    (let ((handle               (gensym))
	  (locked-handle        (gensym)))
      `(let* ((,handle        nil)
	      (,locked-handle nil)
	      (,pointer       nil))
	 (unwind-protect
	     (progn
	       (signaling-oserrs
		 (setf ,pointer (typecase ,text
				  (mac-pointer
				   ,text)
				  (mac-handle
				   (setf ,locked-handle (!hlock ,text))
				   (deref ,locked-handle))
				  (otherwise
				   (setf ,handle (!NewString (string ,text)))
				   (setf ,locked-handle (!hlock ,handle))
				   (deref ,locked-handle)))))
	       ,@body)
	   (signaling-oserrs
	     (when (nonnil-active-handle-p ,locked-handle)
	Ï1               Ï*;Ï1; then we had to lock a handle on entry, so unlock it nowÏ*
	       (!hUnlock ,locked-handle))
	     (dispose-handle-maybe ,handle))))))
  );Ï1;with-text-ptrÏ*



Ï4;;;; WINDOW MACROSÏ*
(defmacro Ï4WITH-WINDOW-INTERNAL Ï*(window wStorage constructor-form body)
  (let ((old-port (gensym)))
    `(let ((,window nil)
	   (,old-port (getport)))
       (unwind-protect
	   (progn
	     (setf ,window (or ,constructor-form
			       (signal 'nil-pointer-error nil
				      ' ,(first constructor-form))))
	     (unwind-protect
		 (progn (!setport ,window)
			,@body)
	       (!setport ,old-port)))
	 ,(if (or (null wstorage) (eq wstorage '!nilptr))
	Ï1              Ï*;Ï1; then the storage type is known at compile time, so hard code the choiceÏ*
	      `(when (nonnil-active-pointer-p ,window)
		 (send ,window :dispose))
	Ï1              Ï*;Ï1; else the choice will have to be made at run timeÏ*
	      `(when (nonnil-active-pointer-p ,window)
		 (if (or (null ,wstorage) (!nilptr-p ,wstorage))
		Ï1            Ï*;Ï1; then this window was allocated on the heapÏ*
		     (send ,window :dispose)
		Ï1            Ï*;Ï1; else this window was pre-allocated in some wayÏ*
		     (!closewindow ,window)))))))
  );Ï1;with-window-internalÏ*


(defmacro Ï4WITH-CWINDOW Ï*((window &rest args &key (wStorage '!nilPtr)
				  (boundsRect '(good-window-size)) (refCon 0)
				  (title "Ï3New WindowÏ*") (visible t) (goAwayFlag t)
				  (procID '!zoomDocProc) (behind '!onePtr))
			  &body body)
  "Ï2Binds symbol WINDOW to a new instance of TB:CWINDOW  and sets theProt
to this window for the duration of BODY. Closes or disposes of WINDOW, as appropriate,
and restores old port upon normal or abnormal exit from BODY.
If any argument is an expression, that expression will be evaluated only once.Ï*"
  (declare (arglist (window &key (wStorage |!nilPtrÏ3|Ï*) boundsRect (refCon 0)
				  (title "Ï3New WindowÏ*") (visible t) (goAwayFlag t)
				  (procID |!zoomDocProcÏ3|Ï*) (behind |!onePtrÏ3|Ï*)
			  &body body))
	   (values values-of-body))
  (validate-macro-keywords 'with-cwindow args :wStorage :boundsRect :refCon :title
			   :visible :goAwayFlag :procID :behind)
  (once-only (wstorage boundsrect refcon title visible goawayflag procid behind)
    (when (null wStorage)   (setf wStorage   'nilPtr))
    (when (null boundsRect) (setf boundsRect '(good-window-size)))
    (when (null behind)     (setf behind     'onePtr))
    `(with-window-internal ,window ,wStorage
			   (!newcwindow ,wstorage ,boundsrect ,title
					 ,visible ,procid ,behind ,goawayflag
					 ,refcon)
			   ,body))
Ï1     Ï*);Ï1;with-cwindowÏ*


(defmacro Ï4WITH-WINDOW Ï*((window &rest args &key (wStorage '!nilPtr)
				  (boundsRect '(good-window-size)) (refCon 0)
				  (title "Ï3New WindowÏ*") (visible t) (goAwayFlag t)
				  (procID '!zoomDocProc) (behind '!onePtr))
			  &body body)
  "Ï2Binds symbol WINDOW to a new instance of TB:WINDOW  and sets theProt
to this window for the duration of BODY. Closes or disposes of WINDOW, as appropriate,
and restores old port upon normal or abnormal exit from BODY.
If any argument is an expression, that expression will be evaluated only once.

NOTE:  Color window (see WITH-CWINDOW) are recommended for all new code
even when it is to be used on a monochrome display.Ï*"
  (declare (arglist (window &key (wStorage |!nilPtrÏ3|Ï*) boundsRect (refCon 0)
				  (title "Ï3New WindowÏ*") (visible t) (goAwayFlag t)
				  (procID |!zoomDocProcÏ3|Ï*) (behind |!onePtrÏ3|Ï*)
			  &body body))
	   (values values-of-body))
  (validate-macro-keywords 'with-cwindow args :wStorage :boundsRect :refCon :title
			   :visible :goAwayFlag :procID :behind)
  (once-only (wstorage boundsrect refcon title visible goawayflag procid behind)
    (when (null wStorage)   (setf wStorage   'nilPtr))
    (when (null boundsRect) (setf boundsRect '(good-window-size)))
    (when (null behind)     (setf behind     'onePtr))
    `(with-window-internal ,window ,wStorage
			   (!newwindow ,wstorage ,boundsrect ,title
				       ,visible ,procid ,behind ,goawayflag
				       ,refcon)
			   ,body))
Ï1     Ï*);Ï1;with-windowÏ*


(defmacro Ï4WITH-CWINDOW-RES Ï*((window windowID &optional (wStorage '!nilPtr)
				       (behind '!onePtr)) &body body)
  "Ï2Binds symbol WINDOW to the color window object in the 'WIND' resource ID WINDOWID
for the duration of BODY.  Closes or disposes of WINDOW, as appropriate, upon normal or
abnormal exist of BODY.Ï*"
  (declare (arglist (window |Ï3windowID|Ï* &optional (|wStorageÏ3|Ï* |!nilPtrÏ3|Ï*)
			    (|behindÏ3|Ï* |!onePtrÏ3|Ï*) &body body))
	   (values values-of-body))
  (once-only (Ï3windowID Ï*wstorage behind)
    (when (null wStorage) (setf wStorage 'nilPtr))
    (when (null behind)   (setf behind   'onePtr))
    `(with-window-internal ,window ,wStorage
			   (!Ï3getÏ*newcwindow Ï3,windowid Ï*,wstorage ,behind)Ï3 Ï*,body))
Ï1     Ï*);Ï1;with-cwindow-resÏ*


(defmacro Ï4WITH-WINDOW-RES Ï*((window windowID &optional (wStorage '!nilPtr)
				       (behind '!onePtr)) &body body)
  "Ï2Binds symbol WINDOW to the window object in the 'WIND' resource ID WINDOWID
for the duration of BODY.  Closes or disposes of WINDOW, as appropriate, upon normal or
abnormal exist of BODY.Ï*"
  (declare (arglist (window |Ï3windowID|Ï* &optional (|wStorageÏ3|Ï* |!nilPtrÏ3|Ï*)
			    (|behindÏ3|Ï* |!onePtrÏ3|Ï*) &body body))
	   (values values-of-body))
  (once-only (Ï3windowID Ï*wstorage behind)
    (when (null wStorage) (setf wStorage 'nilPtr))
    (when (null behind)   (setf behind   'onePtr))
    `(with-window-internal ,window ,wStorage
			   (!Ï3getÏ*newwindow Ï3,windowid Ï*,wstorage ,behind)Ï3 Ï*,body))
Ï1     Ï*);Ï1;with-window-resÏ*


Ï3;Ï4;; ERROR REPORTING MACROSÏ*
;Ï1;; The following macros simplify checking for an reporting OSErrs returned by error traps such asÏ*
;Ï1;; !ResError, !MemError, or !QDError.  For example, instead of writingÏ*
;Ï1;; Ï*      Ï*(!OpenResFile Ï2filenameÏ*)
Ï3;Ï1;; Ï*      Ï*(signal-oserr (!ResError) '!OpenResFile)
Ï3;Ï1;; Ï*
;Ï1;; you can write eitherÏ*
;Ï1;; Ï*
;Ï1;; Ï*      Ï*(!OpenResFile Ï2filenameÏ*)
Ï3;Ï1;; Ï*      Ï*(signal-reserror !OpenResFile)
Ï3;Ï1;; orÏ*
;Ï1;; Ï*      Ï*(signal-reserror (!OpenResFile Ï2filenameÏ*))
Ï3;Ï1;; Ï*
;Ï1;; In this latter case, signal-resedrror returns whatever the trap returns.Ï*


(Ï*defmacro Ï4SIGNAL-TOOLERROR-INTERNALÏ* (error-function symbol-or-form
					 format-string args)
  "Ï2This macro preforms the work of SIGNAL-RESERROR and friends.Ï*"
    (if (consp symbol-or-form)
      `(multiple-value-prog1
	 ,symbol-or-form
	 (funcall 'signal-oserr (,error-function) ',(first symbol-or-form)
		  ,format-string ,@args))
      `(funcall 'signal-oserr (,error-function) ',symbol-or-form ,format-string
		,@args))
  );Ï1;signal-toolerror-internal


Ï3(Ï*Ï*defmacro Ï4SIGNAL-RESERROR Ï*(symbol-or-form &optional format-string &rest args)
  "Ï2Calls !ResError and signals an OSErr if !ResError returns other than !noErr.  
If SYMBOL-OR-FORM is a symbol, it is used as the trap symbol name to build the 
error message.  If SYMBOL-OR-FORM is a form, the CAR of that form is used as the 
trap symbol.  FORMAT-STRING and ARGS can be used to override the default error 
message.

If SYMBOL-OR-FORM is a form, then it is presumed to be the Resource Manager trap 
which is going to set resError.  That form is evaluated BEFORE the call to 
!ResError and its value(sÏ3)Ï* returned AFTER the check of the value returned by 
!ResError.Ï*"
  `(signal-toolerror-internal !ResError ,symbol-or-form ,format-string ,args)
  );Ï1;signal-reserror


Ï3(Ï*Ï*defmacro Ï4SIGNAL-MEMERROR Ï*(symbol-or-form &optional format-string &rest args)
  "Ï2Calls !MemError and signals an OSErr if !MemError returns other than !noErr.  
If SYMBOL-OR-FORM is a symbol, it is used as the trap symbol name to build the 
error message.  If SYMBOL-OR-FORM is a form, the CAR of that form is used as the 
trap symbol.  FORMAT-STRING and ARGS can be used to override the default error 
message.

If SYMBOL-OR-FORM is a form, then it is presumed to be the Memory Manager trap 
which is going to set memError.  That form is evaluated BEFORE the call to 
!MemError and its value(sÏ3)Ï* returned AFTER the check of the value returned by 
!MemError.Ï*"
  `(signal-toolerror-internal !MemError ,symbol-or-form ,format-string ,args)
  );Ï1;signal-memerror


Ï3(Ï*Ï*defmacro Ï4SIGNAL-QDERROR Ï*(symbol-or-form &optional format-string &rest args)
  "Ï2Calls !QDError and signals an OSErr if !QDError returns other than !noErr.  
If SYMBOL-OR-FORM is a symbol, it is used as the trap symbol name to build the 
error message.  If SYMBOL-OR-FORM is a form, the CAR of that form is used as the 
trap symbol.  FORMAT-STRING and ARGS can be used to override the default error 
message.

If SYMBOL-OR-FORM is a form, then it is presumed to be the QuickDraw trap 
which is going to set qdError.  That form is evaluated BEFORE the call to 
!QDError and its value(sÏ3)Ï* returned AFTER the check of the value returned by 
!QDError.Ï*"
  `(signal-toolerror-internal !QDError ,symbol-or-form ,format-string ,args)
  );Ï1;signal-qderror


Ï3(Ï*Ï*defmacro Ï4SIGNAL-PRERROR Ï*(symbol-or-form &optional format-string &rest args)
  "Ï2Calls !PrError and signals an OSErr if !PrError returns other than !noErr.  
If SYMBOL-OR-FORM is a symbol, it is used as the trap symbol name to build the 
error message.  If SYMBOL-OR-FORM is a form, the CAR of that form is used as the 
trap symbol.  FORMAT-STRING and ARGS can be used to override the default error 
message.

If SYMBOL-OR-FORM is a form, then it is presumed to be the Printing Manager 
which is going to set prError.  That form is evaluated BEFORE the call to 
!PrError and its value(s Ï3)Ï*returned AFTER the check of the value returned by 
!PrError.Ï*"
  `(signal-toolerror-internal !PrError ,symbol-or-form ,format-string ,args)
  );Ï1;signal-prerrorÏ*


(defmacro Ï4WITH-CURRENT-PORT Ï*((|grafPortÏ3_or_window|Ï*) &body body)
  "Ï2The port specified by  grafPort_or_window becomes the current port during
the execution of BODY.  Upon normal or abnormal exit from BODY, the previous port
is restored as the current port.  If grafPort_or_window is an expression, it will be
evaluated only once.Ï*"
  (declare (values values-of-body))
  (let ((old-port (gensym)))
Ï3    Ï*(once-only (|Ï3grafPort_or_window|Ï*)
      `(let ((,old-port (getport)))
	 (unwind-protect
	      (progn (!setport ,|Ï3grafPort_or_window|Ï*)
		     ,@body)
	   (when (typep ,old-port 'agrafport)
	     (!setport ,old-port))))))
  );Ï1;with-current-portÏ*


(defmacro Ï4WITH-CURSOR-INTERNAL Ï*((handle cursorid make-current-p color-p)
				   &body body)
  "Ï2Implements WITH-CURSOR and WITH-CCURSOR.Ï*"
  (once-only (Ï3cursorIDÏ* make-current-p)
    `(let ((,handle nil))
       (unwind-protect
	   (progn
	     (setf ,handle ,(if color-p
				`(or (!getcccrsor ,cursorid)
				     (signal 'nil-handle-error nil 'GETCCURSOR))
				`(or (!getcursor ,cursorid)
				     (signal 'nil-handle-error nil 'GETCURSOR))))
	     ,@(if (constantp make-current-p)
		   (when make-current-p
		     (if color-p
			 `((!setccursor ,handle))
			 `((!setcursor  ,handle))))
		 `((when ,make-current-p
		    ,(if color-p
		     `(!setccursor ,handle)
		     `(!setcursor  ,handle)))))
	     ,@body)
	 (when (nonnil-active-handle-p ,handle)
	   ,(if color-p
		`(!disposccursor ,handle)
		`(!disposhandle  ,handle))))))
  );Ï1;with-cursor-internalÏ*

(defmacro Ï4WITH-CURSOR Ï*((handle |Ï3cursorID|Ï* &optional make-current-p) &body body)
  "Ï2Binds the symbol HANDLE to a handle to the black-and-white cursor represented by
the \"CURS\" resource ID, cursorID (see TB:iBeamCursor's doc string for available 
cursors) during execution of BODY.  Disposes of handle upon normal or abnormal exit
from BODY.  If cursorID  or make-current-p is an expression, it will be executed only once.Ï*"
  (declare (values values-of-body))
  `(with-cursor-internal (,handle ,|Ï3cursorID|Ï* ,make-current-p nil) ,@body))


(defmacro Ï4WITH-CCURSOR Ï*((handle |Ï3cursorID|Ï* &optional make-current-p) &body body)
  "Ï2Binds the symbol HANDLE to a handle to the color cursor represented by  the
\"CURS\" resource ID, cursorID (see TB:iBeamCursor's docu string for available
cursors) during execution of BODY.  Disposes of handle upon normal or abnormal exit
from BODY.  If cursorID or make-current-p is an expression, it will be executed only once.Ï*"
  (declare (values values-of-body))
  `(with-cursor-internal (,handle ,|Ï3cursorID|Ï* ,make-current-p t) ,@body))



(defmacro Ï4WITH-ICON-INTERNAL Ï*((handle iconid color-p) &body body)
  "Ï2Implements WITH-ICON and WITH-CICONÏ*"
  (once-only (iconid color-p)
    `(let ((,handle nil))
       (unwind-protect
	   (progn
	     (setf ,handle ,(if color-p
				`(or (!getcicon ,iconid)
				    (signal 'nil-handle-error nil 'GETCICON))
				`(or (!geticon ,iconid)
				    (signal 'nil-handle-error nil 'GETICON))))
	     ,@body)
	 (when (nonnil-active-handle-p ,handle)
	   ,(if color-p
		`(!disposcicon  ,handle)
		`(!disposhandle ,handle))))))
  );Ï1;with-icon-internalÏ*


(defmacro Ï4WITH-ICON Ï*((handle |Ï3iconID|Ï*) &body body)
  "Ï2Executes BODY with the symbol HANDLE bound to the icon specified by the 
resource iconID.  Upon normal or abnormal exit of BODY, the icon is disposed of.  
If iconID is an expression, it will be evn\aluated only once.Ï*"
  (declare (values values-of-body))
  `(with-icon-internal (,handle ,|Ï3iconID|Ï* nil) ,@body))


(defmacro Ï4WITH-CICON Ï*((handle |Ï3iconID|Ï*) &body body)
  "Ï2Executes BODY with the symbol HANDLE bound to the  color icon specified by the 
resource iconID.  Upon normal or abnormal exit of BODY, the icon is disposed of.  
If iconID is an expression, it will be evaluated only once.Ï*"
  (declare (values values-of-body))
  `(with-icon-internal (,handle ,|Ï3iconID|Ï* t) ,@body))


(defmacro Ï4WITH-COLOR-TABLE Ï*((handle |Ï3resID|Ï*) &body body)
  "Ï2Executes BODY with the symbol HANDLE bound to the handle of the color table in the \"clut\" resource with the integer resource ID of resID.  Upon normal or abnormal exit of BODY, the color table is disposed of.  If resID is an expression, it will be evaluated only once.Ï*"
  (declare (values values-or-body))
  (once-only (|Ï3resID|Ï*)
    `(let ((,handle nil))
       (unwind-protect
	   (progn (setf ,handle (or (!getctable ,|Ï3resID|Ï*)
				    (signal 'nil-handle-error nil '!GETCTABLE)))
		  ,@body)
	 (when (nonnil-active-handle-p ,handle)
	   (!disposctable ,handle)))))
  );Ï1;with-color-tableÏ*


(setf (get 'polygon 'multiple-open-error-symbol) 'with-open-polygon-p)
(setf (get 'region  'multiple-open-error-symbol) 'with-open-region-p)
(setf (get 'picture 'multiple-open-error-symbol) 'with-open-picture-p)

(defmacro Ï4WITH-INSTANCE Ï*((handle flavor-name &rest args) &body body)
  "Ï2Binds the symbol HANDLE to a new  handle instance of FLAVOR-NAME creates with
MAKE-INSTANCE arguments ARGS during execution of BODY.  FLAVOR-NAME must be able to
handle a :DISPOSE message (e.g., PixPat, Region, PixMap, Polygon, Picture, etc.).  Upon
normal or abnormal  exit of BODY,  HANDLE is sent a :DISPOSE message.

If FLAVOR-NAME has a TB:MULTIPLE-OPEN-ERROR-SYMBOL property, then a check
is made at runtime to assure that a second instance of that FLAVOR-NAME is not created
inside of another instance.Ï*"
  (declare (values values-of-body))
  (once-only (flavor-name)
    (let ((protected-body nil)
	  (multiple-open-error-symbol
	    (get flavor-name 'multiple-open-error-symbol)))
      (setf protected-body
	    `(progn
	       (unwind-protect
		   (setf ,handle
			 (or (make-instance ',flavor-name ,@args)
			     (signal 'nil-handle-error
				     "Ï3MAKE-INSTANCE of ~A returned a NIL handleÏ*"
				     ',flavor-name)))
		 ,@body)
	       (dispose-handle-maybe ,handle)))
      (if (null multiple-open-error-symbol)
	  `(let ((,handle nil))
	     ,protected-body)
	  `(locally
	     (declare (special ,multiple-open-error-symbol))
	       (when (and (boundp ',multiple-open-error-symbol)
			  ,multiple-open-error-symbol)
		Ï1 Ï*;Ï1; then we are trying to open a second regionÏ*
		 (signal 'multiple-open-instance-error nil ',flavor-name))
	       (let ((,handle nil)
		     (,multiple-open-error-symbol t))
		 (declare (special ,multiple-open-error-symbol))
		 ,protected-body)))))
  );Ï1;with-instanceÏ*


(defsignal Ï4MULTIPLE-OPEN-INSTANCE-ERRORÏ*
	   (toolbox-error multiple-open-instance-error) (flavor-name)
  "Ï2signaled if one WITH-INSTANCE of a flavor name is nested inside anotherÏ*"
  :format-string "Attempt to instantiate ~A while another instance still exists.")


;Ï1;;;Ï4MAIN EVENT LOOP MACROÏ*Ï*
(defvarÏ4 *DEBUG-LOOP-ON-EVENT-P* Ï*nil
  "Ï2Determines what happens if an error is signaled inside the clauses of a
TB:LOOP-ON-EVENT form.  True=>let the error continue on into the debugger.
False=>simply restart the event loop waiting for the next event.Ï*")

(defmacro Ï4LOOP-ON-EVENT Ï*((&rest args
			    &key (event-mask '!everyEvent) (stop-mask 0) (sleep 0)
			    (region '!nilRgn) (event-record-symbol 'event)
			    (flushevents-p t)) &body clauses)
  "Ï2This macro creates a Toolbox Main Event Loop where the CLAUSES are clauses to a
CASE statement which specify the dispatch actions for each event received.  During
the execution of CLAUSES, the symbol specified by EVENT-RECORD-SYMBOL is bound to
the current event record as a special variable.  If one of the CLAUSES begins with
the symbol :CLEANUP, then that clause will begin execution upon normal or abnormal
exit from the event loop.  The defaults are sufficient for most uses.

Throwing to TB:EVENT-LOOP-EXIT during the execution of CLAUSES will gracefully
exit the event loop while throwing to TB:EVENT-LOOP-TOP will terminate the
execution of the current event and return to the top of the event loop to wait for
the next event.  Throwing to TB:EVENT-LOOP-TOP will NOT cause the cleanup clause
to be executed.

If FLUSHEVENTS-P is true, then EVENT-MASK and STOP-MASK are passed to !FlushEvents
before entering the event loop for the first time.  Otherwise, !FlushEvents is not
called on initial entry to the loop.  EVENT-MASK, SLEEP, and REGION are passed on
to !WaitNextEvent.  The CLAUSES are executed only if !WaitNextEvent returns true.

If an error is signaled or if the user presses ABORT or CONTROL-ABORT, then the
execution of the current event terminates and returns to the top of the event loop.
However, if the global variable TB:*DEBUG-LOOP-ON-EVENT-P* is bound and true, then
error signals are NOT intercepted (so you can get into the debugger is you really
need to).  If you enter the debugger, you will have proceed options to restart
the loop with and without flushing pending events.  The ABORT key always causes
the loop to restart regardless of TB:*DEBUG-LOOP-ON-EVENT-P*.  (CONTROL-META-ABORT
does not work by signaling abort, so it will always break you out of this loop.)Ï*

     (loop-on-event (:sleep 10 ...)
       (#.!nullEvent ...)
       (#.!mouseDown ...)
       ...
       (otherwise    ...)
       (:CLEANUP     ...))"
  (declare (arglist (&key (event-mask |!everyEvent|) (stop-mask 0) (sleep 0)
			    (region |!nilRgn|) (event-record-symbol \'event)
			    (flushevents-p t) &body clauses))
	   (values ignore))
  (validate-macro-keywords 'loop-on-event args :event-mask :region
			   :event-record-symbol :flushevents-p :sleep :stop-mask)
  
  (let ((protected-forms           nil)
	(condition-handler         nil)
	(flush-and-restart-handler nil)
	(restart-handler           nil))
    ;Ï1; make sure any sideeffecting expressions we were passed are only evaluated onceÏ*
    (once-only (event-mask region sleep flushevents-p event-record-symbol)
      (when (null region) (setf region '!nilRgn))
      (setf condition-handler		     ;Ï1create condition handler for later useÏ*
	    '(lambda (condition)
	       (declare (special *debug-loop-on-event-p*))
	       (cond ((send condition :dangerous-condition-p) nil)
		     ((send condition :debugging-condition-p) nil)
		     ((condition-typep condition 'sys:abort)
		      (throw 'EVENT-LOOP-TOP nil))
		     ((and (boundp '*debug-loop-on-event-p*)
			   *debug-loop-on-event-p*)           nil)
		     (t (throw 'EVENT-LOOP-TOP nil)))))
      
      (setf flush-and-restart-handler        ;Ï1create flush & restart handler for later useÏ*
	    `(error :flush-and-restart-loop t
		    ("Ï3Flush pending events then restart event loop.Ï*")
		    (lambda (condition)
		      (declare (ignore condition))
		      (!flushevents ,event-mask ,stop-mask)
		      (throw 'EVENT-LOOP-TOP nil))))
      
      (setf restart-handler                  ;Ï1create handler for later useÏ*
	    `(error :restart-loop t
		    ("Ï3Restart event loop with pending events.Ï*")
		    (lambda (condition)
		      (declare (ignore condition))
		      (throw 'EVENT-LOOP-TOP nil))))
	       
      (setf protected-forms		     ;Ï1create body of UNWIND-PROTECT for later useÏ*
	    `(catch 'EVENT-LOOP-EXIT
	       ,@(when flushevents-p
		   ;Ï1; then we were asked to flush pending events before we startÏ*
		   `((!FlushEvents ,event-mask ,stop-mask)))
	       (loop
		 (catch 'EVENT-LOOP-TOP
		   (condition-resume ',flush-and-restart-handler
		     (condition-resume ',restart-handler
		       (condition-bind (((error sys:abort) #',condition-handler))
			 (loop
			   (when (!WaitNextEvent ,event-mask ,event-record-symbol
						 ,sleep ,region)
			     (case (the fixnum (send ,event-record-symbol :what))
			       ,@(remove :CLEANUP clauses :key #'car)))))))))))
Ï1              Ï*;Ï1; finally, create output formÏ*
      `(let ((,event-record-symbol (make-instance 'eventrecord)))
	 (declare (special ,event-record-symbol))
	 ,@(if (member :CLEANUP clauses :key #'car)
	       ;Ï1; then there are cleanup forms, so we need an UNWIND-PROTECTÏ*
	       `((unwind-protect
		    ,protected-forms
		  ,@(rest (assoc :CLEANUP clauses))))
	       ;Ï1; else no cleanup forms, so straight execution is OKÏ*
	       `(,protected-forms)))))
  );Ï1;loop-on-eventÏ*


;Ï1;;; Ï4MENUSÏ*Ï*
(defmacro Ï4WITH-MENUS Ï*((&rest menu-descriptors) &body body)
  "Ï2For each descriptor in MENU-DESCRIPTORS, creates a menu and binds it to a symbol
during the execution of BODY.  Upon normal or abnormal exit from BODY, the menus
are disposed (or their resource released).  A descriptor is a list as follows:Ï*

	(handle-symbol menuID-symbol &key :resID :menuID :title)

Ï2where HANDLE-SYMBOL will be bound as a special variable to the handle of the newly
created menu and MENUID-SYMBOL will be bound as a special variable to the menu or
resource ID, as appropriate, of the menu.  If the menu is defined by a resource,
then the keyword :RESID is followed by the resource ID which will be used as the
argument to !GetMenu.  Otherwise, the keyword :MENUID is followed by the menu ID and :TITLE is followed by the title string of arguments to !NewMenu.  That is, :RESID
and the :MENUID/:TITLE pair are mutually exclusive.  The presence of :RESID is used
to determine whether !GetMenu or !NewMenu is used.  For example:Ï*

	(FÏ3Menu FID :menuID 128 :title \Ï*"FileÏ3\Ï*"Ï3)Ï2 => Ï*Ï*(setf FMenu (!NewMenu FID Ï3\Ï*"FileÏ3\Ï*"))
	(EMeÏ3nu EID :resid 52)Ï2 Ï*Ï*                Ï2=> Ï*(setf EMenu (!GetMenu 52))Ï2 Ï*"
  (declare (values values-of-body))
  (let ((old-*signal-mac-oserr* (gensym))
	(let-bindings         nil)
	(special-declarations nil)
	(handle-symbol        nil)
	(id-symbol            nil)
	(resid-expr           nil)
	(menuid-expr          nil))
    (labels ((Ï4WITH-MENUS-INTERNAL Ï*(descriptors)
	       (if (null descriptors)
		   `((setf *signal-mac-oserr* ,old-*signal-mac-oserr*)
		     ,@body)
		   (let ((handle-symbol (caar descriptors))
			 (id-symbol     (cadar descriptors))
			 (resid-expr    (getf (cddar descriptors) :resid))
			 (title         (getf (cddar descriptors) :title "")))
		     `((unwind-protect
			 (progn
			   ,(if (null resid-expr)
				`(setf ,handle-symbol (!NewMenu ,id-symbol ,title))
				`(setf ,handle-symbol (!GetMenu ,id-symbol)))
			   ,@(with-menus-internal (cdr descriptors)))
			 ,@(if (= 1 (length descriptors))
			       `((setf *signal-mac-oserr*
				       ,old-*signal-mac-oserr*)))
			 ,(if (null resid-expr)
			      `(when (nonnil-active-handle-p ,handle-symbol)
				 (!DisposeMenu ,handle-symbol))
			      `(!ReleaseResource ,id-symbol)))))))
	     );Ï1;labels bindingsÏ*
      (dolist (descriptor menu-descriptors)	
	(setf handle-symbol (first  descriptor)
	      id-symbol     (second descriptor)
	      resid-expr    (getf (cddr descriptor) :resid)
	      menuid-expr   (getf (cddr descriptor) :menuid))
	(when (not (and (symbolp handle-symbol)
			(not (constantp handle-symbol))
			(symbolp id-symbol)
			(not (constantp id-symbol))))
	  (compiler:warn :INVALID-SYMBOL-ARG :probable-error
			 "Ï3The TB:WITH-MENUS menu descriptor~
                         ~%   ~s~
                         ~%does not have non-constant symbols as its first two ~
                           arguments: menuHandle and menuID.Ï*" descriptor))
        (when (and (not (null resid-expr)) (not (null menuid-expr)))
          (compiler:warn :CONFLICTING-ARGS :probable-error
                         "The TB:WITH-MENUS menu descriptor~
			 ~%   ~s~
			 ~%specifies both a :RESID and :MENUID arguments.  :RESID ~
			   will be used." descriptor))
	(push-end (list handle-symbol  nil) let-bindings)
	(push-end (list id-symbol (or resid-expr menuid-expr)) let-bindings)
	(push handle-symbol special-declarations)
	(push id-symbol special-declarations)
	);Ï1;dolistÏ*
      (push `(*signal-mac-oserr* t)                       let-bindings)
      (push `(,old-*signal-mac-oserr* *signal-mac-oserr*) let-bindings)
      (if (null menu-descriptors)
	  `(progn ,@body)
	  `(let* ,let-bindings
	     (declare (special ,@special-declarations))
	     ,@(with-menus-internal menu-descriptors)))
      );Ï1;labelsÏ*
    );Ï1;letÏ*
  );Ï1;with-menusÏ*


(defmacro Ï4WITH-MENU-BAR Ï*((&rest menus) &body body)
  "Ï2Clears the Menu Bar and then draws a new one using the menus in MENUS.  Upon
normal or abnormal exit from BODY, redraws a clear Menu Bar.  MENUS is a list of
menu handles for simple menus and submenu lists for hierarchial menus.  A submenu
list has the formÏ*:
Ï2  Ï*(SUBMENU-HANDLE SUBMENU-ID PARENT-MENU-HANDLE PARENT-MENU-ITEM-NUMBER);"

  (declare (values values-of-body))
  `(unwind-protect
       (progn
	 (!ClearMenuBar)
	 ,@(mapcar #'(lambda (menu)
		       ;Ï1; MENU => menu-handle; orÏ*
		       ;Ï1;             => (submenu-handle  submenu-idÏ*
		       ;Ï1;                   parent-menu-handle parent-menu-item-number)Ï*
		       (if (consp menu)
			Ï1       Ï*;Ï1; then MENU = > (submenu-handle submenu-id parent-handle parent-item-number)Ï*
			   `(progn
			      (!SetItemCmd  ,(third menu) ,(fourth menu)
					    ,!hMenuCmd)
			      (!SetItemMark ,(third menu) ,(fourth menu)
					    (if (characterp ,(second menu))
						,(second menu)
						(code-char ,(second menu))))
			      (!InsertMenu ,(first menu) !hierMenu))
			Ï1       Ï*;Ï1; else MENU => menu handleÏ*
			   `(!InsertMenu ,menu 0)))
		   menus)
	 (!DrawMenuBar)
	 ,@body)
     (!ClearMenuBar)
     (!DrawMenuBar))
  );Ï1;with-menu-barÏ*



(defmacro Ï4WITH-SELECTED-APPLICATION Ï*((application) &body body)
  "Ï2The MacintoshMultiFinder is switched to the specified APPLICATION during the execution of BODY
and then is switched back to the original application upon normal or abnormal exit from BODY.

APPLICATION may be a string naming the application as it appears in the Apple Menu, an instance
of TB:MAC-POINTER, or an instance of TB:MAC-HANDLE.Ï*"
  (declare (values values of body))
  (let ((current-application (gensym)))
    `(let ((,current-application CurApName))
       (unwind-protect
	   (progn
	     (select-application ,application)
	     ,@body)
	 (select-application ,current-application))))
  );Ï1;with-selected-applicationÏ*
  
Ï3(Ï*provide "TOOLBOX-MACROS")
