Changeset 10341


Ignore:
Timestamp:
Aug 5, 2008, 9:11:29 AM (11 years ago)
Author:
gb
Message:

Compiler-macros for package-reg stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/optimizers.lisp

    r10319 r10341  
    142142          (return))
    143143        (push key seen)))))
     144
    144145
    145146(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
     
    569570      call)))
    570571
     572(defun string-designator-p (object)
     573  (typecase object
     574    (character t)
     575    (symbol t)
     576    (string t)))
    571577
    572578(define-compiler-macro ldb (&whole call &environment env byte integer)
     
    779785    (let* ((call-list (make-list 6))
    780786           (dims-var (make-symbol "DIMS"))
    781          (let-list (comp-nuke-keys keys
    782                                    '((:adjustable 0)
    783                                      (:fill-pointer 1)
    784                                      (:initial-element 2 3)
    785                                      (:initial-contents 4 5))
    786                                    call-list
    787                                    `((,dims-var ,dims)))))
    788     `(let ,let-list
    789        (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil)))))
     787           (let-list (comp-nuke-keys keys
     788                                     '((:adjustable 0)
     789                                       (:fill-pointer 1)
     790                                       (:initial-element 2 3)
     791                                       (:initial-contents 4 5))
     792                                     call-list
     793                                     `((,dims-var ,dims)))))
     794      `(let ,let-list
     795        (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil)))))
    790796
    791797(defun comp-make-array-1 (dims keys)
     
    19111917    `(eq ,tag (typecode ,lock))))
    19121918
     1919(define-compiler-macro structurep (s)
     1920  (let* ((tag (nx-lookup-target-uvector-subtag :struct)))
     1921    `(eq ,tag (typecode ,s))))
     1922 
     1923
    19131924(define-compiler-macro integerp (thing)
    19141925  (let* ((typecode (gensym))
     
    19361947    (if (null (cdr others))
    19371948      (let* ((third (car others))
    1938              (code (gensym)))
    1939         `(let* ((,code (char-code ,ch)))
    1940           (and (eq ,code (setq ,code (char-code ,other)))
    1941            (eq ,code (char-code ,third)))))
     1949             (code (gensym))
     1950             (code2 (gensym))
     1951             (code3 (gensym)))
     1952        `(let* ((,code (char-code ,ch))
     1953                (,code2 (char-code ,other))
     1954                (,code3 (char-code ,third)))
     1955          (and (eq ,code ,code2)
     1956           (eq ,code2 ,code3))))
    19421957      call)))
    19431958
     
    19561971                (,code3 (%char-code (char-upcase ,third))))
    19571972          (and (eq ,code ,code2)
    1958            (eq ,code2 ,code3))))
     1973           (eq ,code ,code3))))
    19591974      call)))
    19601975
     
    19771992             (code2 (gensym))
    19781993             (code3 (gensym)))
     1994        ;; We have to evaluate all forms for side-effects.
     1995        ;; Hopefully, there won't be any
    19791996        `(let* ((,code (char-code ,ch))
    19801997                (,code2 (char-code ,other))
     
    20942111    w))
    20952112
     2113;;; Try to use "package-references" to speed up package lookup when
     2114;;; a package name is used as a constant argument to some functions.
     2115
     2116(defun package-ref-form (arg)
     2117  (when (and arg (constantp arg) (typep (setq arg (nx-unquote arg))
     2118                                        '(or symbol string)))
     2119    `(load-time-value (register-package-ref ,(string arg)))))
     2120
     2121
     2122
     2123(define-compiler-macro intern (&whole w string &optional package)
     2124  (let* ((ref (package-ref-form package)))
     2125    (if (or ref
     2126            (setq ref (and (consp package)
     2127                           (eq (car package) 'find-package)
     2128                           (consp (cdr package))
     2129                           (null (cddr package))
     2130                           (package-ref-form (cadr package)))))
     2131      `(%pkg-ref-intern ,string ,ref)
     2132      w)))
     2133
     2134(define-compiler-macro find-symbol (&whole w string &optional package)
     2135  (let* ((ref (package-ref-form package)))
     2136    (if (or ref
     2137            (setq ref (and (consp package)
     2138                           (eq (car package) 'find-package)
     2139                           (consp (cdr package))
     2140                           (null (cddr package))
     2141                           (package-ref-form (cadr package)))))
     2142      `(%pkg-ref-find-symbol ,string ,ref)
     2143      w)))
     2144
     2145(define-compiler-macro find-package (&whole w package)
     2146  (let* ((ref (package-ref-form package)))
     2147    (if ref
     2148      `(package-ref.pkg ,ref)
     2149      w)))
     2150
     2151(define-compiler-macro pkg-arg (&whole w package &optional allow-deleted)
     2152  (let* ((ref (unless allow-deleted (package-ref-form package))))
     2153    (if ref
     2154      (let* ((r (gensym)))
     2155        `(let* ((,r ,ref))
     2156          (or (package-ref.pkg ,ref)
     2157           (%kernel-restart $xnopkg (package-ref.pkg ,r)))))
     2158      w)))
    20962159
    20972160
Note: See TracChangeset for help on using the changeset viewer.