;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 130.9
;;; Reason:
;;;  Optimize (COERCE x 'RATIONAL) into (RATIONAL X).  This also avoids
;;;  foolish compiler warnings compiling such forms.  Note that calls in the
;;;  form (COERCE X '(RATIONAL ...)) are not optimized.
;;; Written 21-Nov-88 18:16:14 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 130.7, Experimental ZWEI 128.7, Experimental ZMail 75.0, Experimental Local-File 77.0, Experimental File-Server 26.0, Experimental Unix-Interface 16.0, Experimental Tape 27.0, Experimental Lambda-Diag 19.0, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, 11/18 Falcon System Loaded.



; From modified file DJ: L.SYS; TYPES.LISP#110 at 21-Nov-88 18:16:16
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; TYPES  "

(defun coerce-optimizer (form)
  (let (frob type canon)
    (cond ((not (list-match-p form `(coerce ,frob ',type)))
	   form)
	  (t
	   (setq canon (type-canonicalize type nil nil))
	   (case (if (atom canon) canon (car canon))
	     (list
	      (once-only (frob)
		`(if (consp ,frob) ,frob (coerce-to-list ,frob))))
	     (short-float `(small-float ,frob))	;not strictly correct, since works on complex
	     (single-float `(float ,frob))	;ditto
	     (float
	      (once-only (frob)			;ditto
		`(if (small-floatp ,frob) ,frob (float ,frob))))
	     ((t) frob)
	     (cl:character `(cl:character ,frob))
	     (complex
	      (if (memq (cadr-safe canon) '(nil *))
		  (once-only (frob)
		    `(if (complexp ,frob) ,frob
		       (complex frob)))
		(once-only (frob)
		  `(if (complexp ,frob)
		       (%complex-cons (coerce (%complex-real-part ,frob) ',(cadr canon))
				      (coerce (%complex-imag-part ,frob) ',(cadr canon)))
		     (complex (coerce ,frob ',(cadr canon)))))))
	     (rational
	      (if (consp canon) form `(rational ,frob)))
	     (array
	      `(coerce-to-vector
		 ,frob
		 ',(array-type-from-element-type
		     (if (atom canon) t (cadr canon)))
		 nil))
	     (simple-array
	      `(coerce-to-vector
		 ,frob
		 ',(array-type-from-element-type
		     (if (atom canon) t (cadr canon)))
		 t))
	     (t (compiler::warn 'compiler::bad-coerce :improbable
				"Do not know how to coerce to type ~S" type)
		form))))))

))