Index: /branches/working-0711/ccl/compiler/optimizers.lisp
===================================================================
--- /branches/working-0711/ccl/compiler/optimizers.lisp	(revision 9388)
+++ /branches/working-0711/ccl/compiler/optimizers.lisp	(revision 9389)
@@ -2,5 +2,5 @@
 ;;;
 ;;;   Copyright (C) 1994-2001 Digitool, Inc
-;;;   This file is part of OpenMCL.  
+;;;   This file is part of OpenMCL.
 ;;;
 ;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
@@ -8,5 +8,5 @@
 ;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
 ;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
-;;;   conflict, the preamble takes precedence.  
+;;;   conflict, the preamble takes precedence.
 ;;;
 ;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
@@ -58,5 +58,5 @@
     (let* ((bits (%symbol-bits name)))
       (declare (fixnum bits))
-      (%symbol-bits name (logior 
+      (%symbol-bits name (logior
                           (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold))
                               (ash 1 $sym_fbit_constant_fold))
@@ -118,5 +118,5 @@
               (push arg targs)
               (return)))
-        (return 
+        (return
          (fixnumify (nreverse targs) op))))
     call))
@@ -144,5 +144,5 @@
                             keys
           (declare (ignore test-not))
-          (if (and test-p 
+          (if (and test-p
                    (not test-not-p)
                    (or (not key-p)
@@ -153,5 +153,5 @@
                                 (eq (%car key) 'quote))
                             (eq (%cadr key) 'identity)))
-                   (consp test) 
+                   (consp test)
                    (consp (%cdr test))
                    (null (%cddr test))
@@ -203,5 +203,5 @@
         (let* ((op (car call))
                (constant (if (cdr constants) (handler-case (apply op constants)
-                                               (error (c) (declare (ignore c)) 
+                                               (error (c) (declare (ignore c))
                                                       (return-from fold-constant-subforms (values call t))))
                              (car constants))))
@@ -256,5 +256,5 @@
 ;;;
 ;;; The new (roughly alphabetical) order.
-;;; 
+;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -302,9 +302,9 @@
   `(+ ,x 1))
 
-(define-compiler-macro append  (&whole call 
-                                       &optional arg0 
-                                       &rest 
-                                       (&whole tail 
-                                               &optional (junk nil arg1-p) 
+(define-compiler-macro append  (&whole call
+                                       &optional arg0
+                                       &rest
+                                       (&whole tail
+                                               &optional (junk nil arg1-p)
                                                &rest more))
   ;(append (list x y z) A) -> (list* x y z A)
@@ -338,5 +338,5 @@
         (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args)))
     (let ((original-fn fn))
-      (if (and arg0 
+      (if (and arg0
                (null args)
                (consp fn)
@@ -368,5 +368,5 @@
     `(asseql ,item ,list)
     call))
-  
+
 (define-compiler-macro asseql (&whole call &environment env item list)
   (if (or (eql-iff-eq-p item env)
@@ -424,5 +424,5 @@
 (define-compiler-macro caaaar (form)
   `(car (caaar ,form)))
-  
+
 (define-compiler-macro caaadr (form)
   `(car (caadr ,form)))
@@ -448,5 +448,5 @@
 (define-compiler-macro cdaaar (form)
   `(cdr (caaar ,form)))
-  
+
 (define-compiler-macro cdaadr (form)
   `(cdr (caadr ,form)))
@@ -492,5 +492,5 @@
      call))
 
-(define-compiler-macro dotimes (&whole call (i n &optional result) 
+(define-compiler-macro dotimes (&whole call (i n &optional result)
                                        &body body
                                        &environment env)
@@ -545,5 +545,5 @@
   (multiple-value-bind (test test-win) (nx-transform test env)
     (if (or (quoted-form-p test) (self-evaluating-p test))
-      (if (eval test) 
+      (if (eval test)
         true
         false)
@@ -559,4 +559,19 @@
       call)))
 
+(defun string-designator-p (object)
+  (typecase object
+    (character t)
+    (symbol t)
+    (string t)))
+
+(defun package-designator-p (object)
+  (or (string-designator-p object) (packagep object)))
+
+(define-compiler-macro intern (&whole call str &optional package)
+  (if (or (and (quoted-form-p package) (package-designator-p (%cadr package)))
+          (keywordp package)
+          (stringp package))
+    `(intern ,str (load-time-value (or (find-package ,package) ,package)))
+    call))
 
 (define-compiler-macro ldb (&whole call &environment env byte integer)
@@ -679,6 +694,6 @@
     (type-specifier ctype)))
 
-      
-      
+
+
 (define-compiler-macro make-array (&whole call &environment env dims &rest keys)
   (if (constant-keywords-p keys)
@@ -689,5 +704,5 @@
                               (fill-pointer () fill-pointer-p)
                               (initial-element () initial-element-p)
-                              (initial-contents () initial-contents-p)) 
+                              (initial-contents () initial-contents-p))
         keys
       (declare (ignorable element-type element-type-p
@@ -699,5 +714,5 @@
                           initial-contents initial-contents-p))
       (let* ((element-type-keyword nil)
-             (expansion 
+             (expansion
               (cond ((and initial-element-p initial-contents-p)
                      (nx1-whine 'illegal-arguments call)
@@ -707,5 +722,5 @@
                        (comp-make-array-1 dims keys)
                        (comp-make-displaced-array dims keys)))
-                    ((or displaced-index-offset-p 
+                    ((or displaced-index-offset-p
                          (not (constantp element-type))
                          (null (setq element-type-keyword
@@ -713,24 +728,24 @@
                                       (eval element-type) env))))
                      (comp-make-array-1 dims keys))
-                    ((and (typep element-type-keyword 'keyword) 
-                          (nx-form-typep dims 'fixnum env) 
-                          (null (or adjustable fill-pointer initial-contents 
-                                    initial-contents-p))) 
-                     (if 
-                       (or (null initial-element-p) 
-                           (cond ((eql element-type-keyword :double-float-vector) 
-                                  (eql initial-element 0.0d0)) 
-                                 ((eql element-type-keyword :single-float-vector) 
-                                  (eql initial-element 0.0s0)) 
-                                 ((eql element-type :simple-string) 
+                    ((and (typep element-type-keyword 'keyword)
+                          (nx-form-typep dims 'fixnum env)
+                          (null (or adjustable fill-pointer initial-contents
+                                    initial-contents-p)))
+                     (if
+                       (or (null initial-element-p)
+                           (cond ((eql element-type-keyword :double-float-vector)
+                                  (eql initial-element 0.0d0))
+                                 ((eql element-type-keyword :single-float-vector)
+                                  (eql initial-element 0.0s0))
+                                 ((eql element-type :simple-string)
                                   (eql initial-element #\Null))
                                  (t (eql initial-element 0))))
-                       `(allocate-typed-vector ,element-type-keyword ,dims) 
-                       `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) 
+                       `(allocate-typed-vector ,element-type-keyword ,dims)
+                       `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element)))
                     (t                        ;Should do more here
                      (comp-make-uarray dims keys (type-keyword-code element-type-keyword)))))
              (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
         `(the ,type ,expansion)))
-        
+
         call))
 
@@ -767,5 +782,5 @@
   (let* ((call-list (make-list 10 :initial-element nil))
 	 (dims-var (make-symbol "DIMS"))
-         (let-list (comp-nuke-keys keys                                   
+         (let-list (comp-nuke-keys keys
                                    '((:element-type 0 1)
                                      (:displaced-to 2)
@@ -813,5 +828,5 @@
 
 
-                                 
+
 
 (define-compiler-macro mapc  (&whole call fn lst &rest more)
@@ -853,5 +868,5 @@
     `(memeql ,item ,list)
     call))
-  
+
 (define-compiler-macro memeql (&whole call &environment env item list)
   (if (or (eql-iff-eq-p item env)
@@ -898,5 +913,5 @@
   (if (and (fixnump count)
            (%i>= count 0)
-           (%i< count 4))  
+           (%i< count 4))
      (if (%izerop count)
        `(require-type ,list 'list)
@@ -949,5 +964,5 @@
                ((type= ctype
                        (specifier-type '(signed-byte 8)))
-                `(the (signed-byte 8) (require-s8 ,arg)))               
+                `(the (signed-byte 8) (require-s8 ,arg)))
                ((type= ctype
                        (specifier-type '(unsigned-byte 8)))
@@ -958,5 +973,5 @@
                ((type= ctype
                        (specifier-type '(unsigned-byte 16)))
-                `(the (unsigned-byte 16) (require-u16 ,arg)))               
+                `(the (unsigned-byte 16) (require-u16 ,arg)))
                ((type= ctype
                        (specifier-type '(signed-byte 32)))
@@ -1168,6 +1183,6 @@
                  (dolist (,elt-var ,sequence (%cdr ,result-var))
                    (,loop-test (funcall ,test (funcall ,key ,elt-var))
-                               (setq ,temp-var 
-                                     (%cdr 
+                               (setq ,temp-var
+                                     (%cdr
                                       (%rplacd ,temp-var (list ,elt-var)))))))))
           call))
@@ -1288,5 +1303,5 @@
     `(not (logbitp 0 (the fixnum ,n0)))
     w))
-  
+
 
 (define-compiler-macro logandc2 (n0 n1)
@@ -1328,5 +1343,5 @@
               `(require-type ,n0 'integer)
               identity)))))))
-          
+
 (define-compiler-macro logand (&whole w &rest all)
   (declare (ignore all))
@@ -1351,5 +1366,5 @@
     `(not (eql 0 (logand ,n1 ,n2)))
     w))
-  
+
 
 (defmacro defsynonym (from to)
@@ -1358,6 +1373,6 @@
      (setf (compiler-macro-function ',from) nil)
      (let ((pair (assq ',from *nx-synonyms*)))
-       (if pair (rplacd pair ',to) 
-           (push (cons ',from ',to) 
+       (if pair (rplacd pair ',to)
+           (push (cons ',from ',to)
                  *nx-synonyms*))
        ',to)))
@@ -1486,6 +1501,6 @@
         `(array-%%typep ,thing ,ctype))))))
 
-                              
-  
+
+
 (defun optimize-typep (thing type env)
   ;; returns a new form, or nil if it can't optimize
@@ -1514,8 +1529,8 @@
                            (t nil)))
                     ((consp type)
-                     (cond 
+                     (cond
                        ((info-type-builtin type) ; byte types
                         `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
-                       (t 
+                       (t
                         (case (%car type)
                           (satisfies `(funcall ',(cadr type) ,thing))
@@ -1689,5 +1704,5 @@
 
 
-                       
+
 (defsynonym %get-unsigned-byte %get-byte)
 (defsynonym %get-unsigned-word %get-word)
@@ -1796,5 +1811,5 @@
          (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
          (useful (unless (or (eq type *) (eq type t))
-                   type)))  
+                   type)))
     (if (= 2 (length subscripts))
       (setq call `(%aref2 ,a ,@subscripts))
@@ -1893,5 +1908,5 @@
 
 
-(define-compiler-macro integerp (thing)  
+(define-compiler-macro integerp (thing)
   (let* ((typecode (gensym))
          (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*)))
@@ -1929,5 +1944,5 @@
                            (ash 1 x8664::subtag-double-float)
                            (ash 1 x8664::subtag-ratio))))))))
-        
+
 (define-compiler-macro %composite-pointer-ref (size pointer offset)
   (if (constantp size)
@@ -2029,5 +2044,5 @@
 
 (define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env)
-  
+
   (cond ((and (typep other 'single-float)
               (nx-form-typep number 'double-float env))
@@ -2106,12 +2121,3 @@
         (and (integerp ,val) (not (< ,val 0)))))))
 
-
-
 (provide "OPTIMIZERS")
-
-
-
-
-
-
-