;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.41
;;; Reason:
;;;  Fix package inadequacy in array-type optimizations for K cross compilation.
;;;  This will eventually be better fixed such that array-type args will be
;;;  quoted symbols instead of groady numbers.
;;; Written 11-Aug-88 16:10:54 by smh at site Gigamos Cambridge
;;; while running on Harpo from band 3
;;; with Experimental System 126.38, ZWEI 125.15, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.12, SDU ROM 102, kold 4aug88.



; From modified file DJ: L.SYS; QCOPT.LISP#180 at 11-Aug-88 16:11:06
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "

(defoptimizer make-array-simple-make-array make-array (form)
  (let ((len (length form))
	(dimensions-form nil)
	(initial-value-form nil)
	(initial-value-specified nil)
	(area-form nil)
	(type-form (if (eq *target-computer* 'k)
		       ;;array:art-q               ;;WKF: 5/18/88
		       #+lambda k-array:art-q #+falcon array:art-q
		     ''art-q))
	(leader-length-form nil)
	(fill-pointer-form nil)
	(fill-pointer-specified nil)
	(named-structure-symbol-form nil)
	(named-structure-symbol-specified nil)
	out-of-order
	startform)
    (when (or (< len 2) (oddp len))
      (return-from make-array-simple-make-array form))
    (setq dimensions-form (second form))
    (loop for (keyword-form argument-form) on (rest2 form) by #'cddr
	  do (case (if (eq (car-safe keyword-form) 'quote)
			  (cadr keyword-form)
			keyword-form)
	       (:type
		(setq type-form argument-form)
		(or (constantp type-form)
		    (and (constantp area-form)
			 (constantp leader-length-form)
			 (constantp initial-value-form)
			 (constantp fill-pointer-form)
			 (constantp named-structure-symbol-form))
		    (setq out-of-order t)))
	       (:element-type
		(setq type-form argument-form)
		(or (constantp type-form)
		    (if (symbolp type-form)
			(and (trivial-form-p area-form)
			     (trivial-form-p leader-length-form)
			     (trivial-form-p initial-value-form)
			     (trivial-form-p fill-pointer-form)
			     (trivial-form-p named-structure-symbol-form))
		      (and (constantp area-form)
			   (constantp leader-length-form)
			   (constantp initial-value-form)
			   (constantp fill-pointer-form)
			   (constantp named-structure-symbol-form)))
		    (setq out-of-order t))
		(setq type-form
		      (if (constantp type-form)
			  `',(si::array-type-from-element-type (eval type-form))
			  `  (si::array-type-from-element-type ,type-form))))
			  
	       (:area
		(setq area-form argument-form)
		(or (constantp area-form)
		    (if (symbolp area-form)
			(and (trivial-form-p leader-length-form)
			     (trivial-form-p initial-value-form)
			     (trivial-form-p fill-pointer-form)
			     (trivial-form-p named-structure-symbol-form))
		      (and (constantp leader-length-form)
			   (constantp initial-value-form)
			   (constantp fill-pointer-form)
			   (constantp named-structure-symbol-form)))
		    (setq out-of-order t)))
	       (:leader-length
		(setq leader-length-form argument-form)
		(or (constantp leader-length-form)
		    (if (symbolp leader-length-form)
			(and (trivial-form-p initial-value-form)
			     (trivial-form-p fill-pointer-form)
			     (trivial-form-p named-structure-symbol-form))
		      (and (constantp initial-value-form)
			   (constantp fill-pointer-form)
			   (constantp named-structure-symbol-form)))
		    (setq out-of-order t)))
	       ((:initial-value :initial-element)
		(setq initial-value-form argument-form initial-value-specified t)
		(or (constantp initial-value-form)
		    (if (symbolp initial-value-form)
			(and (trivial-form-p fill-pointer-form)
			     (trivial-form-p named-structure-symbol-form))
		      (and (constantp fill-pointer-form)
			   (constantp named-structure-symbol-form)))
		    (setq out-of-order t)))
	       (:fill-pointer
		(setq fill-pointer-form argument-form fill-pointer-specified t)
		(or (constantp fill-pointer-form)
		    (if (symbolp fill-pointer-form)
			(trivial-form-p named-structure-symbol-form)
		      (constantp named-structure-symbol-form))
		    (setq out-of-order t)))
	       (:named-structure-symbol
		(setq named-structure-symbol-form argument-form
		      named-structure-symbol-specified t))
	       (otherwise
		(return-from make-array-simple-make-array form))))
    (if out-of-order
	;; Don't optimize if it means exchanging two subforms
	;; which could affect each other.
	form
      (if fill-pointer-specified
	  (setq leader-length-form
		(if leader-length-form
		    `(max 1 ,leader-length-form)
		  1)))
      (setq startform
	    (cond
	      (initial-value-specified
	       `(si:simple-make-array ,dimensions-form ,type-form ,area-form
				      ,leader-length-form ,initial-value-form))
	      (leader-length-form
	       `(si:simple-make-array ,dimensions-form ,type-form ,area-form
				      ,leader-length-form))
	      (area-form
	       `(si:simple-make-array ,dimensions-form ,type-form ,area-form))
	      (t
	       `(si:simple-make-array ,dimensions-form ,type-form))))
      (if (or fill-pointer-specified named-structure-symbol-specified)
	  (let ((array-var (gensym)))
	    `(let ((,array-var ,startform))
	       ,(if fill-pointer-specified
		    `(setf (fill-pointer ,array-var) ,fill-pointer-form))
	       ,(if named-structure-symbol-specified
		    `(make-array-into-named-structure
		       ,array-var ,named-structure-symbol-form))
	       , array-var))
	startform))))

))

; From modified file DJ: L.SYS; QCOPT.LISP#180 at 11-Aug-88 16:11:16
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "

(defoptimizer simple-make-array-simple-make-array-1d-q-short si:simple-make-array (form)
  (let ((dims (second form))
	(type (third form)))
    (cond ((and (numberp dims)	;DEFSTRUCT makes a lot of these!
		(< dims si:%array-max-short-index-length)
		(null (cdddr form))
		(if (eq *target-computer* 'k)  ;;wkf: 5/18/88 handle different art-q's
		    (or (and (numberp type)
			     (= type #+lambda k-array:art-q #+falcon array:art-q))
			(equal type '(quote array:art-q))
			(eq type 'array:art-q))
		  (or (equal type '(quote art-q))
		      (eq type 'art-q)
		      (and (numberp type)
			   (= type art-q)))))
	   `(si:simple-make-array-1d-q-short ,(cadr form)))
	  ((and (if (eq *target-computer* 'k)                  ;;wkf: 5/18/88
		    (or (equal type '(quote array:art-string))
			(eq type 'array:art-string)
			(and (numberp type)
			     (= type #+lambda k-array:art-string #+falcon array:art-string)))
		  (or (equal type '(quote art-string))
		      (eq type 'art-string)
		      (and (numberp type)
			   (= type art-string))))
		(null (fourth form))
		(eq (fifth form) 1)
		(null (nthcdr 5 form)))
	   `(si:simple-make-array-1d-string-with-fill-pointer ,(cadr form)))
	  (t form))))

))