1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-


;;;                           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
;;;                                 MS 2151

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

(DEFMACRO WITHOUT-INTERRUPTS (&REST body)
  1"Execute BODY not allowing process-switching or sequence breaks.
If Control-Abort or Control-Break is typed while inside BODY,
it will not take effect until after they are finished."*
  `(LET ((INHIBIT-SCHEDULING-FLAG T))
     . ,body))

;;AB 7-24-87.  Add :WHOSTATE keyword so user can provide own wait-for-lock whostate.
(DEFMACRO WITH-LOCK ((LOCATOR . OPTIONS) &BODY BODY &AUX NORECURSIVE NOERROR whostate)
  1"Execute the BODY with a lock locked.
LOCATOR is an expression whose value is the lock status;
it should be suitable for use inside LOCF.
OPTIONS include: 
  :NORECURSIVE - this keyword's presence says not to allow locking a lock 
already locked by this process.
  :WHOSTATE - keyword's value is the state to display in wholine while 
waiting for the lock."*
  ;; Ignore the old :NOERROR option -- it's always that way now.
  (KEYWORD-EXTRACT OPTIONS O (whostate) (NORECURSIVE NOERROR) (OTHERWISE NIL))
  `(LET* ((POINTER (LOCF ,LOCATOR))
	  (ALREADY-MINE (EQ (CAR POINTER) CURRENT-PROCESS)))
     (IF (CONSP POINTER)
	 (SETQ POINTER (CDR-LOCATION-FORCE POINTER)))
     (UNWIND-PROTECT
	 (PROGN (IF ALREADY-MINE
		    ,(IF NORECURSIVE `(FERROR NIL "Attempt to lock ~S recursively." ',LOCATOR))
		    ;; Redundant, but saves time if not locked.
		    (OR (%STORE-CONDITIONAL POINTER NIL CURRENT-PROCESS)
			(PROCESS-LOCK POINTER current-process ,(OR whostate "Lock"))))
		. ,BODY)
       (UNLESS ALREADY-MINE
	 (%STORE-CONDITIONAL POINTER CURRENT-PROCESS NIL)))))

(defmacro with-lock-fast ((locator) &body body)
  1"Like WITH-LOCK, except executes BODY with the scheduler inhibited, and its faster."*
  (let ((temp (gensym)))
    `(let* ((inhibit-scheduling-flag t)
	    (,temp ,locator))
       ;; When the lock isn't free, or we don't have the lock
       (when (and ,temp (not (eq ,temp current-process)))
	 ;; Wait until we can get the lock
	 (process-wait "Hash Table Lock" #'(lambda () (null ,locator))))
       ;; Then execute the body with interrupts inhibited
       ,@body)))


;;PHD 3/30/87 prepare for new implementation, change macro.
(proclaim '(notinline prepare-timeout cancel-timer))
;;RJF 8/26/87 remove these, no longer needed
;;;(defun prepare-timeout (process duration)
;;;  (PROCESS-RUN-FUNCTION "WITH-TIMEOUT"
;;;				       'WITH-TIMEOUT-INTERNAL
;;;				       DURATION PROCESS))
;;;
;;;(defun cancel-timer (arg)
;;;  (send arg :kill))

;;PHD-RJF 1/16/86 Fix it by using :kill instead of :reset.
(DEFMACRO WITH-TIMEOUT ((DURATION . TIMEOUT-FORMS) &BODY BODY)
  1"Execute BODY with a timeout set for DURATION 60'ths of a second from time of entry.
If the timeout elapses while BODY is still in progress,
the TIMEOUT-FORMS are executed and their values returned, and
whatever is left of BODY is not done, except for its UNWIND-PROTECTs.
If BODY returns, is values are returned and the timeout is cancelled.
The timeout is also cancelled if BODY throws out of the WITH-TIMEOUT."*
  `(LET ((.PROC. (prepare-timeout current-process ,duration )))
     (CONDITION-CASE ()
	 (UNWIND-PROTECT
	   (PROGN . ,BODY)
	   (cancel-timer .proc.))
       (TIMEOUT
	. ,TIMEOUT-FORMS))))

(DEFPARAMETER TIMEOUT-INSTANCE (MAKE-CONDITION 'CONDITION ':CONDITION-NAMES '(TIMEOUT)))

(DEFUN WITH-TIMEOUT-INTERNAL (DURATION PROCESS)
  (PROCESS-SLEEP DURATION)
  (SEND PROCESS :INTERRUPT 'SIGNAL-CONDITION TIMEOUT-INSTANCE))