Changeset 8032

Timestamp:

Jan 10, 2008, 12:04:24 AM (17 years ago)

Author:

Gary Byers

Message:

Handle unquoted type T in TYPEP.

In REQUIRE-TYPE, don't devolve to %REQUIRE-TYPE just because we
have a predicate; TYPEP can often use that predicate inline.

Provide a compiler-macro for UNSIGNED-BYTE-P: some code does
typechecking before that's defined as a function.

File:

• branches/working-0711/ccl/compiler/optimizers.lisp (modified) (4 diffs)

branches/working-0711/ccl/compiler/optimizers.lisp

@@ -919 +919 @@
 ;;; (<typecheck> foo)).
 (define-compiler-macro require-type (&whole call &environment env arg type)
-  (cond ((and (quoted-form-p type)
-              (setq type (%cadr type))
+  (cond ((and (or (eq type t)
+                  (and (quoted-form-p type)
+                       (setq type (%cadr type))))
               (not (typep (specifier-type type) 'unknown-ctype)))        
          (cond ((nx-form-typep arg type env) arg)
@@ -964 +965 @@
                ((type= (specifier-type type)
                        (specifier-type '(unsigned-byte 64)))
-                `(the (unsigned-byte 64) (require-u64 ,arg)))               
+                `(the (unsigned-byte 64) (require-u64 ,arg)))
+               #+nil
                ((and (symbolp type)
                      (let ((simpler (type-predicate type)))
                        (if simpler `(the ,type (%require-type ,arg ',simpler))))))
+               #+nil
                ((and (symbolp type)(find-class type nil env))
                   `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
@@ -1530 +1533 @@
   (declare (ignore e))
   (if (quoted-form-p type)
-    (or (optimize-typep thing (%cadr type) env)
-        call)
+    (if (constantp thing)
+      (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type))
+      (or (optimize-typep thing (%cadr type) env)
+          call))
     (if (eq type t)
       `(progn ,thing t)
@@ -2013 +2018 @@
     call))
 
+(define-compiler-macro instance-slots (&whole w instance)
+  (if (and (constantp instance)
+           (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance)))
+    `(instance.slots ,instance)
+    w))
+
+(define-compiler-macro unsigned-byte-p (x)
+  (if (typep (nx-unquote x) 'unsigned-byte)
+    t
+    (let* ((val (gensym)))
+      `(let* ((,val ,x))
+        (and (integerp ,val) (not (< ,val 0)))))))
+
 (provide "OPTIMIZERS")
 
+
+
+
+
+
+