;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.220
;;; Reason:
;;;  Update SELECT-PROCESSOR for :FALCON.  Add SELECT-TARGET-PROCESSOR which
;;;  is similar but operates at compile time.
;;; Reason:
;;;  Add stuff for falcon processor code.
;;; Written 4-Apr-88 10:04:56 by rg at site Gigamos Cambridge
;;; while running on Love from band 1
;;; with Experimental System 123.218, Experimental Local-File 73.4, Experimental FILE-Server 22.2, Experimental Unix-Interface 11.0, Experimental Tape 18.2, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.13, SDU ROM 102, LOADED.



; From modified file DJ: L.WINDOW; COLD.LISP#184 at 4-Apr-88 10:04:57
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; COLD  "

(DEFCONSTANT FALCON-TYPE-CODE 4
  "The value which SI:PROCESSOR-TYPE-CODE has when you run on an Falcon.")

))

; From modified file DJ: L.SYS; QCDEFS.LISP#206 at 4-Apr-88 11:26:22
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCDEFS  "

(defvar-resettable *target-computer* 'lambda-interface 'lambda-interface)	;or 'k
		;get generators off this.

(defun target-processor-symbol ()
  (case *target-computer*
    (lambda-interface :lambda)
    (k :falcon)
    (t (ferror nil "*TARGET-COMPUTER* is ~s, which is unknown" *target-computer*))))
))

; From modified file DJ: L.SYS2; LMMAC.LISP#460 at 4-Apr-88 11:32:46
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

;These are evaluated at read time and compared with CASE instead of SELECT
; to avoid losing in the cold load. Problem is, the setqs for lambda-type-code,
; etc, are on the LISP-CRASH-LIST which doesn't get evaluated soon enough.
(eval-when (eval compile load)
  (defprop :cadr #.cadr-type-code processor-type-symbol)
  (defprop :lambda #.lambda-type-code processor-type-symbol)
  (defprop :explorer #.explorer-type-code processor-type-symbol)
  (defprop :falcon #.falcon-type-code processor-type-symbol)
  (defconst *all-known-processor-types* '(:lambda :falcon))	;dont generate warnings for :cadr :explorer
)

(defmacro select-processor (&rest clauses)
  (let* ((processor-types-not-used (copy-list *all-known-processor-types*)))
    (prog1 `(case processor-type-code
	      ,@(mapcar
		 (lambda (clause &aux types)
		   (block nil
		     (cond
			   ;this is a bad way to lose when bringing up new processors - pace
			   ;((memq (car clause) '(t otherwise :otherwise))
			   ; (setq processor-types-not-used nil)
			   ; (return clause))
			   ((symbolp (car clause))
			    (setq types (list (car clause))))
			   ((not (consp (car clause)))
			    (compiler:warn 'compiler::bad-argument :impossible
					   "~S is a bogus ~S clause"
					    clause 'select-processor)
			    (return nil))
			   (t
			    (setq types (car clause))))
		     (cons
		       (loop for ptype in types
			     do (setq processor-types-not-used
				      (delq ptype processor-types-not-used))
			     when (null (get ptype 'processor-type-symbol))
			       do (compiler:warn 'unknown-processor :impossible
						  "The processor type ~S, in a ~S, is unknown."
						  ptype 'select-processor)
			     else
			       collect (get ptype 'processor-type-symbol))
		       (cdr clause))))
		 clauses))
	   (when processor-types-not-used
	     (compiler:warn 'extra-processors :implausible
			    "A ~S expression failed to give alternatives for ~S"
			    'select-processor processor-types-not-used)))))

(defmacro select-target-processor (&rest clauses)
  (let* ((processor-types-not-used (copy-list *all-known-processor-types*)))
    (prog1
      (let ((processor-symbol
	      (compiler:target-processor-symbol)) ;works off compiler:*target-computer*
	    (ans nil))	;LIST of real ans.
	(dolist (c clauses)
	  (let ((proc (first c))
		(clause (second c))
		(types nil))
	    (cond ((symbolp proc)
		   (setq types (list proc)))
		  ((not (consp proc))
		   (compiler:warn 'compiler::bad-argument :impossible
				  "~S is a bogus ~s clause"
				  c 'select-target-processor))
		  (t (setq types proc)))
	    (if (memq processor-symbol types)
		(setq ans (list clause)))
	    (loop for ptype in types
		  do (setq processor-types-not-used
			   (delq ptype processor-types-not-used))
		  when (null (get ptype 'processor-type-symbol))
		  do (compiler:warn 'unknown-processor :impossible
				    "The processor type ~S, in a ~S, is unknown."
				    ptype 'select-target-processor))))
	(if (null ans)
	    (compiler:warn 'no-option-for-target-processor :fatal
			   "No alternative was given for ~S, the target processor"
			   processor-symbol)
	  (car ans)))
      (when processor-types-not-used
	(compiler:warn 'extra-processors :implausible
		       "A ~S expression failed to give alternatives for ~S"
		       'select-processor processor-types-not-used)))))
))