Changeset 13031 for release/1.4/source


Ignore:
Timestamp:
Oct 15, 2009, 6:48:26 PM (10 years ago)
Author:
rme
Message:

Trunk changes r12910 through r13030 (need to update interfaces separately).

Location:
release/1.4/source
Files:
38 edited
3 copied

Legend:

Unmodified
Added
Removed
  • release/1.4/source/cocoa-ide/cocoa-editor.lisp

    r12877 r13031  
    25762576                               (lisp-string-from-nsstring
    25772577                                (#/displayName doc))
    2578                                :modes '("Lisp" "Editor"))))
    2579       ;; Cocotron's NSUndoManager implementation causes CPU usage to peg at 90+%
    2580       ;; Remove this when Cocotron issue #273 is fixed
    2581       ;;  (http://code.google.com/p/cocotron/issues/detail?id=273)
    2582       #+cocotron (#/setHasUndoManager: doc nil))
     2578                               :modes '("Lisp" "Editor")))))
    25832579    (with-slots (encoding) doc
    25842580      (setq encoding (or (get-default-encoding) #$NSISOLatin1StringEncoding)))
  • release/1.4/source/cocoa-ide/defsystem.lisp

    r12734 r13031  
    7777    "cocoa-backtrace"
    7878    "inspector"
     79    "project"
    7980    "preferences"
    8081    "processes-window"
  • release/1.4/source/compiler/X86/x86-disassemble.lisp

    r12846 r13031  
    3636(defmethod print-object ((xdi x86-disassembled-instruction) stream)
    3737  (print-unreadable-object (xdi stream :type t :identity t)
    38     (format stream "~a" (x86-di-mnemonic xdi))))
     38    (dolist (p (x86-di-prefixes xdi))
     39      (format stream "(~a) " p))
     40    (format stream "(~a" (x86-di-mnemonic xdi))
     41    (let* ((op0 (x86-di-op0 xdi))
     42           (op1 (x86-di-op1 xdi))
     43           (op2 (x86-di-op2 xdi))
     44           (ds (make-x86-disassembly-state :mode-64 #+x8664-target t
     45                                                    #+x8632-target nil
     46                                           :code-vector nil
     47                                           :code-pointer 0)))
     48      (when op0
     49        (write-x86-lap-operand stream op0 ds)
     50        (when op1
     51          (write-x86-lap-operand stream op1 ds)
     52          (when op2
     53            (write-x86-lap-operand stream op2 ds)))))
     54    (format stream ")")))
    3955
    4056(defstruct (x86-disassembly-state (:conc-name x86-ds-))
     
    27812797    (format t "  (~a" (x86-di-mnemonic instruction))
    27822798    (let* ((op0 (x86-di-op0 instruction))
    2783            (op1 (x86-di-op1 instruction))
    2784            (op2 (x86-di-op2 instruction)))
     2799           (op1 (x86-di-op1 instruction))
     2800           (op2 (x86-di-op2 instruction)))
    27852801      (when op0
    2786         (write-x86-lap-operand t op0 ds)
    2787         (when op1
    2788         (write-x86-lap-operand t op1 ds)
    2789           (when op2
    2790             (write-x86-lap-operand t op2 ds)))))
     2802        (write-x86-lap-operand t op0 ds)
     2803        (when op1
     2804          (write-x86-lap-operand t op1 ds)
     2805          (when op2
     2806            (write-x86-lap-operand t op2 ds)))))
    27912807    (format t ")")
    27922808    (format t "~%")
  • release/1.4/source/compiler/nx-basic.lisp

    r12861 r13031  
    584584    (setq env (lexenv.parent-env env))))
    585585
    586 (defun report-compile-time-argument-mismatch (condition stream)
     586(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition)))
    587587  (destructuring-bind (callee reason args spread-p)
    588588      (compiler-warning-args condition)
     
    591591            callee
    592592            args)
    593     (case (car reason)
     593    (ecase (car reason)
    594594      (:toomany
    595595       (destructuring-bind (provided max)
     
    606606       (destructuring-bind (badguy goodguys)
    607607           (cdr reason)
    608          (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~s, which are recognized~&  by "
    609                  (consp badguy) badguy goodguys))))
     608         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by "
     609                 (consp badguy) badguy goodguys)))
     610      (:unknown-gf-keywords
     611         (let ((badguys (cadr reason)))
     612           (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys)))
     613           (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by "
     614
     615                   (consp badguys) badguys))))
    610616    (format stream
    611             (ecase (compiler-warning-warning-type condition)       
     617            (ecase type
    612618              (:ftype-mismatch "the FTYPE declaration of ~s")
    613619              (:global-mismatch "the current global definition of ~s")
    614620              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
    615               (:lexical-mismatch "the lexically visible definition of ~s"))
     621              (:lexical-mismatch "the lexically visible definition of ~s")
     622              ;; This can happen when compiling without compilation unit:
     623              (:deferred-mismatch "~s"))
    616624            callee)))
    617625
     
    620628    (:unused . "Unused lexical variable ~S")
    621629    (:ignore . "Variable ~S not ignored.")
    622     (:undefined-function . "Undefined function ~S") ;; (not reported if defined later)
    623     (:undefined-type . "Undefined type ~S")         ;; (not reported if defined later)
     630    (:undefined-function . "Undefined function ~S") ;; (deferred)
     631    (:undefined-type . "Undefined type ~S")         ;; (deferred)
    624632    (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored")
    625633    (:bad-declaration . "Unknown or invalid declaration ~S")
     
    633641    (:lexical-mismatch . report-compile-time-argument-mismatch)   
    634642    (:ftype-mismatch . report-compile-time-argument-mismatch)
     643    (:deferred-mismatch . report-compile-time-argument-mismatch)
    635644    (:type . "Type declarations violated in ~S")
    636645    (:type-conflict . "Conflicting type declarations for ~S")
    637646    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
    638647    (:lambda . "Suspicious lambda-list: ~s")
     648    (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods")
     649    (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s")
     650    (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions")
    639651    (:result-ignored . "Function result ignored in call to ~s")
    640652    (:duplicate-definition . report-compile-time-duplicate-definition)
  • release/1.4/source/compiler/nx.lisp

    r12500 r13031  
    199199  '((:undefined-function . undefined-function-reference)
    200200    (:undefined-type . undefined-type-reference)
     201    (:deferred-mismatch . undefined-keyword-reference)
    201202    (:invalid-type . invalid-type-warning)
    202203    (:global-mismatch . invalid-arguments-global)
  • release/1.4/source/compiler/nx0.lisp

    r12861 r13031  
    20972097
    20982098(defun innermost-lfun-bits-keyvect (def)
    2099   (declare (notinline innermost-lfun-bits-keyvect))
    21002099  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
    21012100         (bits (lfun-bits inner-def))
    21022101         (keys (lfun-keyvect inner-def)))
    21032102    (declare (fixnum bits))
     2103    #+no
    21042104    (when (and (eq (ash 1 $lfbits-gfn-bit)
    21052105                   (logand bits (logior (ash 1 $lfbits-gfn-bit)
     
    21102110    (values bits keys)))
    21112111
     2112(defun def-info-bits-keyvect (info)
     2113  (let ((bits (def-info.lfbits info)))
     2114    (when (and (eq (def-info.function-type info) 'defgeneric)
     2115               (logbitp $lfbits-keys-bit bits)
     2116               (not (logbitp $lfbits-aok-bit bits))
     2117               #-BOOTSTRAPPED (fboundp 'def-info-method.keyvect)
     2118               (loop for m in (def-info.methods info)
     2119                     thereis (null (def-info-method.keyvect m))))
     2120      ;; Some method has &aok, don't bother checking keywords.
     2121      (setq bits (logior bits (ash 1 $lfbits-aok-bit))))
     2122    (values bits (def-info.keyvect info))))
     2123
    21122124
    21132125(defun nx1-check-call-args (def arglist spread-p)
    2114   (let* ((deftype (if (functionp def)
    2115                     :global-mismatch
    2116                     (if (istruct-typep def 'afunc)
    2117                       :lexical-mismatch
    2118                       :environment-mismatch)))
    2119          (reason nil))
    2120     (multiple-value-bind (bits keyvect)
    2121                          (case deftype
    2122                            (:global-mismatch (innermost-lfun-bits-keyvect def))
    2123                            (:environment-mismatch
    2124                               (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
    2125                            (t (let* ((lambda-form (afunc-lambdaform def)))
    2126                                 (if (lambda-expression-p lambda-form)
    2127                                   (encode-lambda-list (cadr lambda-form))))))
    2128       (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
    2129       (when reason
    2130         (values deftype reason)))))
    2131 
    2132 (defun nx1-check-call-bits (bits keyvect arglist spread-p)
    2133   (when bits
    2134     (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
    2135     (let* ((env *nx-lexical-environment*)
    2136            (nargs (length arglist))
    2137            (minargs (if spread-p (1- nargs) nargs))
    2138            (required (ldb $lfbits-numreq bits))
    2139            (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
    2140                   nil
    2141                   (+ required (ldb $lfbits-numopt bits)))))
    2142       ;; If the (apparent) number of args in the call doesn't
    2143       ;; match the definition, complain.  If "spread-p" is true,
    2144       ;; we can only be sure of the case when more than the
    2145       ;; required number of args have been supplied.
    2146       (or (and (not spread-p)
    2147                (< minargs required)
    2148                `(:toofew ,minargs ,required))
    2149           (and max
    2150                (> minargs max)
    2151                (list :toomany nargs max))
    2152           (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
    2153 
    2154 (defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
    2155   (declare (fixnum bits))
    2156   (when (logbitp $lfbits-aok-bit bits)
    2157     (setq keyvect nil))                 ; only check for even length tail
    2158   (when (and (logbitp $lfbits-keys-bit bits)
    2159              (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
    2160     (do* ((bad-keys nil)
    2161           (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
    2162           (key-args key-values  (cddr key-args)))
    2163          ((null key-args)
    2164           (when (and keyvect bad-keys)
    2165             (list :unknown-keyword
    2166                   (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
    2167                   (coerce keyvect 'list))))
    2168       (unless (cdr key-args)
    2169         (return (list :odd-keywords key-values)))
    2170       (when keyvect
    2171         (let* ((keyword (%car key-args)))
    2172           (unless (nx-form-constant-p keyword env)
    2173             (return nil))
    2174           (setq keyword (nx-form-constant-value keyword env))
    2175           (if (eq keyword :allow-other-keys)
    2176             (setq keyvect nil)
    2177             (unless (position keyword keyvect)
    2178               (push keyword bad-keys))))))))
     2126  (multiple-value-bind (bits keyvect)
     2127      (etypecase def
     2128        (function (innermost-lfun-bits-keyvect def))
     2129        (afunc (let ((lambda-form (afunc-lambdaform def)))
     2130                 (and (lambda-expression-p lambda-form)
     2131                      (encode-lambda-list (cadr lambda-form) t))))
     2132        (cons (def-info-bits-keyvect (cdr def))))
     2133    (when bits
     2134      (multiple-value-bind (reason defer-p)
     2135          (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred
     2136              (nx1-check-call-keywords def bits keyvect arglist spread-p))
     2137        (when reason
     2138          #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference nil)
     2139                           (return-from nx1-check-call-args nil))
     2140          (values (if defer-p
     2141                    :deferred-mismatch
     2142                    (typecase def
     2143                      (function :global-mismatch)
     2144                      (afunc :lexical-mismatch)
     2145                      (t :environment-mismatch)))
     2146                  reason))))))
     2147
     2148(defun nx1-check-call-bits (bits arglist spread-p)
     2149  (let* ((nargs (length arglist))
     2150         (minargs (if spread-p (1- nargs) nargs))
     2151         (required (ldb $lfbits-numreq bits))
     2152         (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
     2153                nil
     2154                (+ required (ldb $lfbits-numopt bits)))))
     2155    ;; If the (apparent) number of args in the call doesn't
     2156    ;; match the definition, complain.  If "spread-p" is true,
     2157    ;; we can only be sure of the case when more than the
     2158    ;; required number of args have been supplied.
     2159    (or (and (not spread-p)
     2160             (< minargs required)
     2161             `(:toofew ,minargs ,required))
     2162        (and max
     2163             (> minargs max)
     2164             `(:toomany ,nargs ,max)))))
     2165
     2166(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *nx-lexical-environment*))
     2167  ;; Ok, if generic function, bits and keyvect are for the generic function itself.
     2168  ;; Still, since all congruent, can check whether have variable numargs
     2169  (unless (and (logbitp $lfbits-keys-bit bits)
     2170               (not spread-p)) ; last argform may contain :allow-other-keys
     2171    (return-from nx1-check-call-keywords nil))
     2172  (let* ((bad-keys nil)
     2173         (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args))
     2174         (generic-p (or (generic-function-p def)
     2175                        (and (consp def)
     2176                             (eq (def-info.function-type (cdr def)) 'defgeneric)))))
     2177    (when (oddp (length key-args))
     2178      (return-from nx1-check-call-keywords (list :odd-keywords key-args)))
     2179    (when (logbitp $lfbits-aok-bit bits)
     2180      (return-from nx1-check-call-keywords nil))
     2181    (loop for key-form in key-args by #'cddr
     2182          do (unless (nx-form-constant-p key-form env) ;; could be :aok
     2183               (return-from nx1-check-call-keywords nil))
     2184          do (let ((key (nx-form-constant-value key-form env)))
     2185               (when (eq key :allow-other-keys)
     2186                 (return-from nx1-check-call-keywords nil))
     2187               (unless (or (find key keyvect)
     2188                          (and generic-p (nx1-valid-gf-keyword-p def key)))
     2189                 (push key bad-keys))))
     2190    (when bad-keys
     2191      (if generic-p
     2192        (values (list :unknown-gf-keywords bad-keys) t)
     2193        (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys)) keyvect)))))
     2194
     2195(defun nx1-valid-gf-keyword-p (def key)
     2196  ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit
     2197  (if (consp def)
     2198    (let ((definfo (cdr def)))
     2199      (assert (eq (def-info.function-type definfo) 'defgeneric))
     2200      (loop for m in (def-info.methods definfo)
     2201            as keyvect = (def-info-method.keyvect m)
     2202            thereis (or (null keyvect) (find key keyvect))))
     2203    (let ((gf (find-unencapsulated-definition def)))
     2204      (or (find key (%defgeneric-keys gf))
     2205          (loop for m in (%gf-methods gf)
     2206                thereis (let* ((func (%inner-method-function m))
     2207                               (mbits (lfun-bits func)))
     2208                          (or (and (logbitp $lfbits-aok-bit mbits)
     2209                                   ;; If no &rest, then either don't use the keyword in which case
     2210                                   ;; it's good to warn; or it's used via next-method, we'll approve
     2211                                   ;; it when we get to that method.
     2212                                   (logbitp $lfbits-rest-bit mbits))
     2213                              (find key (lfun-keyvect func)))))))))
    21792214
    21802215;;; we can save some space by going through subprims to call "builtin"
  • release/1.4/source/doc/ccl-documentation.html

    r12730 r13031  
    1262512625                  </dt>
    1262612626                  <dd>
    12627                     <p>Equivalent to (%ptr-to-int 0).</p>
     12627                    <p>Equivalent to (%int-to-ptr 0).</p>
    1262812628                  </dd>
    1262912629                </dl>
     
    1693416934              </div>
    1693516935            </div>
    16936             <p xmlns="http://www.w3.org/1999/xhtml">Fixnums on 32-bit systems use 30 bits and are in the
    16937             range XXX through YYY.  Fixnums on 64-bit systems use 61-bits
    16938             and are in the range XXX through YYY. (see <a href="#Tagging-scheme" title="16.2.4. Tagging scheme">Section 16.2.4, “Tagging scheme”</a>)</p>
     16936            <p xmlns="http://www.w3.org/1999/xhtml">Fixnums on 32-bit systems are 30 bits long, and are in the
     16937          range -536870912 through 536870911.  Fixnums on 64-bit
     16938          systems are 61 bits long, and are in the range
     16939          -1152921504606846976 through 1152921504606846975. (see <a href="#Tagging-scheme" title="16.2.4. Tagging scheme">Section 16.2.4, “Tagging scheme”</a>)</p>
    1693916940            <p xmlns="http://www.w3.org/1999/xhtml">Since we have much larger fixnums on 64-bit systems,
    1694016941            <em class="varname">INTERNAL-TIME-UNITS-PER-SECOND</em> is 1000000
     
    1739917400            <div>
    1740017401              <div class="refsect1" lang="en" xml:lang="en">
    17401                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397124"></a>
     17402                <a xmlns="http://www.w3.org/1999/xhtml" id="id397123"></a>
    1740217403                <div class="header">Arguments and Values:</div>
    1740317404                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">name</span></i>---a string which is the name of an existing
     
    1740917410              </div>
    1741017411              <div class="refsect1" lang="en" xml:lang="en">
    17411                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397169"></a>
     17412                <a xmlns="http://www.w3.org/1999/xhtml" id="id397168"></a>
    1741217413                <div class="header">Description:</div>
    1741317414                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1743017431            <div>
    1743117432              <div class="refsect1" lang="en" xml:lang="en">
    17432                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397230"></a>
     17433                <a xmlns="http://www.w3.org/1999/xhtml" id="id397229"></a>
    1743317434                <div class="header">Arguments and Values:</div>
    1743417435                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">name</span></i>---a string which is the name of a new or existing
     
    1744317444              </div>
    1744417445              <div class="refsect1" lang="en" xml:lang="en">
    17445                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397290"></a>
     17446                <a xmlns="http://www.w3.org/1999/xhtml" id="id397289"></a>
    1744617447                <div class="header">Description:</div>
    1744717448                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1746717468            <div>
    1746817469              <div class="refsect1" lang="en" xml:lang="en">
    17469                 <a xmlns="http://www.w3.org/1999/xhtml" id="id396617"></a>
     17470                <a xmlns="http://www.w3.org/1999/xhtml" id="id396616"></a>
    1747017471                <div class="header">Values:</div>
    1747117472                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">path</span></i>---a string, an absolute pathname in Posix format - with
     
    1747317474              </div>
    1747417475              <div class="refsect1" lang="en" xml:lang="en">
    17475                 <a xmlns="http://www.w3.org/1999/xhtml" id="id396644"></a>
     17476                <a xmlns="http://www.w3.org/1999/xhtml" id="id396643"></a>
    1747617477                <div class="header">Description:</div>
    1747717478                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1749517496            <div>
    1749617497              <div class="refsect1" lang="en" xml:lang="en">
    17497                 <a xmlns="http://www.w3.org/1999/xhtml" id="id396703"></a>
     17498                <a xmlns="http://www.w3.org/1999/xhtml" id="id396702"></a>
    1749817499                <div class="header">Values:</div>
    1749917500                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">uid</span></i>---a non-negative integer, identifying a specific user
     
    1750117502              </div>
    1750217503              <div class="refsect1" lang="en" xml:lang="en">
    17503                 <a xmlns="http://www.w3.org/1999/xhtml" id="id396730"></a>
     17504                <a xmlns="http://www.w3.org/1999/xhtml" id="id396729"></a>
    1750417505                <div class="header">Description:</div>
    1750517506                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1752117522            <div>
    1752217523              <div class="refsect1" lang="en" xml:lang="en">
    17523                 <a xmlns="http://www.w3.org/1999/xhtml" id="id396787"></a>
     17524                <a xmlns="http://www.w3.org/1999/xhtml" id="id396786"></a>
    1752417525                <div class="header">Arguments and Values:</div>
    1752517526                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">uid</span></i>---a non-negative integer, identifying a specific user
     
    1753017531              </div>
    1753117532              <div class="refsect1" lang="en" xml:lang="en">
    17532                 <a xmlns="http://www.w3.org/1999/xhtml" id="id396830"></a>
     17533                <a xmlns="http://www.w3.org/1999/xhtml" id="id396829"></a>
    1753317534                <div class="header">Description:</div>
    1753417535                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1755317554            <div>
    1755417555              <div class="refsect1" lang="en" xml:lang="en">
    17555                 <a xmlns="http://www.w3.org/1999/xhtml" id="id410161"></a>
     17556                <a xmlns="http://www.w3.org/1999/xhtml" id="id410160"></a>
    1755617557                <div class="header">Arguments and Values:</div>
    1755717558                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">gid</span></i>---a non-negative integer, identifying a specific
     
    1756217563              </div>
    1756317564              <div class="refsect1" lang="en" xml:lang="en">
    17564                 <a xmlns="http://www.w3.org/1999/xhtml" id="id410204"></a>
     17565                <a xmlns="http://www.w3.org/1999/xhtml" id="id410202"></a>
    1756517566                <div class="header">Description:</div>
    1756617567                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1758517586            <div>
    1758617587              <div class="refsect1" lang="en" xml:lang="en">
    17587                 <a xmlns="http://www.w3.org/1999/xhtml" id="id410263"></a>
     17588                <a xmlns="http://www.w3.org/1999/xhtml" id="id410262"></a>
    1758817589                <div class="header">Values:</div>
    1758917590                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">pid</span></i>---a non-negative integer, identifying an OS process</p>
    1759017591              </div>
    1759117592              <div class="refsect1" lang="en" xml:lang="en">
    17592                 <a xmlns="http://www.w3.org/1999/xhtml" id="id410289"></a>
     17593                <a xmlns="http://www.w3.org/1999/xhtml" id="id410288"></a>
    1759317594                <div class="header">Description:</div>
    1759417595                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1761117612            <div>
    1761217613              <div class="refsect1" lang="en" xml:lang="en">
    17613                 <a xmlns="http://www.w3.org/1999/xhtml" id="id410346"></a>
     17614                <a xmlns="http://www.w3.org/1999/xhtml" id="id410345"></a>
    1761417615                <div class="header">Values:</div>
    1761517616                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">uid</span></i>---a non-negative integer, identifying a specific user
     
    1761917620              </div>
    1762017621              <div class="refsect1" lang="en" xml:lang="en">
    17621                 <a xmlns="http://www.w3.org/1999/xhtml" id="id408852"></a>
     17622                <a xmlns="http://www.w3.org/1999/xhtml" id="id408851"></a>
    1762217623                <div class="header">Description:</div>
    1762317624                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1764417645            <div>
    1764517646              <div class="refsect1" lang="en" xml:lang="en">
    17646                 <a xmlns="http://www.w3.org/1999/xhtml" id="id408921"></a>
     17647                <a xmlns="http://www.w3.org/1999/xhtml" id="id408920"></a>
    1764717648                <div class="header">Values:</div>
    1764817649                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">command-line</span></i>---a string, obeying all the whitespace and
     
    1765317654              </div>
    1765417655              <div class="refsect1" lang="en" xml:lang="en">
    17655                 <a xmlns="http://www.w3.org/1999/xhtml" id="id408963"></a>
     17656                <a xmlns="http://www.w3.org/1999/xhtml" id="id408962"></a>
    1765617657                <div class="header">Description:</div>
    1765717658                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1766917670              </div>
    1767017671              <div class="refsect1" lang="en" xml:lang="en">
    17671                 <a xmlns="http://www.w3.org/1999/xhtml" id="id408997"></a>
     17672                <a xmlns="http://www.w3.org/1999/xhtml" id="id408996"></a>
    1767217673                <div class="header">Notes:</div>
    1767317674                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1769417695            <div>
    1769517696              <div class="refsect1" lang="en" xml:lang="en">
    17696                 <a xmlns="http://www.w3.org/1999/xhtml" id="id409057"></a>
     17697                <a xmlns="http://www.w3.org/1999/xhtml" id="id409056"></a>
    1769717698                <div class="header">Arguments and Values:</div>
    1769817699                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">class-name</span></i>---a string which denotes an existing class name, or a
     
    1770117702              </div>
    1770217703              <div class="refsect1" lang="en" xml:lang="en">
    17703                 <a xmlns="http://www.w3.org/1999/xhtml" id="id409085"></a>
     17704                <a xmlns="http://www.w3.org/1999/xhtml" id="id409084"></a>
    1770417705                <div class="header">Description:</div>
    1770517706                <p xmlns="http://www.w3.org/1999/xhtml">Used to refer to a known ObjC class by name. (Via the use
     
    1772617727            <div>
    1772717728              <div class="refsect1" lang="en" xml:lang="en">
    17728                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397372"></a>
     17729                <a xmlns="http://www.w3.org/1999/xhtml" id="id397371"></a>
    1772917730                <div class="header">Arguments and Values:</div>
    1773017731                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">string</span></i>---a string constant, used to canonically refer to an
     
    1773217733              </div>
    1773317734              <div class="refsect1" lang="en" xml:lang="en">
    17734                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397398"></a>
     17735                <a xmlns="http://www.w3.org/1999/xhtml" id="id397396"></a>
    1773517736                <div class="header">Description:</div>
    1773617737                <p xmlns="http://www.w3.org/1999/xhtml">Used to refer to an ObjC method selector (method name). Uses
     
    1775417755            <div>
    1775517756              <div class="refsect1" lang="en" xml:lang="en">
    17756                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397464"></a>
     17757                <a xmlns="http://www.w3.org/1999/xhtml" id="id397462"></a>
    1775717758                <div class="header">Arguments and Values:</div>
    1775817759                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">name-and-result-type</span></i>---either an Objective-C message name, for methods
     
    1777617777              </div>
    1777717778              <div class="refsect1" lang="en" xml:lang="en">
    17778                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397545"></a>
     17779                <a xmlns="http://www.w3.org/1999/xhtml" id="id397543"></a>
    1777917780                <div class="header">Description:</div>
    1778017781                <p xmlns="http://www.w3.org/1999/xhtml">Defines an Objective-C-callable method which implements
     
    1780117802            <div>
    1780217803              <div class="refsect1" lang="en" xml:lang="en">
    17803                 <a xmlns="http://www.w3.org/1999/xhtml" id="id397628"></a>
     17804                <a xmlns="http://www.w3.org/1999/xhtml" id="id397626"></a>
    1780417805                <div class="header">Arguments and Values:</div>
    1780517806                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">selector</span></i>---either a string which represents the name of the
     
    1783717838            <div>
    1783817839              <div class="refsect1" lang="en" xml:lang="en">
    17839                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411348"></a>
     17840                <a xmlns="http://www.w3.org/1999/xhtml" id="id411346"></a>
    1784017841                <div class="header">Arguments and Values:</div>
    1784117842                <p xmlns="http://www.w3.org/1999/xhtml">As per DEFINE-OBJC-METHOD</p>
    1784217843              </div>
    1784317844              <div class="refsect1" lang="en" xml:lang="en">
    17844                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411359"></a>
     17845                <a xmlns="http://www.w3.org/1999/xhtml" id="id411358"></a>
    1784517846                <div class="header">Description:</div>
    1784617847                <p xmlns="http://www.w3.org/1999/xhtml">Like DEFINE-OBJC-METHOD, only used to define methods on the
     
    1788417885            <div>
    1788517886              <div class="refsect1" lang="en" xml:lang="en">
    17886                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411435"></a>
     17887                <a xmlns="http://www.w3.org/1999/xhtml" id="id411434"></a>
    1788717888                <div class="header">Description:</div>
    1788817889                <p xmlns="http://www.w3.org/1999/xhtml">This variable is currently only used by the standard reader macro
     
    1791917920            <div>
    1792017921              <div class="refsect1" lang="en" xml:lang="en">
    17921                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411493"></a>
     17922                <a xmlns="http://www.w3.org/1999/xhtml" id="id411492"></a>
    1792217923                <div class="header">Description:</div>
    1792317924                <p xmlns="http://www.w3.org/1999/xhtml">Per ANSI CL, Clozure CL supports the :EXTERNAL-FORMAT keyword
     
    1796317964            <div>
    1796417965              <div class="refsect1" lang="en" xml:lang="en">
    17965                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411573"></a>
     17966                <a xmlns="http://www.w3.org/1999/xhtml" id="id411572"></a>
    1796617967                <div class="header">Description:</div>
    1796717968                <p xmlns="http://www.w3.org/1999/xhtml">The value of this variable is used when :EXTERNAL-FORMAT is
     
    1798717988            <div>
    1798817989              <div class="refsect1" lang="en" xml:lang="en">
    17989                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411623"></a>
     17990                <a xmlns="http://www.w3.org/1999/xhtml" id="id411622"></a>
    1799017991                <div class="header">Superclasses:</div>
    1799117992                <p xmlns="http://www.w3.org/1999/xhtml">NS:NS-STRING</p>
    1799217993              </div>
    1799317994              <div class="refsect1" lang="en" xml:lang="en">
    17994                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411634"></a>
     17995                <a xmlns="http://www.w3.org/1999/xhtml" id="id411633"></a>
    1799517996                <div class="header">Initargs:</div>
    1799617997                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">:string</span></i>---
     
    1800018001              </div>
    1800118002              <div class="refsect1" lang="en" xml:lang="en">
    18002                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411661"></a>
     18003                <a xmlns="http://www.w3.org/1999/xhtml" id="id411660"></a>
    1800318004                <div class="header">Description:</div>
    1800418005                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1801818019              </div>
    1801918020              <div class="refsect1" lang="en" xml:lang="en">
    18020                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411681"></a>
     18021                <a xmlns="http://www.w3.org/1999/xhtml" id="id411680"></a>
    1802118022                <div class="header">Examples:</div>
    1802218023                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1804918050              </div>
    1805018051              <div class="refsect1" lang="en" xml:lang="en">
    18051                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394242"></a>
     18052                <a xmlns="http://www.w3.org/1999/xhtml" id="id394241"></a>
    1805218053                <div class="header">Notes:</div>
    1805318054                <p xmlns="http://www.w3.org/1999/xhtml">
     
    1838918390            <div>
    1839018391              <div class="refsect1" lang="en" xml:lang="en">
    18391                 <a xmlns="http://www.w3.org/1999/xhtml" id="id411950"></a>
     18392                <a xmlns="http://www.w3.org/1999/xhtml" id="id411949"></a>
    1839218393                <div class="header">Arguments and Values:</div>
    1839318394                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">type</span></i>---The type of population, one of <code xmlns="http://www.w3.org/1999/xhtml" class="literal">:LIST</code> (the default) or <code xmlns="http://www.w3.org/1999/xhtml" class="literal">:ALIST</code></p>
     
    1839718398              </div>
    1839818399              <div class="refsect1" lang="en" xml:lang="en">
    18399                 <a xmlns="http://www.w3.org/1999/xhtml" id="id412009"></a>
     18400                <a xmlns="http://www.w3.org/1999/xhtml" id="id412008"></a>
    1840018401                <div class="header">Description:</div>
    1840118402                <p xmlns="http://www.w3.org/1999/xhtml">Creates a new population of the specified type.</p>
     
    1841518416            <div>
    1841618417              <div class="refsect1" lang="en" xml:lang="en">
    18417                 <a xmlns="http://www.w3.org/1999/xhtml" id="id412066"></a>
     18418                <a xmlns="http://www.w3.org/1999/xhtml" id="id412065"></a>
    1841818419                <div class="header">Description:</div>
    1841918420                <p xmlns="http://www.w3.org/1999/xhtml">returns the type of <code class="literal">population</code>, one of <code class="literal">:LIST</code> or <code class="literal">:ALIST</code></p>
     
    1843318434            <div>
    1843418435              <div class="refsect1" lang="en" xml:lang="en">
    18435                 <a xmlns="http://www.w3.org/1999/xhtml" id="id393854"></a>
     18436                <a xmlns="http://www.w3.org/1999/xhtml" id="id393852"></a>
    1843618437                <div class="header">Description:</div>
    1843718438                <p xmlns="http://www.w3.org/1999/xhtml">returns the list encapsulated in <code class="literal">population</code>.
     
    1845618457            <div>
    1845718458              <div class="refsect1" lang="en" xml:lang="en">
    18458                 <a xmlns="http://www.w3.org/1999/xhtml" id="id412232"></a>
     18459                <a xmlns="http://www.w3.org/1999/xhtml" id="id412231"></a>
    1845918460                <div class="header">Description:</div>
    1846018461                <p xmlns="http://www.w3.org/1999/xhtml">Sets the list encapsulated in <code class="literal">population</code> to
     
    1851018511            <div>
    1851118512              <div class="refsect1" lang="en" xml:lang="en">
    18512                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394272"></a>
     18513                <a xmlns="http://www.w3.org/1999/xhtml" id="id394270"></a>
    1851318514                <div class="header">Arguments and Values:</div>
    1851418515                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">new-threshold</span></i>---The requested new lisp-heap-gc-threshold.</p>
    1851518516              </div>
    1851618517              <div class="refsect1" lang="en" xml:lang="en">
    18517                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394298"></a>
     18518                <a xmlns="http://www.w3.org/1999/xhtml" id="id394296"></a>
    1851818519                <div class="header">Description:</div>
    1851918520                <p xmlns="http://www.w3.org/1999/xhtml">Sets the value of the kernel variable that specifies the
     
    1853918540            <div>
    1854018541              <div class="refsect1" lang="en" xml:lang="en">
    18541                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394360"></a>
     18542                <a xmlns="http://www.w3.org/1999/xhtml" id="id394358"></a>
    1854218543                <div class="header">Description:</div>
    1854318544                <p xmlns="http://www.w3.org/1999/xhtml">Tries to grow or shrink lisp's heap space, so that the
     
    1855918560            <div>
    1856018561              <div class="refsect1" lang="en" xml:lang="en">
    18561                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394418"></a>
     18562                <a xmlns="http://www.w3.org/1999/xhtml" id="id394416"></a>
    1856218563                <div class="header">Arguments and Values:</div>
    1856318564                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">arg</span></i>---a generalized boolean</p>
    1856418565              </div>
    1856518566              <div class="refsect1" lang="en" xml:lang="en">
    18566                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394444"></a>
     18567                <a xmlns="http://www.w3.org/1999/xhtml" id="id394442"></a>
    1856718568                <div class="header">Description:</div>
    1856818569                <p xmlns="http://www.w3.org/1999/xhtml">Enables the EGC if arg is non-nil, disables the EGC
     
    1859018591            <div>
    1859118592              <div class="refsect1" lang="en" xml:lang="en">
    18592                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394503"></a>
     18593                <a xmlns="http://www.w3.org/1999/xhtml" id="id394501"></a>
    1859318594                <div class="header">Description:</div>
    1859418595                <p xmlns="http://www.w3.org/1999/xhtml">Returns T if the EGC was enabled at the time of the call,
     
    1861318614            <div>
    1861418615              <div class="refsect1" lang="en" xml:lang="en">
    18615                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394558"></a>
     18616                <a xmlns="http://www.w3.org/1999/xhtml" id="id394557"></a>
    1861618617                <div class="header">Description:</div>
    1861718618                <p xmlns="http://www.w3.org/1999/xhtml">Returns T if the EGC was active at the time of the call, NIL
     
    1863818639            <div>
    1863918640              <div class="refsect1" lang="en" xml:lang="en">
    18640                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394616"></a>
     18641                <a xmlns="http://www.w3.org/1999/xhtml" id="id394615"></a>
    1864118642                <div class="header">Description:</div>
    1864218643                <p xmlns="http://www.w3.org/1999/xhtml">Returns, as multiple values, the sizes in kilobytes of the
     
    1866018661            <div>
    1866118662              <div class="refsect1" lang="en" xml:lang="en">
    18662                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394675"></a>
     18663                <a xmlns="http://www.w3.org/1999/xhtml" id="id394674"></a>
    1866318664                <div class="header">Arguments and Values:</div>
    1866418665                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">generation-0-size</span></i>---the requested threshold size of the youngest
     
    1867018671              </div>
    1867118672              <div class="refsect1" lang="en" xml:lang="en">
    18672                 <a xmlns="http://www.w3.org/1999/xhtml" id="id394730"></a>
     18673                <a xmlns="http://www.w3.org/1999/xhtml" id="id394729"></a>
    1867318674                <div class="header">Description:</div>
    18674                 <p xmlns="http://www.w3.org/1999/xhtml">If the EGC is currently disabled, puts the indicated
    18675           threshold sizes in effect and returns T, otherwise, returns NIL.
     18675                <p xmlns="http://www.w3.org/1999/xhtml">Puts the indicated threshold sizes in effect.
     18676          Each threshold indicates the total size that may be allocated
     18677          in that and all younger generations before a GC is triggered.
     18678          Disables EGC while setting the values.
    1867618679          (The provided threshold sizes are rounded up to a multiple of
    1867718680          64Kbytes in <code class="literal">CCL</code> 0.14 and to a multiple of 32KBytes in earlier
     
    1887718880                <dt>
    1887818881                  <span class="sect2">
    18879                     <a href="#id404491">16.7.2. Recommended Reading</a>
     18882                    <a href="#id404502">16.7.2. Recommended Reading</a>
    1888018883                  </span>
    1888118884                </dt>
     
    2015320156                <li>
    2015420157                  <p>To support a feature called <span class="emphasis"><em>GCTWA
    20155                 <sup>[<a id="id403223" href="#ftn.id403223">1</a>]</sup>
     20158                <sup>[<a id="id403234" href="#ftn.id403234">1</a>]</sup>
    2015620159                    , </em></span>the vector that contains the internal
    2015720160                  symbols of the current package is marked on entry to the
     
    2028620289            <hr width="100" align="left" />
    2028720290            <div xmlns="http://www.w3.org/1999/xhtml" class="footnote">
    20288               <p><sup>[<a id="ftn.id403223" href="#id403223">1</a>] </sup>I believe that the acronym comes from MACLISP,
     20291              <p><sup>[<a id="ftn.id403234" href="#id403234">1</a>] </sup>I believe that the acronym comes from MACLISP,
    2028920292                            where it stood for "Garbage Collection of Truly
    2029020293                            Worthless Atoms".</p>
     
    2034620349        generations looking for such intergenerational references, the
    2034720350        runtime system must note all such intergenerational references
    20348         at the point where they're created (via Setf).<sup>[<a id="id404278" href="#ftn.id404278">2</a>]</sup> The
     20351        at the point where they're created (via Setf).<sup>[<a id="id404289" href="#ftn.id404289">2</a>]</sup> The
    2034920352        set of pointers that may contain intergenerational references is
    2035020353        sometimes called <span class="emphasis"><em>the remembered set</em></span>.</p>
     
    2039320396        that might introduce an intergenerational reference must be
    2039420397        memoized.
    20395         <sup>[<a id="id404347" href="#ftn.id404347">3</a>]</sup> It's always safe to
     20398        <sup>[<a id="id404359" href="#ftn.id404359">3</a>]</sup> It's always safe to
    2039620399        push any cons cell or gvector locative onto the memo stack;
    2039720400        it's never safe to push anything else.
     
    2041420417            <hr width="100" align="left" />
    2041520418            <div xmlns="http://www.w3.org/1999/xhtml" class="footnote">
    20416               <p><sup>[<a id="ftn.id404278" href="#id404278">2</a>] </sup>This is
     20419              <p><sup>[<a id="ftn.id404289" href="#id404289">2</a>] </sup>This is
    2041720420            sometimes called "The Write Barrier": all assignments which
    2041820421            might result in intergenerational references must be noted, as
     
    2042020423            </div>
    2042120424            <div xmlns="http://www.w3.org/1999/xhtml" class="footnote">
    20422               <p><sup>[<a id="ftn.id404347" href="#id404347">3</a>] </sup>Note that the implicit setfs that occur when
     20425              <p><sup>[<a id="ftn.id404359" href="#id404359">3</a>] </sup>Note that the implicit setfs that occur when
    2042320426        initializing an object - as in the case of a call to cons or
    2042420427        vector - can't introduce intergenerational references, since
     
    2053620539              <div>
    2053720540                <div>
    20538                   <h3 class="title"><a id="id404491"></a>16.7.2. Recommended Reading</h3>
     20541                  <h3 class="title"><a id="id404502"></a>16.7.2. Recommended Reading</h3>
    2053920542                </div>
    2054020543              </div>
     
    2094920952            <div>
    2095020953              <div class="refsect1" lang="en" xml:lang="en">
    20951                 <a xmlns="http://www.w3.org/1999/xhtml" id="id362876"></a>
     20954                <a xmlns="http://www.w3.org/1999/xhtml" id="id285538"></a>
    2095220955                <div class="header">Description:</div>
    2095320956                <p xmlns="http://www.w3.org/1999/xhtml">When true, attempts to redefine (via DEFUN or DEFMETHOD)
     
    2097420977            <div>
    2097520978              <div class="refsect1" lang="en" xml:lang="en">
    20976                 <a xmlns="http://www.w3.org/1999/xhtml" id="id396482"></a>
     20979                <a xmlns="http://www.w3.org/1999/xhtml" id="id393300"></a>
    2097720980                <div class="header">Description:</div>
    2097820981                <p xmlns="http://www.w3.org/1999/xhtml">Arranges that the outermost special bindings of *PACKAGE*
     
    2099821001            <div>
    2099921002              <div class="refsect1" lang="en" xml:lang="en">
    21000                 <a xmlns="http://www.w3.org/1999/xhtml" id="id410712"></a>
     21003                <a xmlns="http://www.w3.org/1999/xhtml" id="id395749"></a>
    2100121004                <div class="header">Description:</div>
    2100221005                <p xmlns="http://www.w3.org/1999/xhtml">Arranges that the outermost special bindings of *PACKAGE*
     
    2102121024            <div>
    2102221025              <div class="refsect1" lang="en" xml:lang="en">
    21023                 <a xmlns="http://www.w3.org/1999/xhtml" id="id342136"></a>
     21026                <a xmlns="http://www.w3.org/1999/xhtml" id="id342109"></a>
    2102421027                <div class="header">Description:</div>
    2102521028                <p xmlns="http://www.w3.org/1999/xhtml">This variable is initialized each time an Clozure CL session
     
    2104621049            <div>
    2104721050              <div class="refsect1" lang="en" xml:lang="en">
    21048                 <a xmlns="http://www.w3.org/1999/xhtml" id="id339429"></a>
     21051                <a xmlns="http://www.w3.org/1999/xhtml" id="id397671"></a>
    2104921052                <div class="header">Description:</div>
    2105021053                <p xmlns="http://www.w3.org/1999/xhtml">Returns non-NIL if AltiVec is available.</p>
     
    2106421067            <div>
    2106521068              <div class="refsect1" lang="en" xml:lang="en">
    21066                 <a xmlns="http://www.w3.org/1999/xhtml" id="id379784"></a>
     21069                <a xmlns="http://www.w3.org/1999/xhtml" id="id397714"></a>
    2106721070                <div class="header">Description:</div>
    2106821071                <p xmlns="http://www.w3.org/1999/xhtml">Intended to control the expansion of certain lap macros.
     
    2108621089            <div>
    2108721090              <div class="refsect1" lang="en" xml:lang="en">
    21088                 <a xmlns="http://www.w3.org/1999/xhtml" id="id403499"></a>
     21091                <a xmlns="http://www.w3.org/1999/xhtml" id="id335473"></a>
    2108921092                <div class="header">Arguments and Values:</div>
    2109021093                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">reglist</span></i>---A list of vector register names (vr0 .. vr31).</p>
     
    2109221095              </div>
    2109321096              <div class="refsect1" lang="en" xml:lang="en">
    21094                 <a xmlns="http://www.w3.org/1999/xhtml" id="id403540"></a>
     21097                <a xmlns="http://www.w3.org/1999/xhtml" id="id395300"></a>
    2109521098                <div class="header">Description:</div>
    2109621099                <p xmlns="http://www.w3.org/1999/xhtml">Specifies the set of AltiVec registers used in body. If
     
    2111821121            <div>
    2111921122              <div class="refsect1" lang="en" xml:lang="en">
    21120                 <a xmlns="http://www.w3.org/1999/xhtml" id="id395242"></a>
     21123                <a xmlns="http://www.w3.org/1999/xhtml" id="id379776"></a>
    2112121124                <div class="header">Arguments and Values:</div>
    2112221125                <p><i><span xmlns="http://www.w3.org/1999/xhtml" class="term">base</span></i>---Any available general-purpose register.</p>
     
    2112721130              </div>
    2112821131              <div class="refsect1" lang="en" xml:lang="en">
    21129                 <a xmlns="http://www.w3.org/1999/xhtml" id="id335443"></a>
     21132                <a xmlns="http://www.w3.org/1999/xhtml" id="id379834"></a>
    2113021133                <div class="header">Description:</div>
    2113121134                <p xmlns="http://www.w3.org/1999/xhtml">Generates code which allocates a 16-byte aligned buffer
     
    2177621779      <a href="#Symbol-Index">Symbol Index</a>
    2177721780    </div>
    21778     <p xmlns="http://www.w3.org/TR/xhtml1/transitional" xmlns:date="http://exslt.org/dates-and-times" class="footer">This document was last modified at 20:0 on September 1, 2009, in UTC.<br></br>It uses version 1.72.0 of the Norman Walsh Docbook stylesheets.<br></br>Built from subversion rev 12729<br></br>Using libxml 20629, libxslt 10121 and libexslt 813.</p>
     21781    <p xmlns="http://www.w3.org/TR/xhtml1/transitional" xmlns:date="http://exslt.org/dates-and-times" class="footer">This document was last modified at 5:0 on October 9, 2009, in UTC.<br></br>It uses version 1.72.0 of the Norman Walsh Docbook stylesheets.<br></br>Built from subversion rev 12933<br></br>Using libxml 20629, libxslt 10121 and libexslt 813.</p>
    2177921782  </body>
    2178021783</html>
  • release/1.4/source/doc/src/ffi.xml

    r12330 r13031  
    942942
    943943                <listitem>
    944                       <para>Equivalent to (%ptr-to-int 0).</para>
     944                      <para>Equivalent to (%int-to-ptr 0).</para>
    945945                </listitem>
    946946              </varlistentry>
  • release/1.4/source/doc/src/gc.xml

    r12330 r13031  
    638638          <title>Description</title>
    639639
    640           <para>If the EGC is currently disabled, puts the indicated
    641           threshold sizes in effect and returns T, otherwise, returns NIL.
     640          <para>Puts the indicated threshold sizes in effect.
     641          Each threshold indicates the total size that may be allocated
     642          in that and all younger generations before a GC is triggered.
     643          Disables EGC while setting the values.
    642644          (The provided threshold sizes are rounded up to a multiple of
    643645          64Kbytes in &CCL; 0.14 and to a multiple of 32KBytes in earlier
  • release/1.4/source/doc/src/platform-notes.xml

    r11007 r13031  
    2525          <title>Differences Between 32-bit and 64-bit implementations</title>
    2626
    27           <para>Fixnums on 32-bit systems use 30 bits and are in the
    28             range XXX through YYY.  Fixnums on 64-bit systems use 61-bits
    29             and are in the range XXX through YYY. (see <xref
    30                                                           linkend="Tagging-scheme"/>)</para>
     27          <para>Fixnums on 32-bit systems are 30 bits long, and are in the
     28          range -536870912 through 536870911.  Fixnums on 64-bit
     29          systems are 61 bits long, and are in the range
     30          -1152921504606846976 through 1152921504606846975. (see <xref
     31          linkend="Tagging-scheme"/>)</para>
    3132
    3233          <para>Since we have much larger fixnums on 64-bit systems,
  • release/1.4/source/level-0/X86/X8632/x8632-utils.lisp

    r12837 r13031  
    394394(defx8632lapfunction %watch ((uvector arg_z))
    395395  (check-nargs 1)
    396   ;; May want to tighten this up to disallow watching functions,
    397   ;; symbols, etc.
    398   (trap-unless-lisptag= uvector x8632::tag-misc imm0)
    399396  (movl ($ arch::watch-trap-function-watch) (%l imm0))
    400397  (uuo-watch-trap)
    401   (movl ($ nil) (%l arg_z))
    402398  (single-value-return))
    403399
  • release/1.4/source/level-0/X86/x86-utils.lisp

    r12888 r13031  
    449449  (movl ($ arch::watch-trap-function-watch) (%l imm0))
    450450  (uuo-watch-trap)
    451   (movl ($ nil) (%l arg_z))
    452451  (single-value-return))
    453452
  • release/1.4/source/level-1/l1-aprims.lisp

    r12463 r13031  
    11391139are rounded up to a multiple of 64Kbytes in OpenMCL 0.14 and to a multiple
    11401140of 32KBytes in earlier versions.)"
    1141   (let* ((was-enabled (egc-active-p)))
     1141  (let* ((was-enabled (egc-active-p))
     1142         (e2size (require-type e2size '(unsigned-byte 18)))
     1143         (e1size (require-type e1size '(unsigned-byte 18)))
     1144         (e0size (require-type e0size '(integer 1 #.(ash 1 18)))))
     1145    (unless (<= e0size e1size e2size)
     1146      (error "Generation ~s threshold cannot be smaller than generation ~s threshold"
     1147             (if (> e0size e1size) 1 2) (if (> e0size e1size) 0 1)))
    11421148    (unwind-protect
    11431149         (progn
    11441150           (egc nil)
    1145            (setq e2size (logand (lognot #xffff) (+ #xffff (ash (require-type e2size '(unsigned-byte 18)) 10)))
    1146                  e1size (logand (lognot #xffff) (+ #xffff (ash (require-type e1size '(unsigned-byte 18)) 10)))
    1147                  e0size (logand (lognot #xffff) (+ #xffff (ash (require-type e0size '(integer 1 #.(ash 1 18))) 10))))
     1151           (setq e2size (logand (lognot #xffff) (+ #xffff (ash e2size 10)))
     1152                 e1size (logand (lognot #xffff) (+ #xffff (ash e1size 10)))
     1153                 e0size (logand (lognot #xffff) (+ #xffff (ash e0size 10))))
    11481154           (%configure-egc e0size e1size e2size))
    11491155      (egc was-enabled))))
  • release/1.4/source/level-1/l1-clos-boot.lisp

    r12761 r13031  
    360360        (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits)))
    361361        (if return-keys?
    362           (values bits (apply #'vector (nreverse key-list)))
     362          (values bits (and keyp (apply #'vector (nreverse key-list))))
    363363          bits)))))
    364364
  • release/1.4/source/level-1/l1-error-system.lisp

    r12821 r13031  
    8484(define-condition invalid-arguments (style-warning) ())
    8585(define-condition invalid-arguments-global (style-warning) ())
     86(define-condition undefined-keyword-reference (undefined-reference invalid-arguments) ())
    8687
    8788(define-condition simple-error (simple-condition error) ())
     
    104105
    105106(define-condition write-to-watched-object (storage-condition)
    106   ((address :initarg :address)
    107    (object :initform nil :initarg :object))
    108   (:report (lambda (c s)
    109              (with-slots (object address) c
    110                (if (uvectorp object)
    111                  ;; This is safe only because watched objects are in a
    112                  ;; static GC area and won't be moved around.
    113                  (let* ((size (uvsize object))
    114                         (nbytes (if (ivectorp object)
    115                                   (subtag-bytes (typecode object) size)
    116                                   (* size target::node-size)))
    117                         (bytes-per-element (/ nbytes size))
    118                         (noderef (logandc2 (%address-of object)
    119                                            target::fulltagmask))
    120                         (offset (- address (+ noderef target::node-size)))
    121                         (index (/ offset bytes-per-element)))
    122                    (format s "Write to watched object ~s at address #x~x (uvector index ~d)." object address index))
    123                  (format s "Write to watched object ~s at address #x~x" object address))))))
     107  ((object :initform nil :initarg :object
     108           :reader write-to-watched-object-object)
     109   (offset :initarg :offset
     110           :reader write-to-watched-object-offset)
     111   (instruction :initarg :instruction
     112                :reader write-to-watched-object-instruction))
     113  (:report report-write-to-watched-object))
     114
     115(defun report-write-to-watched-object (c s)
     116  (with-slots (object offset instruction) c
     117    (cond
     118      ((uvectorp object)
     119       (let* ((count (uvsize object))
     120              (nbytes (if (ivectorp object)
     121                        (subtag-bytes (typecode object) count)
     122                        (* count target::node-size)))
     123              (bytes-per-element (/ nbytes count))
     124              (offset (- offset target::misc-data-offset))
     125              (index (/ offset bytes-per-element)))
     126         (format s "Write to watched uvector ~s at " object)
     127         (if (fixnump index)
     128           (format s "index ~s" index)
     129           (format s "an apparently unaligned byte offset ~s" offset))))
     130      ((consp object)
     131       (format s "Write to ~a watched cons cell ~s"
     132               (cond
     133                 ((= offset target::cons.cdr) "the CDR of")
     134                 ((= offset target::cons.car) "the CAR of")
     135                 (t
     136                  (format nil "an apparently unaligned byte offset (~s) into"
     137                          offset)))
     138               object))
     139      (t
     140       (format s "Write to a strange object ~s at byte offset ~s"
     141               object offset)))
     142    (when instruction
     143      (format s "~&Faulting instruction: ~s" instruction))))
    124144
    125145(define-condition type-error (error)
  • release/1.4/source/level-1/l1-reader.lisp

    r12854 r13031  
    21512151    t))
    21522152
    2153 (defun %make-readtable-iterator (readtable macs? dmacs?)
    2154   (setq readtable (readtable-arg (or readtable %initial-readtable%)))
    2155   (let ((char-macro-alist (rdtab.alist readtable)))
    2156     (labels ((generate ()
    2157                (if char-macro-alist
    2158                    (destructuring-bind (char . defn) (pop char-macro-alist)
    2159                      (if (consp defn)
    2160                          (if dmacs?
    2161                              (values t char (car defn) t (cdr defn))
    2162                              (generate))
    2163                          (if macs?
    2164                              (values t char defn nil nil)
    2165                              (generate))))
    2166                    (values nil nil nil nil nil))))
    2167       #'generate)))
    2168 
    2169 (defmacro with-readtable-iterator ((name readtable &rest macro-char-types) &body body)
    2170   "While executing BODY, bind NAME to a macro that iterates over
    2171    READTABLE's macros.  Each invocation of NAME yields five values:
    2172 
    2173    VALUE? CHAR FUNCTION DISPATCH? DISPATCH-ALIST
    2174 
    2175    VALUE? is true until the iterator runs out of items.  CHAR is the
    2176    macro character.  FUNCTION is the primary value of
    2177    `get-macro-character' for CHAR.  DISPATCH? is true if and only if
    2178    CHAR is a dispatching macro character.  DISPATCH-ALIST is an alist
    2179    mapping sub-characters to their respective values of
    2180    `get-dispatch-macro-character', and is NIL unless DISPATCH?.
    2181 
    2182    MACRO-CHAR-TYPES, which defaults
    2183    to (:macro-char :dispatch-macro-char) thereby yielding all items,
    2184    selects subsets of the iterated items.  When `:macro-char' is
    2185    present, yield those values where DISPATCH? is false; when
    2186    `:dispatch-macro-char' is present, yield those values where
    2187    DISPATCH? is true.
    2188 
    2189    The consequences of modifying READTABLE after entering BODY and
    2190    before the final invocation of NAME or final use of a
    2191    DISPATCH-ALIST are undefined."
    2192   (unless (symbolp name)
    2193     (signal-program-error
    2194      "~S is not a variable name" name))
    2195   (let ((it (gensym)) macs? dmacs?)
    2196     (if macro-char-types
    2197         (dolist (mct macro-char-types)
    2198           (case mct
    2199             ((:macro-char) (setq macs? t))
    2200             ((:dispatch-macro-char) (setq dmacs? t))
    2201             (otherwise
    2202                (signal-program-error    ;can't be type-error
    2203                 "~S is not one of ~S or ~S"
    2204                 mct :macro-char :dispatch-macro-char))))
    2205         (setq macs? t dmacs? t))
    2206     `(let ((,it (%make-readtable-iterator ,readtable ,macs? ,dmacs?)))
    2207        (macrolet ((,name () `(funcall ,',it)))
    2208          ,@body))))
    2209 
    2210 
    22112153
    22122154;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  • release/1.4/source/level-1/l1-readloop.lisp

    r12550 r13031  
    421421
    422422
    423 (defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
     423(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers)
    424424  (ecase type
    425425    (defun nil)
    426     (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
    427     (defgeneric (setq lambda (list :methods)))
    428     (defmethod (setq lambda (list :methods (cons qualifiers specializers))))
    429     (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-file*))))
    430   (vector lfbits keyvect *loading-file-source-file* lambda))
     426    (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=nil
     427    (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-gfn-bit) lfbits)))
     428    (defmethod (setq data (list :methods
     429                                (%cons-def-info-method lfbits keyvect qualifiers specializers))
     430                     lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit))
     431                     keyvect nil))
     432    (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file*))))
     433  (vector lfbits keyvect *loading-file-source-file* data))
    431434
    432435(defun def-info.lfbits (def-info)
     
    451454         (and (eq (car data) :methods) (%cdr data)))))
    452455
    453 (defun def-info-with-new-methods (def-info new-methods)
    454   (if (eq new-methods (def-info.methods def-info))
     456(defun %cons-def-info-method (lfbits keyvect qualifiers specializers)
     457  (cons (cons (and keyvect
     458                   (if (logbitp $lfbits-aok-bit lfbits)
     459                     (and (not (logbitp $lfbits-rest-bit lfbits))
     460                          (list keyvect))
     461                     keyvect))
     462              *loading-file-source-file*)
     463        (cons qualifiers specializers)))
     464
     465(defun def-info-method.keyvect (def-info-method)
     466  (let ((kv (caar def-info-method)))
     467    (if (listp kv)
     468      (values (car kv) t)
     469      (values kv  nil))))
     470
     471(defun def-info-method.file (def-info-method)
     472  (cdar def-info-method))
     473
     474(defun def-info-with-new-methods (def-info new-bits new-methods)
     475  (if (and (eq new-methods (def-info.methods def-info))
     476           (eql new-bits (def-info.lfbits def-info)))
    455477    def-info
    456     (let ((new (copy-seq def-info)))
     478    (let ((new (copy-seq def-info))
     479          (old-bits (svref def-info 0)))
     480      (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bits)) old-bits))
    457481      (setf (svref new 3) (cons :methods new-methods))
    458482      new)))
     
    520544        :deftype-type (def-info.deftype-type def-info)))
    521545
     546(defun combine-gf-def-infos (name old-info new-info)
     547  (let* ((old-bits (def-info.lfbits old-info))
     548         (new-bits (def-info.lfbits new-info))
     549         (old-methods (def-info.methods old-info))
     550         (new-methods (def-info.methods new-info)))
     551    (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit new-bits))
     552      (when *compiler-warn-on-duplicate-definitions*
     553        (nx1-whine :duplicate-definition
     554                   name
     555                   (def-info.file old-info)
     556                   (def-info.file new-info)))
     557      (return-from combine-gf-def-infos new-info))
     558    (unless (congruent-lfbits-p old-bits new-bits)
     559      (if (logbitp $lfbits-gfn-bit new-bits)
     560        ;; A defgeneric, incongruent with previously defined methods
     561        (nx1-whine :incongruent-gf-lambda-list name)
     562        ;; A defmethod incongruent with previously defined explicit or implicit generic
     563        (nx1-whine :incongruent-method-lambda-list
     564                   (if new-methods `(:method ,@(cadar new-methods) ,name ,(cddar new-methods)) name)
     565                   name))
     566      ;; Perhaps once this happens, should just mark it somehow to not complain again
     567      (return-from combine-gf-def-infos
     568        (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info)))
     569    (loop for new-method in new-methods
     570          as old = (member (cdr new-method) old-methods :test #'equal :key #'cdr)
     571          do (when old
     572               (when *compiler-warn-on-duplicate-definitions*
     573                 (nx1-whine :duplicate-definition
     574                            `(:method ,@(cadr new-method) ,name ,(cddr new-method))
     575                            (def-info-method.file (car old))
     576                            (def-info-method.file new-method)))
     577               (setq old-methods (remove (car old) old-methods :test #'eq)))
     578          do (push new-method old-methods))
     579    (cond ((logbitp $lfbits-gfn-bit new-bits)
     580           ;; If adding a defgeneric, use its info.
     581           (setq old-info new-info old-bits new-bits))
     582          ((not (logbitp $lfbits-gfn-bit old-bits))
     583           ;; If no defgeneric (yet?) just remember whether any method has &key
     584           (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits-keys-bit))))))
     585    ;; Check that all methods implement defgeneric keys
     586    (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvect old-info))))
     587      (when (> (length gfkeys) 0)
     588        (loop for minfo in old-methods
     589              do (multiple-value-bind (mkeys aok) (def-info-method.keyvect minfo)
     590                   (when (and mkeys
     591                              (not aok)
     592                              (setq mkeys (loop for gk across gfkeys
     593                                                unless (find gk mkeys) collect gk)))
     594                     (nx1-whine :gf-keys-not-accepted
     595                                `(:method ,@(cadr minfo) ,name ,(cddr minfo))
     596                                mkeys))))))
     597    (def-info-with-new-methods old-info old-bits old-methods)))
     598
    522599(defun combine-definition-infos (name old-info new-info)
    523   (let ((old-type (def-info.function-type old-info))  ;; defmacro
    524         (old-deftype (def-info.deftype old-info))      ;; nil
    525         (new-type (def-info.function-type new-info))  ;; nil
    526         (new-deftype (def-info.deftype new-info)))   ;; (nil . file)
     600  (let ((old-type (def-info.function-type old-info))
     601        (old-deftype (def-info.deftype old-info))
     602        (new-type (def-info.function-type new-info))
     603        (new-deftype (def-info.deftype new-info)))
    527604    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
    528            ;; TODO: Check compatibility of lfbits...
    529            ;; TODO: check that all methods implement defgeneric keys
    530            (let ((old-methods (def-info.methods old-info))
    531                  (new-methods (def-info.methods new-info)))
    532              (loop for new-method in new-methods
    533                    do (if (member new-method old-methods :test #'equal)
    534                         (when *compiler-warn-on-duplicate-definitions*
    535                           (nx1-whine :duplicate-definition
    536                                      `(method ,@(car new-method) ,name ,(cdr new-method))
    537                                      (def-info.file old-info)
    538                                      (def-info.file new-info)))
    539                         (push new-method old-methods)))
    540              (setq new-info (def-info-with-new-methods old-info old-methods))))
     605           (setq new-info (combine-gf-def-infos name old-info new-info)))
    541606          ((or (eq (or old-type 'defun) (or new-type 'defun))
    542607               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
  • release/1.4/source/level-1/linux-files.lisp

    r12841 r13031  
    714714                    (%null-ptr)
    715715                    #$OPEN_EXISTING
    716                     #$FILE_ATTRIBUTE_NORMAL
     716                    #$FILE_FLAG_BACKUP_SEMANTICS
    717717                    (%null-ptr))))
    718718      (if (eql handle *windows-invalid-handle*)
  • release/1.4/source/level-1/sysutils.lisp

    r12500 r13031  
    563563    (undefined-type-reference (verify-deferred-type-warning w))
    564564    (undefined-function-reference (verify-deferred-function-warning w))
     565    (undefined-keyword-reference (verify-deferred-keyword-warning w))
    565566    (compiler-warning nil)))
    566567
     
    595596
    596597
     598(defun deferred-function-def (name)
     599  (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*))
     600         (def (or (let ((cell (gethash name defs)))
     601                    (and cell (def-info.function-p (cdr cell)) cell))
     602                 (let* ((global (fboundp name)))
     603                   (and (typep global 'function) global)))))
     604    def))
     605
     606(defun check-deferred-call-args (w def wargs)
     607  (destructuring-bind (arglist spread-p) wargs
     608    (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist spread-p)
     609      (when deftype
     610        (when (eq deftype :deferred-mismatch)
     611          (setq deftype (if (consp def) :environment-mismatch :global-mismatch)))
     612        (make-condition
     613         'invalid-arguments
     614         :function-name (compiler-warning-function-name w)
     615         :source-note (compiler-warning-source-note w)
     616         :warning-type deftype
     617         :args (list (car (compiler-warning-args w)) reason arglist spread-p))))))
     618
    597619(defun verify-deferred-function-warning (w)
    598620  (let* ((args (compiler-warning-args w))
    599621         (wfname (car args))
    600          (defs (deferred-warnings.defs *outstanding-deferred-warnings*))
    601          (def (or (let ((cell (gethash wfname defs)))
    602                    (and cell (def-info.function-p (cdr cell)) cell))
    603                  (let* ((global (fboundp wfname)))
    604                    (and (typep global 'function) global)))))
     622         (def (deferred-function-def wfname)))
    605623    (cond ((null def) w)
    606624          ((or (typep def 'function)
     
    609627           ;; Check args in call to forward-referenced function.
    610628           (when (cdr args)
    611              (destructuring-bind (arglist spread-p) (cdr args)
    612                (multiple-value-bind (deftype reason)
    613                    (nx1-check-call-args def arglist spread-p)
    614                  (when deftype
    615                    (let* ((w2 (make-condition
    616                                'invalid-arguments
    617                                :function-name (compiler-warning-function-name w)
    618                                :source-note (compiler-warning-source-note w)
    619                                :warning-type deftype
    620                                :args (list (car args) reason arglist spread-p))))
    621                      w2))))))
     629             (check-deferred-call-args w def (cdr args))))
    622630          ((def-info.macro-p (cdr def))
    623631           (let* ((w2 (make-condition
     
    628636                       :args (list (car args)))))
    629637             w2)))))
     638
     639(defun verify-deferred-keyword-warning (w)
     640  (let* ((args (compiler-warning-args w))
     641         (wfname (car args))
     642         (def (deferred-function-def wfname)))
     643    (when def
     644      (check-deferred-call-args w def (cddr args)))))
    630645
    631646
  • release/1.4/source/level-1/x86-trap-support.lisp

    r12888 r13031  
    387387;;; may not be meaningful.
    388388(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
    389   (let* ((frame-ptr (macptr->fixnum xcf)))
     389  (let* ((frame-ptr (macptr->fixnum xcf))
     390         (skip 0))
    390391    (cond ((zerop signal)               ;thread interrupt
    391392           (cmain))
     
    431432             ((= code 2)
    432433              ;; Write to a watched object.
    433               (flet ((%int-to-object (i)
    434                        (rlet ((a :address))
    435                          (setf (%get-ptr a) (%int-to-ptr i))
    436                          (%get-object a 0))))
    437                 (let ((object (%int-to-object other)))
     434              (let* ((offset other)
     435                     ;; The kernel exception handler leaves the
     436                     ;; watched object on the lisp stack under the
     437                     ;; xcf.
     438                     (object (%get-object xcf target::xcf.size)))
     439                (multiple-value-bind (insn insn-length)
     440                    (ignore-errors (x86-faulting-instruction xp))
    438441                  (restart-case (%error (make-condition
    439442                                         'write-to-watched-object
    440                                          :address addr
    441                                          :object object)
     443                                         :offset offset
     444                                         :object object
     445                                         :instruction insn)
    442446                                        nil frame-ptr)
     447                    #-windows-target
     448                    (emulate ()
     449                      :test (lambda (c)
     450                              (declare (ignore c))
     451                              (x86-can-emulate-instruction insn))
     452                      :report
     453                      "Emulate this instruction, leaving the object watched."
     454                      (flet ((watchedp (object)
     455                               (%map-areas #'(lambda (x)
     456                                               (when (eq object x)
     457                                                 (return-from watchedp t)))
     458                                           area-watched area-watched)))
     459                        (let ((result nil))
     460                          (with-other-threads-suspended
     461                            (when (watchedp object)
     462                              ;; We now trust that the object is in a
     463                              ;; static gc area.
     464                              (let* ((a (+ (%address-of object) offset))
     465                                     (ptr (%int-to-ptr
     466                                           (logandc2 a (1- *host-page-size*)))))
     467                                (#_mprotect ptr *host-page-size* #$PROT_WRITE)
     468                                (setq result (x86-emulate-instruction xp insn))
     469                                (#_mprotect ptr *host-page-size*
     470                                            (logior #$PROT_READ #$PROT_EXEC)))))
     471                          (if result
     472                            (setq skip insn-length)
     473                            (error "could not emulate the instrution")))))
     474                    (skip ()
     475                      :test (lambda (c)
     476                              (declare (ignore c))
     477                              insn)
     478                      :report "Skip over this write instruction."
     479                      (setq skip insn-length))
    443480                    (unwatch ()
    444                       :report (lambda (s)
    445                                 (format s "Unwatch ~s and perform the write." object))
     481                      :report "Unwatch the object and retry the write."
    446482                      (unwatch object))))))))
    447483          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
     
    454490                                     :write-p (not (zerop code)))
    455491                     ()
    456                      frame-ptr)))))
    457   0)
     492                     frame-ptr))))
     493    skip))
     494
     495(defun x86-faulting-instruction (xp)
     496  (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
     497         (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
     498                                    #+x8664-target rip-register-offset)))
     499    (dotimes (i (length code-bytes))
     500      (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
     501    (let* ((ds (make-x86-disassembly-state
     502                :mode-64 #+x8664-target t #+x8632-target nil
     503                :code-vector code-bytes
     504                :code-pointer 0))
     505           (insn (x86-disassemble-instruction ds nil))
     506           (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
     507      (values insn len))))
  • release/1.4/source/lib/ccl-export-syms.lisp

    r12693 r13031  
    706706     ;; Miscellany
    707707     heap-utilization
    708      with-readtable-iterator
    709708
    710709     external-process-creation-failure
  • release/1.4/source/lib/compile-ccl.lisp

    r12896 r13031  
    175175          (case target
    176176            ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
    177             ((:x8632 :x8664) '(x86-backtrace x86-disassemble)))))
     177            ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch)))))
    178178         
    179179
  • release/1.4/source/lib/ffi-win64.lisp

    • Property svn:executable deleted
  • release/1.4/source/lib/level-2.lisp

    r12535 r13031  
    4949; that have been scarfed out of a macro-like lambda list.
    5050; The returned value is supposed to be suitable for splicing ...
    51 #+not-used
    5251(defun hoist-special-decls (sym decls)
    5352  (when sym
  • release/1.4/source/lib/macros.lisp

    r12889 r13031  
    178178  `(%stack-block (,spec) ,@forms))
    179179
    180 
    181 
    182 (eval-when (:compile-toplevel :load-toplevel :execute)
    183 (defun extract-type-decl-for-dolist-var (var decls env)
    184   (if (null decls)
    185     (values nil nil nil)
    186     (let* ((declared-type-p nil))
    187       (collect ((new-decls)
    188                 (declared-types))
    189         (dolist (declform decls)
    190           ;; (assert (eq (car declform) 'declare))
    191           (dolist (decl (cdr declform))
    192             (if (atom decl)
    193               (new-decls decl)
    194               (let* ((spec (car decl)))
    195                 (if (specifier-type-if-known spec env)
    196                   (setq spec 'type
    197                         decl `(type ,@decl)))
    198                 (if (eq spec 'type)
    199                   (destructuring-bind (typespec &rest vars) (cdr decl)
    200                     (cond ((member var vars :test #'eq)
    201                            (setq declared-type-p t)
    202                            (declared-types typespec)
    203                            (new-decls `(type ,typespec ,@(remove var vars))))
    204                           (t (new-decls decl))))
    205                   (new-decls decl))))))
    206         (if (not declared-type-p)
    207           (values nil nil (new-decls))
    208           (values t
    209                   (let* ((declared-type (declared-types)))
    210                     (if (cdr declared-type)
    211                       `(and ,@declared-type)
    212                       (car declared-type)))
    213                   (new-decls)))))))
    214 )
    215 
    216 
    217180(defmacro dolist ((varsym list &optional ret) &body body &environment env)
    218181  (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
     
    221184         (lstsym (gensym)))
    222185    (multiple-value-bind (forms decls) (parse-body body env nil)
    223       (multiple-value-bind (var-type-p vartype other-decls)
    224           (extract-type-decl-for-dolist-var varsym decls env)
    225         (if var-type-p
    226           (setq forms `((locally (declare (type ,vartype ,varsym)) (tagbody ,@forms)))))
    227         (if other-decls
    228           (setq other-decls `((declare ,@other-decls))))
    229         `(block nil
    230           (let* ((,lstsym ,list) ,varsym)
    231             ,@(if var-type-p `((declare (type (or null ,vartype) ,varsym))))
    232             ,@other-decls
    233             (tagbody
    234                (go ,tstlab)
    235                ,toplab
    236                (setq ,lstsym (cdr (the list ,lstsym)))
    237                ,@forms
    238                ,tstlab
    239                (setq ,varsym (car ,lstsym))
    240                (if ,lstsym (go ,toplab)))
    241             ,@(if ret `((progn  ,ret)))))))))
    242 
     186      `(block nil
     187         (let* ((,lstsym ,list))
     188           (tagbody
     189              (go ,tstlab)
     190              ,toplab
     191              (let ((,varsym (car ,lstsym)))
     192                ,@decls
     193                (tagbody
     194                   ,@forms)
     195                (setq ,lstsym (cdr (the list ,lstsym))))
     196              ,tstlab
     197              (if ,lstsym (go ,toplab))))
     198         ,@(if ret `((let ((,varsym nil))
     199                       (declare (ignore-if-unused ,varsym)
     200                                ,@(loop for decl in decls
     201                                        append (remove 'special (cdr decl) :test #'neq :key #'car)))
     202                       ,ret)))))))
    243203
    244204(defmacro dovector ((varsym vector &optional ret) &body body &environment env)
     
    18111771      (append ll '(&allow-other-keys)))))
    18121772
    1813 (defun encode-gf-lambda-list (lambda-list)
    1814   (let* ((bits (encode-lambda-list lambda-list)))
    1815     (declare (fixnum bits))
    1816     (if (logbitp $lfbits-keys-bit bits)
    1817       (logior bits (ash 1 $lfbits-aok-bit))
    1818       bits)))
    1819 
    18201773(defmacro defmethod (name &rest args &environment env)
    18211774  (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
     
    18241777       (eval-when (:compile-toplevel)
    18251778         (record-function-info ',(maybe-setf-function-name name)
    1826                                ',(%cons-def-info 'defmethod (encode-gf-lambda-list lambda-list) nil nil
    1827                                                  specializers qualifiers)
     1779                               ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
     1780                                   (%cons-def-info 'defmethod bits keyvect nil specializers qualifiers))
    18281781                               ,env))
    18291782       (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
     
    21262079         (eval-when (:compile-toplevel)
    21272080           (record-function-info ',(maybe-setf-function-name function-name)
    2128                                  ',(%cons-def-info 'defgeneric (encode-gf-lambda-list lambda-list))
     2081                                 ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
     2082                                     (%cons-def-info 'defgeneric bits keyvect))
    21292083                                 ,env))
    21302084         (let ((,gf (%defgeneric
  • release/1.4/source/lib/misc.lisp

    r12888 r13031  
    964964  (let* ((total-cons-size  (* nconses target::cons.size))
    965965         (total-vector-size 0)
    966          (total-physical-vector-size 0))
    967     (format out "~&Object type~40tCount~48tTotal Size in Bytes~70tTotal Size")
    968     (format out "~&CONS~34t~12d~46t~16d~16d" nconses total-cons-size total-cons-size)
     966         (total-physical-vector-size 0)
     967         (total-size 0))
     968    (format out "~&Object type~42tCount~50tTotal Size in Bytes~72tTotal Size~82t % of Heap")
     969    (dotimes( i (length nvectors))
     970      (incf total-vector-size (aref vector-sizes i))
     971      (incf total-physical-vector-size (aref vector-physical-sizes i)))
     972    (setq total-size (+ total-cons-size total-physical-vector-size))
     973    (unless (zerop nconses)
     974      (format out "~&CONS~36t~12d~48t~16d~16d~8,2f%" nconses total-cons-size total-cons-size
     975              (* 100 (/ total-cons-size total-size))))
    969976    (dotimes (i (length nvectors))
    970       (let* ((count (aref nvectors i))
    971              (sizes (aref vector-sizes i))
    972              (psizes (aref vector-physical-sizes i)))
     977      (let ((count (aref nvectors i))
     978            (sizes (aref vector-sizes i))
     979            (psizes (aref vector-physical-sizes i)))
    973980        (unless (zerop count)
    974           (incf total-vector-size sizes)
    975           (incf total-physical-vector-size psizes)
    976           (format out "~&~a~34t~12d~46t~16d~16d" (aref *heap-utilization-vector-type-names* i)  count sizes psizes))))
    977     (format out "~&   Total sizes: ~47t~16d~16d" (+ total-cons-size total-vector-size) (+ total-cons-size total-physical-vector-size))))
    978                            
     981          (format out "~&~a~36t~12d~48t~16d~16d~8,2f%"
     982                  (aref *heap-utilization-vector-type-names* i)
     983                  count sizes psizes
     984                  (* 100.0 (/ psizes total-size))))))
     985    (format out "~&   Total sizes: ~49t~16d~16d" (+ total-cons-size total-vector-size) (+ total-cons-size total-physical-vector-size))))
     986
    979987;; The number of words to allocate for static conses when the user requests
    980988;; one and we don't have any left over
     
    10441052              (%ptr-to-int (%svref lock target::lock._value-cell)))))
    10451053
     1054(defun all-watched-objects ()
     1055  (let (result)
     1056    (with-other-threads-suspended
     1057      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched))
     1058    result))
     1059
     1060(defun primitive-watch (thing)
     1061  (require-type thing '(or cons (satisfies uvectorp)))
     1062  (%watch thing))
     1063
    10461064(defun watch (&optional thing)
    1047   (if thing
    1048     (progn
    1049       (require-type thing '(or cons (satisfies uvectorp)))
    1050       (%watch thing))
    1051     (let (result)
    1052       (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
    1053       result)))
     1065  (cond ((null thing)
     1066         (all-watched-objects))
     1067        ((arrayp thing)
     1068         (primitive-watch (array-data-and-offset thing)))
     1069        ((hash-table-p thing)
     1070         (primitive-watch (nhash.vector thing)))
     1071        ((standard-instance-p thing)
     1072         (primitive-watch (instance-slots thing)))
     1073        (t
     1074         (primitive-watch thing))))
    10541075
    10551076(defun unwatch (thing)
    1056   (%map-areas #'(lambda (x)
    1057                   (when (eq x thing)
    1058                     ;; This is a rather questionable thing to do,
    1059                     ;; since we'll be unlinking an area from the area
    1060                     ;; list while %map-areas iterates over it, but I
    1061                     ;; think we'll get away with it.
    1062                     (let ((new (if (uvectorp thing)
    1063                                  (%alloc-misc (uvsize thing) (typecode thing))
    1064                                  (cons nil nil))))
    1065                       (return-from unwatch (%unwatch thing new)))))
    1066               area-watched area-watched))
    1067      
     1077  (with-other-threads-suspended
     1078    (%map-areas #'(lambda (x)
     1079                    (when (eq x thing)
     1080                      (let ((new (if (uvectorp thing)
     1081                                   (%alloc-misc (uvsize thing)
     1082                                                (typecode thing))
     1083                                   (cons nil nil))))
     1084                        (return-from unwatch (%unwatch thing new)))))
     1085                area-watched area-watched)))
  • release/1.4/source/lib/nfcomp.lisp

    r12709 r13031  
    12311231                                 (ash 1 x8664::fulltag-immheader-2))))
    12321232           (case type-code
    1233              ((#.target::subtag-macptr #.target::subtag-dead-macptr) (unless (%null-ptr-p exp) (fasl-unknown exp)))
     1233             (#.target::subtag-dead-macptr (fasl-unknown exp))
     1234             (#.target::subtag-macptr
     1235              ;; Treat untyped pointers to the high/low 64K of the address
     1236              ;; space as constants.  Refuse to dump other pointers.
     1237              (unless (and (zerop (%macptr-type exp))
     1238                           (<= (%macptr-domain exp) 1))
     1239                (error "Can't dump typed pointer ~s" exp))
     1240              (let* ((addr (%ptr-to-int exp)))
     1241                (unless (or (< addr #x10000)
     1242                            (>= addr (- (ash 1 target::nbits-in-word)
     1243                                        #x10000)))
     1244                  (error "Can't dump pointer ~s : address is not in the low or high 64K of the address space." exp))))
    12341245             (t (fasl-scan-ref exp)))
    12351246           (case type-code
  • release/1.4/source/lib/systems.lisp

    r12375 r13031  
    161161    (ppc-backtrace    "ccl:bin;ppc-backtrace"    ("ccl:lib;ppc-backtrace.lisp"))
    162162    (x86-backtrace    "ccl:bin;x86-backtrace"    ("ccl:lib;x86-backtrace.lisp"))
     163    (x86-watch        "ccl:bin;x86-watch"        ("ccl:lib;x86-watch.lisp"))
    163164    (backtrace-lds    "ccl:bin;backtrace-lds"    ("ccl:lib;backtrace-lds.lisp"))
    164165    (apropos          "ccl:bin;apropos"          ("ccl:lib;apropos.lisp"))
  • release/1.4/source/library/leaks.lisp

    r11373 r13031  
    235235  (with-open-file (s log-file)
    236236    (let ((hash (make-hash-table :test 'equal))
     237          (free-list '())
    237238          (eof (list :eof)))
    238239      (loop for line = (read-line s nil eof)
     
    242243              do
    243244           (setf line (subseq line 2))
    244            (let ((plus-pos (search " + " line))
    245                  (minus-pos (search " - " line)))
     245           (let ((plus-pos (or (search " + " line) (search " > " line)))
     246                 (minus-pos (or (search " - " line) (search " < " line))))
    246247             (cond (plus-pos
    247248                    (let* ((where (subseq line 0 plus-pos))
     
    252253                      (setf (gethash addr hash) (list where size))))
    253254                   (minus-pos
    254                     (let ((addr (subseq line (+ minus-pos 3))))
    255                       (remhash addr hash))))))
     255                    (let* ((where (subseq line 0 minus-pos))
     256                           (addr (subseq line (+ minus-pos 3)))
     257                           (found (nth-value 1 (gethash addr hash))))
     258                      (if found
     259                        (remhash addr hash)
     260                        (push (list where addr) free-list)))))))
    256261      (let ((res nil))
    257262        (maphash (lambda (key value)
    258263                   (push (append value (list key)) res))
    259264                 hash)
    260         res))))
     265        (values res free-list)))))
     266
     267(defun pretty-print-mtrace-summary (file)
     268  (let* ((malloc-sum 0))
     269    (multiple-value-bind (mallocs frees) (parse-mtrace-log file)
     270      (dolist (i mallocs)
     271        (incf malloc-sum (parse-integer (second i) :radix 16 :start 2))
     272        (format t "~&~A" i))
     273      (format t "~&Freed but not malloced:~%~{~A~%~}" frees)
     274      (format t "~&total-malloc-not-freed: ~~A ~A free not malloc: ~A"
     275              (/ malloc-sum 1024.0)
     276              (length mallocs)
     277              (length frees)))))
    261278
    262279;; Return the total number of bytes allocated by malloc()
     
    266283    (ccl::rref mallinfo :mallinfo.uordblks)))
    267284
     285#||
     286http://www.gnu.org/s/libc/manual/html_node/Statistics-of-Malloc.html
     287
     288int arena
     289    This is the total size of memory allocated with sbrk by malloc, in bytes.
     290int ordblks
     291    This is the number of chunks not in use. (The memory allocator internally gets chunks of memory from the operating system, and then carves them up to satisfy individual malloc requests; see Efficiency and Malloc.)
     292int smblks
     293    This field is unused.
     294int hblks
     295    This is the total number of chunks allocated with mmap.
     296int hblkhd
     297    This is the total size of memory allocated with mmap, in bytes.
     298int usmblks
     299    This field is unused.
     300int fsmblks
     301    This field is unused.
     302int uordblks
     303    This is the total size of memory occupied by chunks handed out by malloc.
     304int fordblks
     305    This is the total size of memory occupied by free (not in use) chunks.
     306int keepcost
     307    This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space's data segment).
     308||#   
     309
     310(defun show-malloc-info ()
     311  (rlet ((info :mallinfo))
     312    (#_mallinfo info)                   ;struct return invisible arg.
     313    (let* ((arena (pref info :mallinfo.arena))
     314           (ordblks (pref info :mallinfo.ordblks))
     315           (hblks (pref info :mallinfo.hblks))
     316           (hblkhd (pref info :mallinfo.hblkhd))
     317           (uordblks (pref info :mallinfo.uordblks))
     318           (fordblks (pref info :mallinfo.fordblks))
     319           (keepcost (pref info :mallinfo.keepcost)))
     320      (format t "~& arena size: ~d/#x~x" arena arena)
     321      (format t "~& number of unused chunks = ~d" ordblks)
     322      (format t "~& number of mmap'ed chunks = ~d" hblks)
     323      (format t "~& total size of mmap'ed chunks = ~d/#x~x" hblkhd hblkhd)
     324      (format t "~& total size of malloc'ed chunks = ~d/#x~x" uordblks uordblks)
     325      (format t "~& total size of free chunks = ~d/#x~x" fordblks fordblks)
     326      (format t "~& size of releaseable chunk = ~d/#x~x" keepcost keepcost))))
     327
    268328)  ;; end of linux-only code
  • release/1.4/source/library/x86-win64-syscalls.lisp

    • Property svn:executable deleted
  • release/1.4/source/lisp-kernel/windows-calls.c

    r12714 r13031  
    195195
    196196  if ((flag & _O_WRONLY) == _O_WRONLY) {
    197     dwDesiredAccess |= GENERIC_WRITE | FILE_WRITE_DATA |
    198       FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES;
     197    dwDesiredAccess |= GENERIC_WRITE;
    199198  } else if ((flag & _O_RDWR) == _O_RDWR) {
    200     dwDesiredAccess |= GENERIC_WRITE|GENERIC_READ | FILE_READ_DATA |
    201       FILE_WRITE_DATA | FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES;
     199    dwDesiredAccess |= GENERIC_WRITE|GENERIC_READ;
    202200  } else {
    203     dwDesiredAccess |= GENERIC_READ | FILE_READ_DATA | FILE_READ_ATTRIBUTES |
    204       FILE_WRITE_ATTRIBUTES;
     201    dwDesiredAccess |= GENERIC_READ;
    205202  }
    206203   
  • release/1.4/source/lisp-kernel/x86-exceptions.c

    r12888 r13031  
    842842          LispObj save_vsp = xpGPR(xp, Isp);
    843843          LispObj save_fp = xpGPR(xp, Ifp);
    844           LispObj xcf = create_exception_callback_frame(xp, tcr);
     844          LispObj xcf;
     845          natural offset = (LispObj)addr - obj;
    845846          int skip;
    846847
     848          push_on_lisp_stack(xp, obj);
     849          xcf = create_exception_callback_frame(xp, tcr);
     850
    847851          /* The magic 2 means this was a write to a watchd object */
    848           skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, (natural) addr, obj);
     852          skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2,
     853                                  (natural)addr, offset);
    849854          xpPC(xp) += skip;
    850855          xpGPR(xp, Ifp) = save_fp;
     
    37303735    size = uvector_total_size_in_bytes(noderef);
    37313736
    3732   if (object_area && object_area->code != AREA_WATCHED) {
     3737  if (object_area && object_area->code == AREA_DYNAMIC) {
    37333738    area *a = new_watched_area(size);
    37343739    LispObj old = object;
     
    37433748    wp_update_references(tcr, old, new);
    37443749    check_all_areas(tcr);
     3750    return 1;
    37453751  }
    37463752  return 0;
     
    37863792  LispObj selector = xpGPR(xp,Iimm0);
    37873793  LispObj object = xpGPR(xp, Iarg_z);
     3794  signed_natural result;
    37883795 
    37893796  switch (selector) {
    37903797    case WATCH_TRAP_FUNCTION_WATCH:
    3791       gc_like_from_xp(xp, watch_object, object);
     3798      result = gc_like_from_xp(xp, watch_object, object);
     3799      if (result == 0)
     3800        xpGPR(xp,Iarg_z) = lisp_nil;
    37923801      break;
    37933802    case WATCH_TRAP_FUNCTION_UNWATCH:
  • release/1.4/source/lisp-kernel/x86-gc.c

    r12815 r13031  
    28132813 */
    28142814
    2815 static inline void
     2815static inline int
    28162816wp_maybe_update(LispObj *p, LispObj old, LispObj new)
    28172817{
    28182818  if (*p == old) {
    28192819    *p = new;
    2820   }
     2820    return true;
     2821  }
     2822  return false;
    28212823}
    28222824
     
    28482850    } else if (nodeheader_tag_p(tag_n)) {
    28492851      nwords = header_element_count(node);
    2850      
    28512852      nwords += 1 - (nwords & 1);
    28522853
     
    28592860        nwords -= skip;
    28602861        while(skip--) {
    2861           if (*p == old) *p = new;
     2862          wp_maybe_update(p, old, new);
    28622863          p++;
    28632864        }
     
    28682869        nwords >>= 1;
    28692870        while(nwords--) {
    2870           if (*p == old && hashp) {
    2871             *p = new;
     2871          if (wp_maybe_update(p, old, new) && hashp) {
    28722872            hashp->flags |= nhash_key_moved_mask;
    28732873            hashp = NULL;
    28742874          }
    28752875          p++;
    2876           if (*p == old) *p = new;
     2876          wp_maybe_update(p, old, new);
    28772877          p++;
    28782878        }
     
    30573057    other_tcr = other_tcr->next;
    30583058  } while (other_tcr != tcr);
     3059  unprotect_watched_areas();
    30593060  wp_update_all_areas(old, new);
    3060 }
     3061  protect_watched_areas();
     3062}
  • release/1.4/source/lisp-kernel/x86_print.c

    r10101 r13031  
    238238  add_c_string("#<");
    239239  sprint_unsigned_decimal(elements);
    240   add_c_string("-element vector subtag = ");
     240  add_c_string("-element vector subtag = #x");
    241241  add_char(digits[subtag>>4]);
    242242  add_char(digits[subtag&15]);
  • release/1.4/source/objc-bridge/objc-runtime.lisp

    r12843 r13031  
    25502550    (apply (objc-message-info-lisp-name info) instance args)))
    25512551                   
     2552(defun objc-set->setf (method)
     2553  (let* ((info (get-objc-message-info method))
     2554         (name (objc-message-info-lisp-name info))
     2555         (str (symbol-name name))
     2556         (value-placeholder-index (position #\: str)))
     2557    (when (and (> (length str) 4) value-placeholder-index)
     2558      (let* ((truncated-name (nstring-downcase (subseq (remove #\: str
     2559                                                               :test #'char= :count 1)
     2560                                                       3)
     2561                                               :end 1))
     2562             (reader-name (if (> (length truncated-name)
     2563                                 (decf value-placeholder-index 3))
     2564                            (nstring-upcase truncated-name
     2565                                           :start value-placeholder-index
     2566                                           :end (1+ value-placeholder-index))
     2567                            truncated-name))
     2568             (reader (intern reader-name :nextstep-functions)))
     2569        (eval `(defun (setf ,reader) (value object &rest args)
     2570                 (apply #',name object value args)
     2571                 value))))))
     2572
     2573(defun register-objc-set-messages ()
     2574  (do-interface-dirs (d)
     2575    (dolist (init (cdb-enumerate-keys (db-objc-methods d)
     2576                                      #'(lambda (string)
     2577                                          (string= string "set"
     2578                                                   :end1 (min (length string) 3)))))
     2579      (objc-set->setf init))))
    25522580
    25532581 
     
    27482776          :imp imp
    27492777          :class-p class-p)))
     2778  (if (string= selname "set" :end1 (min (length selname) 3))
     2779    (objc-set->setf selname))
    27502780  impname)
    27512781   
  • release/1.4/source/objc-bridge/objc-support.lisp

    r12659 r13031  
    107107(maybe-map-objc-classes t)
    108108(register-objc-init-messages)
     109(register-objc-set-messages)
    109110
    110111#+gnu-objc
     
    552553                        (map-objc-classes)
    553554                        ;; Update info about init messages.
    554                         (register-objc-init-messages))
     555                        (register-objc-init-messages)
     556                        (register-objc-set-messages))
    555557                      (return winning)))))))))))
    556558
  • release/1.4/source/scripts/makedmg

    r9411 r13031  
    1 
    21#!/bin/sh
    32#
  • release/1.4/source/tools/asdf.lisp

    r11305 r13031  
    1 ;;; This is asdf: Another System Definition Facility.  $Revision$
     1;;; This is asdf: Another System Definition Facility.
     2;;; hash - $Format:%H$
     3;;;
     4;;; Local Variables:
     5;;; mode: lisp
     6;;; End:
    27;;;
    38;;; Feedback, bug reports, and patches are all welcome: please mail to
    4 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
    5 ;;; source for asdf is presently the cCLan CVS repository at
    6 ;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
     9;;; <asdf-devel@common-lisp.net>.  But note first that the canonical
     10;;; source for asdf is presently on common-lisp.net at
     11;;; <URL:http://common-lisp.net/project/asdf/>
    712;;;
    813;;; If you obtained this copy from anywhere else, and you experience
     
    1015;;; location above for a more recent version (and for documentation
    1116;;; and test files, if your copy came without them) before reporting
    12 ;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
     17;;; bugs.  There are usually two "supported" revisions - the git HEAD
    1318;;; is the latest development version, whereas the revision tagged
    1419;;; RELEASE may be slightly older but is considered `stable'
    1520
    16 ;;; Copyright (c) 2001-2008 Daniel Barlow and contributors
     21;;; -- LICENSE START
     22;;; (This is the MIT / X Consortium license as taken from
     23;;;  http://www.opensource.org/licenses/mit-license.html on or about
     24;;;  Monday; July 13, 2009)
     25;;;
     26;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
    1727;;;
    1828;;; Permission is hereby granted, free of charge, to any person obtaining
     
    3444;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
    3545;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
     46;;;
     47;;; -- LICENSE END
    3648
    3749;;; the problem with writing a defsystem replacement is bootstrapping:
    3850;;; we can't use defsystem to compile it.  Hence, all in one file
    3951
     52#+xcvb (module ())
     53
    4054(defpackage #:asdf
     55  (:documentation "Another System Definition Facility")
    4156  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
    4257           #:system-definition-pathname #:find-component ; miscellaneous
    43 
    44            #:compile-op #:load-op #:load-source-op 
     58           #:compile-system #:load-system #:test-system
     59           #:compile-op #:load-op #:load-source-op
    4560           #:test-op
    4661           #:operation           ; operations
     
    8196           #:system-source-file
    8297           #:system-relative-pathname
     98           #:map-systems
    8399
    84100           #:operation-on-warnings
     
    91107           #:*compile-file-failure-behaviour*
    92108           #:*asdf-revision*
     109           #:*resolve-symlinks*
    93110
    94111           #:operation-error #:compile-failed #:compile-warned #:compile-error
     
    105122           #:retry
    106123           #:accept                     ; restarts
     124           #:coerce-entry-to-directory
     125           #:remove-entry-from-registry
    107126
    108127           #:standard-asdf-method-combination
    109128           #:around                     ; protocol assistants
    110            )
     129           
     130           #:*source-to-target-mappings*
     131           #:*default-toplevel-directory*
     132           #:*centralize-lisp-binaries*
     133           #:*include-per-user-information*
     134           #:*map-all-source-files*
     135           #:output-files-for-system-and-operation
     136           #:*enable-asdf-binary-locations*
     137           #:implementation-specific-directory-name)
    111138  (:use :cl))
    112139
     
    119146(in-package #:asdf)
    120147
    121 (defvar *asdf-revision* (let* ((v "$Revision$")
    122                                (colon (or (position #\: v) -1))
    123                                (dot (position #\. v)))
    124                           (and v colon dot
    125                                (list (parse-integer v :start (1+ colon)
    126                                                       :junk-allowed t)
    127                                      (parse-integer v :start (1+ dot)
    128                                                       :junk-allowed t)))))
     148(defvar *asdf-revision*
     149  ;; the 1+ hair is to ensure that we don't do an inadvertant find and replace
     150  (subseq "REVISION:1.366" (1+ (length "REVISION"))))
     151 
     152
     153(defvar *resolve-symlinks* t
     154  "Determine whether or not ASDF resolves symlinks when defining systems.
     155
     156Defaults to `t`.")
    129157
    130158(defvar *compile-file-warnings-behaviour* :warn)
     
    136164(defparameter +asdf-methods+
    137165  '(perform explain output-files operation-done-p))
    138 
    139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    140 ;; utility stuff
    141 
    142 (defmacro aif (test then &optional else)
    143   `(let ((it ,test)) (if it ,then ,else)))
    144 
    145 (defun pathname-sans-name+type (pathname)
    146   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    147 and NIL NAME and TYPE components"
    148   (make-pathname :name nil :type nil :defaults pathname))
    149 
    150 (define-modify-macro appendf (&rest args)
    151   append "Append onto list")
    152 
    153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    154 ;; classes, condiitons
    155 
    156 (define-condition system-definition-error (error) ()
    157   ;; [this use of :report should be redundant, but unfortunately it's not.
    158   ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
    159   ;; over print-object; this is always conditions::%print-condition for
    160   ;; condition objects, which in turn does inheritance of :report options at
    161   ;; run-time.  fortunately, inheritance means we only need this kludge here in
    162   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    163   #+cmu (:report print-object))
    164 
    165 (define-condition formatted-system-definition-error (system-definition-error)
    166   ((format-control :initarg :format-control :reader format-control)
    167    (format-arguments :initarg :format-arguments :reader format-arguments))
    168   (:report (lambda (c s)
    169              (apply #'format s (format-control c) (format-arguments c)))))
    170 
    171 (define-condition circular-dependency (system-definition-error)
    172   ((components :initarg :components :reader circular-dependency-components)))
    173 
    174 (define-condition duplicate-names (system-definition-error)
    175   ((name :initarg :name :reader duplicate-names-name)))
    176 
    177 (define-condition missing-component (system-definition-error)
    178   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    179    (parent :initform nil :reader missing-parent :initarg :parent)))
    180 
    181 (define-condition missing-component-of-version (missing-component)
    182   ((version :initform nil :reader missing-version :initarg :version)))
    183 
    184 (define-condition missing-dependency (missing-component)
    185   ((required-by :initarg :required-by :reader missing-required-by)))
    186 
    187 (define-condition missing-dependency-of-version (missing-dependency
    188                                                  missing-component-of-version)
    189   ())
    190 
    191 (define-condition operation-error (error)
    192   ((component :reader error-component :initarg :component)
    193    (operation :reader error-operation :initarg :operation))
    194   (:report (lambda (c s)
    195              (format s "~@<erred while invoking ~A on ~A~@:>"
    196                      (error-operation c) (error-component c)))))
    197 (define-condition compile-error (operation-error) ())
    198 (define-condition compile-failed (compile-error) ())
    199 (define-condition compile-warned (compile-error) ())
    200 
    201 (defclass component ()
    202   ((name :accessor component-name :initarg :name :documentation
    203          "Component name: designator for a string composed of portable pathname characters")
    204    (version :accessor component-version :initarg :version)
    205    (in-order-to :initform nil :initarg :in-order-to)
    206    ;; XXX crap name
    207    (do-first :initform nil :initarg :do-first)
    208    ;; methods defined using the "inline" style inside a defsystem form:
    209    ;; need to store them somewhere so we can delete them when the system
    210    ;; is re-evaluated
    211    (inline-methods :accessor component-inline-methods :initform nil)
    212    (parent :initarg :parent :initform nil :reader component-parent)
    213    ;; no direct accessor for pathname, we do this as a method to allow
    214    ;; it to default in funky ways if not supplied
    215    (relative-pathname :initarg :pathname)
    216    (operation-times :initform (make-hash-table )
    217                     :accessor component-operation-times)
    218    ;; XXX we should provide some atomic interface for updating the
    219    ;; component properties
    220    (properties :accessor component-properties :initarg :properties
    221                :initform nil)))
    222 
    223 ;;;; methods: conditions
    224 
    225 (defmethod print-object ((c missing-dependency) s)
    226   (format s "~@<~A, required by ~A~@:>"
    227           (call-next-method c nil) (missing-required-by c)))
    228 
    229 (defun sysdef-error (format &rest arguments)
    230   (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
    231 
    232 ;;;; methods: components
    233 
    234 (defmethod print-object ((c missing-component) s)
    235    (format s "~@<component ~S not found~
    236              ~@[ in ~A~]~@:>"
    237           (missing-requires c)
    238           (when (missing-parent c)
    239             (component-name (missing-parent c)))))
    240 
    241 (defmethod print-object ((c missing-component-of-version) s)
    242   (format s "~@<component ~S does not match version ~A~
    243               ~@[ in ~A~]~@:>"
    244            (missing-requires c)
    245            (missing-version c)
    246            (when (missing-parent c)
    247              (component-name (missing-parent c)))))
    248 
    249 (defgeneric component-system (component)
    250   (:documentation "Find the top-level system containing COMPONENT"))
    251 
    252 (defmethod component-system ((component component))
    253   (aif (component-parent component)
    254        (component-system it)
    255        component))
    256 
    257 (defmethod print-object ((c component) stream)
    258   (print-unreadable-object (c stream :type t :identity t)
    259     (ignore-errors
    260       (prin1 (component-name c) stream))))
    261 
    262 (defclass module (component)
    263   ((components :initform nil :accessor module-components :initarg :components)
    264    ;; what to do if we can't satisfy a dependency of one of this module's
    265    ;; components.  This allows a limited form of conditional processing
    266    (if-component-dep-fails :initform :fail
    267                            :accessor module-if-component-dep-fails
    268                            :initarg :if-component-dep-fails)
    269    (default-component-class :accessor module-default-component-class
    270      :initform 'cl-source-file :initarg :default-component-class)))
    271 
    272 (defgeneric component-pathname (component)
    273   (:documentation "Extracts the pathname applicable for a particular component."))
    274 
    275 (defun component-parent-pathname (component)
    276   (aif (component-parent component)
    277        (component-pathname it)
    278        *default-pathname-defaults*))
    279 
    280 (defgeneric component-relative-pathname (component)
    281   (:documentation "Extracts the relative pathname applicable for a particular component."))
    282 
    283 (defmethod component-relative-pathname ((component module))
    284   (or (slot-value component 'relative-pathname)
    285       (make-pathname
    286        :directory `(:relative ,(component-name component))
    287        :host (pathname-host (component-parent-pathname component)))))
    288 
    289 (defmethod component-pathname ((component component))
    290   (let ((*default-pathname-defaults* (component-parent-pathname component)))
    291     (merge-pathnames (component-relative-pathname component))))
    292 
    293 (defgeneric component-property (component property))
    294 
    295 (defmethod component-property ((c component) property)
    296   (cdr (assoc property (slot-value c 'properties) :test #'equal)))
    297 
    298 (defgeneric (setf component-property) (new-value component property))
    299 
    300 (defmethod (setf component-property) (new-value (c component) property)
    301   (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    302     (if a
    303         (setf (cdr a) new-value)
    304         (setf (slot-value c 'properties)
    305               (acons property new-value (slot-value c 'properties))))))
    306 
    307 (defclass system (module)
    308   ((description :accessor system-description :initarg :description)
    309    (long-description
    310     :accessor system-long-description :initarg :long-description)
    311    (author :accessor system-author :initarg :author)
    312    (maintainer :accessor system-maintainer :initarg :maintainer)
    313    (licence :accessor system-licence :initarg :licence
    314             :accessor system-license :initarg :license)))
    315 
    316 ;;; version-satisfies
    317 
    318 ;;; with apologies to christophe rhodes ...
    319 (defun split (string &optional max (ws '(#\Space #\Tab)))
    320   (flet ((is-ws (char) (find char ws)))
    321     (nreverse
    322      (let ((list nil) (start 0) (words 0) end)
    323        (loop
    324          (when (and max (>= words (1- max)))
    325            (return (cons (subseq string start) list)))
    326          (setf end (position-if #'is-ws string :start start))
    327          (push (subseq string start end) list)
    328          (incf words)
    329          (unless end (return list))
    330          (setf start (1+ end)))))))
    331 
    332 (defgeneric version-satisfies (component version))
    333 
    334 (defmethod version-satisfies ((c component) version)
    335   (unless (and version (slot-boundp c 'version))
    336     (return-from version-satisfies t))
    337   (let ((x (mapcar #'parse-integer
    338                    (split (component-version c) nil '(#\.))))
    339         (y (mapcar #'parse-integer
    340                    (split version nil '(#\.)))))
    341     (labels ((bigger (x y)
    342                (cond ((not y) t)
    343                      ((not x) nil)
    344                      ((> (car x) (car y)) t)
    345                      ((= (car x) (car y))
    346                       (bigger (cdr x) (cdr y))))))
    347       (and (= (car x) (car y))
    348            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    349 
    350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    351 ;;; finding systems
    352 
    353 (defvar *defined-systems* (make-hash-table :test 'equal))
    354 (defun coerce-name (name)
    355   (typecase name
    356     (component (component-name name))
    357     (symbol (string-downcase (symbol-name name)))
    358     (string name)
    359     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    360 
    361 ;;; for the sake of keeping things reasonably neat, we adopt a
    362 ;;; convention that functions in this list are prefixed SYSDEF-
    363 
    364 (defvar *system-definition-search-functions*
    365   '(sysdef-central-registry-search))
    366 
    367 (defun system-definition-pathname (system)
    368   (let ((system-name (coerce-name system)))
    369     (or
    370      (some (lambda (x) (funcall x system-name))
    371            *system-definition-search-functions*)
    372      (let ((system-pair (system-registered-p system-name)))
    373        (and system-pair
    374             (system-source-file (cdr system-pair)))))))
    375 
    376 (defvar *central-registry*
    377   '(*default-pathname-defaults*
    378     #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
    379     #+nil "telent:asdf;systems;"))
    380 
    381 (defun sysdef-central-registry-search (system)
    382   (let ((name (coerce-name system)))
    383     (block nil
    384       (dolist (dir *central-registry*)
    385         (let* ((defaults (eval dir))
    386                (file (and defaults
    387                           (make-pathname
    388                            :defaults defaults :version :newest
    389                            :name name :type "asd" :case :local))))
    390           (if (and file (probe-file file))
    391               (return file)))))))
    392 
    393 (defun make-temporary-package ()
    394   (flet ((try (counter)
    395            (ignore-errors
    396              (make-package (format nil "ASDF~D" counter)
    397                            :use '(:cl :asdf)))))
    398     (do* ((counter 0 (+ counter 1))
    399           (package (try counter) (try counter)))
    400          (package package))))
    401 
    402 (defun find-system (name &optional (error-p t))
    403   (let* ((name (coerce-name name))
    404          (in-memory (system-registered-p name))
    405          (on-disk (system-definition-pathname name)))
    406     (when (and on-disk
    407                (or (not in-memory)
    408                    (< (car in-memory) (file-write-date on-disk))))
    409       (let ((package (make-temporary-package)))
    410         (unwind-protect
    411              (let ((*package* package))
    412                (format
    413                 *verbose-out*
    414                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    415                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    416                 ;; ON-DISK), but CMUCL barfs on that.
    417                 on-disk
    418                 *package*)
    419                (load on-disk))
    420           (delete-package package))))
    421     (let ((in-memory (system-registered-p name)))
    422       (if in-memory
    423           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
    424                  (cdr in-memory))
    425           (if error-p (error 'missing-component :requires name))))))
    426 
    427 (defun register-system (name system)
    428   (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    429   (setf (gethash (coerce-name name) *defined-systems*)
    430         (cons (get-universal-time) system)))
    431 
    432 (defun system-registered-p (name)
    433   (gethash (coerce-name name) *defined-systems*))
    434 
    435 
    436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    437 ;;; finding components
    438 
    439 (defgeneric find-component (module name &optional version)
    440   (:documentation "Finds the component with name NAME present in the
    441 MODULE module; if MODULE is nil, then the component is assumed to be a
    442 system."))
    443 
    444 (defmethod find-component ((module module) name &optional version)
    445   (if (slot-boundp module 'components)
    446       (let ((m (find name (module-components module)
    447                      :test #'equal :key #'component-name)))
    448         (if (and m (version-satisfies m version)) m))))
    449 
    450 
    451 ;;; a component with no parent is a system
    452 (defmethod find-component ((module (eql nil)) name &optional version)
    453   (let ((m (find-system name nil)))
    454     (if (and m (version-satisfies m version)) m)))
    455 
    456 ;;; component subclasses
    457 
    458 (defclass source-file (component) ())
    459 
    460 (defclass cl-source-file (source-file) ())
    461 (defclass c-source-file (source-file) ())
    462 (defclass java-source-file (source-file) ())
    463 (defclass static-file (source-file) ())
    464 (defclass doc-file (static-file) ())
    465 (defclass html-file (doc-file) ())
    466 
    467 (defgeneric source-file-type (component system))
    468 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
    469 (defmethod source-file-type ((c c-source-file) (s module)) "c")
    470 (defmethod source-file-type ((c java-source-file) (s module)) "java")
    471 (defmethod source-file-type ((c html-file) (s module)) "html")
    472 (defmethod source-file-type ((c static-file) (s module)) nil)
    473 
    474 (defmethod component-relative-pathname ((component source-file))
    475   (let ((relative-pathname (slot-value component 'relative-pathname)))
    476     (if relative-pathname
    477         (merge-pathnames
    478          relative-pathname
    479          (make-pathname
    480           :type (source-file-type component (component-system component))))
    481         (let* ((*default-pathname-defaults*
    482                 (component-parent-pathname component))
    483                (name-type
    484                 (make-pathname
    485                  :name (component-name component)
    486                  :type (source-file-type component
    487                                          (component-system component)))))
    488           name-type))))
    489 
    490 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    491 ;;; operations
    492 
    493 ;;; one of these is instantiated whenever (operate ) is called
    494 
    495 (defclass operation ()
    496   ((forced :initform nil :initarg :force :accessor operation-forced)
    497    (original-initargs :initform nil :initarg :original-initargs
    498                       :accessor operation-original-initargs)
    499    (visited-nodes :initform nil :accessor operation-visited-nodes)
    500    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
    501    (parent :initform nil :initarg :parent :accessor operation-parent)))
    502 
    503 (defmethod print-object ((o operation) stream)
    504   (print-unreadable-object (o stream :type t :identity t)
    505     (ignore-errors
    506       (prin1 (operation-original-initargs o) stream))))
    507 
    508 (defmethod shared-initialize :after ((operation operation) slot-names
    509                                      &key force
    510                                      &allow-other-keys)
    511   (declare (ignore slot-names force))
    512   ;; empty method to disable initarg validity checking
    513   )
    514166
    515167(define-method-combination standard-asdf-method-combination ()
     
    540192          standard-form))))
    541193
     194(setf (documentation 'standard-asdf-method-combination
     195                     'method-combination)
     196      "This method combination is based on the standard method combination,
     197but defines a new method-qualifier, `asdf:around`.  `asdf:around`
     198methods will be run *around* any `:around` methods, so that the core
     199protocol may employ around methods and those around methods will not
     200be overridden by around methods added by a system developer.")
     201
    542202(defgeneric perform (operation component)
    543203  (:method-combination standard-asdf-method-combination))
     
    551211  (:method-combination standard-asdf-method-combination))
    552212
    553 (defun node-for (o c)
    554   (cons (class-name (class-of o)) c))
     213(defgeneric system-source-file (system)
     214  (:documentation "Return the source file in which system is defined."))
     215
     216(defgeneric component-system (component)
     217  (:documentation "Find the top-level system containing COMPONENT"))
     218
     219(defgeneric component-pathname (component)
     220  (:documentation "Extracts the pathname applicable for a particular component."))
     221
     222(defgeneric component-relative-pathname (component)
     223  (:documentation "Extracts the relative pathname applicable for a particular component."))
     224
     225(defgeneric component-property (component property))
     226
     227(defgeneric (setf component-property) (new-value component property))
     228
     229(defgeneric version-satisfies (component version))
     230
     231(defgeneric find-component (module name &optional version)
     232  (:documentation "Finds the component with name NAME present in the
     233MODULE module; if MODULE is nil, then the component is assumed to be a
     234system."))
     235
     236(defgeneric source-file-type (component system))
    555237
    556238(defgeneric operation-ancestor (operation)
     
    558240   "Recursively chase the operation's parent pointer until we get to
    559241the head of the tree"))
     242
     243(defgeneric component-visited-p (operation component))
     244
     245(defgeneric visit-component (operation component data))
     246
     247(defgeneric (setf visiting-component) (new-value operation component))
     248
     249(defgeneric component-visiting-p (operation component))
     250
     251(defgeneric component-depends-on (operation component)
     252  (:documentation
     253   "Returns a list of dependencies needed by the component to perform
     254    the operation.  A dependency has one of the following forms:
     255
     256      (<operation> <component>*), where <operation> is a class
     257        designator and each <component> is a component
     258        designator, which means that the component depends on
     259        <operation> having been performed on each <component>; or
     260
     261      (FEATURE <feature>), which means that the component depends
     262        on <feature>'s presence in *FEATURES*.
     263
     264    Methods specialized on subclasses of existing component types
     265    should usually append the results of CALL-NEXT-METHOD to the
     266    list."))
     267
     268(defgeneric component-self-dependencies (operation component))
     269
     270(defgeneric traverse (operation component)
     271  (:documentation
     272"Generate and return a plan for performing `operation` on `component`.
     273
     274The plan returned is a list of dotted-pairs. Each pair is the `cons`
     275of ASDF operation object and a `component` object. The pairs will be
     276processed in order by `operate`."))
     277
     278(defgeneric output-files-using-mappings (source possible-paths path-mappings)
     279  (:documentation
     280"Use the variable \\*source-to-target-mappings\\* to find
     281an output path for the source. The algorithm transforms each
     282entry in possible-paths as follows: If there is a mapping
     283whose source starts with the path of possible-path, then
     284replace possible-path with a pathname that starts with the
     285target of the mapping and continues with the rest of
     286possible-path. If no such mapping is found, then use the
     287default mapping.
     288
     289If \\*centralize-lisp-binaries\\* is false, then the default
     290mapping is to place the output in a subdirectory of the
     291source. The subdirectory is named using the Lisp
     292implementation \(see
     293implementation-specific-directory-name\). If
     294\\*centralize-lisp-binaries\\* is true, then the default
     295mapping is to place the output in subdirectories of
     296\\*default-toplevel-directory\\* where the subdirectory
     297structure will mirror that of the source."))
     298
     299
     300;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     301;; utility stuff
     302
     303(defmacro aif (test then &optional else)
     304  `(let ((it ,test)) (if it ,then ,else)))
     305
     306(defun pathname-sans-name+type (pathname)
     307  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     308and NIL NAME and TYPE components"
     309  (make-pathname :name nil :type nil :defaults pathname))
     310
     311(define-modify-macro appendf (&rest args)
     312  append "Append onto list")
     313
     314(defun asdf-message (format-string &rest format-args)
     315  (declare (dynamic-extent format-args))
     316  (apply #'format *verbose-out* format-string format-args))
     317
     318(defun split-path-string (s &optional force-directory)
     319  (check-type s string)
     320  (let* ((components (split s nil "/"))
     321         (last-comp (car (last components))))
     322    (multiple-value-bind (relative components)
     323        (if (equal (first components) "")
     324          (values :absolute (cdr components))
     325          (values :relative components))
     326      (cond
     327        ((equal last-comp "")
     328         (values relative (butlast components) nil))
     329        (force-directory
     330         (values relative components nil))
     331        (t
     332         (values relative (butlast components) last-comp))))))
     333
     334;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     335;; classes, condiitons
     336
     337(define-condition system-definition-error (error) ()
     338  ;; [this use of :report should be redundant, but unfortunately it's not.
     339  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
     340  ;; over print-object; this is always conditions::%print-condition for
     341  ;; condition objects, which in turn does inheritance of :report options at
     342  ;; run-time.  fortunately, inheritance means we only need this kludge here in
     343  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
     344  #+cmu (:report print-object))
     345
     346(define-condition formatted-system-definition-error (system-definition-error)
     347  ((format-control :initarg :format-control :reader format-control)
     348   (format-arguments :initarg :format-arguments :reader format-arguments))
     349  (:report (lambda (c s)
     350             (apply #'format s (format-control c) (format-arguments c)))))
     351
     352(define-condition circular-dependency (system-definition-error)
     353  ((components :initarg :components :reader circular-dependency-components)))
     354
     355(define-condition duplicate-names (system-definition-error)
     356  ((name :initarg :name :reader duplicate-names-name)))
     357
     358(define-condition missing-component (system-definition-error)
     359  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
     360   (parent :initform nil :reader missing-parent :initarg :parent)))
     361
     362(define-condition missing-component-of-version (missing-component)
     363  ((version :initform nil :reader missing-version :initarg :version)))
     364
     365(define-condition missing-dependency (missing-component)
     366  ((required-by :initarg :required-by :reader missing-required-by)))
     367
     368(define-condition missing-dependency-of-version (missing-dependency
     369                                                 missing-component-of-version)
     370  ())
     371
     372(define-condition operation-error (error)
     373  ((component :reader error-component :initarg :component)
     374   (operation :reader error-operation :initarg :operation))
     375  (:report (lambda (c s)
     376             (format s "~@<erred while invoking ~A on ~A~@:>"
     377                     (error-operation c) (error-component c)))))
     378(define-condition compile-error (operation-error) ())
     379(define-condition compile-failed (compile-error) ())
     380(define-condition compile-warned (compile-error) ())
     381
     382(defclass component ()
     383  ((name :accessor component-name :initarg :name :documentation
     384         "Component name: designator for a string composed of portable pathname characters")
     385   (version :accessor component-version :initarg :version)
     386   (in-order-to :initform nil :initarg :in-order-to)
     387   ;; XXX crap name
     388   (do-first :initform nil :initarg :do-first)
     389   ;; methods defined using the "inline" style inside a defsystem form:
     390   ;; need to store them somewhere so we can delete them when the system
     391   ;; is re-evaluated
     392   (inline-methods :accessor component-inline-methods :initform nil)
     393   (parent :initarg :parent :initform nil :reader component-parent)
     394   ;; no direct accessor for pathname, we do this as a method to allow
     395   ;; it to default in funky ways if not supplied
     396   (relative-pathname :initarg :pathname)
     397   (operation-times :initform (make-hash-table )
     398                    :accessor component-operation-times)
     399   ;; XXX we should provide some atomic interface for updating the
     400   ;; component properties
     401   (properties :accessor component-properties :initarg :properties
     402               :initform nil)))
     403
     404;;;; methods: conditions
     405
     406(defmethod print-object ((c missing-dependency) s)
     407  (format s "~@<~A, required by ~A~@:>"
     408          (call-next-method c nil) (missing-required-by c)))
     409
     410(defun sysdef-error (format &rest arguments)
     411  (error 'formatted-system-definition-error :format-control
     412         format :format-arguments arguments))
     413
     414;;;; methods: components
     415
     416(defmethod print-object ((c missing-component) s)
     417   (format s "~@<component ~S not found~
     418             ~@[ in ~A~]~@:>"
     419          (missing-requires c)
     420          (when (missing-parent c)
     421            (component-name (missing-parent c)))))
     422
     423(defmethod print-object ((c missing-component-of-version) s)
     424  (format s "~@<component ~S does not match version ~A~
     425              ~@[ in ~A~]~@:>"
     426           (missing-requires c)
     427           (missing-version c)
     428           (when (missing-parent c)
     429             (component-name (missing-parent c)))))
     430
     431(defmethod component-system ((component component))
     432  (aif (component-parent component)
     433       (component-system it)
     434       component))
     435
     436(defmethod print-object ((c component) stream)
     437  (print-unreadable-object (c stream :type t :identity t)
     438    (ignore-errors
     439      (prin1 (component-name c) stream))))
     440
     441(defclass module (component)
     442  ((components :initform nil :accessor module-components :initarg :components)
     443   ;; what to do if we can't satisfy a dependency of one of this module's
     444   ;; components.  This allows a limited form of conditional processing
     445   (if-component-dep-fails :initform :fail
     446                           :accessor module-if-component-dep-fails
     447                           :initarg :if-component-dep-fails)
     448   (default-component-class :accessor module-default-component-class
     449     :initform 'cl-source-file :initarg :default-component-class)))
     450
     451(defun component-parent-pathname (component)
     452  (aif (component-parent component)
     453       (component-pathname it)
     454       *default-pathname-defaults*))
     455
     456(defmethod component-relative-pathname ((component module))
     457  (or (slot-value component 'relative-pathname)
     458      (multiple-value-bind (relative path)
     459          (split-path-string (component-name component) t)
     460        (make-pathname
     461         :directory `(,relative ,@path)
     462         :host (pathname-host (component-parent-pathname component))))))
     463
     464(defmethod component-pathname ((component component))
     465  (let ((*default-pathname-defaults* (component-parent-pathname component)))
     466    (merge-pathnames (component-relative-pathname component))))
     467
     468(defmethod component-property ((c component) property)
     469  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
     470
     471(defmethod (setf component-property) (new-value (c component) property)
     472  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
     473    (if a
     474        (setf (cdr a) new-value)
     475        (setf (slot-value c 'properties)
     476              (acons property new-value (slot-value c 'properties))))))
     477
     478(defclass system (module)
     479  ((description :accessor system-description :initarg :description)
     480   (long-description
     481    :accessor system-long-description :initarg :long-description)
     482   (author :accessor system-author :initarg :author)
     483   (maintainer :accessor system-maintainer :initarg :maintainer)
     484   (licence :accessor system-licence :initarg :licence
     485            :accessor system-license :initarg :license)
     486   (source-file :reader system-source-file :initarg :source-file
     487                :writer %set-system-source-file)))
     488
     489;;; version-satisfies
     490
     491;;; with apologies to christophe rhodes ...
     492(defun split (string &optional max (ws '(#\Space #\Tab)))
     493  (flet ((is-ws (char) (find char ws)))
     494    (nreverse
     495     (let ((list nil) (start 0) (words 0) end)
     496       (loop
     497         (when (and max (>= words (1- max)))
     498           (return (cons (subseq string start) list)))
     499         (setf end (position-if #'is-ws string :start start))
     500         (push (subseq string start end) list)
     501         (incf words)
     502         (unless end (return list))
     503         (setf start (1+ end)))))))
     504
     505(defmethod version-satisfies ((c component) version)
     506  (unless (and version (slot-boundp c 'version))
     507    (return-from version-satisfies t))
     508  (let ((x (mapcar #'parse-integer
     509                   (split (component-version c) nil '(#\.))))
     510        (y (mapcar #'parse-integer
     511                   (split version nil '(#\.)))))
     512    (labels ((bigger (x y)
     513               (cond ((not y) t)
     514                     ((not x) nil)
     515                     ((> (car x) (car y)) t)
     516                     ((= (car x) (car y))
     517                      (bigger (cdr x) (cdr y))))))
     518      (and (= (car x) (car y))
     519           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     520
     521;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     522;;; finding systems
     523
     524(defun make-defined-systems-table ()
     525  (make-hash-table :test 'equal))
     526
     527(defvar *defined-systems* (make-defined-systems-table))
     528
     529(defun coerce-name (name)
     530  (typecase name
     531    (component (component-name name))
     532    (symbol (string-downcase (symbol-name name)))
     533    (string name)
     534    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     535
     536(defun system-registered-p (name)
     537  (gethash (coerce-name name) *defined-systems*))
     538
     539(defun map-systems (fn)
     540  "Apply `fn` to each defined system.
     541
     542`fn` should be a function of one argument. It will be
     543called with an object of type asdf:system."
     544  (maphash (lambda (_ datum)
     545             (declare (ignore _))
     546             (destructuring-bind (_ . def) datum
     547               (declare (ignore _))
     548               (funcall fn def)))
     549           *defined-systems*))
     550
     551;;; for the sake of keeping things reasonably neat, we adopt a
     552;;; convention that functions in this list are prefixed SYSDEF-
     553
     554(defvar *system-definition-search-functions*
     555  '(sysdef-central-registry-search))
     556
     557(defun system-definition-pathname (system)
     558  (let ((system-name (coerce-name system)))
     559    (or
     560     (some (lambda (x) (funcall x system-name))
     561           *system-definition-search-functions*)
     562     (let ((system-pair (system-registered-p system-name)))
     563       (and system-pair
     564            (system-source-file (cdr system-pair)))))))
     565
     566(defvar *central-registry*
     567  `((directory-namestring *default-pathname-defaults*))
     568"A list of 'system directory designators' ASDF uses to find systems.
     569
     570A 'system directory designator' is a pathname or a function
     571which evaluates to a pathname. For example:
     572
     573    (setf asdf:*central-registry*
     574          (list '*default-pathname-defaults*
     575                #p\"/home/me/cl/systems/\"
     576                #p\"/usr/share/common-lisp/systems/\"))
     577")
     578
     579(defun directory-pathname-p (pathname)
     580  "Does `pathname` represent a directory?
     581
     582A directory-pathname is a pathname _without_ a filename. The three
     583ways that the filename components can be missing are for it to be `nil`,
     584`:unspecific` or the empty string.
     585
     586Note that this does _not_ check to see that `pathname` points to an
     587actually-existing directory."
     588  (flet ((check-one (x)
     589           (not (null (member x '(nil :unspecific "")
     590                              :test 'equal)))))
     591    (and (check-one (pathname-name pathname))
     592         (check-one (pathname-type pathname)))))
     593
     594#+(or)
     595;;test
     596;;?? move into testsuite sometime soon
     597(every (lambda (p)
     598          (directory-pathname-p p))
     599        (list
     600         (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
     601         (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
     602         (make-pathname :name nil :type "" :directory '(:absolute "tmp"))
     603         (make-pathname :name "" :directory '(:absolute "tmp"))
     604         (make-pathname :type :unspecific :directory '(:absolute "tmp"))
     605         (make-pathname :name :unspecific :directory '(:absolute "tmp"))
     606         (make-pathname :name :unspecific :directory '(:absolute "tmp"))
     607         (make-pathname :type "" :directory '(:absolute "tmp"))
     608         ))
     609
     610(defun ensure-directory-pathname (pathname)
     611  (if (directory-pathname-p pathname)
     612      pathname
     613      (make-pathname :defaults pathname
     614                     :directory (append
     615                                 (pathname-directory pathname)
     616                                 (list (file-namestring pathname)))
     617                     :name nil :type nil :version nil)))
     618
     619(defun sysdef-central-registry-search (system)
     620  (let ((name (coerce-name system))
     621        (to-remove nil)
     622        (to-replace nil))
     623    (block nil
     624      (unwind-protect
     625           (dolist (dir *central-registry*)
     626             (let ((defaults (eval dir)))
     627               (when defaults
     628                 (cond ((directory-pathname-p defaults)
     629                        (let ((file (and defaults
     630                                         (make-pathname
     631                                          :defaults defaults :version :newest
     632                                          :name name :type "asd" :case :local)))
     633                               #+(and (or win32 windows) (not :clisp))
     634                               (shortcut (make-pathname
     635                                          :defaults defaults :version :newest
     636                                          :name name :type "asd.lnk" :case :local)))
     637                          (if (and file (probe-file file))
     638                              (return file))
     639                          #+(and (or win32 windows) (not :clisp))
     640                          (when (probe-file shortcut)
     641                            (let ((target (parse-windows-shortcut shortcut)))
     642                              (when target
     643                                (return (pathname target)))))))
     644                       (t
     645                        (restart-case
     646                            (let* ((*print-circle* nil)
     647                                   (message
     648                                    (format nil
     649                                            "~@<While searching for system `~a`: `~a` evaluated ~
     650to `~a` which is not a directory.~@:>"
     651                                            system dir defaults)))
     652                              (error message))
     653                          (remove-entry-from-registry ()
     654                            :report "Remove entry from *central-registry* and continue"
     655                            (push dir to-remove))
     656                          (coerce-entry-to-directory ()
     657                            :report (lambda (s)
     658                                      (format s "Coerce entry to ~a, replace ~a and continue."
     659                                              (ensure-directory-pathname defaults) dir))
     660                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
     661        ;; cleanup
     662        (dolist (dir to-remove)
     663          (setf *central-registry* (remove dir *central-registry*)))
     664        (dolist (pair to-replace)
     665          (let* ((current (car pair))
     666                 (new (cdr pair))
     667                 (position (position current *central-registry*)))
     668            (setf *central-registry*
     669                  (append (subseq *central-registry* 0 position)
     670                          (list new)
     671                          (subseq *central-registry* (1+ position))))))))))
     672
     673(defun make-temporary-package ()
     674  (flet ((try (counter)
     675           (ignore-errors
     676             (make-package (format nil "~a~D" 'asdf counter)
     677                           :use '(:cl :asdf)))))
     678    (do* ((counter 0 (+ counter 1))
     679          (package (try counter) (try counter)))
     680         (package package))))
     681
     682(defun find-system (name &optional (error-p t))
     683  (let* ((name (coerce-name name))
     684         (in-memory (system-registered-p name))
     685         (on-disk (system-definition-pathname name)))
     686    (when (and on-disk
     687               (or (not in-memory)
     688                   (< (car in-memory) (file-write-date on-disk))))
     689      (let ((package (make-temporary-package)))
     690        (unwind-protect
     691             (let ((*package* package))
     692               (asdf-message
     693                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     694                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
     695                ;; ON-DISK), but CMUCL barfs on that.
     696                on-disk
     697                *package*)
     698               (load on-disk))
     699          (delete-package package))))
     700    (let ((in-memory (system-registered-p name)))
     701      (if in-memory
     702          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
     703                 (cdr in-memory))
     704          (if error-p (error 'missing-component :requires name))))))
     705
     706(defun register-system (name system)
     707  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
     708  (setf (gethash (coerce-name name) *defined-systems*)
     709        (cons (get-universal-time) system)))
     710
     711
     712;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     713;;; finding components
     714
     715(defmethod find-component ((module module) name &optional version)
     716  (if (slot-boundp module 'components)
     717      (let ((m (find name (module-components module)
     718                     :test #'equal :key #'component-name)))
     719        (if (and m (version-satisfies m version)) m))))
     720
     721
     722;;; a component with no parent is a system
     723(defmethod find-component ((module (eql nil)) name &optional version)
     724  (let ((m (find-system name nil)))
     725    (if (and m (version-satisfies m version)) m)))
     726
     727;;; component subclasses
     728
     729(defclass source-file (component) ())
     730
     731(defclass cl-source-file (source-file) ())
     732(defclass c-source-file (source-file) ())
     733(defclass java-source-file (source-file) ())
     734(defclass static-file (source-file) ())
     735(defclass doc-file (static-file) ())
     736(defclass html-file (doc-file) ())
     737
     738(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
     739(defmethod source-file-type ((c c-source-file) (s module)) "c")
     740(defmethod source-file-type ((c java-source-file) (s module)) "java")
     741(defmethod source-file-type ((c html-file) (s module)) "html")
     742(defmethod source-file-type ((c static-file) (s module)) nil)
     743
     744(defmethod component-relative-pathname ((component source-file))
     745  (multiple-value-bind (relative path name)
     746      (split-path-string (component-name component))
     747    (let ((type (source-file-type component (component-system component)))
     748          (relative-pathname (slot-value component 'relative-pathname))
     749          (*default-pathname-defaults* (component-parent-pathname component)))
     750      (if relative-pathname
     751        (merge-pathnames
     752         relative-pathname
     753         (if type
     754           (make-pathname :name name :type type)
     755           name))
     756        (make-pathname :directory `(,relative ,@path) :name name :type type)))))
     757
     758;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     759;;; operations
     760
     761;;; one of these is instantiated whenever (operate ) is called
     762
     763(defclass operation ()
     764  ((forced :initform nil :initarg :force :accessor operation-forced)
     765   (original-initargs :initform nil :initarg :original-initargs
     766                      :accessor operation-original-initargs)
     767   (visited-nodes :initform nil :accessor operation-visited-nodes)
     768   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     769   (parent :initform nil :initarg :parent :accessor operation-parent)))
     770
     771(defmethod print-object ((o operation) stream)
     772  (print-unreadable-object (o stream :type t :identity t)
     773    (ignore-errors
     774      (prin1 (operation-original-initargs o) stream))))
     775
     776(defmethod shared-initialize :after ((operation operation) slot-names
     777                                     &key force
     778                                     &allow-other-keys)
     779  (declare (ignore slot-names force))
     780  ;; empty method to disable initarg validity checking
     781  )
     782
     783(defun node-for (o c)
     784  (cons (class-name (class-of o)) c))
    560785
    561786(defmethod operation-ancestor ((operation operation))
     
    585810
    586811
    587 (defgeneric component-visited-p (operation component))
    588 
    589 (defgeneric visit-component (operation component data))
    590 
    591812(defmethod visit-component ((o operation) (c component) data)
    592813  (unless (component-visited-p o c)
     
    598819         (operation-visited-nodes (operation-ancestor o))
    599820         :test 'equal))
    600 
    601 (defgeneric (setf visiting-component) (new-value operation component))
    602821
    603822(defmethod (setf visiting-component) (new-value operation component)
     
    613832              (remove node  (operation-visiting-nodes a) :test 'equal)))))
    614833
    615 (defgeneric component-visiting-p (operation component))
    616 
    617834(defmethod component-visiting-p ((o operation) (c component))
    618835  (let ((node (node-for o c)))
     
    620837            :test 'equal)))
    621838
    622 (defgeneric component-depends-on (operation component)
    623   (:documentation
    624    "Returns a list of dependencies needed by the component to perform
    625     the operation.  A dependency has one of the following forms:
    626 
    627       (<operation> <component>*), where <operation> is a class
    628         designator and each <component> is a component
    629         designator, which means that the component depends on
    630         <operation> having been performed on each <component>; or
    631 
    632       (FEATURE <feature>), which means that the component depends
    633         on <feature>'s presence in *FEATURES*.
    634 
    635     Methods specialized on subclasses of existing component types
    636     should usually append the results of CALL-NEXT-METHOD to the
    637     list."))
    638 
    639839(defmethod component-depends-on ((op-spec symbol) (c component))
    640840  (component-depends-on (make-instance op-spec) c))
     
    643843  (cdr (assoc (class-name (class-of o))
    644844              (slot-value c 'in-order-to))))
    645 
    646 (defgeneric component-self-dependencies (operation component))
    647845
    648846(defmethod component-self-dependencies ((o operation) (c component))
     
    706904;;; methods".  And the answer is, because standard method combination
    707905;;; runs :before methods most->least-specific, which is back to front
    708 ;;; for our purposes.  And CLISP doesn't have non-standard method
    709 ;;; combinations, so let's keep it simple and aspire to portability
    710 
    711 (defgeneric traverse (operation component))
     906;;; for our purposes. 
     907
    712908(defmethod traverse ((operation operation) (c component))
    713909  (let ((forced nil))
    714     (labels ((do-one-dep (required-op required-c required-v)
     910    (labels ((%do-one-dep (required-op required-c required-v)
    715911               (let* ((dep-c (or (find-component
    716912                                  (component-parent c)
     
    729925                      (op (make-sub-operation c operation dep-c required-op)))
    730926                 (traverse op dep-c)))
     927             (do-one-dep (required-op required-c required-v)
     928               (loop
     929                  (restart-case
     930                      (return (%do-one-dep required-op required-c required-v))
     931                    (retry ()
     932                      :report (lambda (s)
     933                                (format s "~@<Retry loading component ~S.~@:>"
     934                                        required-c))
     935                      :test
     936                      (lambda (c)
     937#|
     938                        (print (list :c1 c (typep c 'missing-dependency)))
     939                        (when (typep c 'missing-dependency)
     940                          (print (list :c2 (missing-requires c) required-c
     941                                       (equalp (missing-requires c)
     942                                               required-c))))
     943|#
     944                        (and (typep c 'missing-dependency)
     945                             (equalp (missing-requires c)
     946                                     required-c)))))))
    731947             (do-dep (op dep)
    732948               (cond ((eq op 'feature)
     
    738954                      (dolist (d dep)
    739955                        (cond ((consp d)
    740                                (assert (string-equal
    741                                         (symbol-name (first d))
    742                                         "VERSION"))
    743                                (appendf forced
    744                                         (do-one-dep op (second d) (third d))))
     956                               (cond ((string-equal
     957                                       (symbol-name (first d))
     958                                       "VERSION")
     959                                      (appendf
     960                                       forced
     961                                       (do-one-dep op (second d) (third d))))
     962                                     ((and (string-equal
     963                                            (symbol-name (first d))
     964                                            "FEATURE")
     965                                           (find (second d) *features*
     966                                                 :test 'string-equal))
     967                                      (appendf
     968                                       forced
     969                                       (do-one-dep op (second d) (third d))))
     970                                     (t
     971                                      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
    745972                              (t
    746973                               (appendf forced (do-one-dep op d nil)))))))))
     
    754981      (unwind-protect
    755982           (progn
    756              (loop for (required-op . deps) in 
     983             (loop for (required-op . deps) in
    757984                  (component-depends-on operation c)
    758                 do (do-dep required-op deps))
     985                  do (do-dep required-op deps))
    759986             ;; constituent bits
    760987             (let ((module-ops
     
    767994                                  (appendf forced (traverse operation kid ))
    768995                                (missing-dependency (condition)
    769                                   (if (eq (module-if-component-dep-fails c) 
     996                                  (if (eq (module-if-component-dep-fails c)
    770997                                          :fail)
    771998                                      (error condition))
     
    7821009               (when (or forced module-ops
    7831010                         (not (operation-done-p operation c))
    784                          (let ((f (operation-forced 
     1011                         (let ((f (operation-forced
    7851012                                   (operation-ancestor operation))))
    7861013                           (and f (or (not (consp f))
     
    8111038
    8121039(defmethod explain ((operation operation) (component component))
    813   (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
     1040  (asdf-message "~&;;; ~A on ~A~%" operation component))
    8141041
    8151042;;; compile-op
     
    8901117            (perform (make-instance 'asdf:compile-op) c))
    8911118           (t
    892             (with-simple-restart 
     1119            (with-simple-restart
    8931120                (try-recompiling "Recompile ~a and try loading it again"
    8941121                                  (component-name c))
     
    9101137            (perform (make-instance 'asdf:compile-op) c))
    9111138           (t
    912             (with-simple-restart 
     1139            (with-simple-restart
    9131140                (try-recompiling "Try recompiling ~a"
    9141141                                  (component-name c))
     
    9711198  nil)
    9721199
     1200(defmethod component-depends-on :around ((o test-op) (c system))
     1201  (cons `(load-op ,(component-name c)) (call-next-method)))
     1202
     1203
    9731204;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    9741205;;; invoking operations
    9751206
    976 (defvar *operate-docstring*
    977   "Operate does three things:
    978 
    979 1. It creates an instance of `operation-class` using any keyword parameters
    980 as initargs.
    981 2. It finds the  asdf-system specified by `system` (possibly loading
    982 it from disk).
    983 3. It then calls `traverse` with the operation and system as arguments
    984 
    985 The traverse operation is wrapped in `with-compilation-unit` and error
    986 handling code. If a `version` argument is supplied, then operate also
    987 ensures that the system found satisfies it using the `version-satisfies`
    988 method.")
    989 
    990 (defun operate (operation-class system &rest args &key (verbose t) version
     1207(defun operate (operation-class system &rest args &key (verbose t) version force
    9911208                &allow-other-keys)
    992   (let* ((op (apply #'make-instance operation-class
     1209  (declare (ignore force))
     1210  (let* ((*package* *package*)
     1211         (*readtable* *readtable*)
     1212         (op (apply #'make-instance operation-class
    9931213                    :original-initargs args
    9941214                    args))
     
    10181238                                      (component-operation-times component))
    10191239                             (get-universal-time))
    1020                        (return)))))))))
    1021 
    1022 (setf (documentation 'operate 'function)
    1023       *operate-docstring*)
    1024 
    1025 (defun oos (operation-class system &rest args &key force (verbose t) version)
     1240                       (return)))))))
     1241    op))
     1242
     1243(defun oos (operation-class system &rest args &key force (verbose t) version
     1244            &allow-other-keys)
    10261245  (declare (ignore force verbose version))
    10271246  (apply #'operate operation-class system args))
    10281247
    1029 (setf (documentation 'oos 'function)
    1030       (format nil
    1031               "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
    1032               *operate-docstring*))
     1248(let ((operate-docstring
     1249  "Operate does three things:
     1250
     12511. It creates an instance of `operation-class` using any keyword parameters
     1252as initargs.
     12532. It finds the  asdf-system specified by `system` (possibly loading
     1254it from disk).
     12553. It then calls `traverse` with the operation and system as arguments
     1256
     1257The traverse operation is wrapped in `with-compilation-unit` and error
     1258handling code. If a `version` argument is supplied, then operate also
     1259ensures that the system found satisfies it using the `version-satisfies`
     1260method.
     1261
     1262Note that dependencies may cause the operation to invoke other
     1263operations on the system or its components: the new operations will be
     1264created with the same initargs as the original one.
     1265"))
     1266  (setf (documentation 'oos 'function)
     1267        (format nil
     1268                "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
     1269                operate-docstring))
     1270  (setf (documentation 'operate 'function)
     1271        operate-docstring))
     1272
     1273(defun load-system (system &rest args &key force (verbose t) version)
     1274  "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
     1275  (declare (ignore force verbose version))
     1276  (apply #'operate 'load-op system args))
     1277
     1278(defun compile-system (system &rest args &key force (verbose t) version)
     1279  "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details."
     1280  (declare (ignore force verbose version))
     1281  (apply #'operate 'compile-op system args))
     1282
     1283(defun test-system (system &rest args &key force (verbose t) version)
     1284  "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
     1285  (declare (ignore force verbose version))
     1286  (apply #'operate 'test-op system args))
    10331287
    10341288;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    10431297                                                 key (cddr arglist))))))))
    10441298    (aux key arglist)))
     1299
     1300(defun resolve-symlinks (path)
     1301  #-allegro (truename path)
     1302  #+allegro (excl:pathname-resolve-symbolic-links path)
     1303  )
     1304
     1305(defun determine-system-pathname (pathname pathname-supplied-p)
     1306  ;; called from the defsystem macro.
     1307  ;; the pathname of a system is either
     1308  ;; 1. the one supplied,
     1309  ;; 2. derived from the *load-truename* (see below), or
     1310  ;; 3. taken from *default-pathname-defaults*
     1311  ;;
     1312  ;; if using *load-truename*, then we also deal with whether or not
     1313  ;; to resolve symbolic links. If not resolving symlinks, then we use
     1314  ;; *load-pathname* instead of *load-truename* since in some
     1315  ;; implementations, the latter has *already resolved it.
     1316  (or (and pathname-supplied-p pathname)
     1317      (when *load-truename*
     1318        (pathname-sans-name+type
     1319         (if *resolve-symlinks*
     1320             (resolve-symlinks *load-truename*)
     1321             *load-pathname*)))
     1322      *default-pathname-defaults*))
    10451323
    10461324(defmacro defsystem (name &body options)
     
    10571335                  (setf (car s) (get-universal-time)))
    10581336                 (s
    1059                   #+clisp
    1060                   (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
    1061                   #-clisp
    10621337                  (change-class (cdr s) ',class))
    10631338                 (t
    10641339                  (register-system (quote ,name)
    1065                                    (make-instance ',class :name ',name)))))
    1066          (parse-component-form nil (apply
    1067                                     #'list
    1068                                     :module (coerce-name ',name)
    1069                                     :pathname
    1070                                     ;; to avoid a note about unreachable code
    1071                                     ,(if pathname-arg-p
    1072                                          pathname
    1073                                          `(or (when *load-truename*
    1074                                                 (pathname-sans-name+type
    1075                                                  (resolve-symlinks
    1076                                                   *load-truename*)))
    1077                                               *default-pathname-defaults*))
    1078                                     ',component-options))))))
     1340                                   (make-instance ',class :name ',name))))
     1341           (%set-system-source-file *load-truename*
     1342                                    (cdr (system-registered-p ',name))))
     1343         (parse-component-form
     1344          nil (apply
     1345               #'list
     1346               :module (coerce-name ',name)
     1347               :pathname
     1348               ,(determine-system-pathname pathname pathname-arg-p)
     1349               ',component-options))))))
    10791350
    10801351
     
    11311402(defvar *serial-depends-on*)
    11321403
     1404(defun sysdef-error-component (msg type name value)
     1405  (sysdef-error (concatenate 'string msg
     1406                             "~&The value specified for ~(~A~) ~A is ~W")
     1407                type name value))
     1408
     1409(defun check-component-input (type name weakly-depends-on
     1410                              depends-on components in-order-to)
     1411  "A partial test of the values of a component."
     1412  (unless (listp depends-on)
     1413    (sysdef-error-component ":depends-on must be a list."
     1414                            type name depends-on))
     1415  (unless (listp weakly-depends-on)
     1416    (sysdef-error-component ":weakly-depends-on must be a list."
     1417                            type name weakly-depends-on))
     1418  (unless (listp components)
     1419    (sysdef-error-component ":components must be NIL or a list of components."
     1420                            type name components))
     1421  (unless (and (listp in-order-to) (listp (car in-order-to)))
     1422    (sysdef-error-component ":in-order-to must be NIL or a list of components."
     1423                            type name in-order-to)))
     1424
     1425(defun %remove-component-inline-methods (component)
     1426  (loop for name in +asdf-methods+
     1427        do (map 'nil
     1428                ;; this is inefficient as most of the stored
     1429                ;; methods will not be for this particular gf n
     1430                ;; But this is hardly performance-critical
     1431                (lambda (m)
     1432                  (remove-method (symbol-function name) m))
     1433                (component-inline-methods component)))
     1434  ;; clear methods, then add the new ones
     1435  (setf (component-inline-methods component) nil))
     1436
     1437(defun %define-component-inline-methods (ret rest)
     1438  (loop for name in +asdf-methods+ do
     1439       (let ((keyword (intern (symbol-name name) :keyword)))
     1440         (loop for data = rest then (cddr data)
     1441              for key = (first data)
     1442              for value = (second data)
     1443              while data
     1444              when (eq key keyword) do
     1445              (destructuring-bind (op qual (o c) &body body) value
     1446              (pushnew
     1447                 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
     1448                                   ,@body))
     1449                 (component-inline-methods ret)))))))
     1450
     1451(defun %refresh-component-inline-methods (component rest)
     1452  (%remove-component-inline-methods component)
     1453  (%define-component-inline-methods component rest))
     1454 
    11331455(defun parse-component-form (parent options)
    11341456
     
    12051527            (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
    12061528
    1207       (%remove-component-inline-methods ret rest)
     1529      (%refresh-component-inline-methods ret rest)
    12081530
    12091531      ret)))
    1210 
    1211 (defun %remove-component-inline-methods (ret rest)
    1212   (loop for name in +asdf-methods+
    1213         do (map 'nil
    1214                 ;; this is inefficient as most of the stored
    1215                 ;; methods will not be for this particular gf n
    1216                 ;; But this is hardly performance-critical
    1217                 (lambda (m)
    1218                   (remove-method (symbol-function name) m))
    1219                 (component-inline-methods ret)))
    1220   ;; clear methods, then add the new ones
    1221   (setf (component-inline-methods ret) nil)
    1222   (loop for name in +asdf-methods+
    1223         for v = (getf rest (intern (symbol-name name) :keyword))
    1224         when v do
    1225         (destructuring-bind (op qual (o c) &body body) v
    1226           (pushnew
    1227            (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
    1228                              ,@body))
    1229            (component-inline-methods ret)))))
    1230 
    1231 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
    1232   "A partial test of the values of a component."
    1233   (when weakly-depends-on (warn "We got one! XXXXX"))
    1234   (unless (listp depends-on)
    1235     (sysdef-error-component ":depends-on must be a list."
    1236                             type name depends-on))
    1237   (unless (listp weakly-depends-on)
    1238     (sysdef-error-component ":weakly-depends-on must be a list."
    1239                             type name weakly-depends-on))
    1240   (unless (listp components)
    1241     (sysdef-error-component ":components must be NIL or a list of components."
    1242                             type name components))
    1243   (unless (and (listp in-order-to) (listp (car in-order-to)))
    1244     (sysdef-error-component ":in-order-to must be NIL or a list of components."
    1245                             type name in-order-to)))
    1246 
    1247 (defun sysdef-error-component (msg type name value)
    1248   (sysdef-error (concatenate 'string msg
    1249                              "~&The value specified for ~(~A~) ~A is ~W")
    1250                 type name value))
    1251 
    1252 (defun resolve-symlinks (path)
    1253   #-allegro (truename path)
    1254   #+allegro (excl:pathname-resolve-symbolic-links path)
    1255   )
    12561532
    12571533;;; optional extras
     
    12621538
    12631539(defun run-shell-command (control-string &rest args)
    1264   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
     1540  "Interpolate `args` into `control-string` as if by `format`, and
    12651541synchronously execute the result using a Bourne-compatible shell, with
    1266 output to *VERBOSE-OUT*.  Returns the shell's exit code."
     1542output to `*verbose-out*`.  Returns the shell's exit code."
    12671543  (let ((command (apply #'format nil control-string args)))
    1268     (format *verbose-out* "; $ ~A~%" command)
     1544    (asdf-message "; $ ~A~%" command)
    12691545    #+sbcl
    12701546    (sb-ext:process-exit-code
    1271      (sb-ext:run-program
    1272       #+win32 "sh" #-win32 "/bin/sh"
    1273       (list  "-c" command)
    1274       #+win32 #+win32 :search t
    1275       :input nil :output *verbose-out*))
     1547     (apply #'sb-ext:run-program
     1548            #+win32 "sh" #-win32 "/bin/sh"
     1549            (list  "-c" command)
     1550            :input nil :output *verbose-out*
     1551            #+win32 '(:search t) #-win32 nil))
    12761552
    12771553    #+(or cmu scl)
     
    12831559
    12841560    #+allegro
    1285     (excl:run-shell-command command :input nil :output *verbose-out*)
     1561    ;; will this fail if command has embedded quotes - it seems to work
     1562    (multiple-value-bind (stdout stderr exit-code)
     1563        (excl.osi:command-output
     1564         (format nil "~a -c \"~a\""
     1565                 #+mswindows "sh" #-mswindows "/bin/sh" command)
     1566         :input nil :whole nil
     1567         #+mswindows :show-window #+mswindows :hide)
     1568      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
     1569      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
     1570      exit-code)
    12861571
    12871572    #+lispworks
     
    13001585                                 :input nil :output *verbose-out*
    13011586                                 :wait t)))
     1587
    13021588    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    13031589    (si:system command)
     1590
    13041591    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
    13051592    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    13061593    ))
    13071594
    1308 (defgeneric system-source-file (system)
    1309   (:documentation "Return the source file in which system is defined."))
    1310 
    13111595(defmethod system-source-file ((system-name t))
    13121596  (system-source-file (find-system system-name)))
    13131597
    1314 (defmethod system-source-file ((system system))
    1315   (let ((pn (and (slot-boundp system 'relative-pathname)
    1316                  (make-pathname
    1317                   :type "asd"
    1318                   :name (asdf:component-name system)
    1319                   :defaults (asdf:component-relative-pathname system)))))
    1320     (when pn
    1321       (probe-file pn))))
    1322  
    13231598(defun system-source-directory (system-name)
    13241599  (make-pathname :name nil
     
    13361611                    :directory directory)
    13371612     (system-source-directory system))))
     1613
     1614;;; ---------------------------------------------------------------------------
     1615;;; asdf-binary-locations
     1616;;;
     1617;;; this bit of code was stolen from Bjorn Lindberg and then it grew!
     1618;;; see http://www.cliki.net/asdf%20binary%20locations
     1619;;; and http://groups.google.com/group/comp.lang.lisp/msg/bd5ea9d2008ab9fd
     1620;;; ---------------------------------------------------------------------------
     1621;;; Portions of this code were once from SWANK / SLIME
     1622
     1623(defparameter *centralize-lisp-binaries*
     1624  nil "
     1625If true, compiled lisp files without an explicit mapping (see
     1626\\*source-to-target-mappings\\*) will be placed in subdirectories of
     1627\\*default-toplevel-directory\\*. If false, then compiled lisp files
     1628without an explicitly mapping will be placed in subdirectories of
     1629their sources.")
     1630
     1631(defparameter *enable-asdf-binary-locations* nil
     1632  "
     1633If true, then compiled lisp files will be placed into a directory
     1634computed from the Lisp version, Operating System and computer archetecture.
     1635See [implementation-specific-directory-name][] for details.")
     1636
     1637
     1638(defparameter *default-toplevel-directory*
     1639  (merge-pathnames
     1640   (make-pathname :directory '(:relative ".fasls"))
     1641   (truename (user-homedir-pathname)))
     1642  "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.")
     1643
     1644(defparameter *include-per-user-information*
     1645  nil
     1646  "When \\*centralize-lisp-binaries\\* is true this variable controls whether or not to customize the output directory based on the current user. It can be nil, t or a string. If it is nil \(the default\), then no additional information will be added to the output directory. If it is t, then the user's name \(as taken from the return value of #'user-homedir-pathname\) will be included into the centralized path (just before the lisp-implementation directory). Finally, if \\*include-per-user-information\\* is a string, then this string will be included in the output-directory.")
     1647
     1648(defparameter *map-all-source-files*
     1649  nil
     1650  "If true, then all subclasses of source-file will have their output locations mapped by ASDF-Binary-Locations. If nil (the default), then only subclasses of cl-source-file will be mapped.")
     1651
     1652(defvar *source-to-target-mappings*
     1653  #-sbcl
     1654  nil
     1655  #+sbcl
     1656  (list (list (princ-to-string (sb-ext:posix-getenv "SBCL_HOME")) nil))
     1657  "The \\*source-to-target-mappings\\* variable specifies mappings from source to target. If the target is nil, then it means to not map the source to anything. I.e., to leave it as is. This has the effect of turning off ASDF-Binary-Locations for the given source directory. Examples:
     1658
     1659    ;; compile everything in .../src and below into .../cmucl
     1660    '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\"
     1661       \"/nfs/home/compbio/d95-bli/lib/common-lisp/cmucl/\"))
     1662
     1663    ;; leave SBCL innards alone (SBCL specific)
     1664    (list (list (princ-to-string (sb-ext:posix-getenv \"SBCL_HOME\")) nil))
     1665")
     1666
     1667(defparameter *implementation-features*
     1668  '(:allegro :lispworks :sbcl :ccl :openmcl :cmu :clisp
     1669    :corman :cormanlisp :armedbear :gcl :ecl :scl))
     1670
     1671(defparameter *os-features*
     1672  '(:windows :mswindows :win32 :mingw32
     1673    :solaris :sunos
     1674    :macosx :darwin :apple
     1675    :freebsd :netbsd :openbsd :bsd
     1676    :linux :unix))
     1677
     1678(defparameter *architecture-features*
     1679  '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3
     1680    :i486 (:i386 :pc386 :iapx386) (:x86 :x8632-target) :pentium4
     1681    :hppa64 :hppa :ppc64 :ppc32 :powerpc :ppc :sparc64 :sparc))
     1682
     1683;; note to gwking: this is in slime, system-check, and system-check-server too
     1684(defun lisp-version-string ()
     1685  #+cmu       (substitute #\- #\/
     1686                          (substitute #\_ #\Space
     1687                                      (lisp-implementation-version)))
     1688  #+scl       (lisp-implementation-version)
     1689  #+sbcl      (lisp-implementation-version)
     1690  #+ecl       (reduce (lambda (x str) (substitute #\_ str x))
     1691                      '(#\Space #\: #\( #\))
     1692                      :initial-value (lisp-implementation-version))
     1693  #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4))
     1694  #+openmcl   (format nil "~d.~d~@[-~d~]"
     1695                      ccl::*openmcl-major-version*
     1696                      ccl::*openmcl-minor-version*
     1697                      #+ppc64-target 64
     1698                      #-ppc64-target nil)
     1699  #+lispworks (format nil "~A~@[~A~]"
     1700                      (lisp-implementation-version)
     1701                      (when (member :lispworks-64bit *features*) "-64bit"))
     1702  #+allegro   (format nil
     1703                      "~A~A~A~A"
     1704                      excl::*common-lisp-version-number*
     1705                                        ; ANSI vs MoDeRn
     1706                      ;; thanks to Robert Goldman and Charley Cox for
     1707                      ;; an improvement to my hack
     1708                      (if (eq excl:*current-case-mode*
     1709                              :case-sensitive-lower) "M" "A")
     1710                      ;; Note if not using International ACL
     1711                      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     1712                      (excl:ics-target-case
     1713                        (:-ics "8")
     1714                        (:+ics ""))
     1715                      (if (member :64bit *features*) "-64bit" ""))
     1716  #+clisp     (let ((s (lisp-implementation-version)))
     1717                (subseq s 0 (position #\space s)))
     1718  #+armedbear (lisp-implementation-version)
     1719  #+cormanlisp (lisp-implementation-version)
     1720  #+digitool   (subseq (lisp-implementation-version) 8))
     1721
     1722
     1723(defparameter *implementation-specific-directory-name* nil)
     1724
     1725(defun implementation-specific-directory-name ()
     1726  "Return a name that can be used as a directory name that is
     1727unique to a Lisp implementation, Lisp implementation version,
     1728operating system, and hardware architecture."
     1729  (and *enable-asdf-binary-locations*
     1730       (list
     1731        (or *implementation-specific-directory-name*
     1732            (setf *implementation-specific-directory-name*
     1733                  (labels
     1734                      ((fp (thing)
     1735                         (etypecase thing
     1736                           (symbol
     1737                            (let ((feature (find thing *features*)))
     1738                              (when feature (return-from fp feature))))
     1739                           ;; allows features to be lists of which the first
     1740                           ;; member is the "main name", the rest being aliases
     1741                           (cons
     1742                            (dolist (subf thing)
     1743                              (let ((feature (find subf *features*)))
     1744                                (when feature (return-from fp (first thing))))))))
     1745                       (first-of (features)
     1746                         (loop for f in features
     1747                            when (fp f) return it))
     1748                       (maybe-warn (value fstring &rest args)
     1749                         (cond (value)
     1750                               (t (apply #'warn fstring args)
     1751                                  "unknown"))))
     1752                    (let ((lisp (maybe-warn (first-of *implementation-features*)
     1753                                            "No implementation feature found in ~a."
     1754                                            *implementation-features*))
     1755                          (os   (maybe-warn (first-of *os-features*)
     1756                                            "No os feature found in ~a." *os-features*))
     1757                          (arch (maybe-warn (first-of *architecture-features*)
     1758                                            "No architecture feature found in ~a."
     1759                                            *architecture-features*))
     1760                          (version (maybe-warn (lisp-version-string)
     1761                                               "Don't know how to get Lisp ~
     1762                                          implementation version.")))
     1763                      (format nil "~(~@{~a~^-~}~)" lisp version os arch))))))))
     1764
     1765(defun pathname-prefix-p (prefix pathname)
     1766  (let ((prefix-ns (namestring prefix))
     1767        (pathname-ns (namestring pathname)))
     1768    (= (length prefix-ns)
     1769       (mismatch prefix-ns pathname-ns))))
     1770
     1771(defgeneric output-files-for-system-and-operation
     1772  (system operation component source possible-paths)
     1773  (:documentation "Returns the directory where the componets output files should be placed. This may depends on the system, the operation and the component. The ASDF default input and outputs are provided in the source and possible-paths parameters."))
     1774
     1775(defun source-to-target-resolved-mappings ()
     1776  "Answer `*source-to-target-mappings*` with additional entries made
     1777by resolving sources that are symlinks.
     1778
     1779As ASDF sometimes resolves symlinks to compute source paths, we must
     1780follow that.  For example, if SBCL is installed under a symlink, and
     1781SBCL_HOME is set through that symlink, the default rule above
     1782preventing SBCL contribs from being mapped elsewhere will not be
     1783applied by the plain `*source-to-target-mappings*`."
     1784  (loop for mapping in asdf:*source-to-target-mappings*
     1785        for (source target) = mapping
     1786        for true-source = (and source (resolve-symlinks source))
     1787        if (equal source true-source)
     1788          collect mapping
     1789        else append (list mapping (list true-source target))))
     1790
     1791(defmethod output-files-for-system-and-operation
     1792           ((system system) operation component source possible-paths)
     1793  (declare (ignore operation component))
     1794  (output-files-using-mappings
     1795   source possible-paths (source-to-target-resolved-mappings)))
     1796
     1797(defmethod output-files-using-mappings (source possible-paths path-mappings)
     1798  (mapcar
     1799   (lambda (path)
     1800     (loop for (from to) in path-mappings
     1801        when (pathname-prefix-p from source)
     1802        do (return
     1803             (if to
     1804                 (merge-pathnames
     1805                  (make-pathname :type (pathname-type path))
     1806                  (merge-pathnames (enough-namestring source from)
     1807                                   to))
     1808                 path))
     1809                 
     1810        finally
     1811          (return
     1812            ;; Instead of just returning the path when we
     1813            ;; don't find a mapping, we stick stuff into
     1814            ;; the appropriate binary directory based on
     1815            ;; the implementation
     1816            (if *centralize-lisp-binaries*
     1817                (merge-pathnames
     1818                 (make-pathname
     1819                  :type (pathname-type path)
     1820                  :directory `(:relative
     1821                               ,@(cond ((eq *include-per-user-information* t)
     1822                                        (cdr (pathname-directory
     1823                                              (user-homedir-pathname))))
     1824                                       ((not (null *include-per-user-information*))
     1825                                        (list *include-per-user-information*)))
     1826                               ,@(implementation-specific-directory-name)
     1827                               ,@(rest (pathname-directory path)))
     1828                  :defaults path)
     1829                 *default-toplevel-directory*)
     1830                (make-pathname
     1831                 :type (pathname-type path)
     1832                 :directory (append
     1833                             (pathname-directory path)
     1834                             (implementation-specific-directory-name))
     1835                 :defaults path)))))
     1836          possible-paths))
     1837
     1838(defmethod output-files
     1839    :around ((operation compile-op) (component source-file))
     1840  (if (or *map-all-source-files*
     1841            (typecase component
     1842              (cl-source-file t)
     1843              (t nil)))
     1844    (let ((source (component-pathname component ))
     1845          (paths (call-next-method)))
     1846      (output-files-for-system-and-operation
     1847       (component-system component) operation component source paths))
     1848    (call-next-method)))
     1849
     1850;;;; -----------------------------------------------------------------
     1851;;;; Windows shortcut support.  Based on:
     1852;;;;
     1853;;;; Jesse Hager: The Windows Shortcut File Format.
     1854;;;; http://www.wotsit.org/list.asp?fc=13
     1855;;;; -----------------------------------------------------------------
     1856
     1857(defparameter *link-initial-dword* 76)
     1858(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     1859
     1860(defun read-null-terminated-string (s)
     1861  (with-output-to-string (out)
     1862    (loop
     1863        for code = (read-byte s)
     1864        until (zerop code)
     1865        do (write-char (code-char code) out))))
     1866
     1867(defun read-little-endian (s &optional (bytes 4))
     1868  (let ((result 0))
     1869    (loop
     1870        for i from 0 below bytes
     1871        do
     1872          (setf result (logior result (ash (read-byte s) (* 8 i)))))
     1873    result))
     1874
     1875(defun parse-windows-shortcut (pathname)
     1876  (with-open-file (s pathname :element-type '(unsigned-byte 8))
     1877    (handler-case
     1878        (when (and (= (read-little-endian s) *link-initial-dword*)
     1879                   (let ((header (make-array (length *link-guid*))))
     1880                     (read-sequence header s)
     1881                     (equalp header *link-guid*)))
     1882          (let ((flags (read-little-endian s)))
     1883            (file-position s 76)        ;skip rest of header
     1884            (when (logbitp 0 flags)
     1885              ;; skip shell item id list
     1886              (let ((length (read-little-endian s 2)))
     1887                (file-position s (+ length (file-position s)))))
     1888            (cond
     1889              ((logbitp 1 flags)
     1890                (parse-file-location-info s))
     1891              (t
     1892                (when (logbitp 2 flags)
     1893                  ;; skip description string
     1894                  (let ((length (read-little-endian s 2)))
     1895                    (file-position s (+ length (file-position s)))))
     1896                (when (logbitp 3 flags)
     1897                  ;; finally, our pathname
     1898                  (let* ((length (read-little-endian s 2))
     1899                         (buffer (make-array length)))
     1900                    (read-sequence buffer s)
     1901                    (map 'string #'code-char buffer)))))))
     1902      (end-of-file ()
     1903        nil))))
     1904
     1905(defun parse-file-location-info (s)
     1906  (let ((start (file-position s))
     1907        (total-length (read-little-endian s))
     1908        (end-of-header (read-little-endian s))
     1909        (fli-flags (read-little-endian s))
     1910        (local-volume-offset (read-little-endian s))
     1911        (local-offset (read-little-endian s))
     1912        (network-volume-offset (read-little-endian s))
     1913        (remaining-offset (read-little-endian s)))
     1914    (declare (ignore total-length end-of-header local-volume-offset))
     1915    (unless (zerop fli-flags)
     1916      (cond
     1917        ((logbitp 0 fli-flags)
     1918          (file-position s (+ start local-offset)))
     1919        ((logbitp 1 fli-flags)
     1920          (file-position s (+ start
     1921                              network-volume-offset
     1922                              #x14))))
     1923      (concatenate 'string
     1924        (read-null-terminated-string s)
     1925        (progn
     1926          (file-position s (+ start remaining-offset))
     1927          (read-null-terminated-string s))))))
     1928
    13381929
    13391930(pushnew :asdf *features*)
     
    13821973  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
    13831974
     1975(if *asdf-revision*
     1976    (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
     1977    (asdf-message ";; ASDF, revision unknown; possibly a development version"))
     1978
    13841979(provide 'asdf)
     1980
     1981
     1982#+(or)
     1983;;?? ignore -- so how will ABL get "installed"
     1984;; should be unnecessary with newer versions of ASDF
     1985;; load customizations
     1986(eval-when (:load-toplevel :execute)
     1987  (let* ((*package* (find-package :common-lisp)))
     1988    (load
     1989     (merge-pathnames
     1990      (make-pathname :name "asdf-binary-locations"
     1991                     :type "lisp"
     1992                     :directory '(:relative ".asdf"))
     1993      (truename (user-homedir-pathname)))
     1994     :if-does-not-exist nil)))
Note: See TracChangeset for help on using the changeset viewer.