(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "16-Oct-86 12:14:14" {eris}<lispcore>sources>cmlarray-optimizers.\;2
 8599   

      |changes| |to:|  (optimizers cl:aref aset bit char cl:sbit cl:schar cl:svref %arrayp 
                              %general-array-p %oned-array-p %simple-array-p %simple-string-p 
                              %stringp %twod-array-p %vectorp %array-read %array-write)
                       (setfs cl:aref bit char cl:fill-pointer cl:sbit cl:schar cl:svref)
                       (functions %aref-expander %aset-expander)
                       (vars cmlarray-optimizerscoms)

      |previous| |date:| " 9-Sep-86 18:49:09" {eris}<lispcore>sources>cmlarray-optimizers.\;1)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint cmlarray-optimizerscoms)

(rpaqq cmlarray-optimizerscoms
 
       ((* |;;;| "Setfs")
        (setfs cl:aref bit char cl:fill-pointer cl:sbit cl:schar cl:svref)
        (* |;;;| "Optimizers")
        (functions %aref-expander %aset-expander)
        (optimizers cl:aref aset bit char cl:sbit cl:schar cl:svref %arrayp %general-array-p 
               %oned-array-p %simple-array-p %simple-string-p %stringp %twod-array-p %vectorp)
        (* |;;;| "Optimizers, not yet used, since not backed by micro-code")
        (optimizers %array-read %array-write)
        (* |;;;| "Compiler options")
        (declare\: donteval@load doeval@compile dontcopy (localvars . t))
        (prop filetype cmlarray-optimizers)))



(* |;;;| "Setfs")


(cl:defsetf cl:aref
 (array &rest indices) (newvalue)
                                          `(aset ,newvalue ,array ,@indices))

(cl:defsetf bit
 (array &rest indices) (newvalue)
                                      `(aset ,newvalue ,array ,@indices))

(cl:defsetf char
 (array index) (newvalue)
                               `(aset ,newvalue ,array ,index))

(cl:defsetf cl:fill-pointer
 set-fill-pointer)

(cl:defsetf cl:sbit
 (array &rest indices) (newvalue)
                                          `(aset ,newvalue ,array ,@indices))

(cl:defsetf cl:schar
 (array index) (newvalue)
                                   `(aset ,newvalue ,array ,index))

(cl:defsetf cl:svref
 (array index) (newvalue)
                                   `(aset ,newvalue ,array ,index))




(* |;;;| "Optimizers")


(cl:defun %aref-expander
 (array indices) 
          
          (* *)

 (case (length indices)
       (1 `(%aref1 ,array ,@indices))
       (2 `(%aref2 ,array ,@indices))
       (cl:otherwise 'compiler:pass)))

(cl:defun %aset-expander
 (newvalue array indices) 
          
          (* *)

 (case (length indices)
       (1 `(%aset1 ,newvalue ,array ,@indices))
       (2 `(%aset2 ,newvalue ,array ,@indices))
       (cl:otherwise 'compiler:pass)))

(defoptimizer cl:aref
 (array &rest indices) (%aref-expander array indices))

(defoptimizer aset
 (newvalue array &rest indices) (%aset-expander newvalue array indices))

(defoptimizer bit
 (array &rest indices) (%aref-expander array indices))

(defoptimizer char
 (string index) `(%aref1 ,string ,index))

(defoptimizer cl:sbit
 (array &rest indices) (%aref-expander array indices))

(defoptimizer cl:schar
 (string index) `(%aref1 ,string ,index))

(defoptimizer cl:svref
 (cl:simple-vector index) `(%aref1 ,cl:simple-vector ,index))

(defoptimizer %arrayp
 (array) (cl:if (cl:symbolp array)
                                     `(or (%oned-array-p ,array)
                                          (%twod-array-p ,array)
                                          (%general-array-p ,array))
                                     (let ((sym (gensym)))
                                          `(let ((,sym ,array))
                                                (or (%oned-array-p ,sym)
                                                    (%twod-array-p ,sym)
                                                    (%general-array-p ,sym))))))

(defoptimizer %general-array-p
 (array) `(and ((opcodes typep 16)
                                              ,array)
                                             t))

(defoptimizer %oned-array-p
 (array) `(and ((opcodes typep 14)
                                           ,array)
                                          t))

(defoptimizer %simple-array-p
 (array) (cl:if (cl:symbolp array)
                                             `(and (%arrayp ,array)
                                                   (|fetch|
 (array-header simple-p)
                                                      |of|
 ,array))
                                             (let ((sym (gensym)))
                                                  `(let ((,sym ,array))
                                                        (and (%arrayp ,sym)
                                                             (|fetch|
 (array-header simple-p)
                                                                |of|
 ,sym))))))

(defoptimizer %simple-string-p
 (string) (cl:if (cl:symbolp string)
                                               `(and (%oned-array-p ,string)
                                                     (|fetch|
 (array-header simple-p)
                                                        |of|
 ,string)
                                                     (|fetch|
 (array-header string-p)
                                                        |of|
 ,string))
                                               (let ((sym (gensym)))
                                                    `(let ((,sym ,string))
                                                          (and (%oned-array-p ,sym)
                                                               (|fetch|
 (array-header simple-p)
                                                                  |of|
 ,sym)
                                                               (|fetch|
 (array-header string-p)
                                                                  |of|
 ,sym))))))

(defoptimizer %stringp
 (string) (cl:if (cl:symbolp string)
                                       `(and (or (%oned-array-p ,string)
                                                 (%general-array-p ,string))
                                             (|fetch|
 (array-header string-p) |of|
 ,string))
                                       (let ((sym (gensym)))
                                            `(let ((,sym ,string))
                                                  (and (or (%oned-array-p ,sym)
                                                           (%general-array-p ,sym))
                                                       (|fetch|
 (array-header string-p)
                                                          |of|
 ,sym))))))

(defoptimizer %twod-array-p
 (array) `(and ((opcodes typep 15)
                                           ,array)
                                          t))

(defoptimizer %vectorp
 (cl:vector)
   (cl:if (cl:symbolp cl:vector)
          `(or (%oned-array-p ,cl:vector)
               (and (%general-array-p ,cl:vector)
                    (eql 1 (length (|ffetch|
 (general-array dims) |of|
 ,cl:vector)))))
          (let ((sym (gensym)))
               `(let ((,sym ,cl:vector))
                     (or (%oned-array-p ,sym)
                         (and (%general-array-p ,sym)
                              (eql 1 (length (|ffetch|
 (general-array dims) |of|
 ,sym)))))))))




(* |;;;| "Optimizers, not yet used, since not backed by micro-code")


(defoptimizer %array-read
 (base typenumber index) `((opcodes misc3 9)
                                                    ,base
                                                    ,typenumber
                                                    ,index))

(defoptimizer %array-write
 (newvalue base typenumber index) `((opcodes misc4 7)
                                                              ,newvalue
                                                              ,base
                                                              ,typenumber
                                                              ,index))




(* |;;;| "Compiler options")


(declare\: donteval@load doeval@compile dontcopy 
(declare\: doeval@compile dontcopy

(localvars . t)
)
)

(putprops cmlarray-optimizers filetype
 cl:compile-file)
(putprops cmlarray-optimizers copyright ("Xerox Corporation" 1986))
(declare\: dontcopy
  (filemap (nil)))
stop