;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.92 ;;; Reason: ;;; Optimization of (ZL:MAKE-ARRAY ... :FILL-POINTER T) was causing run-time error ;;; from SI:SET-FILL-POINTER because a "new" fill-pointer must be a fixnum. The ;;; optimized form, of course, isn't really asking for a new fill-pointer, it's ;;; supposed to initialize it to the length of the array. Solution is to use ;;; specified array dimension. In all working cases (when fill-pointer is legal, ;;; for one-dimensional arrays) this is the value for the fill-pointer, as caller ;;; intended. ;;; Written 24-Sep-88 17:05:48 by keith (Keith Corbett) at site Gigamos Cambridge ;;; while running on Breaking Glass from band 1 ;;; with Experimental System 126.91, 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, Experimental ZWEI 126.11, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103. ; From modified file DJ: L.SYS; QCOPT.LISP#186 at 24-Sep-88 17:05:49 #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) ;;;||| This run-time target-K stuff generates a read error at compile ;;;time, unless you load the K software, which doesn't make sense when ;;;you're compiling for Lambda...???-Keith 9/24/88 (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) ;;Construct optimized form: (let ((array-var (gensym))) `(let ((,array-var ,startform)) ,(if fill-pointer-specified `(setf (fill-pointer ,array-var) ;;Specifying :fill-pointer T was causing run-time ;;error from SET-FILL-POINTER because a "new" ;;fill-pointer must be a fixnum - but this isn't a ;;new fill-pointer. Solution is to use dimensions, ;;==length as caller intended. |||Keith 9/24/88 ,(if (memq fill-pointer-form '(t 't)) dimensions-form fill-pointer-form))) ,(if named-structure-symbol-specified `(make-array-into-named-structure ,array-var ,named-structure-symbol-form)) , array-var)) startform)))) ))