LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031566. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "TIMERS" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758658318. :AUTHOR "REL3" :LENGTH-IN-BYTES 4103. :LENGTH-IN-BLOCKS 5. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 ;;; -*- 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 (b)(3)(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,1987 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))    ((LETTER-CHARACTER-P CHAR);; This is the beginning of an alphabetic token.  Scan over all contiguous         ;; letters, upcasing them, and make a new token which is a symbol.                  (DO ((I INDEX (1+ I)))             ((OR (>= I END)               (LET ((CHAR (AREF STRING I)))                 (AND                  (NOT (OR (= CHAR #\@) (LETTER-CHARACTER-P CHAR)));; This clause is to make "A.M." and "P.M." work, but note                  ;; that trailing dots are ignored (see below).                                    (NOT (CHAR-EQUAL CHAR #\.));; If we are inside an alphabetic token and see a hypen followed                  ;; by a letter, accept this; e.g. "twenty-third".                                    (NOT                   (AND (CHAR-EQUAL CHAR #\-) (< (1+ I) END)                        (LETTER-CHARACTER-P (AREF STRING (1+ I)));; Special kludge: if it is AM- or PM-, break                        ;; here; some hosts send AM-EDT and such.                             