;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 126.84
;;; Reason:
;;;  Better SI:SELECT-PROCESSOR.  More informative messages for ill-formed clauses.
;;;  Use a style checker at compile time to note missing/bogus processor codes.
;;;  (Now we don't get double the warnings, double the fun.)
;;;  
;;;  EVALuators calling this macro don't get warned of missing alternatives, but who
;;;  evaluates this?
;;;  
;;;  Other random doc string cleanups within the LMMAC.LISP file.
;;; Written 15-Sep-88 04:02:15 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 126.82, Experimental ZWEI 126.10, Experimental ZMail 74.1, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Unix-Interface 14.0, Experimental Tape 25.1, Experimental Lambda-Diag 18.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, Lambda/Falcon Development System.



; From modified file DJ: L.SYS2; LMMAC.LISP#469 at 15-Sep-88 04:05:08
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

(eval-when (eval compile load)
  (defconst *all-known-processor-types* '(:lambda :falcon))
  (defconst *all-historical-processor-types* '(:cadr :lambda :explorer :falcon))
)

))

; From modified file DJ: L.SYS2; LMMAC.LISP#469 at 15-Sep-88 04:05:17
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "


(defmacro select-processor (&rest clauses)
  "At run-time select an action to perform based on the hardware processor type.
The format is like CASE:  the first element of each clause is a processor type or
 a list of processor type keywords -- :LAMBDA, :FALCON, etc."
  `(case processor-type-code
     . ,(loop for clause in clauses collect
	      (flet ((spbarf ()
		      (error "Ill-formed clause in ~S: /"~S/". Format should be as for ~S."
			     'select-processor clause 'case)))
		(if (not (listp clause))
		    (spbarf)
		  (let ((procs (car clause))
			(stuff (cdr clause)))
		    (cons
		      (typecase procs
			(symbol (get procs 'processor-type-symbol))
			(cons (mapcar #'(lambda (p)
					  (check-type p keyword)
					  (get p 'processor-type-symbol))
				      procs))
			(t (spbarf)))
		      stuff)))))))

))

; From modified file DJ: L.SYS2; LMMAC.LISP#469 at 15-Sep-88 04:05:20
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "


(defun (:property select-processor compiler:style-checker) (form)
  (block checking
    (let ((clauses (cdr form))
	  processor-types-used)
      (labels ((are-we-done? ()
		(when (>= (length processor-types-used)
			  (length *all-historical-processor-types*))
		  (return-from checking nil)))
	       (note-type (type)
		(cond
		  ((lisp:member type '(t otherwise) :test #'string-equal)
		   (return-from checking
		     (compiler:warn
		       'compiler:bad-argument :implausible
		       "Default processor type /"~S/" is not permitted in ~S."
		       type (car form))))
		  ((get type 'processor-type-symbol)
		   (pushnew type processor-types-used)
		   (are-we-done?))
		  (t (return-from checking
		       (compiler:warn
			 'compiler:bad-argument :implausible
			 "Unknown processor type ~S in ~S. ~&   Use one of: ~S"
			 type (car form) *all-known-processor-types*))))))
	(dolist (clause clauses)
	  (cond
	    ((not (consp clause))
	     (compiler:warn 'compiler:bad-argument :implausible
	       "Ill-formed clause ~S in ~S. Format should be as for CASE."
	       clause (car form)))
	    ((symbolp (car clause))
	     (note-type (car clause)))
	    ((consp (car clause))
	     (dolist (type (car clause))
	       (note-type type)))))
	(are-we-done?))
      (compiler:warn 'extra-processors :implausible
	"A ~S expression failed to give alternatives for ~S"
	'select-processor
	(set-difference *all-known-processor-types* processor-types-used)))))

))

; From modified file DJ: L.SYS2; LMMAC.LISP#469 at 15-Sep-88 04:05:49
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

(DEFMACRO DISPATCH (PPSS WORD &BODY CLAUSES)
  "Extract the byte PPSS from WORD and execute a clause selected by the value.
The first element of each clause is a value to compare with the byte value,
or a list of byte values.  These byte values are evaluated!.
T or OTHERWISE as the first element of a clause matches any test object.
This is a special exception, in that OTHERWISE is not evaluated."
  (declare (zwei:indentation 1 1 2 1))
  (LET ((FOO (GENSYM)))
    `(LET ((,FOO (LDB ,PPSS ,WORD)))
       (COND ,@(MAPCAR (LAMBDA (CLAUSE)
			 (MACRO-TYPE-CHECK-WARNING 'DISPATCH (CAR CLAUSE))
			 `(,(COND ((MEMQ (CAR CLAUSE) '(OTHERWISE :OTHERWISE T))
				   'T)
				  ((ATOM (CAR CLAUSE))
				   `(= ,FOO ,(CAR CLAUSE)))
				  (T
				     `(OR ,@(MAPCAR (LAMBDA (ITEM)
						      `(= ,FOO ,ITEM))
						    (CAR CLAUSE)))))
			     NIL . ,(CDR CLAUSE)))
		       CLAUSES)))))

))

; From modified file DJ: L.SYS2; LMMAC.LISP#469 at 15-Sep-88 04:05:57
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

(DEFMACRO DEFUNP (&ENVIRONMENT ENV FUNCTION-SPEC LAMBDA-LIST &REST BODY)
  "Like DEFUN, but provides an implicit PROG of no variables around the BODY.
So you can use RETURN to return from the function, and use GO.
There is one difference from an ordinary PROG:
the value of the last element of the BODY is returned.
This is so even if it is an atom.  This is like ordinary DEFUNs.

The use of this function is not recommended."
  (LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
	(LAST NIL))
    (SETQ BODY (COPY-LIST BODY))
    (SETQ LAST (LAST BODY))
    (MULTIPLE-VALUE-BIND (BODY DECLARES DOC)
	(EXTRACT-DECLARATIONS BODY NIL T ENV)
      (WHEN (NEQ (CAAR-SAFE LAST) 'RETURN)
	(SETF (CAR LAST) `(RETURN ,(CAR LAST))))
      `(DEFUN ,FUNCTION-SPEC ,LAMBDA-LIST
	 ,DOC
	 (DECLARE . ,DECLARES)
	 (PROG () . ,BODY)))))

))