;;; -*- Mode:Common-Lisp; Package:SYSTEM; 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) 1985-1989 Texas Instruments Incorporated. All rights reserved.

(defvar *timer-process* nil)
(defvar *timer-queue* nil)
(defvar *free-timers* nil)



(defstruct (timer-item (:type list) (:callable-constructors nil))
  time-for-wakeup
  next-item
  process-id
  action
  )

(proclaim '(inline get-timer enqueue-timer remove-timer pop-timer))

(defun get-timer (time process-id action )
  (without-interrupts
    (if *free-timers*
	(let ((item
		(prog1 *free-timers*
		       (setf *free-timers* (timer-item-next-item *free-timers*)))))
	  (setf (timer-item-action item) action
		(timer-item-process-id item) process-id
		(timer-item-time-for-wakeup item) time)
	  item)
	(make-timer-item :time-for-wakeup time
			 :process-id process-id
			 :action action))))

;;PHD Clean up next-item field when timer-item is the first one to be put on *timer-queue*
(defun enqueue-timer (timer-item)
  (without-interrupts
    (if  (null *timer-queue*)
	 (progn
	   (setf *timer-queue* timer-item)
	   (setf (timer-item-next-item timer-item) nil))
	 (let ((item *timer-queue*)
	       (trailer nil)
	       (time (timer-item-time-for-wakeup timer-item)))
	   (loop
	     (cond ((or (null item)
			(time-lessp time (timer-item-time-for-wakeup item)))
		    (setf (timer-item-next-item timer-item) item)
		    (if trailer
			(setf (timer-item-next-item trailer) timer-item)
			(setf *timer-queue* timer-item))
		    (return))
		   (t (psetq item (timer-item-next-item item)
			     trailer item))))))))

(defun remove-timer (item-to-remove)
  (without-interrupts
    (when *timer-queue*
      (let ((item *timer-queue*)
	    (trailer nil))
	(loop
	  (cond ((null item)
		 (return))
		((eq item item-to-remove)
		 (if trailer
		     (setf (timer-item-next-item trailer) (timer-item-next-item item-to-remove))
		     (setf *timer-queue* (timer-item-next-item item-to-remove)))
		 (setf (timer-item-next-item  item-to-remove) *free-timers*
		       *free-timers* item-to-remove
		       (timer-item-process-id item-to-remove) nil)
		 (return))
		(t (psetq item (timer-item-next-item item)
			  trailer item))))))))

(defun pop-timer ()
  ;;Remove first timer off *timer-queue* and return it to *free-timers*.
  (without-interrupts
    (when *timer-queue*
      (prog1 *timer-queue*
	     (psetf *timer-queue* (timer-item-next-item *timer-queue*)
		    (timer-item-next-item *timer-queue*) *free-timers*
		    *free-timers* *timer-queue*)))))

(defun time-wait ()
  ;;wait function for timer-process.
  (and *timer-queue*
       (not (time-lessp (time-in-60ths) (timer-item-time-for-wakeup *timer-queue*)))))

(defun timer-top-level ()
  ;;top-level function for timer-process
  (loop
    (process-wait "timer-wait" #'time-wait)
    (let ((item (pop-timer)))
	  (funcall (timer-item-action item) (timer-item-process-id item))
	  (setf (timer-item-process-id item ) nil))))

(defun timer-init ()
  (setf *timer-queue* nil
	*free-timers* nil)
  (setf *timer-process* (make-process "timer-process" :initial-form '(timer-top-level)
				      :warm-boot-action 'process-warm-boot-restart
				      :priority 35.))
  (process-reset-and-enable *timer-process* ))

    
(defun timeout-action (process)
  (SEND PROCESS :INTERRUPT 'SIGNAL-CONDITION TIMEOUT-INSTANCE))



(defun prepare-timeout (process duration)
  (let ((item (get-timer (time-increment (time-in-60ths) duration) process 'timeout-action)))
    (unless (and (typep *timer-process* 'process)
		 (send *timer-process* :active-p))
      (timer-init))
    (enqueue-timer item)
    item))

(defun cancel-timer (timer)
  (remove-timer timer))