;;; -*- Mode: Common-Lisp; Package: SYS; Base: 10.; Patch-File: T -*-

;;; Reason: MIsc updates to kernel.

;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for SYSTEM version 6.35
;;; Written 05/24/90 09:34:19 by BERGER,
;;; while running on Pasteur from band LOD2
;;; With SYSTEM 6.32, VIRTUAL-MEMORY 6.3, EH 6.7, MAKE-SYSTEM 6.3, MICRONET 6.0, LOCAL-FILE 6.2,
;;;  BASIC-PATHNAME 6.4, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.3, DISK-LABEL 6.0, BASIC-FILE 6.11, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2,
;;;  COMPILER 6.14, TV 6.25, DATALINK 6.0, CHAOSNET 6.6, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.6, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.16,
;;;  DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.6, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.8, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.46, CLEH 6.5, IP 3.62,
;;;  Experimental CLX 6.11, CLUE 6.104, X11M 6.24, Experimental BUG 11.19,  microcode 648,
;;;  Band Name: rel6.0 1/23

#!C
; From file CONDITIONALS-MACROS.LISP#> KERNEL; SYS:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; CONDITIONALS-MACROS.#"


(defmacro select-memq (test-list &body clauses)
  "Execute the first clause that matches some element of TEST-LIST.
The first element of each clause is a match value or a list of match values.
Each match value is compare with each element of TEST-LIST, using EQ.
When a match-value matches, the rest of that clause is executed
and the value of the last thing in the clause is the value of the SELECT-MEMQ.
T or :OTHERWISE as the first element of a clause matches any test object."
  (let (test-exp cond-exp)
    (setq test-exp
	  ;; If TEST-LIST is an eval-at-load-time,
	  ;; we will treat it as a random expression, which is right.
	  (cond ((or (atom test-list)
		     (and (member (car test-list) '(car cdr caar cadr cdar cddr) :test #'eq)
			  (atom (cadr test-list))))
		 test-list)
		(t '.case.item.)))
    (setq cond-exp
	  (cons 'cond
		(mapcar #'(lambda (clause)
			    (macro-type-check-warning 'select-memq (car clause))
			    (cond ((member (car clause) '(otherwise :otherwise t) :test #'eq)
				   (list* t nil (cdr clause)))
				  ((atom (car clause))
				   `((member ',(car clause) ,test-exp :test #'eq) nil . ,(cdr clause)))
				  (t
				   `((or . ,(mapcar #'(lambda (match-value)
							`(member ',match-value ,test-exp :test #'eq))
						    (car clause)))
				     nil . (or ,(cdr clause) T)  ; DAB 05-10-90
				     ))))
			clauses)))
    (dead-clauses-warning (cdr cond-exp) 'select-memq)
    (cond ((eq test-exp test-list) cond-exp)
	  (t
	   `(let ((.case.item. ,test-list))
	      ,cond-exp)))))
))

#!C
; From file LISTS.LISP#> KERNEL; Hotel:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; LISTS.#"

(eval-when (compile)
  (Defmacro MEMBER-TEMPLATE (x list test)
    `(DO ((,x ,list (CDR ,x)))
	 ((ENDP ,x) nil)
       (WHEN ,test (RETURN ,x))))
)

(Defun *APPEND (l1 l2)
  (if (atom l1 )
      l2
    (PROG* ((result (%make-list* nil nil (LENGTH l1)))
	    (temp result))
	loop					;8 instructions in the inner loop
	   (SETF (CAR temp) (POP l1))
	   (COND ((CONSP (CDR temp))
		  (POP temp)
		  (GO loop))
		 (t (RPLACD temp l2)
		    (RETURN result))))))

(Defun MEMBER-EQUAL (item list)
;; specialization for MEMBER when the keyword TEST is used specifying EQUAL
    (if (symbolp item) (memq item list)  ; DAB 02-08-90 [10216]
	(MEMBER-TEMPLATE x list (EQUAL (CAR x) item))))

(eval-when(compile) 
  (Defmacro ASSOC-TEMPLATE (x list test)
    `(DOLIST (,x ,list)
       ;; the test (when (and x (...  is necessary in cases where
	;; nil appears in the alist and is the item sought. For then assoc
	;; will seek a pair whose car is nil.
       (AND ,test ,x (RETURN ,x))))
)

(Defun ASSOC-EQUAL(item alist)
;; specialization for ASSOC when TEST is EQUAL
  (if (symbolp item) (zlc:assq item alist) ; DAB 02-08-90 [10216]
      (ASSOC-TEMPLATE pair alist (EQUAL item (CAR pair)))))

))

#!C
; From file MICRO-TIME.LISP#> KERNEL; SYS:
#8R TIME#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TIME"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; MICRO-TIME.#"


(DEFUN INITIALIZE-TIMEBASE (&OPTIONAL UT source)
  "Set the clock.  UT, if specified, is the universal time.  
SOURCE describes where to get the time.  NIL means try all sources.  
Other possible values of SOURCE include :NET (the network), :LOCAL (the
local clock), and :USER (ask the user)."
  (let ()
    (setf Time:*timezone* (or (and si:local-host ; DAB 12-21-89 make sure local-host is defined first.
				   (get-site-option :timezone))
			      time:*timezone*)) ; DAB 11-29-89 Otherwise time may be off 1 HR.
    (WHEN (NULL ut)
      (SETQ ut
	    (SELECT source
	      (:net (get-time-from-network))
	      (:local (get-time-from-rtc))
	      (:user (get-time-from-user))
	      (:otherwise
	       (OR (get-time-from-network)
		   (get-time-from-rtc)
		   (progn (setq source :user) (get-time-from-user)))))) )
    (WHEN ut
      (WITHOUT-INTERRUPTS
	(IF (NOT (NULL *UT-AT-BOOT-TIME*))
	    ;;if we are randomly changing the time while up, mung uptime
	    (SETQ *UT-AT-BOOT-TIME*
		  (+ *UT-AT-BOOT-TIME* (- UT (GET-UNIVERSAL-TIME))))
	    ;;no real surprise: changing at boot time
	    (SETQ *UT-AT-BOOT-TIME* UT))
	(SETF (VALUES *LAST-TIME-UPDATE-TIME* *PREVIOUS-TOP-9-TIME-BITS*)
	      (obsolete-FIXNUM-MICROSECOND-TIME))
	(MULTIPLE-VALUE-SETQ
	  (*LAST-TIME-SECONDS* *LAST-TIME-MINUTES* *LAST-TIME-HOURS*
	   *LAST-TIME-DAY* *LAST-TIME-MONTH* *LAST-TIME-YEAR*
	   *LAST-TIME-DAY-OF-THE-WEEK* *LAST-TIME-DAYLIGHT-SAVINGS-P*)
	  (DECODE-UNIVERSAL-TIME UT))
	;; Don't touch the MAC clock if on microExplorer.  ab 11/1/88.
	(WHEN (AND (SI:RESOURCE-PRESENT-P :RTC)	
		   (or (CHAPARRAL-INITIAL-DATE-VALID-P)
		       (equalp source :user)))             ;; clm 3/1/89
	  (CHAPARRAL-SET-UNIVERSAL-TIME UT))
	(LEAP-YEAR-SETUP)
	;; Make sure that the leap year times are OK.  See
	;; leap-year-setup for more details.
	
	
	T))))
))