Changeset 9211


Ignore:
Timestamp:
Apr 20, 2008, 11:00:40 AM (11 years ago)
Author:
gb
Message:

um, let's try that again

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r9201 r9211  
    1 
    2 
    3 
    4 
    5 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
    6 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
    7 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
    8 <!-- ViewVC - http://viewvc.org/
    9 by Greg Stein - mailto:gstein@lyra.org -->
    10 <head>
    11 <title>SourceForge.net Repository - [cclan] View of /asdf/asdf.lisp</title>
    12 <meta name="generator" content="ViewVC 1.0.3" />
    13 <link rel="stylesheet" href="/*docroot*/styles.css" type="text/css" />
    14 </head>
    15 <body>
    16 <table style="padding:0.1em;">
    17 <tr>
    18 <td>
    19 <strong>
    20 
    21 <a href="/cclan/">
    22 
    23 [cclan]</a>
    24 /
    25 
    26 <a href="/cclan/asdf/">
    27 
    28 asdf</a>
    29 /
    30 
    31 <a href="/cclan/asdf/asdf.lisp?view=log">
    32 
    33 asdf.lisp</a>
    34 
    35 
    36 </strong>
    37 
    38 </td>
    39 </tr>
    40 </table>
    41 
    42 
    43 <div style="float: right; padding: 5px;"><a href="http://sourceforge.net"><img src="/*docroot*/images/sflogo-210pxtrans.png" alt="(logo)" border=0 width=210 height=62></a></div>
    44 <h1>View of /asdf/asdf.lisp</h1>
    45 
    46 <p style="margin:0;">
    47 
    48 <a href="/cclan/asdf/"><img src="/*docroot*/images/back_small.png" width="16" height="16" alt="Parent Directory" /> Parent Directory</a>
    49 
    50 | <a href="/cclan/asdf/asdf.lisp?view=log#rev1.115"><img src="/*docroot*/images/log.png" width="16" height="16" alt="Revision Log" /> Revision Log</a>
    51 
    52 
    53 
    54 
    55 </p>
    56 
    57 <hr />
    58 <div class="vc_summary">
    59 Revision <strong>1.115</strong> -
    60 (<a href="/*checkout*/cclan/asdf/asdf.lisp?revision=1.115"><strong>download</strong></a>)
    61 
    62 (<a href="/cclan/asdf/asdf.lisp?annotate=1.115"><strong>annotate</strong></a>)
    63 
    64 <br /><em>Fri Feb 15 12:14:48 2008 UTC</em>
    65 (2 months ago)
    66 by <em>demoss</em>
    67 
    68 
    69 <br />Branch: <strong>MAIN</strong>
    70 
    71 
    72 <br />CVS Tags: <strong>HEAD</strong>
    73 
    74 
    75 
    76 
    77 <br />Changes since <strong>1.114: +2 -2 lines</strong>
    78 
    79 
    80 
    81 
    82 
    83 <pre class="vc_log">fix CVS revision magic in *asdf-revision*
    84 
    85  gah.
    86 </pre>
    87 
    88 </div>
    89 <div id="vc_markup"><pre><a id="l_1"></a><span class="hl line">    1 </span><span class="hl slc">;;; This is asdf: Another System Definition Facility.  $Revision$</span>
    90 <a id="l_2"></a><span class="hl line">    2 </span><span class="hl slc">;;;</span>
    91 <a id="l_3"></a><span class="hl line">    3 </span><span class="hl slc">;;; Feedback, bug reports, and patches are all welcome: please mail to</span>
    92 <a id="l_4"></a><span class="hl line">    4 </span><span class="hl slc">;;; &lt;cclan-list&#64;lists.sf.net&gt;.  But note first that the canonical</span>
    93 <a id="l_5"></a><span class="hl line">    5 </span><span class="hl slc">;;; source for asdf is presently the cCLan CVS repository at</span>
    94 <a id="l_6"></a><span class="hl line">    6 </span><span class="hl slc">;;; &lt;URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/&gt;</span>
    95 <a id="l_7"></a><span class="hl line">    7 </span><span class="hl slc">;;;</span>
    96 <a id="l_8"></a><span class="hl line">    8 </span><span class="hl slc">;;; If you obtained this copy from anywhere else, and you experience</span>
    97 <a id="l_9"></a><span class="hl line">    9 </span><span class="hl slc">;;; trouble using it, or find bugs, you may want to check at the</span>
    98 <a id="l_10"></a><span class="hl line">   10 </span><span class="hl slc">;;; location above for a more recent version (and for documentation</span>
    99 <a id="l_11"></a><span class="hl line">   11 </span><span class="hl slc">;;; and test files, if your copy came without them) before reporting</span>
    100 <a id="l_12"></a><span class="hl line">   12 </span><span class="hl slc">;;; bugs.  There are usually two &quot;supported&quot; revisions - the CVS HEAD</span>
    101 <a id="l_13"></a><span class="hl line">   13 </span><span class="hl slc">;;; is the latest development version, whereas the revision tagged</span>
    102 <a id="l_14"></a><span class="hl line">   14 </span><span class="hl slc">;;; RELEASE may be slightly older but is considered `stable'</span>
    103 <a id="l_15"></a><span class="hl line">   15 </span>
    104 <a id="l_16"></a><span class="hl line">   16 </span><span class="hl slc">;;; Copyright (c) 2001-2007 Daniel Barlow and contributors</span>
    105 <a id="l_17"></a><span class="hl line">   17 </span><span class="hl slc">;;;</span>
    106 <a id="l_18"></a><span class="hl line">   18 </span><span class="hl slc">;;; Permission is hereby granted, free of charge, to any person obtaining</span>
    107 <a id="l_19"></a><span class="hl line">   19 </span><span class="hl slc">;;; a copy of this software and associated documentation files (the</span>
    108 <a id="l_20"></a><span class="hl line">   20 </span><span class="hl slc">;;; &quot;Software&quot;), to deal in the Software without restriction, including</span>
    109 <a id="l_21"></a><span class="hl line">   21 </span><span class="hl slc">;;; without limitation the rights to use, copy, modify, merge, publish,</span>
    110 <a id="l_22"></a><span class="hl line">   22 </span><span class="hl slc">;;; distribute, sublicense, and/or sell copies of the Software, and to</span>
    111 <a id="l_23"></a><span class="hl line">   23 </span><span class="hl slc">;;; permit persons to whom the Software is furnished to do so, subject to</span>
    112 <a id="l_24"></a><span class="hl line">   24 </span><span class="hl slc">;;; the following conditions:</span>
    113 <a id="l_25"></a><span class="hl line">   25 </span><span class="hl slc">;;;</span>
    114 <a id="l_26"></a><span class="hl line">   26 </span><span class="hl slc">;;; The above copyright notice and this permission notice shall be</span>
    115 <a id="l_27"></a><span class="hl line">   27 </span><span class="hl slc">;;; included in all copies or substantial portions of the Software.</span>
    116 <a id="l_28"></a><span class="hl line">   28 </span><span class="hl slc">;;;</span>
    117 <a id="l_29"></a><span class="hl line">   29 </span><span class="hl slc">;;; THE SOFTWARE IS PROVIDED &quot;AS IS&quot;, WITHOUT WARRANTY OF ANY KIND,</span>
    118 <a id="l_30"></a><span class="hl line">   30 </span><span class="hl slc">;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF</span>
    119 <a id="l_31"></a><span class="hl line">   31 </span><span class="hl slc">;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND</span>
    120 <a id="l_32"></a><span class="hl line">   32 </span><span class="hl slc">;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE</span>
    121 <a id="l_33"></a><span class="hl line">   33 </span><span class="hl slc">;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION</span>
    122 <a id="l_34"></a><span class="hl line">   34 </span><span class="hl slc">;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION</span>
    123 <a id="l_35"></a><span class="hl line">   35 </span><span class="hl slc">;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.</span>
    124 <a id="l_36"></a><span class="hl line">   36 </span>
    125 <a id="l_37"></a><span class="hl line">   37 </span><span class="hl slc">;;; the problem with writing a defsystem replacement is bootstrapping:</span>
    126 <a id="l_38"></a><span class="hl line">   38 </span><span class="hl slc">;;; we can't use defsystem to compile it.  Hence, all in one file</span>
    127 <a id="l_39"></a><span class="hl line">   39 </span>
    128 <a id="l_40"></a><span class="hl line">   40 </span><span class="hl sym">(</span>defpackage #<span class="hl sym">:</span>asdf
    129 <a id="l_41"></a><span class="hl line">   41 </span>  <span class="hl sym">(:</span>export #<span class="hl sym">:</span>defsystem #<span class="hl sym">:</span>oos #<span class="hl sym">:</span>operate #<span class="hl sym">:</span>find-system #<span class="hl sym">:</span>run-shell-<span class="hl kwa">command</span>
    130 <a id="l_42"></a><span class="hl line">   42 </span>           #<span class="hl sym">:</span>system-definition-pathname #<span class="hl sym">:</span>find-component <span class="hl slc">; miscellaneous</span>
    131 <a id="l_43"></a><span class="hl line">   43 </span>           #<span class="hl sym">:</span>hyperdocumentation #<span class="hl sym">:</span>hyperdoc
    132 <a id="l_44"></a><span class="hl line">   44 </span>
    133 <a id="l_45"></a><span class="hl line">   45 </span>           #<span class="hl sym">:</span>compile-op #<span class="hl sym">:</span><span class="hl kwa">load</span>-op #<span class="hl sym">:</span><span class="hl kwa">load</span>-source-op #<span class="hl sym">:</span>test-system-version
    134 <a id="l_46"></a><span class="hl line">   46 </span>           #<span class="hl sym">:</span>test-op
    135 <a id="l_47"></a><span class="hl line">   47 </span>           #<span class="hl sym">:</span>operation                  <span class="hl slc">; operations</span>
    136 <a id="l_48"></a><span class="hl line">   48 </span>           #<span class="hl sym">:</span>feature                    <span class="hl slc">; sort-of operation</span>
    137 <a id="l_49"></a><span class="hl line">   49 </span>           #<span class="hl sym">:</span>version                    <span class="hl slc">; metaphorically sort-of an operation</span>
    138 <a id="l_50"></a><span class="hl line">   50 </span>
    139 <a id="l_51"></a><span class="hl line">   51 </span>           #<span class="hl sym">:</span>input-files #<span class="hl sym">:</span>output-files #<span class="hl sym">:</span>perform       <span class="hl slc">; operation methods</span>
    140 <a id="l_52"></a><span class="hl line">   52 </span>           #<span class="hl sym">:</span>operation-done-p #<span class="hl sym">:</span>explain
    141 <a id="l_53"></a><span class="hl line">   53 </span>
    142 <a id="l_54"></a><span class="hl line">   54 </span>           #<span class="hl sym">:</span>component #<span class="hl sym">:</span>source-file
    143 <a id="l_55"></a><span class="hl line">   55 </span>           #<span class="hl sym">:</span>c-source-file #<span class="hl sym">:</span>cl-source-file #<span class="hl sym">:</span>java-source-file
    144 <a id="l_56"></a><span class="hl line">   56 </span>           #<span class="hl sym">:</span>static-file
    145 <a id="l_57"></a><span class="hl line">   57 </span>           #<span class="hl sym">:</span>doc-file
    146 <a id="l_58"></a><span class="hl line">   58 </span>           #<span class="hl sym">:</span>html-file
    147 <a id="l_59"></a><span class="hl line">   59 </span>           #<span class="hl sym">:</span>text-file
    148 <a id="l_60"></a><span class="hl line">   60 </span>           #<span class="hl sym">:</span>source-file-<span class="hl kwa">type</span>
    149 <a id="l_61"></a><span class="hl line">   61 </span>           #<span class="hl sym">:</span>module                     <span class="hl slc">; components</span>
    150 <a id="l_62"></a><span class="hl line">   62 </span>           #<span class="hl sym">:</span>system
    151 <a id="l_63"></a><span class="hl line">   63 </span>           #<span class="hl sym">:</span>unix-dso
    152 <a id="l_64"></a><span class="hl line">   64 </span>
    153 <a id="l_65"></a><span class="hl line">   65 </span>           #<span class="hl sym">:</span>module-components          <span class="hl slc">; component accessors</span>
    154 <a id="l_66"></a><span class="hl line">   66 </span>           #<span class="hl sym">:</span>component-pathname
    155 <a id="l_67"></a><span class="hl line">   67 </span>           #<span class="hl sym">:</span>component-relative-pathname
    156 <a id="l_68"></a><span class="hl line">   68 </span>           #<span class="hl sym">:</span>component-name
    157 <a id="l_69"></a><span class="hl line">   69 </span>           #<span class="hl sym">:</span>component-version
    158 <a id="l_70"></a><span class="hl line">   70 </span>           #<span class="hl sym">:</span>component-parent
    159 <a id="l_71"></a><span class="hl line">   71 </span>           #<span class="hl sym">:</span>component-property
    160 <a id="l_72"></a><span class="hl line">   72 </span>           #<span class="hl sym">:</span>component-system
    161 <a id="l_73"></a><span class="hl line">   73 </span>
    162 <a id="l_74"></a><span class="hl line">   74 </span>           #<span class="hl sym">:</span>component-depends-on
    163 <a id="l_75"></a><span class="hl line">   75 </span>
    164 <a id="l_76"></a><span class="hl line">   76 </span>           #<span class="hl sym">:</span>system-description
    165 <a id="l_77"></a><span class="hl line">   77 </span>           #<span class="hl sym">:</span>system-long-description
    166 <a id="l_78"></a><span class="hl line">   78 </span>           #<span class="hl sym">:</span>system-author
    167 <a id="l_79"></a><span class="hl line">   79 </span>           #<span class="hl sym">:</span>system-maintainer
    168 <a id="l_80"></a><span class="hl line">   80 </span>           #<span class="hl sym">:</span>system-license
    169 <a id="l_81"></a><span class="hl line">   81 </span>           #<span class="hl sym">:</span>system-licence
    170 <a id="l_82"></a><span class="hl line">   82 </span>           #<span class="hl sym">:</span>system-source-file
    171 <a id="l_83"></a><span class="hl line">   83 </span>           #<span class="hl sym">:</span>system-relative-pathname
    172 <a id="l_84"></a><span class="hl line">   84 </span>
    173 <a id="l_85"></a><span class="hl line">   85 </span>           #<span class="hl sym">:</span>operation-on-warnings
    174 <a id="l_86"></a><span class="hl line">   86 </span>           #<span class="hl sym">:</span>operation-on-failure
    175 <a id="l_87"></a><span class="hl line">   87 </span>
    176 <a id="l_88"></a><span class="hl line">   88 </span>           <span class="hl slc">;#:*component-parent-pathname*</span>
    177 <a id="l_89"></a><span class="hl line">   89 </span>           #<span class="hl sym">:*</span>system-definition-search-functions<span class="hl sym">*</span>
    178 <a id="l_90"></a><span class="hl line">   90 </span>           #<span class="hl sym">:*</span>central-registry<span class="hl sym">*</span>         <span class="hl slc">; variables</span>
    179 <a id="l_91"></a><span class="hl line">   91 </span>           #<span class="hl sym">:*</span>compile-file-warnings-behaviour<span class="hl sym">*</span>
    180 <a id="l_92"></a><span class="hl line">   92 </span>           #<span class="hl sym">:*</span>compile-file-failure-behaviour<span class="hl sym">*</span>
    181 <a id="l_93"></a><span class="hl line">   93 </span>           #<span class="hl sym">:*</span>asdf-revision<span class="hl sym">*</span>
    182 <a id="l_94"></a><span class="hl line">   94 </span>
    183 <a id="l_95"></a><span class="hl line">   95 </span>           #<span class="hl sym">:</span>operation-error #<span class="hl sym">:</span>compile-failed #<span class="hl sym">:</span>compile-warned #<span class="hl sym">:</span>compile-error
    184 <a id="l_96"></a><span class="hl line">   96 </span>           #<span class="hl sym">:</span>error-component #<span class="hl sym">:</span>error-operation
    185 <a id="l_97"></a><span class="hl line">   97 </span>           #<span class="hl sym">:</span>system-definition-error
    186 <a id="l_98"></a><span class="hl line">   98 </span>           #<span class="hl sym">:</span>missing-component
    187 <a id="l_99"></a><span class="hl line">   99 </span>           #<span class="hl sym">:</span>missing-dependency
    188 <a id="l_100"></a><span class="hl line">  100 </span>           #<span class="hl sym">:</span>circular-dependency        <span class="hl slc">; errors</span>
    189 <a id="l_101"></a><span class="hl line">  101 </span>           #<span class="hl sym">:</span>duplicate-names
    190 <a id="l_102"></a><span class="hl line">  102 </span>
    191 <a id="l_103"></a><span class="hl line">  103 </span>           #<span class="hl sym">:</span>retry
    192 <a id="l_104"></a><span class="hl line">  104 </span>           #<span class="hl sym">:</span>accept                     <span class="hl slc">; restarts</span>
    193 <a id="l_105"></a><span class="hl line">  105 </span>
    194 <a id="l_106"></a><span class="hl line">  106 </span>           #<span class="hl sym">:</span>preference-file-for-system<span class="hl sym">/</span>operation
    195 <a id="l_107"></a><span class="hl line">  107 </span>           #<span class="hl sym">:</span><span class="hl kwa">load</span>-preferences
    196 <a id="l_108"></a><span class="hl line">  108 </span>           <span class="hl sym">)</span>
    197 <a id="l_109"></a><span class="hl line">  109 </span>  <span class="hl sym">(:</span>use <span class="hl sym">:</span>cl<span class="hl sym">))</span>
    198 <a id="l_110"></a><span class="hl line">  110 </span>
    199 <a id="l_111"></a><span class="hl line">  111 </span>
    200 <a id="l_112"></a><span class="hl line">  112 </span>#<span class="hl sym">+</span>nil
    201 <a id="l_113"></a><span class="hl line">  113 </span><span class="hl sym">(</span>error <span class="hl str">&quot;The author of this file habitually uses #+nil to comment out ~</span>
    202 <a id="l_114"></a><span class="hl line">  114 </span><span class="hl str">        forms. But don't worry, it was unlikely to work in the New ~</span>
    203 <a id="l_115"></a><span class="hl line">  115 </span><span class="hl str">        Implementation of Lisp anyway&quot;</span><span class="hl sym">)</span>
    204 <a id="l_116"></a><span class="hl line">  116 </span>
    205 <a id="l_117"></a><span class="hl line">  117 </span><span class="hl sym">(</span>in-package #<span class="hl sym">:</span>asdf<span class="hl sym">)</span>
    206 <a id="l_118"></a><span class="hl line">  118 </span>
    207 <a id="l_119"></a><span class="hl line">  119 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>asdf-revision<span class="hl sym">* (</span>let<span class="hl sym">* ((</span>v <span class="hl str">&quot;$Revision$&quot;</span><span class="hl sym">)</span>
    208 <a id="l_120"></a><span class="hl line">  120 </span>                               <span class="hl sym">(</span>colon <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>position #\: v<span class="hl sym">)</span> -<span class="hl num">1</span><span class="hl sym">))</span>
    209 <a id="l_121"></a><span class="hl line">  121 </span>                               <span class="hl sym">(</span>dot <span class="hl sym">(</span>position #\. v<span class="hl sym">)))</span>
    210 <a id="l_122"></a><span class="hl line">  122 </span>                          <span class="hl sym">(</span><span class="hl kwa">and</span> v colon dot
    211 <a id="l_123"></a><span class="hl line">  123 </span>                               <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>parse-integer v <span class="hl sym">:</span>start <span class="hl sym">(</span><span class="hl num">1</span><span class="hl sym">+</span> colon<span class="hl sym">)</span>
    212 <a id="l_124"></a><span class="hl line">  124 </span>                                                      <span class="hl sym">:</span>junk-allowed t<span class="hl sym">)</span>
    213 <a id="l_125"></a><span class="hl line">  125 </span>                                     <span class="hl sym">(</span>parse-integer v <span class="hl sym">:</span>start <span class="hl sym">(</span><span class="hl num">1</span><span class="hl sym">+</span> dot<span class="hl sym">)</span>
    214 <a id="l_126"></a><span class="hl line">  126 </span>                                                      <span class="hl sym">:</span>junk-allowed t<span class="hl sym">)))))</span>
    215 <a id="l_127"></a><span class="hl line">  127 </span>
    216 <a id="l_128"></a><span class="hl line">  128 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>compile-file-warnings-behaviour<span class="hl sym">* :</span>warn<span class="hl sym">)</span>
    217 <a id="l_129"></a><span class="hl line">  129 </span>
    218 <a id="l_130"></a><span class="hl line">  130 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>compile-file-failure-behaviour<span class="hl sym">*</span> #<span class="hl sym">+</span>sbcl <span class="hl sym">:</span>error #-sbcl <span class="hl sym">:</span>warn<span class="hl sym">)</span>
    219 <a id="l_131"></a><span class="hl line">  131 </span>
    220 <a id="l_132"></a><span class="hl line">  132 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> nil<span class="hl sym">)</span>
    221 <a id="l_133"></a><span class="hl line">  133 </span>
    222 <a id="l_134"></a><span class="hl line">  134 </span><span class="hl sym">(</span>defparameter <span class="hl sym">+</span>asdf-methods<span class="hl sym">+</span>
    223 <a id="l_135"></a><span class="hl line">  135 </span>  <span class="hl sym">'(</span>perform explain output-files operation-done-p<span class="hl sym">))</span>
    224 <a id="l_136"></a><span class="hl line">  136 </span>
    225 <a id="l_137"></a><span class="hl line">  137 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
    226 <a id="l_138"></a><span class="hl line">  138 </span><span class="hl slc">;; utility stuff</span>
    227 <a id="l_139"></a><span class="hl line">  139 </span>
    228 <a id="l_140"></a><span class="hl line">  140 </span><span class="hl sym">(</span>defmacro aif <span class="hl sym">(</span>test then <span class="hl sym">&amp;</span>optional else<span class="hl sym">)</span>
    229 <a id="l_141"></a><span class="hl line">  141 </span>  `<span class="hl sym">(</span>let <span class="hl sym">((</span>it <span class="hl sym">,</span>test<span class="hl sym">)) (</span><span class="hl kwa">if</span> it <span class="hl sym">,</span>then <span class="hl sym">,</span>else<span class="hl sym">)))</span>
    230 <a id="l_142"></a><span class="hl line">  142 </span>
    231 <a id="l_143"></a><span class="hl line">  143 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> pathname-sans-name<span class="hl sym">+</span><span class="hl kwa">type</span> <span class="hl sym">(</span>pathname<span class="hl sym">)</span>
    232 <a id="l_144"></a><span class="hl line">  144 </span>  <span class="hl str">&quot;Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,</span>
    233 <a id="l_145"></a><span class="hl line">  145 </span><span class="hl str">and NIL NAME and TYPE components&quot;</span>
    234 <a id="l_146"></a><span class="hl line">  146 </span>  <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name nil <span class="hl sym">:</span><span class="hl kwa">type</span> nil <span class="hl sym">:</span>defaults pathname<span class="hl sym">))</span>
    235 <a id="l_147"></a><span class="hl line">  147 </span>
    236 <a id="l_148"></a><span class="hl line">  148 </span><span class="hl sym">(</span>define-modify-macro appendf <span class="hl sym">(&amp;</span>rest args<span class="hl sym">)</span>
    237 <a id="l_149"></a><span class="hl line">  149 </span>  <span class="hl kwa">append</span> <span class="hl str">&quot;Append onto list&quot;</span><span class="hl sym">)</span>
    238 <a id="l_150"></a><span class="hl line">  150 </span>
    239 <a id="l_151"></a><span class="hl line">  151 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
    240 <a id="l_152"></a><span class="hl line">  152 </span><span class="hl slc">;; classes, condiitons</span>
    241 <a id="l_153"></a><span class="hl line">  153 </span>
    242 <a id="l_154"></a><span class="hl line">  154 </span><span class="hl sym">(</span>define-condition system-definition-error <span class="hl sym">(</span>error<span class="hl sym">) ()</span>
    243 <a id="l_155"></a><span class="hl line">  155 </span>  <span class="hl slc">;; [this use of :report should be redundant, but unfortunately it's not.</span>
    244 <a id="l_156"></a><span class="hl line">  156 </span>  <span class="hl slc">;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function</span>
    245 <a id="l_157"></a><span class="hl line">  157 </span>  <span class="hl slc">;; over print-object; this is always conditions::%print-condition for</span>
    246 <a id="l_158"></a><span class="hl line">  158 </span>  <span class="hl slc">;; condition objects, which in turn does inheritance of :report options at</span>
    247 <a id="l_159"></a><span class="hl line">  159 </span>  <span class="hl slc">;; run-time.  fortunately, inheritance means we only need this kludge here in</span>
    248 <a id="l_160"></a><span class="hl line">  160 </span>  <span class="hl slc">;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]</span>
    249 <a id="l_161"></a><span class="hl line">  161 </span>  #<span class="hl sym">+</span>cmu <span class="hl sym">(:</span>report <span class="hl kwa">print</span>-object<span class="hl sym">))</span>
    250 <a id="l_162"></a><span class="hl line">  162 </span>
    251 <a id="l_163"></a><span class="hl line">  163 </span><span class="hl sym">(</span>define-condition formatted-system-definition-error <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
    252 <a id="l_164"></a><span class="hl line">  164 </span>  <span class="hl sym">((</span>format-control <span class="hl sym">:</span>initarg <span class="hl sym">:</span>format-control <span class="hl sym">:</span>reader format-control<span class="hl sym">)</span>
    253 <a id="l_165"></a><span class="hl line">  165 </span>   <span class="hl sym">(</span>format-arguments <span class="hl sym">:</span>initarg <span class="hl sym">:</span>format-arguments <span class="hl sym">:</span>reader format-arguments<span class="hl sym">))</span>
    254 <a id="l_166"></a><span class="hl line">  166 </span>  <span class="hl sym">(:</span>report <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>c s<span class="hl sym">)</span>
    255 <a id="l_167"></a><span class="hl line">  167 </span>             <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>format s <span class="hl sym">(</span>format-control c<span class="hl sym">) (</span>format-arguments c<span class="hl sym">)))))</span>
    256 <a id="l_168"></a><span class="hl line">  168 </span>
    257 <a id="l_169"></a><span class="hl line">  169 </span><span class="hl sym">(</span>define-condition circular-dependency <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
    258 <a id="l_170"></a><span class="hl line">  170 </span>  <span class="hl sym">((</span>components <span class="hl sym">:</span>initarg <span class="hl sym">:</span>components <span class="hl sym">:</span>reader circular-dependency-components<span class="hl sym">)))</span>
    259 <a id="l_171"></a><span class="hl line">  171 </span>
    260 <a id="l_172"></a><span class="hl line">  172 </span><span class="hl sym">(</span>define-condition duplicate-names <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
    261 <a id="l_173"></a><span class="hl line">  173 </span>  <span class="hl sym">((</span>name <span class="hl sym">:</span>initarg <span class="hl sym">:</span>name <span class="hl sym">:</span>reader duplicate-names-name<span class="hl sym">)))</span>
    262 <a id="l_174"></a><span class="hl line">  174 </span>
    263 <a id="l_175"></a><span class="hl line">  175 </span><span class="hl sym">(</span>define-condition missing-component <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
    264 <a id="l_176"></a><span class="hl line">  176 </span>  <span class="hl sym">((</span>requires <span class="hl sym">:</span>initform <span class="hl str">&quot;(unnamed)&quot;</span> <span class="hl sym">:</span>reader missing-requires <span class="hl sym">:</span>initarg <span class="hl sym">:</span>requires<span class="hl sym">)</span>
    265 <a id="l_177"></a><span class="hl line">  177 </span>   <span class="hl sym">(</span>version <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>reader missing-version <span class="hl sym">:</span>initarg <span class="hl sym">:</span>version<span class="hl sym">)</span>
    266 <a id="l_178"></a><span class="hl line">  178 </span>   <span class="hl sym">(</span>parent <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>reader missing-parent <span class="hl sym">:</span>initarg <span class="hl sym">:</span>parent<span class="hl sym">)))</span>
    267 <a id="l_179"></a><span class="hl line">  179 </span>
    268 <a id="l_180"></a><span class="hl line">  180 </span><span class="hl sym">(</span>define-condition missing-dependency <span class="hl sym">(</span>missing-component<span class="hl sym">)</span>
    269 <a id="l_181"></a><span class="hl line">  181 </span>  <span class="hl sym">((</span>required-by <span class="hl sym">:</span>initarg <span class="hl sym">:</span>required-by <span class="hl sym">:</span>reader missing-required-by<span class="hl sym">)))</span>
    270 <a id="l_182"></a><span class="hl line">  182 </span>
    271 <a id="l_183"></a><span class="hl line">  183 </span><span class="hl sym">(</span>define-condition operation-error <span class="hl sym">(</span>error<span class="hl sym">)</span>
    272 <a id="l_184"></a><span class="hl line">  184 </span>  <span class="hl sym">((</span>component <span class="hl sym">:</span>reader error-component <span class="hl sym">:</span>initarg <span class="hl sym">:</span>component<span class="hl sym">)</span>
    273 <a id="l_185"></a><span class="hl line">  185 </span>   <span class="hl sym">(</span>operation <span class="hl sym">:</span>reader error-operation <span class="hl sym">:</span>initarg <span class="hl sym">:</span>operation<span class="hl sym">))</span>
    274 <a id="l_186"></a><span class="hl line">  186 </span>  <span class="hl sym">(:</span>report <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>c s<span class="hl sym">)</span>
    275 <a id="l_187"></a><span class="hl line">  187 </span>             <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;erred while invoking ~A on ~A~&#64;:&gt;&quot;</span>
    276 <a id="l_188"></a><span class="hl line">  188 </span>                     <span class="hl sym">(</span>error-operation c<span class="hl sym">) (</span>error-component c<span class="hl sym">)))))</span>
    277 <a id="l_189"></a><span class="hl line">  189 </span><span class="hl sym">(</span>define-condition compile-error <span class="hl sym">(</span>operation-error<span class="hl sym">) ())</span>
    278 <a id="l_190"></a><span class="hl line">  190 </span><span class="hl sym">(</span>define-condition compile-failed <span class="hl sym">(</span>compile-error<span class="hl sym">) ())</span>
    279 <a id="l_191"></a><span class="hl line">  191 </span><span class="hl sym">(</span>define-condition compile-warned <span class="hl sym">(</span>compile-error<span class="hl sym">) ())</span>
    280 <a id="l_192"></a><span class="hl line">  192 </span>
    281 <a id="l_193"></a><span class="hl line">  193 </span><span class="hl sym">(</span>defclass component <span class="hl sym">()</span>
    282 <a id="l_194"></a><span class="hl line">  194 </span>  <span class="hl sym">((</span>name <span class="hl sym">:</span>accessor component-name <span class="hl sym">:</span>initarg <span class="hl sym">:</span>name <span class="hl sym">:</span>documentation
    283 <a id="l_195"></a><span class="hl line">  195 </span>         <span class="hl str">&quot;Component name: designator for a string composed of portable pathname characters&quot;</span><span class="hl sym">)</span>
    284 <a id="l_196"></a><span class="hl line">  196 </span>   <span class="hl sym">(</span>version <span class="hl sym">:</span>accessor component-version <span class="hl sym">:</span>initarg <span class="hl sym">:</span>version<span class="hl sym">)</span>
    285 <a id="l_197"></a><span class="hl line">  197 </span>   <span class="hl sym">(</span>in-order-to <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>in-order-to<span class="hl sym">)</span>
    286 <a id="l_198"></a><span class="hl line">  198 </span>   <span class="hl slc">;; XXX crap name</span>
    287 <a id="l_199"></a><span class="hl line">  199 </span>   <span class="hl sym">(</span>do-first <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>do-first<span class="hl sym">)</span>
    288 <a id="l_200"></a><span class="hl line">  200 </span>   <span class="hl slc">;; methods defined using the &quot;inline&quot; style inside a defsystem form:</span>
    289 <a id="l_201"></a><span class="hl line">  201 </span>   <span class="hl slc">;; need to store them somewhere so we can delete them when the system</span>
    290 <a id="l_202"></a><span class="hl line">  202 </span>   <span class="hl slc">;; is re-evaluated</span>
    291 <a id="l_203"></a><span class="hl line">  203 </span>   <span class="hl sym">(</span>inline-methods <span class="hl sym">:</span>accessor component-inline-methods <span class="hl sym">:</span>initform nil<span class="hl sym">)</span>
    292 <a id="l_204"></a><span class="hl line">  204 </span>   <span class="hl sym">(</span>parent <span class="hl sym">:</span>initarg <span class="hl sym">:</span>parent <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>reader component-parent<span class="hl sym">)</span>
    293 <a id="l_205"></a><span class="hl line">  205 </span>   <span class="hl slc">;; no direct accessor for pathname, we do this as a method to allow</span>
    294 <a id="l_206"></a><span class="hl line">  206 </span>   <span class="hl slc">;; it to default in funky ways if not supplied</span>
    295 <a id="l_207"></a><span class="hl line">  207 </span>   <span class="hl sym">(</span>relative-pathname <span class="hl sym">:</span>initarg <span class="hl sym">:</span>pathname<span class="hl sym">)</span>
    296 <a id="l_208"></a><span class="hl line">  208 </span>   <span class="hl sym">(</span>operation-times <span class="hl sym">:</span>initform <span class="hl sym">(</span>make-hash-table <span class="hl sym">)</span>
    297 <a id="l_209"></a><span class="hl line">  209 </span>                    <span class="hl sym">:</span>accessor component-operation-times<span class="hl sym">)</span>
    298 <a id="l_210"></a><span class="hl line">  210 </span>   <span class="hl slc">;; XXX we should provide some atomic interface for updating the</span>
    299 <a id="l_211"></a><span class="hl line">  211 </span>   <span class="hl slc">;; component properties</span>
    300 <a id="l_212"></a><span class="hl line">  212 </span>   <span class="hl sym">(</span>properties <span class="hl sym">:</span>accessor component-properties <span class="hl sym">:</span>initarg <span class="hl sym">:</span>properties
    301 <a id="l_213"></a><span class="hl line">  213 </span>               <span class="hl sym">:</span>initform nil<span class="hl sym">)))</span>
    302 <a id="l_214"></a><span class="hl line">  214 </span>
    303 <a id="l_215"></a><span class="hl line">  215 </span><span class="hl slc">;;;; methods: conditions</span>
    304 <a id="l_216"></a><span class="hl line">  216 </span>
    305 <a id="l_217"></a><span class="hl line">  217 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>c missing-dependency<span class="hl sym">)</span> s<span class="hl sym">)</span>
    306 <a id="l_218"></a><span class="hl line">  218 </span>  <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;~A, required by ~A~&#64;:&gt;&quot;</span>
    307 <a id="l_219"></a><span class="hl line">  219 </span>          <span class="hl sym">(</span>call-next-method c nil<span class="hl sym">) (</span>missing-required-by c<span class="hl sym">)))</span>
    308 <a id="l_220"></a><span class="hl line">  220 </span>
    309 <a id="l_221"></a><span class="hl line">  221 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> sysdef-error <span class="hl sym">(</span>format <span class="hl sym">&amp;</span>rest arguments<span class="hl sym">)</span>
    310 <a id="l_222"></a><span class="hl line">  222 </span>  <span class="hl sym">(</span>error <span class="hl sym">'</span>formatted-system-definition-error <span class="hl sym">:</span>format-control format <span class="hl sym">:</span>format-arguments arguments<span class="hl sym">))</span>
    311 <a id="l_223"></a><span class="hl line">  223 </span>
    312 <a id="l_224"></a><span class="hl line">  224 </span><span class="hl slc">;;;; methods: components</span>
    313 <a id="l_225"></a><span class="hl line">  225 </span>
    314 <a id="l_226"></a><span class="hl line">  226 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>c missing-component<span class="hl sym">)</span> s<span class="hl sym">)</span>
    315 <a id="l_227"></a><span class="hl line">  227 </span>  <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;component ~S not found~</span>
    316 <a id="l_228"></a><span class="hl line">  228 </span><span class="hl str">             ~&#64;[ or does not match version ~A~]~</span>
    317 <a id="l_229"></a><span class="hl line">  229 </span><span class="hl str">             ~&#64;[ in ~A~]~&#64;:&gt;&quot;</span>
    318 <a id="l_230"></a><span class="hl line">  230 </span>          <span class="hl sym">(</span>missing-requires c<span class="hl sym">)</span>
    319 <a id="l_231"></a><span class="hl line">  231 </span>          <span class="hl sym">(</span>missing-version c<span class="hl sym">)</span>
    320 <a id="l_232"></a><span class="hl line">  232 </span>          <span class="hl sym">(</span>when <span class="hl sym">(</span>missing-parent c<span class="hl sym">)</span>
    321 <a id="l_233"></a><span class="hl line">  233 </span>            <span class="hl sym">(</span>component-name <span class="hl sym">(</span>missing-parent c<span class="hl sym">)))))</span>
    322 <a id="l_234"></a><span class="hl line">  234 </span>
    323 <a id="l_235"></a><span class="hl line">  235 </span><span class="hl sym">(</span>defgeneric component-system <span class="hl sym">(</span>component<span class="hl sym">)</span>
    324 <a id="l_236"></a><span class="hl line">  236 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Find the top-level system containing COMPONENT&quot;</span><span class="hl sym">))</span>
    325 <a id="l_237"></a><span class="hl line">  237 </span>
    326 <a id="l_238"></a><span class="hl line">  238 </span><span class="hl sym">(</span>defmethod component-system <span class="hl sym">((</span>component component<span class="hl sym">))</span>
    327 <a id="l_239"></a><span class="hl line">  239 </span>  <span class="hl sym">(</span>aif <span class="hl sym">(</span>component-parent component<span class="hl sym">)</span>
    328 <a id="l_240"></a><span class="hl line">  240 </span>       <span class="hl sym">(</span>component-system it<span class="hl sym">)</span>
    329 <a id="l_241"></a><span class="hl line">  241 </span>       component<span class="hl sym">))</span>
    330 <a id="l_242"></a><span class="hl line">  242 </span>
    331 <a id="l_243"></a><span class="hl line">  243 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>c component<span class="hl sym">)</span> stream<span class="hl sym">)</span>
    332 <a id="l_244"></a><span class="hl line">  244 </span>  <span class="hl sym">(</span><span class="hl kwa">print</span>-unreadable-object <span class="hl sym">(</span>c stream <span class="hl sym">:</span><span class="hl kwa">type</span> t <span class="hl sym">:</span>identity t<span class="hl sym">)</span>
    333 <a id="l_245"></a><span class="hl line">  245 </span>    <span class="hl sym">(</span>ignore-errors
    334 <a id="l_246"></a><span class="hl line">  246 </span>      <span class="hl sym">(</span><span class="hl kwa">prin1</span> <span class="hl sym">(</span>component-name c<span class="hl sym">)</span> stream<span class="hl sym">))))</span>
    335 <a id="l_247"></a><span class="hl line">  247 </span>
    336 <a id="l_248"></a><span class="hl line">  248 </span><span class="hl sym">(</span>defclass module <span class="hl sym">(</span>component<span class="hl sym">)</span>
    337 <a id="l_249"></a><span class="hl line">  249 </span>  <span class="hl sym">((</span>components <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>accessor module-components <span class="hl sym">:</span>initarg <span class="hl sym">:</span>components<span class="hl sym">)</span>
    338 <a id="l_250"></a><span class="hl line">  250 </span>   <span class="hl slc">;; what to do if we can't satisfy a dependency of one of this module's</span>
    339 <a id="l_251"></a><span class="hl line">  251 </span>   <span class="hl slc">;; components.  This allows a limited form of conditional processing</span>
    340 <a id="l_252"></a><span class="hl line">  252 </span>   <span class="hl sym">(</span><span class="hl kwa">if</span>-component-dep-fails <span class="hl sym">:</span>initform <span class="hl sym">:</span>fail
    341 <a id="l_253"></a><span class="hl line">  253 </span>                           <span class="hl sym">:</span>accessor module-<span class="hl kwa">if</span>-component-dep-fails
    342 <a id="l_254"></a><span class="hl line">  254 </span>                           <span class="hl sym">:</span>initarg <span class="hl sym">:</span><span class="hl kwa">if</span>-component-dep-fails<span class="hl sym">)</span>
    343 <a id="l_255"></a><span class="hl line">  255 </span>   <span class="hl sym">(</span>default-component-class <span class="hl sym">:</span>accessor module-default-component-class
    344 <a id="l_256"></a><span class="hl line">  256 </span>     <span class="hl sym">:</span>initform <span class="hl sym">'</span>cl-source-file <span class="hl sym">:</span>initarg <span class="hl sym">:</span>default-component-class<span class="hl sym">)))</span>
    345 <a id="l_257"></a><span class="hl line">  257 </span>
    346 <a id="l_258"></a><span class="hl line">  258 </span><span class="hl sym">(</span>defgeneric component-pathname <span class="hl sym">(</span>component<span class="hl sym">)</span>
    347 <a id="l_259"></a><span class="hl line">  259 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Extracts the pathname applicable for a particular component.&quot;</span><span class="hl sym">))</span>
    348 <a id="l_260"></a><span class="hl line">  260 </span>
    349 <a id="l_261"></a><span class="hl line">  261 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> component-parent-pathname <span class="hl sym">(</span>component<span class="hl sym">)</span>
    350 <a id="l_262"></a><span class="hl line">  262 </span>  <span class="hl sym">(</span>aif <span class="hl sym">(</span>component-parent component<span class="hl sym">)</span>
    351 <a id="l_263"></a><span class="hl line">  263 </span>       <span class="hl sym">(</span>component-pathname it<span class="hl sym">)</span>
    352 <a id="l_264"></a><span class="hl line">  264 </span>       <span class="hl sym">*</span>default-pathname-defaults<span class="hl sym">*))</span>
    353 <a id="l_265"></a><span class="hl line">  265 </span>
    354 <a id="l_266"></a><span class="hl line">  266 </span><span class="hl sym">(</span>defgeneric component-relative-pathname <span class="hl sym">(</span>component<span class="hl sym">)</span>
    355 <a id="l_267"></a><span class="hl line">  267 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Extracts the relative pathname applicable for a particular component.&quot;</span><span class="hl sym">))</span>
    356 <a id="l_268"></a><span class="hl line">  268 </span>
    357 <a id="l_269"></a><span class="hl line">  269 </span><span class="hl sym">(</span>defmethod component-relative-pathname <span class="hl sym">((</span>component module<span class="hl sym">))</span>
    358 <a id="l_270"></a><span class="hl line">  270 </span>  <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>slot-value component <span class="hl sym">'</span>relative-pathname<span class="hl sym">)</span>
    359 <a id="l_271"></a><span class="hl line">  271 </span>      <span class="hl sym">(</span>make-pathname
    360 <a id="l_272"></a><span class="hl line">  272 </span>       <span class="hl sym">:</span>directory `<span class="hl sym">(:</span>relative <span class="hl sym">,(</span>component-name component<span class="hl sym">))</span>
    361 <a id="l_273"></a><span class="hl line">  273 </span>       <span class="hl sym">:</span>host <span class="hl sym">(</span>pathname-host <span class="hl sym">(</span>component-parent-pathname component<span class="hl sym">)))))</span>
    362 <a id="l_274"></a><span class="hl line">  274 </span>
    363 <a id="l_275"></a><span class="hl line">  275 </span><span class="hl sym">(</span>defmethod component-pathname <span class="hl sym">((</span>component component<span class="hl sym">))</span>
    364 <a id="l_276"></a><span class="hl line">  276 </span>  <span class="hl sym">(</span>let <span class="hl sym">((*</span>default-pathname-defaults<span class="hl sym">* (</span>component-parent-pathname component<span class="hl sym">)))</span>
    365 <a id="l_277"></a><span class="hl line">  277 </span>    <span class="hl sym">(</span>merge-pathnames <span class="hl sym">(</span>component-relative-pathname component<span class="hl sym">))))</span>
    366 <a id="l_278"></a><span class="hl line">  278 </span>
    367 <a id="l_279"></a><span class="hl line">  279 </span><span class="hl sym">(</span>defgeneric component-property <span class="hl sym">(</span>component property<span class="hl sym">))</span>
    368 <a id="l_280"></a><span class="hl line">  280 </span>
    369 <a id="l_281"></a><span class="hl line">  281 </span><span class="hl sym">(</span>defmethod component-property <span class="hl sym">((</span>c component<span class="hl sym">)</span> property<span class="hl sym">)</span>
    370 <a id="l_282"></a><span class="hl line">  282 </span>  <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> property <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">) :</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
    371 <a id="l_283"></a><span class="hl line">  283 </span>
    372 <a id="l_284"></a><span class="hl line">  284 </span><span class="hl sym">(</span>defgeneric <span class="hl sym">(</span>setf component-property<span class="hl sym">) (</span>new-value component property<span class="hl sym">))</span>
    373 <a id="l_285"></a><span class="hl line">  285 </span>
    374 <a id="l_286"></a><span class="hl line">  286 </span><span class="hl sym">(</span>defmethod <span class="hl sym">(</span>setf component-property<span class="hl sym">) (</span>new-value <span class="hl sym">(</span>c component<span class="hl sym">)</span> property<span class="hl sym">)</span>
    375 <a id="l_287"></a><span class="hl line">  287 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>a <span class="hl sym">(</span><span class="hl kwa">assoc</span> property <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">) :</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
    376 <a id="l_288"></a><span class="hl line">  288 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> a
    377 <a id="l_289"></a><span class="hl line">  289 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">cdr</span> a<span class="hl sym">)</span> new-value<span class="hl sym">)</span>
    378 <a id="l_290"></a><span class="hl line">  290 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">)</span>
    379 <a id="l_291"></a><span class="hl line">  291 </span>              <span class="hl sym">(</span>acons property new-value <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">))))))</span>
    380 <a id="l_292"></a><span class="hl line">  292 </span>
    381 <a id="l_293"></a><span class="hl line">  293 </span><span class="hl sym">(</span>defclass system <span class="hl sym">(</span>module<span class="hl sym">)</span>
    382 <a id="l_294"></a><span class="hl line">  294 </span>  <span class="hl sym">((</span>description <span class="hl sym">:</span>accessor system-description <span class="hl sym">:</span>initarg <span class="hl sym">:</span>description<span class="hl sym">)</span>
    383 <a id="l_295"></a><span class="hl line">  295 </span>   <span class="hl sym">(</span>long-description
    384 <a id="l_296"></a><span class="hl line">  296 </span>    <span class="hl sym">:</span>accessor system-long-description <span class="hl sym">:</span>initarg <span class="hl sym">:</span>long-description<span class="hl sym">)</span>
    385 <a id="l_297"></a><span class="hl line">  297 </span>   <span class="hl sym">(</span>author <span class="hl sym">:</span>accessor system-author <span class="hl sym">:</span>initarg <span class="hl sym">:</span>author<span class="hl sym">)</span>
    386 <a id="l_298"></a><span class="hl line">  298 </span>   <span class="hl sym">(</span>maintainer <span class="hl sym">:</span>accessor system-maintainer <span class="hl sym">:</span>initarg <span class="hl sym">:</span>maintainer<span class="hl sym">)</span>
    387 <a id="l_299"></a><span class="hl line">  299 </span>   <span class="hl sym">(</span>licence <span class="hl sym">:</span>accessor system-licence <span class="hl sym">:</span>initarg <span class="hl sym">:</span>licence
    388 <a id="l_300"></a><span class="hl line">  300 </span>            <span class="hl sym">:</span>accessor system-license <span class="hl sym">:</span>initarg <span class="hl sym">:</span>license<span class="hl sym">)))</span>
    389 <a id="l_301"></a><span class="hl line">  301 </span>
    390 <a id="l_302"></a><span class="hl line">  302 </span><span class="hl slc">;;; version-satisfies</span>
    391 <a id="l_303"></a><span class="hl line">  303 </span>
    392 <a id="l_304"></a><span class="hl line">  304 </span><span class="hl slc">;;; with apologies to christophe rhodes ...</span>
    393 <a id="l_305"></a><span class="hl line">  305 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> split <span class="hl sym">(</span>string <span class="hl sym">&amp;</span>optional <span class="hl kwa">max</span> <span class="hl sym">(</span>ws <span class="hl sym">'(</span>#\Space #\Tab<span class="hl sym">)))</span>
    394 <a id="l_306"></a><span class="hl line">  306 </span>  <span class="hl sym">(</span>flet <span class="hl sym">((</span>is-ws <span class="hl sym">(</span>char<span class="hl sym">) (</span>find char ws<span class="hl sym">)))</span>
    395 <a id="l_307"></a><span class="hl line">  307 </span>    <span class="hl sym">(</span>nreverse
    396 <a id="l_308"></a><span class="hl line">  308 </span>     <span class="hl sym">(</span>let <span class="hl sym">((</span><span class="hl kwa">list</span> nil<span class="hl sym">) (</span>start <span class="hl num">0</span><span class="hl sym">) (</span>words <span class="hl num">0</span><span class="hl sym">)</span> end<span class="hl sym">)</span>
    397 <a id="l_309"></a><span class="hl line">  309 </span>       <span class="hl sym">(</span>loop
    398 <a id="l_310"></a><span class="hl line">  310 </span>         <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and max</span> <span class="hl sym">(&gt;=</span> words <span class="hl sym">(</span><span class="hl num">1</span>- <span class="hl kwa">max</span><span class="hl sym">)))</span>
    399 <a id="l_311"></a><span class="hl line">  311 </span>           <span class="hl sym">(</span>return <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>subseq string start<span class="hl sym">)</span> <span class="hl kwa">list</span><span class="hl sym">)))</span>
    400 <a id="l_312"></a><span class="hl line">  312 </span>         <span class="hl sym">(</span>setf end <span class="hl sym">(</span>position-<span class="hl kwa">if</span> #<span class="hl sym">'</span>is-ws string <span class="hl sym">:</span>start start<span class="hl sym">))</span>
    401 <a id="l_313"></a><span class="hl line">  313 </span>         <span class="hl sym">(</span>push <span class="hl sym">(</span>subseq string start end<span class="hl sym">)</span> <span class="hl kwa">list</span><span class="hl sym">)</span>
    402 <a id="l_314"></a><span class="hl line">  314 </span>         <span class="hl sym">(</span>incf words<span class="hl sym">)</span>
    403 <a id="l_315"></a><span class="hl line">  315 </span>         <span class="hl sym">(</span>unless end <span class="hl sym">(</span>return <span class="hl kwa">list</span><span class="hl sym">))</span>
    404 <a id="l_316"></a><span class="hl line">  316 </span>         <span class="hl sym">(</span>setf start <span class="hl sym">(</span><span class="hl num">1</span><span class="hl sym">+</span> end<span class="hl sym">)))))))</span>
    405 <a id="l_317"></a><span class="hl line">  317 </span>
    406 <a id="l_318"></a><span class="hl line">  318 </span><span class="hl sym">(</span>defgeneric version-satisfies <span class="hl sym">(</span>component version<span class="hl sym">))</span>
    407 <a id="l_319"></a><span class="hl line">  319 </span>
    408 <a id="l_320"></a><span class="hl line">  320 </span><span class="hl sym">(</span>defmethod version-satisfies <span class="hl sym">((</span>c component<span class="hl sym">)</span> version<span class="hl sym">)</span>
    409 <a id="l_321"></a><span class="hl line">  321 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">and</span> version <span class="hl sym">(</span>slot-<span class="hl kwa">boundp</span> c <span class="hl sym">'</span>version<span class="hl sym">))</span>
    410 <a id="l_322"></a><span class="hl line">  322 </span>    <span class="hl sym">(</span>return-from version-satisfies t<span class="hl sym">))</span>
    411 <a id="l_323"></a><span class="hl line">  323 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>x <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>parse-integer
    412 <a id="l_324"></a><span class="hl line">  324 </span>                   <span class="hl sym">(</span>split <span class="hl sym">(</span>component-version c<span class="hl sym">)</span> nil <span class="hl sym">'(</span>#\.<span class="hl sym">))))</span>
    413 <a id="l_325"></a><span class="hl line">  325 </span>        <span class="hl sym">(</span>y <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>parse-integer
    414 <a id="l_326"></a><span class="hl line">  326 </span>                   <span class="hl sym">(</span>split version nil <span class="hl sym">'(</span>#\.<span class="hl sym">)))))</span>
    415 <a id="l_327"></a><span class="hl line">  327 </span>    <span class="hl sym">(</span>labels <span class="hl sym">((</span>bigger <span class="hl sym">(</span>x y<span class="hl sym">)</span>
    416 <a id="l_328"></a><span class="hl line">  328 </span>               <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">not</span> y<span class="hl sym">)</span> t<span class="hl sym">)</span>
    417 <a id="l_329"></a><span class="hl line">  329 </span>                     <span class="hl sym">((</span><span class="hl kwa">not</span> x<span class="hl sym">)</span> nil<span class="hl sym">)</span>
    418 <a id="l_330"></a><span class="hl line">  330 </span>                     <span class="hl sym">((&gt; (</span><span class="hl kwa">car</span> x<span class="hl sym">) (</span><span class="hl kwa">car</span> y<span class="hl sym">))</span> t<span class="hl sym">)</span>
    419 <a id="l_331"></a><span class="hl line">  331 </span>                     <span class="hl sym">((= (</span><span class="hl kwa">car</span> x<span class="hl sym">) (</span><span class="hl kwa">car</span> y<span class="hl sym">))</span>
    420 <a id="l_332"></a><span class="hl line">  332 </span>                      <span class="hl sym">(</span>bigger <span class="hl sym">(</span><span class="hl kwa">cdr</span> x<span class="hl sym">) (</span><span class="hl kwa">cdr</span> y<span class="hl sym">))))))</span>
    421 <a id="l_333"></a><span class="hl line">  333 </span>      <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(= (</span><span class="hl kwa">car</span> x<span class="hl sym">) (</span><span class="hl kwa">car</span> y<span class="hl sym">))</span>
    422 <a id="l_334"></a><span class="hl line">  334 </span>           <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span><span class="hl kwa">cdr</span> y<span class="hl sym">)) (</span>bigger <span class="hl sym">(</span><span class="hl kwa">cdr</span> x<span class="hl sym">) (</span><span class="hl kwa">cdr</span> y<span class="hl sym">)))))))</span>
    423 <a id="l_335"></a><span class="hl line">  335 </span>
    424 <a id="l_336"></a><span class="hl line">  336 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
    425 <a id="l_337"></a><span class="hl line">  337 </span><span class="hl slc">;;; finding systems</span>
    426 <a id="l_338"></a><span class="hl line">  338 </span>
    427 <a id="l_339"></a><span class="hl line">  339 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>defined-systems<span class="hl sym">* (</span>make-hash-table <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">))</span>
    428 <a id="l_340"></a><span class="hl line">  340 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> coerce-name <span class="hl sym">(</span>name<span class="hl sym">)</span>
    429 <a id="l_341"></a><span class="hl line">  341 </span>  <span class="hl sym">(</span>typecase name
    430 <a id="l_342"></a><span class="hl line">  342 </span>    <span class="hl sym">(</span>component <span class="hl sym">(</span>component-name name<span class="hl sym">))</span>
    431 <a id="l_343"></a><span class="hl line">  343 </span>    <span class="hl sym">(</span>symbol <span class="hl sym">(</span>string-downcase <span class="hl sym">(</span>symbol-name name<span class="hl sym">)))</span>
    432 <a id="l_344"></a><span class="hl line">  344 </span>    <span class="hl sym">(</span>string name<span class="hl sym">)</span>
    433 <a id="l_345"></a><span class="hl line">  345 </span>    <span class="hl sym">(</span>t <span class="hl sym">(</span>sysdef-error <span class="hl str">&quot;~&#64;&lt;invalid component designator ~A~&#64;:&gt;&quot;</span> name<span class="hl sym">))))</span>
    434 <a id="l_346"></a><span class="hl line">  346 </span>
    435 <a id="l_347"></a><span class="hl line">  347 </span><span class="hl slc">;;; for the sake of keeping things reasonably neat, we adopt a</span>
    436 <a id="l_348"></a><span class="hl line">  348 </span><span class="hl slc">;;; convention that functions in this list are prefixed SYSDEF-</span>
    437 <a id="l_349"></a><span class="hl line">  349 </span>
    438 <a id="l_350"></a><span class="hl line">  350 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>system-definition-search-functions<span class="hl sym">*</span>
    439 <a id="l_351"></a><span class="hl line">  351 </span>  <span class="hl sym">'(</span>sysdef-central-registry-search<span class="hl sym">))</span>
    440 <a id="l_352"></a><span class="hl line">  352 </span>
    441 <a id="l_353"></a><span class="hl line">  353 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-definition-pathname <span class="hl sym">(</span>system<span class="hl sym">)</span>
    442 <a id="l_354"></a><span class="hl line">  354 </span>  <span class="hl sym">(</span>some <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>x<span class="hl sym">) (</span>funcall x system<span class="hl sym">))</span>
    443 <a id="l_355"></a><span class="hl line">  355 </span>        <span class="hl sym">*</span>system-definition-search-functions<span class="hl sym">*))</span>
    444 <a id="l_356"></a><span class="hl line">  356 </span>
    445 <a id="l_357"></a><span class="hl line">  357 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>central-registry<span class="hl sym">*</span>
    446 <a id="l_358"></a><span class="hl line">  358 </span>  <span class="hl sym">'(*</span>default-pathname-defaults<span class="hl sym">*</span>
    447 <a id="l_359"></a><span class="hl line">  359 </span>    #<span class="hl sym">+</span>nil <span class="hl str">&quot;/home/dan/src/sourceforge/cclan/asdf/systems/&quot;</span>
    448 <a id="l_360"></a><span class="hl line">  360 </span>    #<span class="hl sym">+</span>nil <span class="hl str">&quot;telent:asdf;systems;&quot;</span><span class="hl sym">))</span>
    449 <a id="l_361"></a><span class="hl line">  361 </span>
    450 <a id="l_362"></a><span class="hl line">  362 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> sysdef-central-registry-search <span class="hl sym">(</span>system<span class="hl sym">)</span>
    451 <a id="l_363"></a><span class="hl line">  363 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>name <span class="hl sym">(</span>coerce-name system<span class="hl sym">)))</span>
    452 <a id="l_364"></a><span class="hl line">  364 </span>    <span class="hl sym">(</span>block nil
    453 <a id="l_365"></a><span class="hl line">  365 </span>      <span class="hl sym">(</span>dolist <span class="hl sym">(</span>dir <span class="hl sym">*</span>central-registry<span class="hl sym">*)</span>
    454 <a id="l_366"></a><span class="hl line">  366 </span>        <span class="hl sym">(</span>let<span class="hl sym">* ((</span>defaults <span class="hl sym">(</span><span class="hl kwa">eval</span> dir<span class="hl sym">))</span>
    455 <a id="l_367"></a><span class="hl line">  367 </span>               <span class="hl sym">(</span>file <span class="hl sym">(</span><span class="hl kwa">and</span> defaults
    456 <a id="l_368"></a><span class="hl line">  368 </span>                          <span class="hl sym">(</span>make-pathname
    457 <a id="l_369"></a><span class="hl line">  369 </span>                           <span class="hl sym">:</span>defaults defaults <span class="hl sym">:</span>version <span class="hl sym">:</span>newest
    458 <a id="l_370"></a><span class="hl line">  370 </span>                           <span class="hl sym">:</span>name name <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;asd&quot;</span> <span class="hl sym">:</span>case <span class="hl sym">:</span>local<span class="hl sym">))))</span>
    459 <a id="l_371"></a><span class="hl line">  371 </span>          <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">and</span> file <span class="hl sym">(</span>probe-file file<span class="hl sym">))</span>
    460 <a id="l_372"></a><span class="hl line">  372 </span>              <span class="hl sym">(</span>return file<span class="hl sym">)))))))</span>
    461 <a id="l_373"></a><span class="hl line">  373 </span>
    462 <a id="l_374"></a><span class="hl line">  374 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> make-temporary-package <span class="hl sym">()</span>
    463 <a id="l_375"></a><span class="hl line">  375 </span>  <span class="hl sym">(</span>flet <span class="hl sym">((</span>try <span class="hl sym">(</span>counter<span class="hl sym">)</span>
    464 <a id="l_376"></a><span class="hl line">  376 </span>           <span class="hl sym">(</span>ignore-errors
    465 <a id="l_377"></a><span class="hl line">  377 </span>             <span class="hl sym">(</span>make-package <span class="hl sym">(</span>format nil <span class="hl str">&quot;ASDF~D&quot;</span> counter<span class="hl sym">)</span>
    466 <a id="l_378"></a><span class="hl line">  378 </span>                           <span class="hl sym">:</span>use <span class="hl sym">'(:</span>cl <span class="hl sym">:</span>asdf<span class="hl sym">)))))</span>
    467 <a id="l_379"></a><span class="hl line">  379 </span>    <span class="hl sym">(</span>do<span class="hl sym">* ((</span>counter <span class="hl num">0</span> <span class="hl sym">(+</span> counter <span class="hl num">1</span><span class="hl sym">))</span>
    468 <a id="l_380"></a><span class="hl line">  380 </span>          <span class="hl sym">(</span>package <span class="hl sym">(</span>try counter<span class="hl sym">) (</span>try counter<span class="hl sym">)))</span>
    469 <a id="l_381"></a><span class="hl line">  381 </span>         <span class="hl sym">(</span>package package<span class="hl sym">))))</span>
    470 <a id="l_382"></a><span class="hl line">  382 </span>
    471 <a id="l_383"></a><span class="hl line">  383 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> find-system <span class="hl sym">(</span>name <span class="hl sym">&amp;</span>optional <span class="hl sym">(</span>error-p t<span class="hl sym">))</span>
    472 <a id="l_384"></a><span class="hl line">  384 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>name <span class="hl sym">(</span>coerce-name name<span class="hl sym">))</span>
    473 <a id="l_385"></a><span class="hl line">  385 </span>         <span class="hl sym">(</span>in-memory <span class="hl sym">(</span>gethash name <span class="hl sym">*</span>defined-systems<span class="hl sym">*))</span>
    474 <a id="l_386"></a><span class="hl line">  386 </span>         <span class="hl sym">(</span>on-disk <span class="hl sym">(</span>system-definition-pathname name<span class="hl sym">)))</span>
    475 <a id="l_387"></a><span class="hl line">  387 </span>    <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> on-disk
    476 <a id="l_388"></a><span class="hl line">  388 </span>               <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> in-memory<span class="hl sym">)</span>
    477 <a id="l_389"></a><span class="hl line">  389 </span>                   <span class="hl sym">(&lt; (</span><span class="hl kwa">car</span> in-memory<span class="hl sym">) (</span>file-write-date on-disk<span class="hl sym">))))</span>
    478 <a id="l_390"></a><span class="hl line">  390 </span>      <span class="hl sym">(</span>let <span class="hl sym">((</span>package <span class="hl sym">(</span>make-temporary-package<span class="hl sym">)))</span>
    479 <a id="l_391"></a><span class="hl line">  391 </span>        <span class="hl sym">(</span>unwind-protect
    480 <a id="l_392"></a><span class="hl line">  392 </span>             <span class="hl sym">(</span>let <span class="hl sym">((*</span>package<span class="hl sym">*</span> package<span class="hl sym">))</span>
    481 <a id="l_393"></a><span class="hl line">  393 </span>               <span class="hl sym">(</span>format
    482 <a id="l_394"></a><span class="hl line">  394 </span>                <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
    483 <a id="l_395"></a><span class="hl line">  395 </span>                <span class="hl str">&quot;~&amp;~&#64;&lt;; ~&#64;;loading system definition from ~A into ~A~&#64;:&gt;~%&quot;</span>
    484 <a id="l_396"></a><span class="hl line">  396 </span>                <span class="hl slc">;; FIXME: This wants to be (ENOUGH-NAMESTRING</span>
    485 <a id="l_397"></a><span class="hl line">  397 </span>                <span class="hl slc">;; ON-DISK), but CMUCL barfs on that.</span>
    486 <a id="l_398"></a><span class="hl line">  398 </span>                on-disk
    487 <a id="l_399"></a><span class="hl line">  399 </span>                <span class="hl sym">*</span>package<span class="hl sym">*)</span>
    488 <a id="l_400"></a><span class="hl line">  400 </span>               <span class="hl sym">(</span><span class="hl kwa">load</span> on-disk<span class="hl sym">))</span>
    489 <a id="l_401"></a><span class="hl line">  401 </span>          <span class="hl sym">(</span>delete-package package<span class="hl sym">))))</span>
    490 <a id="l_402"></a><span class="hl line">  402 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>in-memory <span class="hl sym">(</span>gethash name <span class="hl sym">*</span>defined-systems<span class="hl sym">*)))</span>
    491 <a id="l_403"></a><span class="hl line">  403 </span>      <span class="hl sym">(</span><span class="hl kwa">if</span> in-memory
    492 <a id="l_404"></a><span class="hl line">  404 </span>          <span class="hl sym">(</span><span class="hl kwa">progn</span> <span class="hl sym">(</span><span class="hl kwa">if</span> on-disk <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">car</span> in-memory<span class="hl sym">) (</span>file-write-date on-disk<span class="hl sym">)))</span>
    493 <a id="l_405"></a><span class="hl line">  405 </span>                 <span class="hl sym">(</span><span class="hl kwa">cdr</span> in-memory<span class="hl sym">))</span>
    494 <a id="l_406"></a><span class="hl line">  406 </span>          <span class="hl sym">(</span><span class="hl kwa">if</span> error-p <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-component <span class="hl sym">:</span>requires name<span class="hl sym">))))))</span>
    495 <a id="l_407"></a><span class="hl line">  407 </span>
    496 <a id="l_408"></a><span class="hl line">  408 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> register-system <span class="hl sym">(</span>name system<span class="hl sym">)</span>
    497 <a id="l_409"></a><span class="hl line">  409 </span>  <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> <span class="hl str">&quot;~&amp;~&#64;&lt;; ~&#64;;registering ~A as ~A~&#64;:&gt;~%&quot;</span> system name<span class="hl sym">)</span>
    498 <a id="l_410"></a><span class="hl line">  410 </span>  <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span>coerce-name  name<span class="hl sym">) *</span>defined-systems<span class="hl sym">*)</span>
    499 <a id="l_411"></a><span class="hl line">  411 </span>        <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>get-universal-time<span class="hl sym">)</span> system<span class="hl sym">)))</span>
    500 <a id="l_412"></a><span class="hl line">  412 </span>
    501 <a id="l_413"></a><span class="hl line">  413 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-registered-p <span class="hl sym">(</span>name<span class="hl sym">)</span>
    502 <a id="l_414"></a><span class="hl line">  414 </span>  <span class="hl sym">(</span>gethash <span class="hl sym">(</span>coerce-name name<span class="hl sym">) *</span>defined-systems<span class="hl sym">*))</span>
    503 <a id="l_415"></a><span class="hl line">  415 </span>
    504 <a id="l_416"></a><span class="hl line">  416 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
    505 <a id="l_417"></a><span class="hl line">  417 </span><span class="hl slc">;;; finding components</span>
    506 <a id="l_418"></a><span class="hl line">  418 </span>
    507 <a id="l_419"></a><span class="hl line">  419 </span><span class="hl sym">(</span>defgeneric find-component <span class="hl sym">(</span>module name <span class="hl sym">&amp;</span>optional version<span class="hl sym">)</span>
    508 <a id="l_420"></a><span class="hl line">  420 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Finds the component with name NAME present in the</span>
    509 <a id="l_421"></a><span class="hl line">  421 </span><span class="hl str">MODULE module; if MODULE is nil, then the component is assumed to be a</span>
    510 <a id="l_422"></a><span class="hl line">  422 </span><span class="hl str">system.&quot;</span><span class="hl sym">))</span>
    511 <a id="l_423"></a><span class="hl line">  423 </span>
    512 <a id="l_424"></a><span class="hl line">  424 </span><span class="hl sym">(</span>defmethod find-component <span class="hl sym">((</span>module module<span class="hl sym">)</span> name <span class="hl sym">&amp;</span>optional version<span class="hl sym">)</span>
    513 <a id="l_425"></a><span class="hl line">  425 </span>  <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>slot-<span class="hl kwa">boundp</span> module <span class="hl sym">'</span>components<span class="hl sym">)</span>
    514 <a id="l_426"></a><span class="hl line">  426 </span>      <span class="hl sym">(</span>let <span class="hl sym">((</span>m <span class="hl sym">(</span>find name <span class="hl sym">(</span>module-components module<span class="hl sym">)</span>
    515 <a id="l_427"></a><span class="hl line">  427 </span>                     <span class="hl sym">:</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span> <span class="hl sym">:</span>key #<span class="hl sym">'</span>component-name<span class="hl sym">)))</span>
    516 <a id="l_428"></a><span class="hl line">  428 </span>        <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">and</span> m <span class="hl sym">(</span>version-satisfies m version<span class="hl sym">))</span> m<span class="hl sym">))))</span>
    517 <a id="l_429"></a><span class="hl line">  429 </span>
    518 <a id="l_430"></a><span class="hl line">  430 </span>
    519 <a id="l_431"></a><span class="hl line">  431 </span><span class="hl slc">;;; a component with no parent is a system</span>
    520 <a id="l_432"></a><span class="hl line">  432 </span><span class="hl sym">(</span>defmethod find-component <span class="hl sym">((</span>module <span class="hl sym">(</span>eql nil<span class="hl sym">))</span> name <span class="hl sym">&amp;</span>optional version<span class="hl sym">)</span>
    521 <a id="l_433"></a><span class="hl line">  433 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>m <span class="hl sym">(</span>find-system name nil<span class="hl sym">)))</span>
    522 <a id="l_434"></a><span class="hl line">  434 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">and</span> m <span class="hl sym">(</span>version-satisfies m version<span class="hl sym">))</span> m<span class="hl sym">)))</span>
    523 <a id="l_435"></a><span class="hl line">  435 </span>
    524 <a id="l_436"></a><span class="hl line">  436 </span><span class="hl slc">;;; component subclasses</span>
    525 <a id="l_437"></a><span class="hl line">  437 </span>
    526 <a id="l_438"></a><span class="hl line">  438 </span><span class="hl sym">(</span>defclass source-file <span class="hl sym">(</span>component<span class="hl sym">) ())</span>
    527 <a id="l_439"></a><span class="hl line">  439 </span>
    528 <a id="l_440"></a><span class="hl line">  440 </span><span class="hl sym">(</span>defclass cl-source-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
    529 <a id="l_441"></a><span class="hl line">  441 </span><span class="hl sym">(</span>defclass c-source-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
    530 <a id="l_442"></a><span class="hl line">  442 </span><span class="hl sym">(</span>defclass java-source-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
    531 <a id="l_443"></a><span class="hl line">  443 </span><span class="hl sym">(</span>defclass static-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
    532 <a id="l_444"></a><span class="hl line">  444 </span><span class="hl sym">(</span>defclass doc-file <span class="hl sym">(</span>static-file<span class="hl sym">) ())</span>
    533 <a id="l_445"></a><span class="hl line">  445 </span><span class="hl sym">(</span>defclass html-file <span class="hl sym">(</span>doc-file<span class="hl sym">) ())</span>
    534 <a id="l_446"></a><span class="hl line">  446 </span>
    535 <a id="l_447"></a><span class="hl line">  447 </span><span class="hl sym">(</span>defgeneric source-file-<span class="hl kwa">type</span> <span class="hl sym">(</span>component system<span class="hl sym">))</span>
    536 <a id="l_448"></a><span class="hl line">  448 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c cl-source-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;lisp&quot;</span><span class="hl sym">)</span>
    537 <a id="l_449"></a><span class="hl line">  449 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c c-source-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;c&quot;</span><span class="hl sym">)</span>
    538 <a id="l_450"></a><span class="hl line">  450 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c java-source-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;java&quot;</span><span class="hl sym">)</span>
    539 <a id="l_451"></a><span class="hl line">  451 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c html-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;html&quot;</span><span class="hl sym">)</span>
    540 <a id="l_452"></a><span class="hl line">  452 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c static-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> nil<span class="hl sym">)</span>
    541 <a id="l_453"></a><span class="hl line">  453 </span>
    542 <a id="l_454"></a><span class="hl line">  454 </span><span class="hl sym">(</span>defmethod component-relative-pathname <span class="hl sym">((</span>component source-file<span class="hl sym">))</span>
    543 <a id="l_455"></a><span class="hl line">  455 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>relative-pathname <span class="hl sym">(</span>slot-value component <span class="hl sym">'</span>relative-pathname<span class="hl sym">)))</span>
    544 <a id="l_456"></a><span class="hl line">  456 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> relative-pathname
    545 <a id="l_457"></a><span class="hl line">  457 </span>        <span class="hl sym">(</span>merge-pathnames
    546 <a id="l_458"></a><span class="hl line">  458 </span>         relative-pathname
    547 <a id="l_459"></a><span class="hl line">  459 </span>         <span class="hl sym">(</span>make-pathname
    548 <a id="l_460"></a><span class="hl line">  460 </span>          <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl sym">(</span>source-file-<span class="hl kwa">type</span> component <span class="hl sym">(</span>component-system component<span class="hl sym">))))</span>
    549 <a id="l_461"></a><span class="hl line">  461 </span>        <span class="hl sym">(</span>let<span class="hl sym">* ((*</span>default-pathname-defaults<span class="hl sym">*</span>
    550 <a id="l_462"></a><span class="hl line">  462 </span>                <span class="hl sym">(</span>component-parent-pathname component<span class="hl sym">))</span>
    551 <a id="l_463"></a><span class="hl line">  463 </span>               <span class="hl sym">(</span>name-<span class="hl kwa">type</span>
    552 <a id="l_464"></a><span class="hl line">  464 </span>                <span class="hl sym">(</span>make-pathname
    553 <a id="l_465"></a><span class="hl line">  465 </span>                 <span class="hl sym">:</span>name <span class="hl sym">(</span>component-name component<span class="hl sym">)</span>
    554 <a id="l_466"></a><span class="hl line">  466 </span>                 <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl sym">(</span>source-file-<span class="hl kwa">type</span> component
    555 <a id="l_467"></a><span class="hl line">  467 </span>                                         <span class="hl sym">(</span>component-system component<span class="hl sym">)))))</span>
    556 <a id="l_468"></a><span class="hl line">  468 </span>          name-<span class="hl kwa">type</span><span class="hl sym">))))</span>
    557 <a id="l_469"></a><span class="hl line">  469 </span>
    558 <a id="l_470"></a><span class="hl line">  470 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
    559 <a id="l_471"></a><span class="hl line">  471 </span><span class="hl slc">;;; operations</span>
    560 <a id="l_472"></a><span class="hl line">  472 </span>
    561 <a id="l_473"></a><span class="hl line">  473 </span><span class="hl slc">;;; one of these is instantiated whenever (operate ) is called</span>
    562 <a id="l_474"></a><span class="hl line">  474 </span>
    563 <a id="l_475"></a><span class="hl line">  475 </span><span class="hl sym">(</span>defclass operation <span class="hl sym">()</span>
    564 <a id="l_476"></a><span class="hl line">  476 </span>  <span class="hl sym">((</span>forced <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>force <span class="hl sym">:</span>accessor operation-forced<span class="hl sym">)</span>
    565 <a id="l_477"></a><span class="hl line">  477 </span>   <span class="hl sym">(</span>original-initargs <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>original-initargs
    566 <a id="l_478"></a><span class="hl line">  478 </span>                      <span class="hl sym">:</span>accessor operation-original-initargs<span class="hl sym">)</span>
    567 <a id="l_479"></a><span class="hl line">  479 </span>   <span class="hl sym">(</span>visited-nodes <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>accessor operation-visited-nodes<span class="hl sym">)</span>
    568 <a id="l_480"></a><span class="hl line">  480 </span>   <span class="hl sym">(</span>visiting-nodes <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>accessor operation-visiting-nodes<span class="hl sym">)</span>
    569 <a id="l_481"></a><span class="hl line">  481 </span>   <span class="hl sym">(</span>parent <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>parent <span class="hl sym">:</span>accessor operation-parent<span class="hl sym">)))</span>
    570 <a id="l_482"></a><span class="hl line">  482 </span>
    571 <a id="l_483"></a><span class="hl line">  483 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>o operation<span class="hl sym">)</span> stream<span class="hl sym">)</span>
    572 <a id="l_484"></a><span class="hl line">  484 </span>  <span class="hl sym">(</span><span class="hl kwa">print</span>-unreadable-object <span class="hl sym">(</span>o stream <span class="hl sym">:</span><span class="hl kwa">type</span> t <span class="hl sym">:</span>identity t<span class="hl sym">)</span>
    573 <a id="l_485"></a><span class="hl line">  485 </span>    <span class="hl sym">(</span>ignore-errors
    574 <a id="l_486"></a><span class="hl line">  486 </span>      <span class="hl sym">(</span><span class="hl kwa">prin1</span> <span class="hl sym">(</span>operation-original-initargs o<span class="hl sym">)</span> stream<span class="hl sym">))))</span>
    575 <a id="l_487"></a><span class="hl line">  487 </span>
    576 <a id="l_488"></a><span class="hl line">  488 </span><span class="hl sym">(</span>defmethod shared-initialize <span class="hl sym">:</span>after <span class="hl sym">((</span>operation operation<span class="hl sym">)</span> slot-names
    577 <a id="l_489"></a><span class="hl line">  489 </span>                                     <span class="hl sym">&amp;</span>key force
    578 <a id="l_490"></a><span class="hl line">  490 </span>                                     <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span>
    579 <a id="l_491"></a><span class="hl line">  491 </span>  <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignore slot-names force<span class="hl sym">))</span>
    580 <a id="l_492"></a><span class="hl line">  492 </span>  <span class="hl slc">;; empty method to disable initarg validity checking</span>
    581 <a id="l_493"></a><span class="hl line">  493 </span>  <span class="hl sym">)</span>
    582 <a id="l_494"></a><span class="hl line">  494 </span>
    583 <a id="l_495"></a><span class="hl line">  495 </span><span class="hl sym">(</span>defgeneric perform <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    584 <a id="l_496"></a><span class="hl line">  496 </span><span class="hl sym">(</span>defgeneric operation-done-p <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    585 <a id="l_497"></a><span class="hl line">  497 </span><span class="hl sym">(</span>defgeneric explain <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    586 <a id="l_498"></a><span class="hl line">  498 </span><span class="hl sym">(</span>defgeneric output-files <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    587 <a id="l_499"></a><span class="hl line">  499 </span><span class="hl sym">(</span>defgeneric input-files <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    588 <a id="l_500"></a><span class="hl line">  500 </span>
    589 <a id="l_501"></a><span class="hl line">  501 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> node-for <span class="hl sym">(</span>o c<span class="hl sym">)</span>
    590 <a id="l_502"></a><span class="hl line">  502 </span>  <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>class-name <span class="hl sym">(</span>class-of o<span class="hl sym">))</span> c<span class="hl sym">))</span>
    591 <a id="l_503"></a><span class="hl line">  503 </span>
    592 <a id="l_504"></a><span class="hl line">  504 </span><span class="hl sym">(</span>defgeneric operation-ancestor <span class="hl sym">(</span>operation<span class="hl sym">)</span>
    593 <a id="l_505"></a><span class="hl line">  505 </span>  <span class="hl sym">(:</span>documentation
    594 <a id="l_506"></a><span class="hl line">  506 </span>   <span class="hl str">&quot;Recursively chase the operation's parent pointer until we get to</span>
    595 <a id="l_507"></a><span class="hl line">  507 </span><span class="hl str">the head of the tree&quot;</span><span class="hl sym">))</span>
    596 <a id="l_508"></a><span class="hl line">  508 </span>
    597 <a id="l_509"></a><span class="hl line">  509 </span><span class="hl sym">(</span>defmethod operation-ancestor <span class="hl sym">((</span>operation operation<span class="hl sym">))</span>
    598 <a id="l_510"></a><span class="hl line">  510 </span>  <span class="hl sym">(</span>aif <span class="hl sym">(</span>operation-parent operation<span class="hl sym">)</span>
    599 <a id="l_511"></a><span class="hl line">  511 </span>       <span class="hl sym">(</span>operation-ancestor it<span class="hl sym">)</span>
    600 <a id="l_512"></a><span class="hl line">  512 </span>       operation<span class="hl sym">))</span>
    601 <a id="l_513"></a><span class="hl line">  513 </span>
    602 <a id="l_514"></a><span class="hl line">  514 </span>
    603 <a id="l_515"></a><span class="hl line">  515 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> make-sub-operation <span class="hl sym">(</span>c o dep-c dep-o<span class="hl sym">)</span>
    604 <a id="l_516"></a><span class="hl line">  516 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>args <span class="hl sym">(</span>copy-<span class="hl kwa">list</span> <span class="hl sym">(</span>operation-original-initargs o<span class="hl sym">)))</span>
    605 <a id="l_517"></a><span class="hl line">  517 </span>         <span class="hl sym">(</span>force-p <span class="hl sym">(</span>getf args <span class="hl sym">:</span>force<span class="hl sym">)))</span>
    606 <a id="l_518"></a><span class="hl line">  518 </span>    <span class="hl slc">;; note explicit comparison with T: any other non-NIL force value</span>
    607 <a id="l_519"></a><span class="hl line">  519 </span>    <span class="hl slc">;; (e.g. :recursive) will pass through</span>
    608 <a id="l_520"></a><span class="hl line">  520 </span>    <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">null</span> <span class="hl sym">(</span>component-parent c<span class="hl sym">))</span>
    609 <a id="l_521"></a><span class="hl line">  521 </span>                <span class="hl sym">(</span><span class="hl kwa">null</span> <span class="hl sym">(</span>component-parent dep-c<span class="hl sym">))</span>
    610 <a id="l_522"></a><span class="hl line">  522 </span>                <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>eql c dep-c<span class="hl sym">)))</span>
    611 <a id="l_523"></a><span class="hl line">  523 </span>           <span class="hl sym">(</span>when <span class="hl sym">(</span>eql force-p t<span class="hl sym">)</span>
    612 <a id="l_524"></a><span class="hl line">  524 </span>             <span class="hl sym">(</span>setf <span class="hl sym">(</span>getf args <span class="hl sym">:</span>force<span class="hl sym">)</span> nil<span class="hl sym">))</span>
    613 <a id="l_525"></a><span class="hl line">  525 </span>           <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>make-instance dep-o
    614 <a id="l_526"></a><span class="hl line">  526 </span>                  <span class="hl sym">:</span>parent o
    615 <a id="l_527"></a><span class="hl line">  527 </span>                  <span class="hl sym">:</span>original-initargs args args<span class="hl sym">))</span>
    616 <a id="l_528"></a><span class="hl line">  528 </span>          <span class="hl sym">((</span>subtypep <span class="hl sym">(</span><span class="hl kwa">type</span>-of o<span class="hl sym">)</span> dep-o<span class="hl sym">)</span>
    617 <a id="l_529"></a><span class="hl line">  529 </span>           o<span class="hl sym">)</span>
    618 <a id="l_530"></a><span class="hl line">  530 </span>          <span class="hl sym">(</span>t
    619 <a id="l_531"></a><span class="hl line">  531 </span>           <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>make-instance dep-o
    620 <a id="l_532"></a><span class="hl line">  532 </span>                  <span class="hl sym">:</span>parent o <span class="hl sym">:</span>original-initargs args args<span class="hl sym">)))))</span>
    621 <a id="l_533"></a><span class="hl line">  533 </span>
    622 <a id="l_534"></a><span class="hl line">  534 </span>
    623 <a id="l_535"></a><span class="hl line">  535 </span><span class="hl sym">(</span>defgeneric visit-component <span class="hl sym">(</span>operation component data<span class="hl sym">))</span>
    624 <a id="l_536"></a><span class="hl line">  536 </span>
    625 <a id="l_537"></a><span class="hl line">  537 </span><span class="hl sym">(</span>defmethod visit-component <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">)</span> data<span class="hl sym">)</span>
    626 <a id="l_538"></a><span class="hl line">  538 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span>component-visited-p o c<span class="hl sym">)</span>
    627 <a id="l_539"></a><span class="hl line">  539 </span>    <span class="hl sym">(</span>push <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>node-for o c<span class="hl sym">)</span> data<span class="hl sym">)</span>
    628 <a id="l_540"></a><span class="hl line">  540 </span>          <span class="hl sym">(</span>operation-visited-nodes <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">)))))</span>
    629 <a id="l_541"></a><span class="hl line">  541 </span>
    630 <a id="l_542"></a><span class="hl line">  542 </span><span class="hl sym">(</span>defgeneric component-visited-p <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    631 <a id="l_543"></a><span class="hl line">  543 </span>
    632 <a id="l_544"></a><span class="hl line">  544 </span><span class="hl sym">(</span>defmethod component-visited-p <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    633 <a id="l_545"></a><span class="hl line">  545 </span>  <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">(</span>node-for o c<span class="hl sym">)</span>
    634 <a id="l_546"></a><span class="hl line">  546 </span>         <span class="hl sym">(</span>operation-visited-nodes <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">))</span>
    635 <a id="l_547"></a><span class="hl line">  547 </span>         <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">))</span>
    636 <a id="l_548"></a><span class="hl line">  548 </span>
    637 <a id="l_549"></a><span class="hl line">  549 </span><span class="hl sym">(</span>defgeneric <span class="hl sym">(</span>setf visiting-component<span class="hl sym">) (</span>new-value operation component<span class="hl sym">))</span>
    638 <a id="l_550"></a><span class="hl line">  550 </span>
    639 <a id="l_551"></a><span class="hl line">  551 </span><span class="hl sym">(</span>defmethod <span class="hl sym">(</span>setf visiting-component<span class="hl sym">) (</span>new-value operation component<span class="hl sym">)</span>
    640 <a id="l_552"></a><span class="hl line">  552 </span>  <span class="hl slc">;; MCL complains about unused lexical variables</span>
    641 <a id="l_553"></a><span class="hl line">  553 </span>  <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignorable new-value operation component<span class="hl sym">)))</span>
    642 <a id="l_554"></a><span class="hl line">  554 </span>
    643 <a id="l_555"></a><span class="hl line">  555 </span><span class="hl sym">(</span>defmethod <span class="hl sym">(</span>setf visiting-component<span class="hl sym">) (</span>new-value <span class="hl sym">(</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    644 <a id="l_556"></a><span class="hl line">  556 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>node <span class="hl sym">(</span>node-for o c<span class="hl sym">))</span>
    645 <a id="l_557"></a><span class="hl line">  557 </span>        <span class="hl sym">(</span>a <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">)))</span>
    646 <a id="l_558"></a><span class="hl line">  558 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> new-value
    647 <a id="l_559"></a><span class="hl line">  559 </span>        <span class="hl sym">(</span>pushnew node <span class="hl sym">(</span>operation-visiting-nodes a<span class="hl sym">) :</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)</span>
    648 <a id="l_560"></a><span class="hl line">  560 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span>operation-visiting-nodes a<span class="hl sym">)</span>
    649 <a id="l_561"></a><span class="hl line">  561 </span>              <span class="hl sym">(</span>remove node  <span class="hl sym">(</span>operation-visiting-nodes a<span class="hl sym">) :</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))))</span>
    650 <a id="l_562"></a><span class="hl line">  562 </span>
    651 <a id="l_563"></a><span class="hl line">  563 </span><span class="hl sym">(</span>defgeneric component-visiting-p <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    652 <a id="l_564"></a><span class="hl line">  564 </span>
    653 <a id="l_565"></a><span class="hl line">  565 </span><span class="hl sym">(</span>defmethod component-visiting-p <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    654 <a id="l_566"></a><span class="hl line">  566 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>node <span class="hl sym">(</span><span class="hl kwa">cons</span> o c<span class="hl sym">)))</span>
    655 <a id="l_567"></a><span class="hl line">  567 </span>    <span class="hl sym">(</span><span class="hl kwa">member</span> node <span class="hl sym">(</span>operation-visiting-nodes <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">))</span>
    656 <a id="l_568"></a><span class="hl line">  568 </span>            <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
    657 <a id="l_569"></a><span class="hl line">  569 </span>
    658 <a id="l_570"></a><span class="hl line">  570 </span><span class="hl sym">(</span>defgeneric component-depends-on <span class="hl sym">(</span>operation component<span class="hl sym">)</span>
    659 <a id="l_571"></a><span class="hl line">  571 </span>  <span class="hl sym">(:</span>documentation
    660 <a id="l_572"></a><span class="hl line">  572 </span>   <span class="hl str">&quot;Returns a list of dependencies needed by the component to perform</span>
    661 <a id="l_573"></a><span class="hl line">  573 </span><span class="hl str">    the operation.  A dependency has one of the following forms:</span>
    662 <a id="l_574"></a><span class="hl line">  574 </span><span class="hl str"></span>
    663 <a id="l_575"></a><span class="hl line">  575 </span><span class="hl str">      (&lt;operation&gt; &lt;component&gt;*), where &lt;operation&gt; is a class</span>
    664 <a id="l_576"></a><span class="hl line">  576 </span><span class="hl str">        designator and each &lt;component&gt; is a component</span>
    665 <a id="l_577"></a><span class="hl line">  577 </span><span class="hl str">        designator, which means that the component depends on</span>
    666 <a id="l_578"></a><span class="hl line">  578 </span><span class="hl str">        &lt;operation&gt; having been performed on each &lt;component&gt;; or</span>
    667 <a id="l_579"></a><span class="hl line">  579 </span><span class="hl str"></span>
    668 <a id="l_580"></a><span class="hl line">  580 </span><span class="hl str">      (FEATURE &lt;feature&gt;), which means that the component depends</span>
    669 <a id="l_581"></a><span class="hl line">  581 </span><span class="hl str">        on &lt;feature&gt;'s presence in *FEATURES*.</span>
    670 <a id="l_582"></a><span class="hl line">  582 </span><span class="hl str"></span>
    671 <a id="l_583"></a><span class="hl line">  583 </span><span class="hl str">    Methods specialized on subclasses of existing component types</span>
    672 <a id="l_584"></a><span class="hl line">  584 </span><span class="hl str">    should usually append the results of CALL-NEXT-METHOD to the</span>
    673 <a id="l_585"></a><span class="hl line">  585 </span><span class="hl str">    list.&quot;</span><span class="hl sym">))</span>
    674 <a id="l_586"></a><span class="hl line">  586 </span>
    675 <a id="l_587"></a><span class="hl line">  587 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>op-spec symbol<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    676 <a id="l_588"></a><span class="hl line">  588 </span>  <span class="hl sym">(</span>component-depends-on <span class="hl sym">(</span>make-instance op-spec<span class="hl sym">)</span> c<span class="hl sym">))</span>
    677 <a id="l_589"></a><span class="hl line">  589 </span>
    678 <a id="l_590"></a><span class="hl line">  590 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    679 <a id="l_591"></a><span class="hl line">  591 </span>  <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">(</span>class-name <span class="hl sym">(</span>class-of o<span class="hl sym">))</span>
    680 <a id="l_592"></a><span class="hl line">  592 </span>              <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>in-order-to<span class="hl sym">))))</span>
    681 <a id="l_593"></a><span class="hl line">  593 </span>
    682 <a id="l_594"></a><span class="hl line">  594 </span><span class="hl sym">(</span>defgeneric component-self-dependencies <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    683 <a id="l_595"></a><span class="hl line">  595 </span>
    684 <a id="l_596"></a><span class="hl line">  596 </span><span class="hl sym">(</span>defmethod component-self-dependencies <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    685 <a id="l_597"></a><span class="hl line">  597 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>all-deps <span class="hl sym">(</span>component-depends-on o c<span class="hl sym">)))</span>
    686 <a id="l_598"></a><span class="hl line">  598 </span>    <span class="hl sym">(</span>remove-<span class="hl kwa">if</span>-<span class="hl kwa">not</span> <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>x<span class="hl sym">)</span>
    687 <a id="l_599"></a><span class="hl line">  599 </span>                     <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span>component-name c<span class="hl sym">) (</span><span class="hl kwa">cdr</span> x<span class="hl sym">) :</span>test #<span class="hl sym">'</span>string<span class="hl sym">=))</span>
    688 <a id="l_600"></a><span class="hl line">  600 </span>                   all-deps<span class="hl sym">)))</span>
    689 <a id="l_601"></a><span class="hl line">  601 </span>
    690 <a id="l_602"></a><span class="hl line">  602 </span><span class="hl sym">(</span>defmethod input-files <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    691 <a id="l_603"></a><span class="hl line">  603 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>parent <span class="hl sym">(</span>component-parent c<span class="hl sym">))</span>
    692 <a id="l_604"></a><span class="hl line">  604 </span>        <span class="hl sym">(</span>self-deps <span class="hl sym">(</span>component-self-dependencies operation c<span class="hl sym">)))</span>
    693 <a id="l_605"></a><span class="hl line">  605 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> self-deps
    694 <a id="l_606"></a><span class="hl line">  606 </span>        <span class="hl sym">(</span>mapcan <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>dep<span class="hl sym">)</span>
    695 <a id="l_607"></a><span class="hl line">  607 </span>                  <span class="hl sym">(</span>destructuring-bind <span class="hl sym">(</span>op name<span class="hl sym">)</span> dep
    696 <a id="l_608"></a><span class="hl line">  608 </span>                    <span class="hl sym">(</span>output-files <span class="hl sym">(</span>make-instance op<span class="hl sym">)</span>
    697 <a id="l_609"></a><span class="hl line">  609 </span>                                  <span class="hl sym">(</span>find-component parent name<span class="hl sym">))))</span>
    698 <a id="l_610"></a><span class="hl line">  610 </span>                self-deps<span class="hl sym">)</span>
    699 <a id="l_611"></a><span class="hl line">  611 </span>        <span class="hl slc">;; no previous operations needed?  I guess we work with the</span>
    700 <a id="l_612"></a><span class="hl line">  612 </span>        <span class="hl slc">;; original source file, then</span>
    701 <a id="l_613"></a><span class="hl line">  613 </span>        <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))))</span>
    702 <a id="l_614"></a><span class="hl line">  614 </span>
    703 <a id="l_615"></a><span class="hl line">  615 </span><span class="hl sym">(</span>defmethod input-files <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c module<span class="hl sym">))</span> nil<span class="hl sym">)</span>
    704 <a id="l_616"></a><span class="hl line">  616 </span>
    705 <a id="l_617"></a><span class="hl line">  617 </span><span class="hl sym">(</span>defmethod operation-done-p <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    706 <a id="l_618"></a><span class="hl line">  618 </span>  <span class="hl sym">(</span>flet <span class="hl sym">((</span>fwd-<span class="hl kwa">or</span>-return-t <span class="hl sym">(</span>file<span class="hl sym">)</span>
    707 <a id="l_619"></a><span class="hl line">  619 </span>           <span class="hl slc">;; if FILE-WRITE-DATE returns NIL, it's possible that the</span>
    708 <a id="l_620"></a><span class="hl line">  620 </span>           <span class="hl slc">;; user or some other agent has deleted an input file.  If</span>
    709 <a id="l_621"></a><span class="hl line">  621 </span>           <span class="hl slc">;; that's the case, well, that's not good, but as long as</span>
    710 <a id="l_622"></a><span class="hl line">  622 </span>           <span class="hl slc">;; the operation is otherwise considered to be done we</span>
    711 <a id="l_623"></a><span class="hl line">  623 </span>           <span class="hl slc">;; could continue and survive.</span>
    712 <a id="l_624"></a><span class="hl line">  624 </span>           <span class="hl sym">(</span>let <span class="hl sym">((</span>date <span class="hl sym">(</span>file-write-date file<span class="hl sym">)))</span>
    713 <a id="l_625"></a><span class="hl line">  625 </span>             <span class="hl sym">(</span><span class="hl kwa">cond</span>
    714 <a id="l_626"></a><span class="hl line">  626 </span>               <span class="hl sym">(</span>date<span class="hl sym">)</span>
    715 <a id="l_627"></a><span class="hl line">  627 </span>               <span class="hl sym">(</span>t
    716 <a id="l_628"></a><span class="hl line">  628 </span>                <span class="hl sym">(</span>warn <span class="hl str">&quot;~&#64;&lt;Missing FILE-WRITE-DATE for ~S: treating ~</span>
    717 <a id="l_629"></a><span class="hl line">  629 </span><span class="hl str">                       operation ~S on component ~S as done.~&#64;:&gt;&quot;</span>
    718 <a id="l_630"></a><span class="hl line">  630 </span>                      file o c<span class="hl sym">)</span>
    719 <a id="l_631"></a><span class="hl line">  631 </span>                <span class="hl sym">(</span>return-from operation-done-p t<span class="hl sym">))))))</span>
    720 <a id="l_632"></a><span class="hl line">  632 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>out-files <span class="hl sym">(</span>output-files o c<span class="hl sym">))</span>
    721 <a id="l_633"></a><span class="hl line">  633 </span>          <span class="hl sym">(</span>in-files <span class="hl sym">(</span>input-files o c<span class="hl sym">)))</span>
    722 <a id="l_634"></a><span class="hl line">  634 </span>      <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">not</span> in-files<span class="hl sym">) (</span><span class="hl kwa">not</span> out-files<span class="hl sym">))</span>
    723 <a id="l_635"></a><span class="hl line">  635 </span>             <span class="hl slc">;; arbitrary decision: an operation that uses nothing to</span>
    724 <a id="l_636"></a><span class="hl line">  636 </span>             <span class="hl slc">;; produce nothing probably isn't doing much</span>
    725 <a id="l_637"></a><span class="hl line">  637 </span>             t<span class="hl sym">)</span>
    726 <a id="l_638"></a><span class="hl line">  638 </span>            <span class="hl sym">((</span><span class="hl kwa">not</span> out-files<span class="hl sym">)</span>
    727 <a id="l_639"></a><span class="hl line">  639 </span>             <span class="hl sym">(</span>let <span class="hl sym">((</span>op-done
    728 <a id="l_640"></a><span class="hl line">  640 </span>                    <span class="hl sym">(</span>gethash <span class="hl sym">(</span><span class="hl kwa">type</span>-of o<span class="hl sym">)</span>
    729 <a id="l_641"></a><span class="hl line">  641 </span>                             <span class="hl sym">(</span>component-operation-times c<span class="hl sym">))))</span>
    730 <a id="l_642"></a><span class="hl line">  642 </span>               <span class="hl sym">(</span><span class="hl kwa">and</span> op-done
    731 <a id="l_643"></a><span class="hl line">  643 </span>                    <span class="hl sym">(&gt;=</span> op-done
    732 <a id="l_644"></a><span class="hl line">  644 </span>                        <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span><span class="hl kwa">max</span>
    733 <a id="l_645"></a><span class="hl line">  645 </span>                               <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>fwd-<span class="hl kwa">or</span>-return-t in-files<span class="hl sym">))))))</span>
    734 <a id="l_646"></a><span class="hl line">  646 </span>            <span class="hl sym">((</span><span class="hl kwa">not</span> in-files<span class="hl sym">)</span> nil<span class="hl sym">)</span>
    735 <a id="l_647"></a><span class="hl line">  647 </span>            <span class="hl sym">(</span>t
    736 <a id="l_648"></a><span class="hl line">  648 </span>             <span class="hl sym">(</span><span class="hl kwa">and</span>
    737 <a id="l_649"></a><span class="hl line">  649 </span>              <span class="hl sym">(</span>every #<span class="hl sym">'</span>probe-file out-files<span class="hl sym">)</span>
    738 <a id="l_650"></a><span class="hl line">  650 </span>              <span class="hl sym">(&gt; (</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span><span class="hl kwa">min</span> <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>file-write-date out-files<span class="hl sym">))</span>
    739 <a id="l_651"></a><span class="hl line">  651 </span>                 <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span><span class="hl kwa">max</span> <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>fwd-<span class="hl kwa">or</span>-return-t in-files<span class="hl sym">)))))))))</span>
    740 <a id="l_652"></a><span class="hl line">  652 </span>
    741 <a id="l_653"></a><span class="hl line">  653 </span><span class="hl slc">;;; So you look at this code and think &quot;why isn't it a bunch of</span>
    742 <a id="l_654"></a><span class="hl line">  654 </span><span class="hl slc">;;; methods&quot;.  And the answer is, because standard method combination</span>
    743 <a id="l_655"></a><span class="hl line">  655 </span><span class="hl slc">;;; runs :before methods most-&gt;least-specific, which is back to front</span>
    744 <a id="l_656"></a><span class="hl line">  656 </span><span class="hl slc">;;; for our purposes.  And CLISP doesn't have non-standard method</span>
    745 <a id="l_657"></a><span class="hl line">  657 </span><span class="hl slc">;;; combinations, so let's keep it simple and aspire to portability</span>
    746 <a id="l_658"></a><span class="hl line">  658 </span>
    747 <a id="l_659"></a><span class="hl line">  659 </span><span class="hl sym">(</span>defgeneric traverse <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
    748 <a id="l_660"></a><span class="hl line">  660 </span><span class="hl sym">(</span>defmethod traverse <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    749 <a id="l_661"></a><span class="hl line">  661 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>forced nil<span class="hl sym">))</span>
    750 <a id="l_662"></a><span class="hl line">  662 </span>    <span class="hl sym">(</span>labels <span class="hl sym">((</span>do-one-dep <span class="hl sym">(</span>required-op required-c required-v<span class="hl sym">)</span>
    751 <a id="l_663"></a><span class="hl line">  663 </span>               <span class="hl sym">(</span>let<span class="hl sym">* ((</span>dep-c <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>find-component
    752 <a id="l_664"></a><span class="hl line">  664 </span>                                  <span class="hl sym">(</span>component-parent c<span class="hl sym">)</span>
    753 <a id="l_665"></a><span class="hl line">  665 </span>                                  <span class="hl slc">;; XXX tacky.  really we should build the</span>
    754 <a id="l_666"></a><span class="hl line">  666 </span>                                  <span class="hl slc">;; in-order-to slot with canonicalized</span>
    755 <a id="l_667"></a><span class="hl line">  667 </span>                                  <span class="hl slc">;; names instead of coercing this late</span>
    756 <a id="l_668"></a><span class="hl line">  668 </span>                                  <span class="hl sym">(</span>coerce-name required-c<span class="hl sym">)</span> required-v<span class="hl sym">)</span>
    757 <a id="l_669"></a><span class="hl line">  669 </span>                                 <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-dependency
    758 <a id="l_670"></a><span class="hl line">  670 </span>                                        <span class="hl sym">:</span>required-by c
    759 <a id="l_671"></a><span class="hl line">  671 </span>                                        <span class="hl sym">:</span>version required-v
    760 <a id="l_672"></a><span class="hl line">  672 </span>                                        <span class="hl sym">:</span>requires required-c<span class="hl sym">)))</span>
    761 <a id="l_673"></a><span class="hl line">  673 </span>                      <span class="hl sym">(</span>op <span class="hl sym">(</span>make-sub-operation c operation dep-c required-op<span class="hl sym">)))</span>
    762 <a id="l_674"></a><span class="hl line">  674 </span>                 <span class="hl sym">(</span>traverse op dep-c<span class="hl sym">)))</span>
    763 <a id="l_675"></a><span class="hl line">  675 </span>             <span class="hl sym">(</span>do-dep <span class="hl sym">(</span>op dep<span class="hl sym">)</span>
    764 <a id="l_676"></a><span class="hl line">  676 </span>               <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">eq</span> op <span class="hl sym">'</span>feature<span class="hl sym">)</span>
    765 <a id="l_677"></a><span class="hl line">  677 </span>                      <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span><span class="hl kwa">car</span> dep<span class="hl sym">) *</span>features<span class="hl sym">*)</span>
    766 <a id="l_678"></a><span class="hl line">  678 </span>                          <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-dependency
    767 <a id="l_679"></a><span class="hl line">  679 </span>                                 <span class="hl sym">:</span>required-by c
    768 <a id="l_680"></a><span class="hl line">  680 </span>                                 <span class="hl sym">:</span>requires <span class="hl sym">(</span><span class="hl kwa">car</span> dep<span class="hl sym">)</span>
    769 <a id="l_681"></a><span class="hl line">  681 </span>                                 <span class="hl sym">:</span>version nil<span class="hl sym">)))</span>
    770 <a id="l_682"></a><span class="hl line">  682 </span>                     <span class="hl sym">(</span>t
    771 <a id="l_683"></a><span class="hl line">  683 </span>                      <span class="hl sym">(</span>dolist <span class="hl sym">(</span>d dep<span class="hl sym">)</span>
    772 <a id="l_684"></a><span class="hl line">  684 </span>                        <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span>consp d<span class="hl sym">)</span>
    773 <a id="l_685"></a><span class="hl line">  685 </span>                               <span class="hl sym">(</span>assert <span class="hl sym">(</span>string-<span class="hl kwa">equal</span>
    774 <a id="l_686"></a><span class="hl line">  686 </span>                                        <span class="hl sym">(</span>symbol-name <span class="hl sym">(</span>first d<span class="hl sym">))</span>
    775 <a id="l_687"></a><span class="hl line">  687 </span>                                        <span class="hl str">&quot;VERSION&quot;</span><span class="hl sym">))</span>
    776 <a id="l_688"></a><span class="hl line">  688 </span>                               <span class="hl sym">(</span>appendf forced
    777 <a id="l_689"></a><span class="hl line">  689 </span>                                        <span class="hl sym">(</span>do-one-dep op <span class="hl sym">(</span>second d<span class="hl sym">) (</span>third d<span class="hl sym">))))</span>
    778 <a id="l_690"></a><span class="hl line">  690 </span>                              <span class="hl sym">(</span>t
    779 <a id="l_691"></a><span class="hl line">  691 </span>                               <span class="hl sym">(</span>appendf forced <span class="hl sym">(</span>do-one-dep op d nil<span class="hl sym">)))))))))</span>
    780 <a id="l_692"></a><span class="hl line">  692 </span>      <span class="hl sym">(</span>aif <span class="hl sym">(</span>component-visited-p operation c<span class="hl sym">)</span>
    781 <a id="l_693"></a><span class="hl line">  693 </span>           <span class="hl sym">(</span>return-from traverse
    782 <a id="l_694"></a><span class="hl line">  694 </span>             <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">) (</span><span class="hl kwa">list</span> <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">'</span>pruned-op c<span class="hl sym">))</span> nil<span class="hl sym">)))</span>
    783 <a id="l_695"></a><span class="hl line">  695 </span>      <span class="hl slc">;; dependencies</span>
    784 <a id="l_696"></a><span class="hl line">  696 </span>      <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>component-visiting-p operation c<span class="hl sym">)</span>
    785 <a id="l_697"></a><span class="hl line">  697 </span>          <span class="hl sym">(</span>error <span class="hl sym">'</span>circular-dependency <span class="hl sym">:</span>components <span class="hl sym">(</span><span class="hl kwa">list</span> c<span class="hl sym">)))</span>
    786 <a id="l_698"></a><span class="hl line">  698 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span>visiting-component operation c<span class="hl sym">)</span> t<span class="hl sym">)</span>
    787 <a id="l_699"></a><span class="hl line">  699 </span>      <span class="hl sym">(</span>loop for <span class="hl sym">(</span>required-op . deps<span class="hl sym">)</span> in <span class="hl sym">(</span>component-depends-on operation c<span class="hl sym">)</span>
    788 <a id="l_700"></a><span class="hl line">  700 </span>            do <span class="hl sym">(</span>do-dep required-op deps<span class="hl sym">))</span>
    789 <a id="l_701"></a><span class="hl line">  701 </span>      <span class="hl slc">;; constituent bits</span>
    790 <a id="l_702"></a><span class="hl line">  702 </span>      <span class="hl sym">(</span>let <span class="hl sym">((</span>module-ops
    791 <a id="l_703"></a><span class="hl line">  703 </span>             <span class="hl sym">(</span>when <span class="hl sym">(</span>typep c <span class="hl sym">'</span>module<span class="hl sym">)</span>
    792 <a id="l_704"></a><span class="hl line">  704 </span>               <span class="hl sym">(</span>let <span class="hl sym">((</span>at-least-one nil<span class="hl sym">)</span>
    793 <a id="l_705"></a><span class="hl line">  705 </span>                     <span class="hl sym">(</span>forced nil<span class="hl sym">)</span>
    794 <a id="l_706"></a><span class="hl line">  706 </span>                     <span class="hl sym">(</span>error nil<span class="hl sym">))</span>
    795 <a id="l_707"></a><span class="hl line">  707 </span>                 <span class="hl sym">(</span>loop for kid in <span class="hl sym">(</span>module-components c<span class="hl sym">)</span>
    796 <a id="l_708"></a><span class="hl line">  708 </span>                       do <span class="hl sym">(</span>handler-case
    797 <a id="l_709"></a><span class="hl line">  709 </span>                              <span class="hl sym">(</span>appendf forced <span class="hl sym">(</span>traverse operation kid <span class="hl sym">))</span>
    798 <a id="l_710"></a><span class="hl line">  710 </span>                            <span class="hl sym">(</span>missing-dependency <span class="hl sym">(</span>condition<span class="hl sym">)</span>
    799 <a id="l_711"></a><span class="hl line">  711 </span>                              <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span>module-<span class="hl kwa">if</span>-component-dep-fails c<span class="hl sym">) :</span>fail<span class="hl sym">)</span>
    800 <a id="l_712"></a><span class="hl line">  712 </span>                                  <span class="hl sym">(</span>error condition<span class="hl sym">))</span>
    801 <a id="l_713"></a><span class="hl line">  713 </span>                              <span class="hl sym">(</span>setf error condition<span class="hl sym">))</span>
    802 <a id="l_714"></a><span class="hl line">  714 </span>                            <span class="hl sym">(:</span>no-error <span class="hl sym">(</span>c<span class="hl sym">)</span>
    803 <a id="l_715"></a><span class="hl line">  715 </span>                              <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignore c<span class="hl sym">))</span>
    804 <a id="l_716"></a><span class="hl line">  716 </span>                              <span class="hl sym">(</span>setf at-least-one t<span class="hl sym">))))</span>
    805 <a id="l_717"></a><span class="hl line">  717 </span>                 <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span>module-<span class="hl kwa">if</span>-component-dep-fails c<span class="hl sym">) :</span>try-next<span class="hl sym">)</span>
    806 <a id="l_718"></a><span class="hl line">  718 </span>                            <span class="hl sym">(</span><span class="hl kwa">not</span> at-least-one<span class="hl sym">))</span>
    807 <a id="l_719"></a><span class="hl line">  719 </span>                   <span class="hl sym">(</span>error error<span class="hl sym">))</span>
    808 <a id="l_720"></a><span class="hl line">  720 </span>                 forced<span class="hl sym">))))</span>
    809 <a id="l_721"></a><span class="hl line">  721 </span>        <span class="hl slc">;; now the thing itself</span>
    810 <a id="l_722"></a><span class="hl line">  722 </span>        <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">or</span> forced module-ops
    811 <a id="l_723"></a><span class="hl line">  723 </span>                  <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>operation-done-p operation c<span class="hl sym">))</span>
    812 <a id="l_724"></a><span class="hl line">  724 </span>                  <span class="hl sym">(</span>let <span class="hl sym">((</span>f <span class="hl sym">(</span>operation-forced <span class="hl sym">(</span>operation-ancestor operation<span class="hl sym">))))</span>
    813 <a id="l_725"></a><span class="hl line">  725 </span>                    <span class="hl sym">(</span><span class="hl kwa">and</span> f <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>consp f<span class="hl sym">))</span>
    814 <a id="l_726"></a><span class="hl line">  726 </span>                               <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span>component-name
    815 <a id="l_727"></a><span class="hl line">  727 </span>                                        <span class="hl sym">(</span>operation-ancestor operation<span class="hl sym">))</span>
    816 <a id="l_728"></a><span class="hl line">  728 </span>                                       <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>coerce-name f<span class="hl sym">)</span>
    817 <a id="l_729"></a><span class="hl line">  729 </span>                                       <span class="hl sym">:</span>test #<span class="hl sym">'</span>string<span class="hl sym">=)))))</span>
    818 <a id="l_730"></a><span class="hl line">  730 </span>          <span class="hl sym">(</span>let <span class="hl sym">((</span>do-first <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">(</span>class-name <span class="hl sym">(</span>class-of operation<span class="hl sym">))</span>
    819 <a id="l_731"></a><span class="hl line">  731 </span>                                      <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>do-first<span class="hl sym">)))))</span>
    820 <a id="l_732"></a><span class="hl line">  732 </span>            <span class="hl sym">(</span>loop for <span class="hl sym">(</span>required-op . deps<span class="hl sym">)</span> in do-first
    821 <a id="l_733"></a><span class="hl line">  733 </span>                  do <span class="hl sym">(</span>do-dep required-op deps<span class="hl sym">)))</span>
    822 <a id="l_734"></a><span class="hl line">  734 </span>          <span class="hl sym">(</span>setf forced <span class="hl sym">(</span><span class="hl kwa">append</span> <span class="hl sym">(</span>delete <span class="hl sym">'</span>pruned-op forced <span class="hl sym">:</span>key #<span class="hl sym">'</span><span class="hl kwa">car</span><span class="hl sym">)</span>
    823 <a id="l_735"></a><span class="hl line">  735 </span>                               <span class="hl sym">(</span>delete <span class="hl sym">'</span>pruned-op module-ops <span class="hl sym">:</span>key #<span class="hl sym">'</span><span class="hl kwa">car</span><span class="hl sym">)</span>
    824 <a id="l_736"></a><span class="hl line">  736 </span>                               <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span><span class="hl kwa">cons</span> operation c<span class="hl sym">))))))</span>
    825 <a id="l_737"></a><span class="hl line">  737 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span>visiting-component operation c<span class="hl sym">)</span> nil<span class="hl sym">)</span>
    826 <a id="l_738"></a><span class="hl line">  738 </span>      <span class="hl sym">(</span>visit-component operation c <span class="hl sym">(</span><span class="hl kwa">and</span> forced t<span class="hl sym">))</span>
    827 <a id="l_739"></a><span class="hl line">  739 </span>      forced<span class="hl sym">)))</span>
    828 <a id="l_740"></a><span class="hl line">  740 </span>
    829 <a id="l_741"></a><span class="hl line">  741 </span>
    830 <a id="l_742"></a><span class="hl line">  742 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c source-file<span class="hl sym">))</span>
    831 <a id="l_743"></a><span class="hl line">  743 </span>  <span class="hl sym">(</span>sysdef-error
    832 <a id="l_744"></a><span class="hl line">  744 </span>   <span class="hl str">&quot;~&#64;&lt;required method PERFORM not implemented ~</span>
    833 <a id="l_745"></a><span class="hl line">  745 </span><span class="hl str">    for operation ~A, component ~A~&#64;:&gt;&quot;</span>
    834 <a id="l_746"></a><span class="hl line">  746 </span>   <span class="hl sym">(</span>class-of operation<span class="hl sym">) (</span>class-of c<span class="hl sym">)))</span>
    835 <a id="l_747"></a><span class="hl line">  747 </span>
    836 <a id="l_748"></a><span class="hl line">  748 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c module<span class="hl sym">))</span>
    837 <a id="l_749"></a><span class="hl line">  749 </span>  nil<span class="hl sym">)</span>
    838 <a id="l_750"></a><span class="hl line">  750 </span>
    839 <a id="l_751"></a><span class="hl line">  751 </span><span class="hl sym">(</span>defmethod explain <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>component component<span class="hl sym">))</span>
    840 <a id="l_752"></a><span class="hl line">  752 </span>  <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> <span class="hl str">&quot;~&amp;;;; ~A on ~A~%&quot;</span> operation component<span class="hl sym">))</span>
    841 <a id="l_753"></a><span class="hl line">  753 </span>
    842 <a id="l_754"></a><span class="hl line">  754 </span><span class="hl slc">;;; compile-op</span>
    843 <a id="l_755"></a><span class="hl line">  755 </span>
    844 <a id="l_756"></a><span class="hl line">  756 </span><span class="hl sym">(</span>defclass compile-op <span class="hl sym">(</span>operation<span class="hl sym">)</span>
    845 <a id="l_757"></a><span class="hl line">  757 </span>  <span class="hl sym">((</span>proclamations <span class="hl sym">:</span>initarg <span class="hl sym">:</span>proclamations <span class="hl sym">:</span>accessor compile-op-proclamations <span class="hl sym">:</span>initform nil<span class="hl sym">)</span>
    846 <a id="l_758"></a><span class="hl line">  758 </span>   <span class="hl sym">(</span>on-warnings <span class="hl sym">:</span>initarg <span class="hl sym">:</span>on-warnings <span class="hl sym">:</span>accessor operation-on-warnings
    847 <a id="l_759"></a><span class="hl line">  759 </span>                <span class="hl sym">:</span>initform <span class="hl sym">*</span>compile-file-warnings-behaviour<span class="hl sym">*)</span>
    848 <a id="l_760"></a><span class="hl line">  760 </span>   <span class="hl sym">(</span>on-failure <span class="hl sym">:</span>initarg <span class="hl sym">:</span>on-failure <span class="hl sym">:</span>accessor operation-on-failure
    849 <a id="l_761"></a><span class="hl line">  761 </span>               <span class="hl sym">:</span>initform <span class="hl sym">*</span>compile-file-failure-behaviour<span class="hl sym">*)))</span>
    850 <a id="l_762"></a><span class="hl line">  762 </span>
    851 <a id="l_763"></a><span class="hl line">  763 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">:</span>before <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c source-file<span class="hl sym">))</span>
    852 <a id="l_764"></a><span class="hl line">  764 </span>  <span class="hl sym">(</span>map nil #<span class="hl sym">'</span>ensure-directories-exist <span class="hl sym">(</span>output-files operation c<span class="hl sym">)))</span>
    853 <a id="l_765"></a><span class="hl line">  765 </span>
    854 <a id="l_766"></a><span class="hl line">  766 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">:</span>after <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    855 <a id="l_767"></a><span class="hl line">  767 </span>  <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span><span class="hl kwa">type</span>-of operation<span class="hl sym">) (</span>component-operation-times c<span class="hl sym">))</span>
    856 <a id="l_768"></a><span class="hl line">  768 </span>        <span class="hl sym">(</span>get-universal-time<span class="hl sym">))</span>
    857 <a id="l_769"></a><span class="hl line">  769 </span>  <span class="hl sym">(</span><span class="hl kwa">load</span>-preferences c operation<span class="hl sym">))</span>
    858 <a id="l_770"></a><span class="hl line">  770 </span>
    859 <a id="l_771"></a><span class="hl line">  771 </span><span class="hl slc">;;; perform is required to check output-files to find out where to put</span>
    860 <a id="l_772"></a><span class="hl line">  772 </span><span class="hl slc">;;; its answers, in case it has been overridden for site policy</span>
    861 <a id="l_773"></a><span class="hl line">  773 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
    862 <a id="l_774"></a><span class="hl line">  774 </span>  #-<span class="hl sym">:</span>broken-fasl-loader
    863 <a id="l_775"></a><span class="hl line">  775 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>source-file <span class="hl sym">(</span>component-pathname c<span class="hl sym">))</span>
    864 <a id="l_776"></a><span class="hl line">  776 </span>        <span class="hl sym">(</span>output-file <span class="hl sym">(</span><span class="hl kwa">car</span> <span class="hl sym">(</span>output-files operation c<span class="hl sym">))))</span>
    865 <a id="l_777"></a><span class="hl line">  777 </span>    <span class="hl sym">(</span>multiple-value-bind <span class="hl sym">(</span>output warnings-p failure-p<span class="hl sym">)</span>
    866 <a id="l_778"></a><span class="hl line">  778 </span>        <span class="hl sym">(</span>compile-file source-file <span class="hl sym">:</span>output-file output-file<span class="hl sym">)</span>
    867 <a id="l_779"></a><span class="hl line">  779 </span>      <span class="hl sym">(</span>when warnings-p
    868 <a id="l_780"></a><span class="hl line">  780 </span>        <span class="hl sym">(</span>case <span class="hl sym">(</span>operation-on-warnings operation<span class="hl sym">)</span>
    869 <a id="l_781"></a><span class="hl line">  781 </span>          <span class="hl sym">(:</span>warn <span class="hl sym">(</span>warn
    870 <a id="l_782"></a><span class="hl line">  782 </span>                  <span class="hl str">&quot;~&#64;&lt;COMPILE-FILE warned while performing ~A on ~A.~&#64;:&gt;&quot;</span>
    871 <a id="l_783"></a><span class="hl line">  783 </span>                  operation c<span class="hl sym">))</span>
    872 <a id="l_784"></a><span class="hl line">  784 </span>          <span class="hl sym">(:</span>error <span class="hl sym">(</span>error <span class="hl sym">'</span>compile-warned <span class="hl sym">:</span>component c <span class="hl sym">:</span>operation operation<span class="hl sym">))</span>
    873 <a id="l_785"></a><span class="hl line">  785 </span>          <span class="hl sym">(:</span>ignore nil<span class="hl sym">)))</span>
    874 <a id="l_786"></a><span class="hl line">  786 </span>      <span class="hl sym">(</span>when failure-p
    875 <a id="l_787"></a><span class="hl line">  787 </span>        <span class="hl sym">(</span>case <span class="hl sym">(</span>operation-on-failure operation<span class="hl sym">)</span>
    876 <a id="l_788"></a><span class="hl line">  788 </span>          <span class="hl sym">(:</span>warn <span class="hl sym">(</span>warn
    877 <a id="l_789"></a><span class="hl line">  789 </span>                  <span class="hl str">&quot;~&#64;&lt;COMPILE-FILE failed while performing ~A on ~A.~&#64;:&gt;&quot;</span>
    878 <a id="l_790"></a><span class="hl line">  790 </span>                  operation c<span class="hl sym">))</span>
    879 <a id="l_791"></a><span class="hl line">  791 </span>          <span class="hl sym">(:</span>error <span class="hl sym">(</span>error <span class="hl sym">'</span>compile-failed <span class="hl sym">:</span>component c <span class="hl sym">:</span>operation operation<span class="hl sym">))</span>
    880 <a id="l_792"></a><span class="hl line">  792 </span>          <span class="hl sym">(:</span>ignore nil<span class="hl sym">)))</span>
    881 <a id="l_793"></a><span class="hl line">  793 </span>      <span class="hl sym">(</span>unless output
    882 <a id="l_794"></a><span class="hl line">  794 </span>        <span class="hl sym">(</span>error <span class="hl sym">'</span>compile-error <span class="hl sym">:</span>component c <span class="hl sym">:</span>operation operation<span class="hl sym">)))))</span>
    883 <a id="l_795"></a><span class="hl line">  795 </span>
    884 <a id="l_796"></a><span class="hl line">  796 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
    885 <a id="l_797"></a><span class="hl line">  797 </span>  #-<span class="hl sym">:</span>broken-fasl-loader <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>compile-file-pathname <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))</span>
    886 <a id="l_798"></a><span class="hl line">  798 </span>  #<span class="hl sym">+:</span>broken-fasl-loader <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))</span>
    887 <a id="l_799"></a><span class="hl line">  799 </span>
    888 <a id="l_800"></a><span class="hl line">  800 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
    889 <a id="l_801"></a><span class="hl line">  801 </span>  nil<span class="hl sym">)</span>
    890 <a id="l_802"></a><span class="hl line">  802 </span>
    891 <a id="l_803"></a><span class="hl line">  803 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
    892 <a id="l_804"></a><span class="hl line">  804 </span>  nil<span class="hl sym">)</span>
    893 <a id="l_805"></a><span class="hl line">  805 </span>
    894 <a id="l_806"></a><span class="hl line">  806 </span><span class="hl sym">(</span>defmethod input-files <span class="hl sym">((</span>op compile-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
    895 <a id="l_807"></a><span class="hl line">  807 </span>  nil<span class="hl sym">)</span>
    896 <a id="l_808"></a><span class="hl line">  808 </span>
    897 <a id="l_809"></a><span class="hl line">  809 </span>
    898 <a id="l_810"></a><span class="hl line">  810 </span><span class="hl slc">;;; load-op</span>
    899 <a id="l_811"></a><span class="hl line">  811 </span>
    900 <a id="l_812"></a><span class="hl line">  812 </span><span class="hl sym">(</span>defclass basic-<span class="hl kwa">load</span>-op <span class="hl sym">(</span>operation<span class="hl sym">) ())</span>
    901 <a id="l_813"></a><span class="hl line">  813 </span>
    902 <a id="l_814"></a><span class="hl line">  814 </span><span class="hl sym">(</span>defclass <span class="hl kwa">load</span>-op <span class="hl sym">(</span>basic-<span class="hl kwa">load</span>-op<span class="hl sym">) ())</span>
    903 <a id="l_815"></a><span class="hl line">  815 </span>
    904 <a id="l_816"></a><span class="hl line">  816 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>o <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
    905 <a id="l_817"></a><span class="hl line">  817 </span>  <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span><span class="hl kwa">load</span> <span class="hl sym">(</span>input-files o c<span class="hl sym">)))</span>
    906 <a id="l_818"></a><span class="hl line">  818 </span>
    907 <a id="l_819"></a><span class="hl line">  819 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
    908 <a id="l_820"></a><span class="hl line">  820 </span>  nil<span class="hl sym">)</span>
    909 <a id="l_821"></a><span class="hl line">  821 </span><span class="hl sym">(</span>defmethod operation-done-p <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
    910 <a id="l_822"></a><span class="hl line">  822 </span>  t<span class="hl sym">)</span>
    911 <a id="l_823"></a><span class="hl line">  823 </span>
    912 <a id="l_824"></a><span class="hl line">  824 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    913 <a id="l_825"></a><span class="hl line">  825 </span>  nil<span class="hl sym">)</span>
    914 <a id="l_826"></a><span class="hl line">  826 </span>
    915 <a id="l_827"></a><span class="hl line">  827 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    916 <a id="l_828"></a><span class="hl line">  828 </span>  <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">'</span>compile-op <span class="hl sym">(</span>component-name c<span class="hl sym">))</span>
    917 <a id="l_829"></a><span class="hl line">  829 </span>        <span class="hl sym">(</span>call-next-method<span class="hl sym">)))</span>
    918 <a id="l_830"></a><span class="hl line">  830 </span>
    919 <a id="l_831"></a><span class="hl line">  831 </span><span class="hl slc">;;; load-source-op</span>
    920 <a id="l_832"></a><span class="hl line">  832 </span>
    921 <a id="l_833"></a><span class="hl line">  833 </span><span class="hl sym">(</span>defclass <span class="hl kwa">load</span>-source-op <span class="hl sym">(</span>basic-<span class="hl kwa">load</span>-op<span class="hl sym">) ())</span>
    922 <a id="l_834"></a><span class="hl line">  834 </span>
    923 <a id="l_835"></a><span class="hl line">  835 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>o <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
    924 <a id="l_836"></a><span class="hl line">  836 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>source <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))</span>
    925 <a id="l_837"></a><span class="hl line">  837 </span>    <span class="hl sym">(</span>setf <span class="hl sym">(</span>component-property c <span class="hl sym">'</span><span class="hl kwa">last</span>-loaded-as-source<span class="hl sym">)</span>
    926 <a id="l_838"></a><span class="hl line">  838 </span>          <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">load</span> source<span class="hl sym">)</span>
    927 <a id="l_839"></a><span class="hl line">  839 </span>               <span class="hl sym">(</span>get-universal-time<span class="hl sym">)))))</span>
    928 <a id="l_840"></a><span class="hl line">  840 </span>
    929 <a id="l_841"></a><span class="hl line">  841 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
    930 <a id="l_842"></a><span class="hl line">  842 </span>  nil<span class="hl sym">)</span>
    931 <a id="l_843"></a><span class="hl line">  843 </span>
    932 <a id="l_844"></a><span class="hl line">  844 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    933 <a id="l_845"></a><span class="hl line">  845 </span>  nil<span class="hl sym">)</span>
    934 <a id="l_846"></a><span class="hl line">  846 </span>
    935 <a id="l_847"></a><span class="hl line">  847 </span><span class="hl slc">;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.</span>
    936 <a id="l_848"></a><span class="hl line">  848 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>o <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    937 <a id="l_849"></a><span class="hl line">  849 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>what-would-<span class="hl kwa">load</span>-op-do <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">'</span><span class="hl kwa">load</span>-op
    938 <a id="l_850"></a><span class="hl line">  850 </span>                                           <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>in-order-to<span class="hl sym">)))))</span>
    939 <a id="l_851"></a><span class="hl line">  851 </span>    <span class="hl sym">(</span><span class="hl kwa">mapcar</span> <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>dep<span class="hl sym">)</span>
    940 <a id="l_852"></a><span class="hl line">  852 </span>              <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span><span class="hl kwa">car</span> dep<span class="hl sym">) '</span><span class="hl kwa">load</span>-op<span class="hl sym">)</span>
    941 <a id="l_853"></a><span class="hl line">  853 </span>                  <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">'</span><span class="hl kwa">load</span>-source-op <span class="hl sym">(</span><span class="hl kwa">cdr</span> dep<span class="hl sym">))</span>
    942 <a id="l_854"></a><span class="hl line">  854 </span>                  dep<span class="hl sym">))</span>
    943 <a id="l_855"></a><span class="hl line">  855 </span>            what-would-<span class="hl kwa">load</span>-op-do<span class="hl sym">)))</span>
    944 <a id="l_856"></a><span class="hl line">  856 </span>
    945 <a id="l_857"></a><span class="hl line">  857 </span><span class="hl sym">(</span>defmethod operation-done-p <span class="hl sym">((</span>o <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c source-file<span class="hl sym">))</span>
    946 <a id="l_858"></a><span class="hl line">  858 </span>  <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>component-property c <span class="hl sym">'</span><span class="hl kwa">last</span>-loaded-as-source<span class="hl sym">))</span>
    947 <a id="l_859"></a><span class="hl line">  859 </span>          <span class="hl sym">(&gt; (</span>file-write-date <span class="hl sym">(</span>component-pathname c<span class="hl sym">))</span>
    948 <a id="l_860"></a><span class="hl line">  860 </span>             <span class="hl sym">(</span>component-property c <span class="hl sym">'</span><span class="hl kwa">last</span>-loaded-as-source<span class="hl sym">)))</span>
    949 <a id="l_861"></a><span class="hl line">  861 </span>      nil t<span class="hl sym">))</span>
    950 <a id="l_862"></a><span class="hl line">  862 </span>
    951 <a id="l_863"></a><span class="hl line">  863 </span><span class="hl sym">(</span>defclass test-op <span class="hl sym">(</span>operation<span class="hl sym">) ())</span>
    952 <a id="l_864"></a><span class="hl line">  864 </span>
    953 <a id="l_865"></a><span class="hl line">  865 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation test-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
    954 <a id="l_866"></a><span class="hl line">  866 </span>  nil<span class="hl sym">)</span>
    955 <a id="l_867"></a><span class="hl line">  867 </span>
    956 <a id="l_868"></a><span class="hl line">  868 </span><span class="hl sym">(</span>defgeneric <span class="hl kwa">load</span>-preferences <span class="hl sym">(</span>system operation<span class="hl sym">)</span>
    957 <a id="l_869"></a><span class="hl line">  869 </span>  <span class="hl sym">(:</span>documentation
    958 <a id="l_870"></a><span class="hl line">  870 </span>   <span class="hl str">&quot;Called to load system preferences after &lt;perform operation</span>
    959 <a id="l_871"></a><span class="hl line">  871 </span><span class="hl str">system&gt;. Typical uses are to set parameters that don't exist until</span>
    960 <a id="l_872"></a><span class="hl line">  872 </span><span class="hl str">after the system has been loaded.&quot;</span><span class="hl sym">))</span>
    961 <a id="l_873"></a><span class="hl line">  873 </span>
    962 <a id="l_874"></a><span class="hl line">  874 </span><span class="hl sym">(</span>defgeneric preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">(</span>system operation<span class="hl sym">)</span>
    963 <a id="l_875"></a><span class="hl line">  875 </span>  <span class="hl sym">(:</span>documentation
    964 <a id="l_876"></a><span class="hl line">  876 </span>   <span class="hl str">&quot;Returns the pathname of the preference file for this system.</span>
    965 <a id="l_877"></a><span class="hl line">  877 </span><span class="hl str">Called by 'load-preferences to determine what file to load.&quot;</span><span class="hl sym">))</span>
    966 <a id="l_878"></a><span class="hl line">  878 </span>
    967 <a id="l_879"></a><span class="hl line">  879 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">load</span>-preferences <span class="hl sym">((</span>s t<span class="hl sym">) (</span>operation t<span class="hl sym">))</span>
    968 <a id="l_880"></a><span class="hl line">  880 </span>  <span class="hl slc">;; do nothing</span>
    969 <a id="l_881"></a><span class="hl line">  881 </span>  <span class="hl sym">(</span>values<span class="hl sym">))</span>
    970 <a id="l_882"></a><span class="hl line">  882 </span>
    971 <a id="l_883"></a><span class="hl line">  883 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">load</span>-preferences <span class="hl sym">((</span>s system<span class="hl sym">) (</span>operation basic-<span class="hl kwa">load</span>-op<span class="hl sym">))</span>
    972 <a id="l_884"></a><span class="hl line">  884 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((*</span>package<span class="hl sym">* (</span>find-package <span class="hl sym">:</span>common-lisp<span class="hl sym">))</span>
    973 <a id="l_885"></a><span class="hl line">  885 </span>         <span class="hl sym">(</span>file <span class="hl sym">(</span>probe-file <span class="hl sym">(</span>preference-file-for-system<span class="hl sym">/</span>operation s operation<span class="hl sym">))))</span>
    974 <a id="l_886"></a><span class="hl line">  886 </span>    <span class="hl sym">(</span>when file
    975 <a id="l_887"></a><span class="hl line">  887 </span>      <span class="hl sym">(</span>when <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
    976 <a id="l_888"></a><span class="hl line">  888 </span>        <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
    977 <a id="l_889"></a><span class="hl line">  889 </span>                <span class="hl str">&quot;~&amp;~&#64;&lt;; ~&#64;;loading preferences for ~A/~(~A~) from ~A~&#64;:&gt;~%&quot;</span>
    978 <a id="l_890"></a><span class="hl line">  890 </span>                <span class="hl sym">(</span>component-name s<span class="hl sym">)</span>
    979 <a id="l_891"></a><span class="hl line">  891 </span>                <span class="hl sym">(</span><span class="hl kwa">type</span>-of operation<span class="hl sym">)</span> file<span class="hl sym">))</span>
    980 <a id="l_892"></a><span class="hl line">  892 </span>      <span class="hl sym">(</span><span class="hl kwa">load</span> file<span class="hl sym">))))</span>
    981 <a id="l_893"></a><span class="hl line">  893 </span>
    982 <a id="l_894"></a><span class="hl line">  894 </span><span class="hl sym">(</span>defmethod preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">((</span>system t<span class="hl sym">) (</span>operation t<span class="hl sym">))</span>
    983 <a id="l_895"></a><span class="hl line">  895 </span>  <span class="hl slc">;; cope with anything other than systems</span>
    984 <a id="l_896"></a><span class="hl line">  896 </span>  <span class="hl sym">(</span>preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">(</span>find-system system t<span class="hl sym">)</span> operation<span class="hl sym">))</span>
    985 <a id="l_897"></a><span class="hl line">  897 </span>
    986 <a id="l_898"></a><span class="hl line">  898 </span><span class="hl sym">(</span>defmethod preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">((</span>s system<span class="hl sym">) (</span>operation t<span class="hl sym">))</span>
    987 <a id="l_899"></a><span class="hl line">  899 </span>  <span class="hl sym">(</span>let <span class="hl sym">((*</span>default-pathname-defaults<span class="hl sym">*</span>
    988 <a id="l_900"></a><span class="hl line">  900 </span>         <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name nil <span class="hl sym">:</span><span class="hl kwa">type</span> nil
    989 <a id="l_901"></a><span class="hl line">  901 </span>                        <span class="hl sym">:</span>defaults <span class="hl sym">*</span>default-pathname-defaults<span class="hl sym">*)))</span>
    990 <a id="l_902"></a><span class="hl line">  902 </span>     <span class="hl sym">(</span>merge-pathnames
    991 <a id="l_903"></a><span class="hl line">  903 </span>      <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name <span class="hl sym">(</span>component-name s<span class="hl sym">)</span>
    992 <a id="l_904"></a><span class="hl line">  904 </span>                     <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;lisp&quot;</span>
    993 <a id="l_905"></a><span class="hl line">  905 </span>                     <span class="hl sym">:</span>directory <span class="hl sym">'(:</span>relative <span class="hl str">&quot;.asdf&quot;</span><span class="hl sym">))</span>
    994 <a id="l_906"></a><span class="hl line">  906 </span>      <span class="hl sym">(</span>truename <span class="hl sym">(</span>user-homedir-pathname<span class="hl sym">)))))</span>
    995 <a id="l_907"></a><span class="hl line">  907 </span>
    996 <a id="l_908"></a><span class="hl line">  908 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
    997 <a id="l_909"></a><span class="hl line">  909 </span><span class="hl slc">;;; invoking operations</span>
    998 <a id="l_910"></a><span class="hl line">  910 </span>
    999 <a id="l_911"></a><span class="hl line">  911 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>operate-docstring<span class="hl sym">*</span>
    1000 <a id="l_912"></a><span class="hl line">  912 </span>  <span class="hl str">&quot;Operate does three things:</span>
    1001 <a id="l_913"></a><span class="hl line">  913 </span><span class="hl str"></span>
    1002 <a id="l_914"></a><span class="hl line">  914 </span><span class="hl str">1. It creates an instance of `operation-class` using any keyword parameters</span>
    1003 <a id="l_915"></a><span class="hl line">  915 </span><span class="hl str">as initargs.</span>
    1004 <a id="l_916"></a><span class="hl line">  916 </span><span class="hl str">2. It finds the  asdf-system specified by `system` (possibly loading</span>
    1005 <a id="l_917"></a><span class="hl line">  917 </span><span class="hl str">it from disk).</span>
    1006 <a id="l_918"></a><span class="hl line">  918 </span><span class="hl str">3. It then calls `traverse` with the operation and system as arguments</span>
    1007 <a id="l_919"></a><span class="hl line">  919 </span><span class="hl str"></span>
    1008 <a id="l_920"></a><span class="hl line">  920 </span><span class="hl str">The traverse operation is wrapped in `with-compilation-unit` and error</span>
    1009 <a id="l_921"></a><span class="hl line">  921 </span><span class="hl str">handling code. If a `version` argument is supplied, then operate also</span>
    1010 <a id="l_922"></a><span class="hl line">  922 </span><span class="hl str">ensures that the system found satisfies it using the `version-satisfies`</span>
    1011 <a id="l_923"></a><span class="hl line">  923 </span><span class="hl str">method.&quot;</span><span class="hl sym">)</span>
    1012 <a id="l_924"></a><span class="hl line">  924 </span>
    1013 <a id="l_925"></a><span class="hl line">  925 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> operate <span class="hl sym">(</span>operation-class system <span class="hl sym">&amp;</span>rest args <span class="hl sym">&amp;</span>key <span class="hl sym">(</span>verbose t<span class="hl sym">)</span> version
    1014 <a id="l_926"></a><span class="hl line">  926 </span>                <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span>
    1015 <a id="l_927"></a><span class="hl line">  927 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>op <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>make-instance operation-class
    1016 <a id="l_928"></a><span class="hl line">  928 </span>                    <span class="hl sym">:</span>original-initargs args
    1017 <a id="l_929"></a><span class="hl line">  929 </span>                    args<span class="hl sym">))</span>
    1018 <a id="l_930"></a><span class="hl line">  930 </span>         <span class="hl sym">(*</span>verbose-out<span class="hl sym">* (</span><span class="hl kwa">if</span> verbose <span class="hl sym">*</span>standard-output<span class="hl sym">* (</span>make-broadcast-stream<span class="hl sym">)))</span>
    1019 <a id="l_931"></a><span class="hl line">  931 </span>         <span class="hl sym">(</span>system <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>typep system <span class="hl sym">'</span>component<span class="hl sym">)</span> system <span class="hl sym">(</span>find-system system<span class="hl sym">))))</span>
    1020 <a id="l_932"></a><span class="hl line">  932 </span>    <span class="hl sym">(</span>unless <span class="hl sym">(</span>version-satisfies system version<span class="hl sym">)</span>
    1021 <a id="l_933"></a><span class="hl line">  933 </span>      <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-component <span class="hl sym">:</span>requires system <span class="hl sym">:</span>version version<span class="hl sym">))</span>
    1022 <a id="l_934"></a><span class="hl line">  934 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>steps <span class="hl sym">(</span>traverse op system<span class="hl sym">)))</span>
    1023 <a id="l_935"></a><span class="hl line">  935 </span>      <span class="hl sym">(</span>with-compilation-unit <span class="hl sym">()</span>
    1024 <a id="l_936"></a><span class="hl line">  936 </span>        <span class="hl sym">(</span>loop for <span class="hl sym">(</span>op . component<span class="hl sym">)</span> in steps do
    1025 <a id="l_937"></a><span class="hl line">  937 </span>                 <span class="hl sym">(</span>loop
    1026 <a id="l_938"></a><span class="hl line">  938 </span>                   <span class="hl sym">(</span>restart-case
    1027 <a id="l_939"></a><span class="hl line">  939 </span>                       <span class="hl sym">(</span><span class="hl kwa">progn</span> <span class="hl sym">(</span>perform op component<span class="hl sym">)</span>
    1028 <a id="l_940"></a><span class="hl line">  940 </span>                              <span class="hl sym">(</span>return<span class="hl sym">))</span>
    1029 <a id="l_941"></a><span class="hl line">  941 </span>                     <span class="hl sym">(</span>retry <span class="hl sym">()</span>
    1030 <a id="l_942"></a><span class="hl line">  942 </span>                       <span class="hl sym">:</span>report
    1031 <a id="l_943"></a><span class="hl line">  943 </span>                       <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>s<span class="hl sym">)</span>
    1032 <a id="l_944"></a><span class="hl line">  944 </span>                         <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;Retry performing ~S on ~S.~&#64;:&gt;&quot;</span>
    1033 <a id="l_945"></a><span class="hl line">  945 </span>                                 op component<span class="hl sym">)))</span>
    1034 <a id="l_946"></a><span class="hl line">  946 </span>                     <span class="hl sym">(</span>accept <span class="hl sym">()</span>
    1035 <a id="l_947"></a><span class="hl line">  947 </span>                       <span class="hl sym">:</span>report
    1036 <a id="l_948"></a><span class="hl line">  948 </span>                       <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>s<span class="hl sym">)</span>
    1037 <a id="l_949"></a><span class="hl line">  949 </span>                         <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;Continue, treating ~S on ~S as ~</span>
    1038 <a id="l_950"></a><span class="hl line">  950 </span><span class="hl str">                                   having been successful.~&#64;:&gt;&quot;</span>
    1039 <a id="l_951"></a><span class="hl line">  951 </span>                                 op component<span class="hl sym">))</span>
    1040 <a id="l_952"></a><span class="hl line">  952 </span>                       <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span><span class="hl kwa">type</span>-of op<span class="hl sym">)</span>
    1041 <a id="l_953"></a><span class="hl line">  953 </span>                                      <span class="hl sym">(</span>component-operation-times component<span class="hl sym">))</span>
    1042 <a id="l_954"></a><span class="hl line">  954 </span>                             <span class="hl sym">(</span>get-universal-time<span class="hl sym">))</span>
    1043 <a id="l_955"></a><span class="hl line">  955 </span>                       <span class="hl sym">(</span>return<span class="hl sym">)))))))))</span>
    1044 <a id="l_956"></a><span class="hl line">  956 </span>
    1045 <a id="l_957"></a><span class="hl line">  957 </span><span class="hl sym">(</span>setf <span class="hl sym">(</span>documentation <span class="hl sym">'</span>operate <span class="hl sym">'</span>function<span class="hl sym">)</span>
    1046 <a id="l_958"></a><span class="hl line">  958 </span>      <span class="hl sym">*</span>operate-docstring<span class="hl sym">*)</span>
    1047 <a id="l_959"></a><span class="hl line">  959 </span>
    1048 <a id="l_960"></a><span class="hl line">  960 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> oos <span class="hl sym">(</span>operation-class system <span class="hl sym">&amp;</span>rest args <span class="hl sym">&amp;</span>key force <span class="hl sym">(</span>verbose t<span class="hl sym">)</span> version<span class="hl sym">)</span>
    1049 <a id="l_961"></a><span class="hl line">  961 </span>  <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignore force verbose version<span class="hl sym">))</span>
    1050 <a id="l_962"></a><span class="hl line">  962 </span>  <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>operate operation-class system args<span class="hl sym">))</span>
    1051 <a id="l_963"></a><span class="hl line">  963 </span>
    1052 <a id="l_964"></a><span class="hl line">  964 </span><span class="hl sym">(</span>setf <span class="hl sym">(</span>documentation <span class="hl sym">'</span>oos <span class="hl sym">'</span>function<span class="hl sym">)</span>
    1053 <a id="l_965"></a><span class="hl line">  965 </span>      <span class="hl sym">(</span>format nil
    1054 <a id="l_966"></a><span class="hl line">  966 </span>              <span class="hl str">&quot;Short for _operate on system_ and an alias for the `operate` function. ~&amp;~&amp;~a&quot;</span>
    1055 <a id="l_967"></a><span class="hl line">  967 </span>              <span class="hl sym">*</span>operate-docstring<span class="hl sym">*))</span>
    1056 <a id="l_968"></a><span class="hl line">  968 </span>
    1057 <a id="l_969"></a><span class="hl line">  969 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
    1058 <a id="l_970"></a><span class="hl line">  970 </span><span class="hl slc">;;; syntax</span>
    1059 <a id="l_971"></a><span class="hl line">  971 </span>
    1060 <a id="l_972"></a><span class="hl line">  972 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> remove-keyword <span class="hl sym">(</span>key arglist<span class="hl sym">)</span>
    1061 <a id="l_973"></a><span class="hl line">  973 </span>  <span class="hl sym">(</span>labels <span class="hl sym">((</span>aux <span class="hl sym">(</span>key arglist<span class="hl sym">)</span>
    1062 <a id="l_974"></a><span class="hl line">  974 </span>             <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">null</span> arglist<span class="hl sym">)</span> nil<span class="hl sym">)</span>
    1063 <a id="l_975"></a><span class="hl line">  975 </span>                   <span class="hl sym">((</span><span class="hl kwa">eq</span> key <span class="hl sym">(</span><span class="hl kwa">car</span> arglist<span class="hl sym">)) (</span><span class="hl kwa">cddr</span> arglist<span class="hl sym">))</span>
    1064 <a id="l_976"></a><span class="hl line">  976 </span>                   <span class="hl sym">(</span>t <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span><span class="hl kwa">car</span> arglist<span class="hl sym">) (</span><span class="hl kwa">cons</span> <span class="hl sym">(</span><span class="hl kwa">cadr</span> arglist<span class="hl sym">)</span>
    1065 <a id="l_977"></a><span class="hl line">  977 </span>                                                <span class="hl sym">(</span>remove-keyword
    1066 <a id="l_978"></a><span class="hl line">  978 </span>                                                 key <span class="hl sym">(</span><span class="hl kwa">cddr</span> arglist<span class="hl sym">))))))))</span>
    1067 <a id="l_979"></a><span class="hl line">  979 </span>    <span class="hl sym">(</span>aux key arglist<span class="hl sym">)))</span>
    1068 <a id="l_980"></a><span class="hl line">  980 </span>
    1069 <a id="l_981"></a><span class="hl line">  981 </span><span class="hl sym">(</span>defmacro defsystem <span class="hl sym">(</span>name <span class="hl sym">&amp;</span>body options<span class="hl sym">)</span>
    1070 <a id="l_982"></a><span class="hl line">  982 </span>  <span class="hl sym">(</span>destructuring-bind <span class="hl sym">(&amp;</span>key <span class="hl sym">(</span>pathname nil pathname-arg-p<span class="hl sym">) (</span>class <span class="hl sym">'</span>system<span class="hl sym">)</span>
    1071 <a id="l_983"></a><span class="hl line">  983 </span>                            <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span>
    1072 <a id="l_984"></a><span class="hl line">  984 </span>      options
    1073 <a id="l_985"></a><span class="hl line">  985 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>component-options <span class="hl sym">(</span>remove-keyword <span class="hl sym">:</span>class options<span class="hl sym">)))</span>
    1074 <a id="l_986"></a><span class="hl line">  986 </span>      `<span class="hl sym">(</span><span class="hl kwa">progn</span>
    1075 <a id="l_987"></a><span class="hl line">  987 </span>         <span class="hl slc">;; system must be registered before we parse the body, otherwise</span>
    1076 <a id="l_988"></a><span class="hl line">  988 </span>         <span class="hl slc">;; we recur when trying to find an existing system of the same name</span>
    1077 <a id="l_989"></a><span class="hl line">  989 </span>         <span class="hl slc">;; to reuse options (e.g. pathname) from</span>
    1078 <a id="l_990"></a><span class="hl line">  990 </span>         <span class="hl sym">(</span>let <span class="hl sym">((</span>s <span class="hl sym">(</span>system-registered-p <span class="hl sym">',</span>name<span class="hl sym">)))</span>
    1079 <a id="l_991"></a><span class="hl line">  991 </span>           <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">and</span> s <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span><span class="hl kwa">type</span>-of <span class="hl sym">(</span><span class="hl kwa">cdr</span> s<span class="hl sym">)) ',</span>class<span class="hl sym">))</span>
    1080 <a id="l_992"></a><span class="hl line">  992 </span>                  <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">car</span> s<span class="hl sym">) (</span>get-universal-time<span class="hl sym">)))</span>
    1081 <a id="l_993"></a><span class="hl line">  993 </span>                 <span class="hl sym">(</span>s
    1082 <a id="l_994"></a><span class="hl line">  994 </span>                  #<span class="hl sym">+</span>clisp
    1083 <a id="l_995"></a><span class="hl line">  995 </span>                  <span class="hl sym">(</span>sysdef-error <span class="hl str">&quot;Cannot redefine the existing system ~A with a different class&quot;</span> s<span class="hl sym">)</span>
    1084 <a id="l_996"></a><span class="hl line">  996 </span>                  #-clisp
    1085 <a id="l_997"></a><span class="hl line">  997 </span>                  <span class="hl sym">(</span>change-class <span class="hl sym">(</span><span class="hl kwa">cdr</span> s<span class="hl sym">) ',</span>class<span class="hl sym">))</span>
    1086 <a id="l_998"></a><span class="hl line">  998 </span>                 <span class="hl sym">(</span>t
    1087 <a id="l_999"></a><span class="hl line">  999 </span>                  <span class="hl sym">(</span>register-system <span class="hl sym">(</span><span class="hl kwa">quote</span> <span class="hl sym">,</span>name<span class="hl sym">)</span>
    1088 <a id="l_1000"></a><span class="hl line"> 1000 </span>                                   <span class="hl sym">(</span>make-instance <span class="hl sym">',</span>class <span class="hl sym">:</span>name <span class="hl sym">',</span>name<span class="hl sym">)))))</span>
    1089 <a id="l_1001"></a><span class="hl line"> 1001 </span>         <span class="hl sym">(</span>parse-component-form nil <span class="hl sym">(</span><span class="hl kwa">apply</span>
    1090 <a id="l_1002"></a><span class="hl line"> 1002 </span>                                    #<span class="hl sym">'</span><span class="hl kwa">list</span>
    1091 <a id="l_1003"></a><span class="hl line"> 1003 </span>                                    <span class="hl sym">:</span>module <span class="hl sym">(</span>coerce-name <span class="hl sym">',</span>name<span class="hl sym">)</span>
    1092 <a id="l_1004"></a><span class="hl line"> 1004 </span>                                    <span class="hl sym">:</span>pathname
    1093 <a id="l_1005"></a><span class="hl line"> 1005 </span>                                    <span class="hl slc">;; to avoid a note about unreachable code</span>
    1094 <a id="l_1006"></a><span class="hl line"> 1006 </span>                                    <span class="hl sym">,(</span><span class="hl kwa">if</span> pathname-arg-p
    1095 <a id="l_1007"></a><span class="hl line"> 1007 </span>                                         pathname
    1096 <a id="l_1008"></a><span class="hl line"> 1008 </span>                                         `<span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>when <span class="hl sym">*</span><span class="hl kwa">load</span>-truename<span class="hl sym">*</span>
    1097 <a id="l_1009"></a><span class="hl line"> 1009 </span>                                                <span class="hl sym">(</span>pathname-sans-name<span class="hl sym">+</span><span class="hl kwa">type</span>
    1098 <a id="l_1010"></a><span class="hl line"> 1010 </span>                                                 <span class="hl sym">(</span>resolve-symlinks
    1099 <a id="l_1011"></a><span class="hl line"> 1011 </span>                                                  <span class="hl sym">*</span><span class="hl kwa">load</span>-truename<span class="hl sym">*)))</span>
    1100 <a id="l_1012"></a><span class="hl line"> 1012 </span>                                              <span class="hl sym">*</span>default-pathname-defaults<span class="hl sym">*))</span>
    1101 <a id="l_1013"></a><span class="hl line"> 1013 </span>                                    <span class="hl sym">',</span>component-options<span class="hl sym">))))))</span>
    1102 <a id="l_1014"></a><span class="hl line"> 1014 </span>
    1103 <a id="l_1015"></a><span class="hl line"> 1015 </span>
    1104 <a id="l_1016"></a><span class="hl line"> 1016 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> class-for-<span class="hl kwa">type</span> <span class="hl sym">(</span>parent <span class="hl kwa">type</span><span class="hl sym">)</span>
    1105 <a id="l_1017"></a><span class="hl line"> 1017 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>extra-symbols <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>find-symbol <span class="hl sym">(</span>symbol-name <span class="hl kwa">type</span><span class="hl sym">) *</span>package<span class="hl sym">*)</span>
    1106 <a id="l_1018"></a><span class="hl line"> 1018 </span>                              <span class="hl sym">(</span>find-symbol <span class="hl sym">(</span>symbol-name <span class="hl kwa">type</span><span class="hl sym">)</span>
    1107 <a id="l_1019"></a><span class="hl line"> 1019 </span>                                           <span class="hl sym">(</span><span class="hl kwa">load</span>-time-value
    1108 <a id="l_1020"></a><span class="hl line"> 1020 </span>                                            <span class="hl sym">(</span>package-name <span class="hl sym">:</span>asdf<span class="hl sym">)))))</span>
    1109 <a id="l_1021"></a><span class="hl line"> 1021 </span>         <span class="hl sym">(</span>class <span class="hl sym">(</span>dolist <span class="hl sym">(</span>symbol <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>keywordp <span class="hl kwa">type</span><span class="hl sym">)</span>
    1110 <a id="l_1022"></a><span class="hl line"> 1022 </span>                                    extra-symbols
    1111 <a id="l_1023"></a><span class="hl line"> 1023 </span>                                    <span class="hl sym">(</span><span class="hl kwa">cons type</span> extra-symbols<span class="hl sym">)))</span>
    1112 <a id="l_1024"></a><span class="hl line"> 1024 </span>                  <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> symbol
    1113 <a id="l_1025"></a><span class="hl line"> 1025 </span>                             <span class="hl sym">(</span>find-class symbol nil<span class="hl sym">)</span>
    1114 <a id="l_1026"></a><span class="hl line"> 1026 </span>                             <span class="hl sym">(</span>subtypep symbol <span class="hl sym">'</span>component<span class="hl sym">))</span>
    1115 <a id="l_1027"></a><span class="hl line"> 1027 </span>                    <span class="hl sym">(</span>return <span class="hl sym">(</span>find-class symbol<span class="hl sym">))))))</span>
    1116 <a id="l_1028"></a><span class="hl line"> 1028 </span>    <span class="hl sym">(</span><span class="hl kwa">or</span> class
    1117 <a id="l_1029"></a><span class="hl line"> 1029 </span>        <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">eq type</span> <span class="hl sym">:</span>file<span class="hl sym">)</span>
    1118 <a id="l_1030"></a><span class="hl line"> 1030 </span>             <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>module-default-component-class parent<span class="hl sym">)</span>
    1119 <a id="l_1031"></a><span class="hl line"> 1031 </span>                 <span class="hl sym">(</span>find-class <span class="hl sym">'</span>cl-source-file<span class="hl sym">)))</span>
    1120 <a id="l_1032"></a><span class="hl line"> 1032 </span>        <span class="hl sym">(</span>sysdef-error <span class="hl str">&quot;~&#64;&lt;don't recognize component type ~A~&#64;:&gt;&quot;</span> <span class="hl kwa">type</span><span class="hl sym">))))</span>
    1121 <a id="l_1033"></a><span class="hl line"> 1033 </span>
    1122 <a id="l_1034"></a><span class="hl line"> 1034 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> maybe-add-tree <span class="hl sym">(</span>tree op1 op2 c<span class="hl sym">)</span>
    1123 <a id="l_1035"></a><span class="hl line"> 1035 </span>  <span class="hl str">&quot;Add the node C at /OP1/OP2 in TREE, unless it's there already.</span>
    1124 <a id="l_1036"></a><span class="hl line"> 1036 </span><span class="hl str">Returns the new tree (which probably shares structure with the old one)&quot;</span>
    1125 <a id="l_1037"></a><span class="hl line"> 1037 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>first-op-tree <span class="hl sym">(</span><span class="hl kwa">assoc</span> op1 tree<span class="hl sym">)))</span>
    1126 <a id="l_1038"></a><span class="hl line"> 1038 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> first-op-tree
    1127 <a id="l_1039"></a><span class="hl line"> 1039 </span>        <span class="hl sym">(</span><span class="hl kwa">progn</span>
    1128 <a id="l_1040"></a><span class="hl line"> 1040 </span>          <span class="hl sym">(</span>aif <span class="hl sym">(</span><span class="hl kwa">assoc</span> op2 <span class="hl sym">(</span><span class="hl kwa">cdr</span> first-op-tree<span class="hl sym">))</span>
    1129 <a id="l_1041"></a><span class="hl line"> 1041 </span>               <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>find c <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">))</span>
    1130 <a id="l_1042"></a><span class="hl line"> 1042 </span>                   nil
    1131 <a id="l_1043"></a><span class="hl line"> 1043 </span>                   <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">) (</span><span class="hl kwa">cons</span> c <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">))))</span>
    1132 <a id="l_1044"></a><span class="hl line"> 1044 </span>               <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">cdr</span> first-op-tree<span class="hl sym">)</span>
    1133 <a id="l_1045"></a><span class="hl line"> 1045 </span>                     <span class="hl sym">(</span>acons op2 <span class="hl sym">(</span><span class="hl kwa">list</span> c<span class="hl sym">) (</span><span class="hl kwa">cdr</span> first-op-tree<span class="hl sym">))))</span>
    1134 <a id="l_1046"></a><span class="hl line"> 1046 </span>          tree<span class="hl sym">)</span>
    1135 <a id="l_1047"></a><span class="hl line"> 1047 </span>        <span class="hl sym">(</span>acons op1 <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span><span class="hl kwa">list</span> op2 c<span class="hl sym">))</span> tree<span class="hl sym">))))</span>
    1136 <a id="l_1048"></a><span class="hl line"> 1048 </span>
    1137 <a id="l_1049"></a><span class="hl line"> 1049 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> union-of-dependencies <span class="hl sym">(&amp;</span>rest deps<span class="hl sym">)</span>
    1138 <a id="l_1050"></a><span class="hl line"> 1050 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>new-tree nil<span class="hl sym">))</span>
    1139 <a id="l_1051"></a><span class="hl line"> 1051 </span>    <span class="hl sym">(</span>dolist <span class="hl sym">(</span>dep deps<span class="hl sym">)</span>
    1140 <a id="l_1052"></a><span class="hl line"> 1052 </span>      <span class="hl sym">(</span>dolist <span class="hl sym">(</span>op-tree dep<span class="hl sym">)</span>
    1141 <a id="l_1053"></a><span class="hl line"> 1053 </span>        <span class="hl sym">(</span>dolist <span class="hl sym">(</span>op  <span class="hl sym">(</span><span class="hl kwa">cdr</span> op-tree<span class="hl sym">))</span>
    1142 <a id="l_1054"></a><span class="hl line"> 1054 </span>          <span class="hl sym">(</span>dolist <span class="hl sym">(</span>c <span class="hl sym">(</span><span class="hl kwa">cdr</span> op<span class="hl sym">))</span>
    1143 <a id="l_1055"></a><span class="hl line"> 1055 </span>            <span class="hl sym">(</span>setf new-tree
    1144 <a id="l_1056"></a><span class="hl line"> 1056 </span>                  <span class="hl sym">(</span>maybe-add-tree new-tree <span class="hl sym">(</span><span class="hl kwa">car</span> op-tree<span class="hl sym">) (</span><span class="hl kwa">car</span> op<span class="hl sym">)</span> c<span class="hl sym">))))))</span>
    1145 <a id="l_1057"></a><span class="hl line"> 1057 </span>    new-tree<span class="hl sym">))</span>
    1146 <a id="l_1058"></a><span class="hl line"> 1058 </span>
    1147 <a id="l_1059"></a><span class="hl line"> 1059 </span>
    1148 <a id="l_1060"></a><span class="hl line"> 1060 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> remove-keys <span class="hl sym">(</span>key-names args<span class="hl sym">)</span>
    1149 <a id="l_1061"></a><span class="hl line"> 1061 </span>  <span class="hl sym">(</span>loop for <span class="hl sym">(</span> name val <span class="hl sym">)</span> on args by #<span class="hl sym">'</span><span class="hl kwa">cddr</span>
    1150 <a id="l_1062"></a><span class="hl line"> 1062 </span>        unless <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span>symbol-name name<span class="hl sym">)</span> key-names
    1151 <a id="l_1063"></a><span class="hl line"> 1063 </span>                       <span class="hl sym">:</span>key #<span class="hl sym">'</span>symbol-name <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)</span>
    1152 <a id="l_1064"></a><span class="hl line"> 1064 </span>        <span class="hl kwa">append</span> <span class="hl sym">(</span><span class="hl kwa">list</span> name val<span class="hl sym">)))</span>
    1153 <a id="l_1065"></a><span class="hl line"> 1065 </span>
    1154 <a id="l_1066"></a><span class="hl line"> 1066 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>serial-depends-on<span class="hl sym">*)</span>
    1155 <a id="l_1067"></a><span class="hl line"> 1067 </span>
    1156 <a id="l_1068"></a><span class="hl line"> 1068 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> parse-component-form <span class="hl sym">(</span>parent options<span class="hl sym">)</span>
    1157 <a id="l_1069"></a><span class="hl line"> 1069 </span>
    1158 <a id="l_1070"></a><span class="hl line"> 1070 </span>  <span class="hl sym">(</span>destructuring-bind
    1159 <a id="l_1071"></a><span class="hl line"> 1071 </span>        <span class="hl sym">(</span><span class="hl kwa">type</span> name <span class="hl sym">&amp;</span>rest rest <span class="hl sym">&amp;</span>key
    1160 <a id="l_1072"></a><span class="hl line"> 1072 </span>              <span class="hl slc">;; the following list of keywords is reproduced below in the</span>
    1161 <a id="l_1073"></a><span class="hl line"> 1073 </span>              <span class="hl slc">;; remove-keys form.  important to keep them in sync</span>
    1162 <a id="l_1074"></a><span class="hl line"> 1074 </span>              components pathname default-component-class
    1163 <a id="l_1075"></a><span class="hl line"> 1075 </span>              perform explain output-files operation-done-p
    1164 <a id="l_1076"></a><span class="hl line"> 1076 </span>              weakly-depends-on
    1165 <a id="l_1077"></a><span class="hl line"> 1077 </span>              depends-on serial in-order-to
    1166 <a id="l_1078"></a><span class="hl line"> 1078 </span>              <span class="hl slc">;; list ends</span>
    1167 <a id="l_1079"></a><span class="hl line"> 1079 </span>              <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span> options
    1168 <a id="l_1080"></a><span class="hl line"> 1080 </span>    <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignorable perform explain output-files operation-done-p<span class="hl sym">))</span>
    1169 <a id="l_1081"></a><span class="hl line"> 1081 </span>    <span class="hl sym">(</span>check-component-input <span class="hl kwa">type</span> name weakly-depends-on depends-on components in-order-to<span class="hl sym">)</span>
    1170 <a id="l_1082"></a><span class="hl line"> 1082 </span>
    1171 <a id="l_1083"></a><span class="hl line"> 1083 </span>    <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> parent
    1172 <a id="l_1084"></a><span class="hl line"> 1084 </span>               <span class="hl sym">(</span>find-component parent name<span class="hl sym">)</span>
    1173 <a id="l_1085"></a><span class="hl line"> 1085 </span>               <span class="hl slc">;; ignore the same object when rereading the defsystem</span>
    1174 <a id="l_1086"></a><span class="hl line"> 1086 </span>               <span class="hl sym">(</span><span class="hl kwa">not</span>
    1175 <a id="l_1087"></a><span class="hl line"> 1087 </span>                <span class="hl sym">(</span>typep <span class="hl sym">(</span>find-component parent name<span class="hl sym">)</span>
    1176 <a id="l_1088"></a><span class="hl line"> 1088 </span>                       <span class="hl sym">(</span>class-for-<span class="hl kwa">type</span> parent <span class="hl kwa">type</span><span class="hl sym">))))</span>
    1177 <a id="l_1089"></a><span class="hl line"> 1089 </span>      <span class="hl sym">(</span>error <span class="hl sym">'</span>duplicate-names <span class="hl sym">:</span>name name<span class="hl sym">))</span>
    1178 <a id="l_1090"></a><span class="hl line"> 1090 </span>
    1179 <a id="l_1091"></a><span class="hl line"> 1091 </span>    <span class="hl sym">(</span>let<span class="hl sym">* ((</span>other-args <span class="hl sym">(</span>remove-keys
    1180 <a id="l_1092"></a><span class="hl line"> 1092 </span>                        <span class="hl sym">'(</span>components pathname default-component-class
    1181 <a id="l_1093"></a><span class="hl line"> 1093 </span>                          perform explain output-files operation-done-p
    1182 <a id="l_1094"></a><span class="hl line"> 1094 </span>                          weakly-depends-on
    1183 <a id="l_1095"></a><span class="hl line"> 1095 </span>                          depends-on serial in-order-to<span class="hl sym">)</span>
    1184 <a id="l_1096"></a><span class="hl line"> 1096 </span>                        rest<span class="hl sym">))</span>
    1185 <a id="l_1097"></a><span class="hl line"> 1097 </span>           <span class="hl sym">(</span>ret
    1186 <a id="l_1098"></a><span class="hl line"> 1098 </span>            <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>find-component parent name<span class="hl sym">)</span>
    1187 <a id="l_1099"></a><span class="hl line"> 1099 </span>                <span class="hl sym">(</span>make-instance <span class="hl sym">(</span>class-for-<span class="hl kwa">type</span> parent <span class="hl kwa">type</span><span class="hl sym">)))))</span>
    1188 <a id="l_1100"></a><span class="hl line"> 1100 </span>      <span class="hl sym">(</span>when weakly-depends-on
    1189 <a id="l_1101"></a><span class="hl line"> 1101 </span>        <span class="hl sym">(</span>setf depends-on <span class="hl sym">(</span><span class="hl kwa">append</span> depends-on <span class="hl sym">(</span>remove-<span class="hl kwa">if</span> <span class="hl sym">(</span>complement #<span class="hl sym">'</span>find-system<span class="hl sym">)</span> weakly-depends-on<span class="hl sym">))))</span>
    1190 <a id="l_1102"></a><span class="hl line"> 1102 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">boundp</span> <span class="hl sym">'*</span>serial-depends-on<span class="hl sym">*)</span>
    1191 <a id="l_1103"></a><span class="hl line"> 1103 </span>        <span class="hl sym">(</span>setf depends-on
    1192 <a id="l_1104"></a><span class="hl line"> 1104 </span>              <span class="hl sym">(</span>concatenate <span class="hl sym">'</span><span class="hl kwa">list</span> <span class="hl sym">*</span>serial-depends-on<span class="hl sym">*</span> depends-on<span class="hl sym">)))</span>
    1193 <a id="l_1105"></a><span class="hl line"> 1105 </span>      <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>reinitialize-instance ret
    1194 <a id="l_1106"></a><span class="hl line"> 1106 </span>             <span class="hl sym">:</span>name <span class="hl sym">(</span>coerce-name name<span class="hl sym">)</span>
    1195 <a id="l_1107"></a><span class="hl line"> 1107 </span>             <span class="hl sym">:</span>pathname pathname
    1196 <a id="l_1108"></a><span class="hl line"> 1108 </span>             <span class="hl sym">:</span>parent parent
    1197 <a id="l_1109"></a><span class="hl line"> 1109 </span>             other-args<span class="hl sym">)</span>
    1198 <a id="l_1110"></a><span class="hl line"> 1110 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span>typep ret <span class="hl sym">'</span>module<span class="hl sym">)</span>
    1199 <a id="l_1111"></a><span class="hl line"> 1111 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span>module-default-component-class ret<span class="hl sym">)</span>
    1200 <a id="l_1112"></a><span class="hl line"> 1112 </span>              <span class="hl sym">(</span><span class="hl kwa">or</span> default-component-class
    1201 <a id="l_1113"></a><span class="hl line"> 1113 </span>                  <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span>typep parent <span class="hl sym">'</span>module<span class="hl sym">)</span>
    1202 <a id="l_1114"></a><span class="hl line"> 1114 </span>                       <span class="hl sym">(</span>module-default-component-class parent<span class="hl sym">))))</span>
    1203 <a id="l_1115"></a><span class="hl line"> 1115 </span>        <span class="hl sym">(</span>let <span class="hl sym">((*</span>serial-depends-on<span class="hl sym">*</span> nil<span class="hl sym">))</span>
    1204 <a id="l_1116"></a><span class="hl line"> 1116 </span>          <span class="hl sym">(</span>setf <span class="hl sym">(</span>module-components ret<span class="hl sym">)</span>
    1205 <a id="l_1117"></a><span class="hl line"> 1117 </span>                <span class="hl sym">(</span>loop for c-form in components
    1206 <a id="l_1118"></a><span class="hl line"> 1118 </span>                      for c <span class="hl sym">= (</span>parse-component-form ret c-form<span class="hl sym">)</span>
    1207 <a id="l_1119"></a><span class="hl line"> 1119 </span>                      collect c
    1208 <a id="l_1120"></a><span class="hl line"> 1120 </span>                      <span class="hl kwa">if</span> serial
    1209 <a id="l_1121"></a><span class="hl line"> 1121 </span>                      do <span class="hl sym">(</span>push <span class="hl sym">(</span>component-name c<span class="hl sym">) *</span>serial-depends-on<span class="hl sym">*))))</span>
    1210 <a id="l_1122"></a><span class="hl line"> 1122 </span>
    1211 <a id="l_1123"></a><span class="hl line"> 1123 </span>        <span class="hl slc">;; check for duplicate names</span>
    1212 <a id="l_1124"></a><span class="hl line"> 1124 </span>        <span class="hl sym">(</span>let <span class="hl sym">((</span>name-hash <span class="hl sym">(</span>make-hash-table <span class="hl sym">:</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
    1213 <a id="l_1125"></a><span class="hl line"> 1125 </span>          <span class="hl sym">(</span>loop for c in <span class="hl sym">(</span>module-components ret<span class="hl sym">)</span>
    1214 <a id="l_1126"></a><span class="hl line"> 1126 </span>                do
    1215 <a id="l_1127"></a><span class="hl line"> 1127 </span>                <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>gethash <span class="hl sym">(</span>component-name c<span class="hl sym">)</span>
    1216 <a id="l_1128"></a><span class="hl line"> 1128 </span>                             name-hash<span class="hl sym">)</span>
    1217 <a id="l_1129"></a><span class="hl line"> 1129 </span>                    <span class="hl sym">(</span>error <span class="hl sym">'</span>duplicate-names
    1218 <a id="l_1130"></a><span class="hl line"> 1130 </span>                           <span class="hl sym">:</span>name <span class="hl sym">(</span>component-name c<span class="hl sym">))</span>
    1219 <a id="l_1131"></a><span class="hl line"> 1131 </span>                    <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span>component-name c<span class="hl sym">)</span>
    1220 <a id="l_1132"></a><span class="hl line"> 1132 </span>                                   name-hash<span class="hl sym">)</span>
    1221 <a id="l_1133"></a><span class="hl line"> 1133 </span>                          t<span class="hl sym">)))))</span>
    1222 <a id="l_1134"></a><span class="hl line"> 1134 </span>
    1223 <a id="l_1135"></a><span class="hl line"> 1135 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span>slot-value ret <span class="hl sym">'</span>in-order-to<span class="hl sym">)</span>
    1224 <a id="l_1136"></a><span class="hl line"> 1136 </span>            <span class="hl sym">(</span>union-of-dependencies
    1225 <a id="l_1137"></a><span class="hl line"> 1137 </span>             in-order-to
    1226 <a id="l_1138"></a><span class="hl line"> 1138 </span>             `<span class="hl sym">((</span>compile-op <span class="hl sym">(</span>compile-op <span class="hl sym">,</span>&#64;depends-on<span class="hl sym">))</span>
    1227 <a id="l_1139"></a><span class="hl line"> 1139 </span>               <span class="hl sym">(</span><span class="hl kwa">load</span>-op <span class="hl sym">(</span><span class="hl kwa">load</span>-op <span class="hl sym">,</span>&#64;depends-on<span class="hl sym">))))</span>
    1228 <a id="l_1140"></a><span class="hl line"> 1140 </span>            <span class="hl sym">(</span>slot-value ret <span class="hl sym">'</span>do-first<span class="hl sym">)</span> `<span class="hl sym">((</span>compile-op <span class="hl sym">(</span><span class="hl kwa">load</span>-op <span class="hl sym">,</span>&#64;depends-on<span class="hl sym">))))</span>
    1229 <a id="l_1141"></a><span class="hl line"> 1141 </span>
    1230 <a id="l_1142"></a><span class="hl line"> 1142 </span>      <span class="hl sym">(</span>%remove-component-inline-methods ret rest<span class="hl sym">)</span>
    1231 <a id="l_1143"></a><span class="hl line"> 1143 </span>
    1232 <a id="l_1144"></a><span class="hl line"> 1144 </span>      ret<span class="hl sym">)))</span>
    1233 <a id="l_1145"></a><span class="hl line"> 1145 </span>
    1234 <a id="l_1146"></a><span class="hl line"> 1146 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> %remove-component-inline-methods <span class="hl sym">(</span>ret rest<span class="hl sym">)</span>
    1235 <a id="l_1147"></a><span class="hl line"> 1147 </span>  <span class="hl sym">(</span>loop for name in <span class="hl sym">+</span>asdf-methods<span class="hl sym">+</span>
    1236 <a id="l_1148"></a><span class="hl line"> 1148 </span>        do <span class="hl sym">(</span>map <span class="hl sym">'</span>nil
    1237 <a id="l_1149"></a><span class="hl line"> 1149 </span>                <span class="hl slc">;; this is inefficient as most of the stored</span>
    1238 <a id="l_1150"></a><span class="hl line"> 1150 </span>                <span class="hl slc">;; methods will not be for this particular gf n</span>
    1239 <a id="l_1151"></a><span class="hl line"> 1151 </span>                <span class="hl slc">;; But this is hardly performance-critical</span>
    1240 <a id="l_1152"></a><span class="hl line"> 1152 </span>                <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>m<span class="hl sym">)</span>
    1241 <a id="l_1153"></a><span class="hl line"> 1153 </span>                  <span class="hl sym">(</span>remove-method <span class="hl sym">(</span>symbol-function name<span class="hl sym">)</span> m<span class="hl sym">))</span>
    1242 <a id="l_1154"></a><span class="hl line"> 1154 </span>                <span class="hl sym">(</span>component-inline-methods ret<span class="hl sym">)))</span>
    1243 <a id="l_1155"></a><span class="hl line"> 1155 </span>  <span class="hl slc">;; clear methods, then add the new ones</span>
    1244 <a id="l_1156"></a><span class="hl line"> 1156 </span>  <span class="hl sym">(</span>setf <span class="hl sym">(</span>component-inline-methods ret<span class="hl sym">)</span> nil<span class="hl sym">)</span>
    1245 <a id="l_1157"></a><span class="hl line"> 1157 </span>  <span class="hl sym">(</span>loop for name in <span class="hl sym">+</span>asdf-methods<span class="hl sym">+</span>
    1246 <a id="l_1158"></a><span class="hl line"> 1158 </span>        for v <span class="hl sym">= (</span>getf rest <span class="hl sym">(</span>intern <span class="hl sym">(</span>symbol-name name<span class="hl sym">) :</span>keyword<span class="hl sym">))</span>
    1247 <a id="l_1159"></a><span class="hl line"> 1159 </span>        when v do
    1248 <a id="l_1160"></a><span class="hl line"> 1160 </span>        <span class="hl sym">(</span>destructuring-bind <span class="hl sym">(</span>op qual <span class="hl sym">(</span>o c<span class="hl sym">) &amp;</span>body body<span class="hl sym">)</span> v
    1249 <a id="l_1161"></a><span class="hl line"> 1161 </span>          <span class="hl sym">(</span>pushnew
    1250 <a id="l_1162"></a><span class="hl line"> 1162 </span>           <span class="hl sym">(</span><span class="hl kwa">eval</span> `<span class="hl sym">(</span>defmethod <span class="hl sym">,</span>name <span class="hl sym">,</span>qual <span class="hl sym">((,</span>o <span class="hl sym">,</span>op<span class="hl sym">) (,</span>c <span class="hl sym">(</span>eql <span class="hl sym">,</span>ret<span class="hl sym">)))</span>
    1251 <a id="l_1163"></a><span class="hl line"> 1163 </span>                             <span class="hl sym">,</span>&#64;body<span class="hl sym">))</span>
    1252 <a id="l_1164"></a><span class="hl line"> 1164 </span>           <span class="hl sym">(</span>component-inline-methods ret<span class="hl sym">)))))</span>
    1253 <a id="l_1165"></a><span class="hl line"> 1165 </span>
    1254 <a id="l_1166"></a><span class="hl line"> 1166 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> check-component-input <span class="hl sym">(</span><span class="hl kwa">type</span> name weakly-depends-on depends-on components in-order-to<span class="hl sym">)</span>
    1255 <a id="l_1167"></a><span class="hl line"> 1167 </span>  <span class="hl str">&quot;A partial test of the values of a component.&quot;</span>
    1256 <a id="l_1168"></a><span class="hl line"> 1168 </span>  <span class="hl sym">(</span>when weakly-depends-on <span class="hl sym">(</span>warn <span class="hl str">&quot;We got one! XXXXX&quot;</span><span class="hl sym">))</span>
    1257 <a id="l_1169"></a><span class="hl line"> 1169 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">listp</span> depends-on<span class="hl sym">)</span>
    1258 <a id="l_1170"></a><span class="hl line"> 1170 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:depends-on must be a list.&quot;</span>
    1259 <a id="l_1171"></a><span class="hl line"> 1171 </span>                            <span class="hl kwa">type</span> name depends-on<span class="hl sym">))</span>
    1260 <a id="l_1172"></a><span class="hl line"> 1172 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">listp</span> weakly-depends-on<span class="hl sym">)</span>
    1261 <a id="l_1173"></a><span class="hl line"> 1173 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:weakly-depends-on must be a list.&quot;</span>
    1262 <a id="l_1174"></a><span class="hl line"> 1174 </span>                            <span class="hl kwa">type</span> name weakly-depends-on<span class="hl sym">))</span>
    1263 <a id="l_1175"></a><span class="hl line"> 1175 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">listp</span> components<span class="hl sym">)</span>
    1264 <a id="l_1176"></a><span class="hl line"> 1176 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:components must be NIL or a list of components.&quot;</span>
    1265 <a id="l_1177"></a><span class="hl line"> 1177 </span>                            <span class="hl kwa">type</span> name components<span class="hl sym">))</span>
    1266 <a id="l_1178"></a><span class="hl line"> 1178 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">listp</span> in-order-to<span class="hl sym">) (</span><span class="hl kwa">listp</span> <span class="hl sym">(</span><span class="hl kwa">car</span> in-order-to<span class="hl sym">)))</span>
    1267 <a id="l_1179"></a><span class="hl line"> 1179 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:in-order-to must be NIL or a list of components.&quot;</span>
    1268 <a id="l_1180"></a><span class="hl line"> 1180 </span>                            <span class="hl kwa">type</span> name in-order-to<span class="hl sym">)))</span>
    1269 <a id="l_1181"></a><span class="hl line"> 1181 </span>
    1270 <a id="l_1182"></a><span class="hl line"> 1182 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> sysdef-error-component <span class="hl sym">(</span>msg <span class="hl kwa">type</span> name value<span class="hl sym">)</span>
    1271 <a id="l_1183"></a><span class="hl line"> 1183 </span>  <span class="hl sym">(</span>sysdef-error <span class="hl sym">(</span>concatenate <span class="hl sym">'</span>string msg
    1272 <a id="l_1184"></a><span class="hl line"> 1184 </span>                             <span class="hl str">&quot;~&amp;The value specified for ~(~A~) ~A is ~W&quot;</span><span class="hl sym">)</span>
    1273 <a id="l_1185"></a><span class="hl line"> 1185 </span>                <span class="hl kwa">type</span> name value<span class="hl sym">))</span>
    1274 <a id="l_1186"></a><span class="hl line"> 1186 </span>
    1275 <a id="l_1187"></a><span class="hl line"> 1187 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> resolve-symlinks <span class="hl sym">(</span>path<span class="hl sym">)</span>
    1276 <a id="l_1188"></a><span class="hl line"> 1188 </span>  #-allegro <span class="hl sym">(</span>truename path<span class="hl sym">)</span>
    1277 <a id="l_1189"></a><span class="hl line"> 1189 </span>  #<span class="hl sym">+</span>allegro <span class="hl sym">(</span>excl<span class="hl sym">:</span>pathname-resolve-symbolic-links path<span class="hl sym">)</span>
    1278 <a id="l_1190"></a><span class="hl line"> 1190 </span>  <span class="hl sym">)</span>
    1279 <a id="l_1191"></a><span class="hl line"> 1191 </span>
    1280 <a id="l_1192"></a><span class="hl line"> 1192 </span><span class="hl slc">;;; optional extras</span>
    1281 <a id="l_1193"></a><span class="hl line"> 1193 </span>
    1282 <a id="l_1194"></a><span class="hl line"> 1194 </span><span class="hl slc">;;; run-shell-command functions for other lisp implementations will be</span>
    1283 <a id="l_1195"></a><span class="hl line"> 1195 </span><span class="hl slc">;;; gratefully accepted, if they do the same thing.  If the docstring</span>
    1284 <a id="l_1196"></a><span class="hl line"> 1196 </span><span class="hl slc">;;; is ambiguous, send a bug report</span>
    1285 <a id="l_1197"></a><span class="hl line"> 1197 </span>
    1286 <a id="l_1198"></a><span class="hl line"> 1198 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> run-shell-<span class="hl kwa">command</span> <span class="hl sym">(</span>control-string <span class="hl sym">&amp;</span>rest args<span class="hl sym">)</span>
    1287 <a id="l_1199"></a><span class="hl line"> 1199 </span>  <span class="hl str">&quot;Interpolate ARGS into CONTROL-STRING as if by FORMAT, and</span>
    1288 <a id="l_1200"></a><span class="hl line"> 1200 </span><span class="hl str">synchronously execute the result using a Bourne-compatible shell, with</span>
    1289 <a id="l_1201"></a><span class="hl line"> 1201 </span><span class="hl str">output to *VERBOSE-OUT*.  Returns the shell's exit code.&quot;</span>
    1290 <a id="l_1202"></a><span class="hl line"> 1202 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span><span class="hl kwa">command</span> <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>format nil control-string args<span class="hl sym">)))</span>
    1291 <a id="l_1203"></a><span class="hl line"> 1203 </span>    <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> <span class="hl str">&quot;; $ ~A~%&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
    1292 <a id="l_1204"></a><span class="hl line"> 1204 </span>    #<span class="hl sym">+</span>sbcl
    1293 <a id="l_1205"></a><span class="hl line"> 1205 </span>    <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>process-<span class="hl kwa">exit</span>-code
    1294 <a id="l_1206"></a><span class="hl line"> 1206 </span>     <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>run-program
    1295 <a id="l_1207"></a><span class="hl line"> 1207 </span>      #<span class="hl sym">+</span>win32 <span class="hl str">&quot;sh&quot;</span> #-win32 <span class="hl str">&quot;/bin/sh&quot;</span>
    1296 <a id="l_1208"></a><span class="hl line"> 1208 </span>      <span class="hl sym">(</span><span class="hl kwa">list</span>  <span class="hl str">&quot;-c&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
    1297 <a id="l_1209"></a><span class="hl line"> 1209 </span>      #<span class="hl sym">+</span>win32 #<span class="hl sym">+</span>win32 <span class="hl sym">:</span>search t
    1298 <a id="l_1210"></a><span class="hl line"> 1210 </span>      <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*))</span>
    1299 <a id="l_1211"></a><span class="hl line"> 1211 </span>
    1300 <a id="l_1212"></a><span class="hl line"> 1212 </span>    #<span class="hl sym">+(</span><span class="hl kwa">or</span> cmu scl<span class="hl sym">)</span>
    1301 <a id="l_1213"></a><span class="hl line"> 1213 </span>    <span class="hl sym">(</span>ext<span class="hl sym">:</span>process-<span class="hl kwa">exit</span>-code
    1302 <a id="l_1214"></a><span class="hl line"> 1214 </span>     <span class="hl sym">(</span>ext<span class="hl sym">:</span>run-program
    1303 <a id="l_1215"></a><span class="hl line"> 1215 </span>      <span class="hl str">&quot;/bin/sh&quot;</span>
    1304 <a id="l_1216"></a><span class="hl line"> 1216 </span>      <span class="hl sym">(</span><span class="hl kwa">list</span>  <span class="hl str">&quot;-c&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
    1305 <a id="l_1217"></a><span class="hl line"> 1217 </span>      <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*))</span>
    1306 <a id="l_1218"></a><span class="hl line"> 1218 </span>
    1307 <a id="l_1219"></a><span class="hl line"> 1219 </span>    #<span class="hl sym">+</span>allegro
    1308 <a id="l_1220"></a><span class="hl line"> 1220 </span>    <span class="hl sym">(</span>excl<span class="hl sym">:</span>run-shell-<span class="hl kwa">command command</span> <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*)</span>
    1309 <a id="l_1221"></a><span class="hl line"> 1221 </span>
    1310 <a id="l_1222"></a><span class="hl line"> 1222 </span>    #<span class="hl sym">+</span>lispworks
    1311 <a id="l_1223"></a><span class="hl line"> 1223 </span>    <span class="hl sym">(</span>system<span class="hl sym">:</span>call-system-showing-output
    1312 <a id="l_1224"></a><span class="hl line"> 1224 </span>     <span class="hl kwa">command</span>
    1313 <a id="l_1225"></a><span class="hl line"> 1225 </span>     <span class="hl sym">:</span>shell-<span class="hl kwa">type</span> <span class="hl str">&quot;/bin/sh&quot;</span>
    1314 <a id="l_1226"></a><span class="hl line"> 1226 </span>     <span class="hl sym">:</span>output-stream <span class="hl sym">*</span>verbose-out<span class="hl sym">*)</span>
    1315 <a id="l_1227"></a><span class="hl line"> 1227 </span>
    1316 <a id="l_1228"></a><span class="hl line"> 1228 </span>    #<span class="hl sym">+</span>clisp                     <span class="hl slc">;XXX not exactly *verbose-out*, I know</span>
    1317 <a id="l_1229"></a><span class="hl line"> 1229 </span>    <span class="hl sym">(</span>ext<span class="hl sym">:</span>run-shell-<span class="hl kwa">command  command</span> <span class="hl sym">:</span>output <span class="hl sym">:</span>terminal <span class="hl sym">:</span>wait t<span class="hl sym">)</span>
    1318 <a id="l_1230"></a><span class="hl line"> 1230 </span>
    1319 <a id="l_1231"></a><span class="hl line"> 1231 </span>    #<span class="hl sym">+</span>openmcl
    1320 <a id="l_1232"></a><span class="hl line"> 1232 </span>    <span class="hl sym">(</span><span class="hl kwa">nth</span>-value <span class="hl num">1</span>
    1321 <a id="l_1233"></a><span class="hl line"> 1233 </span>               <span class="hl sym">(</span>ccl<span class="hl sym">:</span>external-process-status
    1322 <a id="l_1234"></a><span class="hl line"> 1234 </span>                <span class="hl sym">(</span>ccl<span class="hl sym">:</span>run-program <span class="hl str">&quot;/bin/sh&quot;</span> <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl str">&quot;-c&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
    1323 <a id="l_1235"></a><span class="hl line"> 1235 </span>                                 <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
    1324 <a id="l_1236"></a><span class="hl line"> 1236 </span>                                 <span class="hl sym">:</span>wait t<span class="hl sym">)))</span>
    1325 <a id="l_1237"></a><span class="hl line"> 1237 </span>    #<span class="hl sym">+</span>ecl <span class="hl slc">;; courtesy of Juan Jose Garcia Ripoll</span>
    1326 <a id="l_1238"></a><span class="hl line"> 1238 </span>    <span class="hl sym">(</span>si<span class="hl sym">:</span>system <span class="hl kwa">command</span><span class="hl sym">)</span>
    1327 <a id="l_1239"></a><span class="hl line"> 1239 </span>    #-<span class="hl sym">(</span><span class="hl kwa">or</span> openmcl clisp lispworks allegro scl cmu sbcl ecl<span class="hl sym">)</span>
    1328 <a id="l_1240"></a><span class="hl line"> 1240 </span>    <span class="hl sym">(</span>error <span class="hl str">&quot;RUN-SHELL-PROGRAM not implemented for this Lisp&quot;</span><span class="hl sym">)</span>
    1329 <a id="l_1241"></a><span class="hl line"> 1241 </span>    <span class="hl sym">))</span>
    1330 <a id="l_1242"></a><span class="hl line"> 1242 </span>
    1331 <a id="l_1243"></a><span class="hl line"> 1243 </span>
    1332 <a id="l_1244"></a><span class="hl line"> 1244 </span><span class="hl sym">(</span>defgeneric hyperdocumentation <span class="hl sym">(</span>package name doc-<span class="hl kwa">type</span><span class="hl sym">))</span>
    1333 <a id="l_1245"></a><span class="hl line"> 1245 </span><span class="hl sym">(</span>defmethod hyperdocumentation <span class="hl sym">((</span>package symbol<span class="hl sym">)</span> name doc-<span class="hl kwa">type</span><span class="hl sym">)</span>
    1334 <a id="l_1246"></a><span class="hl line"> 1246 </span>  <span class="hl sym">(</span>hyperdocumentation <span class="hl sym">(</span>find-package package<span class="hl sym">)</span> name doc-<span class="hl kwa">type</span><span class="hl sym">))</span>
    1335 <a id="l_1247"></a><span class="hl line"> 1247 </span>
    1336 <a id="l_1248"></a><span class="hl line"> 1248 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> hyperdoc <span class="hl sym">(</span>name doc-<span class="hl kwa">type</span><span class="hl sym">)</span>
    1337 <a id="l_1249"></a><span class="hl line"> 1249 </span>  <span class="hl sym">(</span>hyperdocumentation <span class="hl sym">(</span>symbol-package name<span class="hl sym">)</span> name doc-<span class="hl kwa">type</span><span class="hl sym">))</span>
    1338 <a id="l_1250"></a><span class="hl line"> 1250 </span>
    1339 <a id="l_1251"></a><span class="hl line"> 1251 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-source-file <span class="hl sym">(</span>system-name<span class="hl sym">)</span>
    1340 <a id="l_1252"></a><span class="hl line"> 1252 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>system <span class="hl sym">(</span>asdf<span class="hl sym">:</span>find-system system-name<span class="hl sym">)))</span>
    1341 <a id="l_1253"></a><span class="hl line"> 1253 </span>    <span class="hl sym">(</span>make-pathname
    1342 <a id="l_1254"></a><span class="hl line"> 1254 </span>     <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;asd&quot;</span>
    1343 <a id="l_1255"></a><span class="hl line"> 1255 </span>     <span class="hl sym">:</span>name <span class="hl sym">(</span>asdf<span class="hl sym">:</span>component-name system<span class="hl sym">)</span>
    1344 <a id="l_1256"></a><span class="hl line"> 1256 </span>     <span class="hl sym">:</span>defaults <span class="hl sym">(</span>asdf<span class="hl sym">:</span>component-relative-pathname system<span class="hl sym">))))</span>
    1345 <a id="l_1257"></a><span class="hl line"> 1257 </span>
    1346 <a id="l_1258"></a><span class="hl line"> 1258 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-source-directory <span class="hl sym">(</span>system-name<span class="hl sym">)</span>
    1347 <a id="l_1259"></a><span class="hl line"> 1259 </span>  <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name nil
    1348 <a id="l_1260"></a><span class="hl line"> 1260 </span>                 <span class="hl sym">:</span><span class="hl kwa">type</span> nil
    1349 <a id="l_1261"></a><span class="hl line"> 1261 </span>                 <span class="hl sym">:</span>defaults <span class="hl sym">(</span>system-source-file system-name<span class="hl sym">)))</span>
    1350 <a id="l_1262"></a><span class="hl line"> 1262 </span>
    1351 <a id="l_1263"></a><span class="hl line"> 1263 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-relative-pathname <span class="hl sym">(</span>system pathname <span class="hl sym">&amp;</span>key name <span class="hl kwa">type</span><span class="hl sym">)</span>
    1352 <a id="l_1264"></a><span class="hl line"> 1264 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>directory <span class="hl sym">(</span>pathname-directory pathname<span class="hl sym">)))</span>
    1353 <a id="l_1265"></a><span class="hl line"> 1265 </span>    <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span><span class="hl kwa">car</span> directory<span class="hl sym">) :</span>absolute<span class="hl sym">)</span>
    1354 <a id="l_1266"></a><span class="hl line"> 1266 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">car</span> directory<span class="hl sym">) :</span>relative<span class="hl sym">))</span>
    1355 <a id="l_1267"></a><span class="hl line"> 1267 </span>    <span class="hl sym">(</span>merge-pathnames
    1356 <a id="l_1268"></a><span class="hl line"> 1268 </span>     <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name <span class="hl sym">(</span><span class="hl kwa">or</span> name <span class="hl sym">(</span>pathname-name pathname<span class="hl sym">))</span>
    1357 <a id="l_1269"></a><span class="hl line"> 1269 </span>                    <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl sym">(</span><span class="hl kwa">or type</span> <span class="hl sym">(</span>pathname-<span class="hl kwa">type</span> pathname<span class="hl sym">))</span>
    1358 <a id="l_1270"></a><span class="hl line"> 1270 </span>                    <span class="hl sym">:</span>directory directory<span class="hl sym">)</span>
    1359 <a id="l_1271"></a><span class="hl line"> 1271 </span>     <span class="hl sym">(</span>system-source-directory system<span class="hl sym">))))</span>
    1360 <a id="l_1272"></a><span class="hl line"> 1272 </span>
    1361 <a id="l_1273"></a><span class="hl line"> 1273 </span>
    1362 <a id="l_1274"></a><span class="hl line"> 1274 </span><span class="hl sym">(</span>pushnew <span class="hl sym">:</span>asdf <span class="hl sym">*</span>features<span class="hl sym">*)</span>
    1363 <a id="l_1275"></a><span class="hl line"> 1275 </span>
    1364 <a id="l_1276"></a><span class="hl line"> 1276 </span>#<span class="hl sym">+</span>sbcl
    1365 <a id="l_1277"></a><span class="hl line"> 1277 </span><span class="hl sym">(</span><span class="hl kwa">eval</span>-when <span class="hl sym">(:</span>compile-toplevel <span class="hl sym">:</span><span class="hl kwa">load</span>-toplevel <span class="hl sym">:</span>execute<span class="hl sym">)</span>
    1366 <a id="l_1278"></a><span class="hl line"> 1278 </span>  <span class="hl sym">(</span>when <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>posix-<span class="hl kwa">getenv</span> <span class="hl str">&quot;SBCL_BUILDING_CONTRIB&quot;</span><span class="hl sym">)</span>
    1367 <a id="l_1279"></a><span class="hl line"> 1279 </span>    <span class="hl sym">(</span>pushnew <span class="hl sym">:</span>sbcl-hooks-require <span class="hl sym">*</span>features<span class="hl sym">*)))</span>
    1368 <a id="l_1280"></a><span class="hl line"> 1280 </span>
    1369 <a id="l_1281"></a><span class="hl line"> 1281 </span>#<span class="hl sym">+(</span><span class="hl kwa">and</span> sbcl sbcl-hooks-require<span class="hl sym">)</span>
    1370 <a id="l_1282"></a><span class="hl line"> 1282 </span><span class="hl sym">(</span><span class="hl kwa">progn</span>
    1371 <a id="l_1283"></a><span class="hl line"> 1283 </span>  <span class="hl sym">(</span><span class="hl kwa">defun</span> module-provide-asdf <span class="hl sym">(</span>name<span class="hl sym">)</span>
    1372 <a id="l_1284"></a><span class="hl line"> 1284 </span>    <span class="hl sym">(</span>handler-bind <span class="hl sym">((</span>style-warning #<span class="hl sym">'</span>muffle-warning<span class="hl sym">))</span>
    1373 <a id="l_1285"></a><span class="hl line"> 1285 </span>      <span class="hl sym">(</span>let<span class="hl sym">* ((*</span>verbose-out<span class="hl sym">* (</span>make-broadcast-stream<span class="hl sym">))</span>
    1374 <a id="l_1286"></a><span class="hl line"> 1286 </span>             <span class="hl sym">(</span>system <span class="hl sym">(</span>asdf<span class="hl sym">:</span>find-system name nil<span class="hl sym">)))</span>
    1375 <a id="l_1287"></a><span class="hl line"> 1287 </span>        <span class="hl sym">(</span>when system
    1376 <a id="l_1288"></a><span class="hl line"> 1288 </span>          <span class="hl sym">(</span>asdf<span class="hl sym">:</span>operate <span class="hl sym">'</span>asdf<span class="hl sym">:</span><span class="hl kwa">load</span>-op name<span class="hl sym">)</span>
    1377 <a id="l_1289"></a><span class="hl line"> 1289 </span>          t<span class="hl sym">))))</span>
    1378 <a id="l_1290"></a><span class="hl line"> 1290 </span>
    1379 <a id="l_1291"></a><span class="hl line"> 1291 </span>  <span class="hl sym">(</span><span class="hl kwa">defun</span> contrib-sysdef-search <span class="hl sym">(</span>system<span class="hl sym">)</span>
    1380 <a id="l_1292"></a><span class="hl line"> 1292 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>home <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>posix-<span class="hl kwa">getenv</span> <span class="hl str">&quot;SBCL_HOME&quot;</span><span class="hl sym">)))</span>
    1381 <a id="l_1293"></a><span class="hl line"> 1293 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> home <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>string<span class="hl sym">=</span> home <span class="hl str">&quot;&quot;</span><span class="hl sym">)))</span>
    1382 <a id="l_1294"></a><span class="hl line"> 1294 </span>        <span class="hl sym">(</span>let<span class="hl sym">* ((</span>name <span class="hl sym">(</span>coerce-name system<span class="hl sym">))</span>
    1383 <a id="l_1295"></a><span class="hl line"> 1295 </span>               <span class="hl sym">(</span>home <span class="hl sym">(</span>truename home<span class="hl sym">))</span>
    1384 <a id="l_1296"></a><span class="hl line"> 1296 </span>               <span class="hl sym">(</span>contrib <span class="hl sym">(</span>merge-pathnames
    1385 <a id="l_1297"></a><span class="hl line"> 1297 </span>                         <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>directory `<span class="hl sym">(:</span>relative <span class="hl sym">,</span>name<span class="hl sym">)</span>
    1386 <a id="l_1298"></a><span class="hl line"> 1298 </span>                                        <span class="hl sym">:</span>name name
    1387 <a id="l_1299"></a><span class="hl line"> 1299 </span>                                        <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;asd&quot;</span>
    1388 <a id="l_1300"></a><span class="hl line"> 1300 </span>                                        <span class="hl sym">:</span>case <span class="hl sym">:</span>local
    1389 <a id="l_1301"></a><span class="hl line"> 1301 </span>                                        <span class="hl sym">:</span>version <span class="hl sym">:</span>newest<span class="hl sym">)</span>
    1390 <a id="l_1302"></a><span class="hl line"> 1302 </span>                         home<span class="hl sym">)))</span>
    1391 <a id="l_1303"></a><span class="hl line"> 1303 </span>          <span class="hl sym">(</span>probe-file contrib<span class="hl sym">)))))</span>
    1392 <a id="l_1304"></a><span class="hl line"> 1304 </span>
    1393 <a id="l_1305"></a><span class="hl line"> 1305 </span>  <span class="hl sym">(</span>pushnew
    1394 <a id="l_1306"></a><span class="hl line"> 1306 </span>   <span class="hl sym">'(</span>let <span class="hl sym">((</span>home <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>posix-<span class="hl kwa">getenv</span> <span class="hl str">&quot;SBCL_HOME&quot;</span><span class="hl sym">)))</span>
    1395 <a id="l_1307"></a><span class="hl line"> 1307 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> home <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>string<span class="hl sym">=</span> home <span class="hl str">&quot;&quot;</span><span class="hl sym">)))</span>
    1396 <a id="l_1308"></a><span class="hl line"> 1308 </span>        <span class="hl sym">(</span>merge-pathnames <span class="hl str">&quot;site-systems/&quot;</span> <span class="hl sym">(</span>truename home<span class="hl sym">))))</span>
    1397 <a id="l_1309"></a><span class="hl line"> 1309 </span>   <span class="hl sym">*</span>central-registry<span class="hl sym">*)</span>
    1398 <a id="l_1310"></a><span class="hl line"> 1310 </span>
    1399 <a id="l_1311"></a><span class="hl line"> 1311 </span>  <span class="hl sym">(</span>pushnew
    1400 <a id="l_1312"></a><span class="hl line"> 1312 </span>   <span class="hl sym">'(</span>merge-pathnames <span class="hl str">&quot;.sbcl/systems/&quot;</span>
    1401 <a id="l_1313"></a><span class="hl line"> 1313 </span>     <span class="hl sym">(</span>user-homedir-pathname<span class="hl sym">))</span>
    1402 <a id="l_1314"></a><span class="hl line"> 1314 </span>   <span class="hl sym">*</span>central-registry<span class="hl sym">*)</span>
    1403 <a id="l_1315"></a><span class="hl line"> 1315 </span>
    1404 <a id="l_1316"></a><span class="hl line"> 1316 </span>  <span class="hl sym">(</span>pushnew <span class="hl sym">'</span>module-provide-asdf sb-ext<span class="hl sym">:*</span>module-provider-functions<span class="hl sym">*)</span>
    1405 <a id="l_1317"></a><span class="hl line"> 1317 </span>  <span class="hl sym">(</span>pushnew <span class="hl sym">'</span>contrib-sysdef-search <span class="hl sym">*</span>system-definition-search-functions<span class="hl sym">*))</span>
    1406 <a id="l_1318"></a><span class="hl line"> 1318 </span>
    1407 <a id="l_1319"></a><span class="hl line"> 1319 </span><span class="hl sym">(</span>provide <span class="hl sym">'</span>asdf<span class="hl sym">)</span>
    1408 </pre></div>
    1409 
    1410 <hr />
    1411 <table>
    1412 <tr>
    1413 <td>
    1414 <address><a href="http://sourceforge.net/">Back to SourceForge.net</a></address><br />
    1415 Powered by <a href="http://viewvc.tigris.org/">ViewVC 1.0.3</a>
    1416 </td>
    1417 <td style="text-align:right;">
    1418 <h3><a href="/*docroot*/help_rootview.html">ViewVC and Help</a></h3>
    1419 </td>
    1420 </tr>
    1421 </table>
    1422 </body>
    1423 </html>
    1424 
     1;;; This is asdf: Another System Definition Facility.  $Revision$
     2;;;
     3;;; 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/>
     7;;;
     8;;; If you obtained this copy from anywhere else, and you experience
     9;;; trouble using it, or find bugs, you may want to check at the
     10;;; location above for a more recent version (and for documentation
     11;;; and test files, if your copy came without them) before reporting
     12;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
     13;;; is the latest development version, whereas the revision tagged
     14;;; RELEASE may be slightly older but is considered `stable'
     15
     16;;; Copyright (c) 2001-2007 Daniel Barlow and contributors
     17;;;
     18;;; Permission is hereby granted, free of charge, to any person obtaining
     19;;; a copy of this software and associated documentation files (the
     20;;; "Software"), to deal in the Software without restriction, including
     21;;; without limitation the rights to use, copy, modify, merge, publish,
     22;;; distribute, sublicense, and/or sell copies of the Software, and to
     23;;; permit persons to whom the Software is furnished to do so, subject to
     24;;; the following conditions:
     25;;;
     26;;; The above copyright notice and this permission notice shall be
     27;;; included in all copies or substantial portions of the Software.
     28;;;
     29;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     30;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     31;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     32;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
     33;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
     34;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
     35;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
     36
     37;;; the problem with writing a defsystem replacement is bootstrapping:
     38;;; we can't use defsystem to compile it.  Hence, all in one file
     39
     40(defpackage #:asdf
     41  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
     42           #:system-definition-pathname #:find-component ; miscellaneous
     43           #:hyperdocumentation #:hyperdoc
     44
     45           #:compile-op #:load-op #:load-source-op #:test-system-version
     46           #:test-op
     47           #:operation                  ; operations
     48           #:feature                    ; sort-of operation
     49           #:version                    ; metaphorically sort-of an operation
     50
     51           #:input-files #:output-files #:perform       ; operation methods
     52           #:operation-done-p #:explain
     53
     54           #:component #:source-file
     55           #:c-source-file #:cl-source-file #:java-source-file
     56           #:static-file
     57           #:doc-file
     58           #:html-file
     59           #:text-file
     60           #:source-file-type
     61           #:module                     ; components
     62           #:system
     63           #:unix-dso
     64
     65           #:module-components          ; component accessors
     66           #:component-pathname
     67           #:component-relative-pathname
     68           #:component-name
     69           #:component-version
     70           #:component-parent
     71           #:component-property
     72           #:component-system
     73
     74           #:component-depends-on
     75
     76           #:system-description
     77           #:system-long-description
     78           #:system-author
     79           #:system-maintainer
     80           #:system-license
     81           #:system-licence
     82           #:system-source-file
     83           #:system-relative-pathname
     84
     85           #:operation-on-warnings
     86           #:operation-on-failure
     87
     88           ;#:*component-parent-pathname*
     89           #:*system-definition-search-functions*
     90           #:*central-registry*         ; variables
     91           #:*compile-file-warnings-behaviour*
     92           #:*compile-file-failure-behaviour*
     93           #:*asdf-revision*
     94
     95           #:operation-error #:compile-failed #:compile-warned #:compile-error
     96           #:error-component #:error-operation
     97           #:system-definition-error
     98           #:missing-component
     99           #:missing-dependency
     100           #:circular-dependency        ; errors
     101           #:duplicate-names
     102
     103           #:retry
     104           #:accept                     ; restarts
     105
     106           #:preference-file-for-system/operation
     107           #:load-preferences
     108           )
     109  (:use :cl))
     110
     111
     112#+nil
     113(error "The author of this file habitually uses #+nil to comment out ~
     114        forms. But don't worry, it was unlikely to work in the New ~
     115        Implementation of Lisp anyway")
     116
     117(in-package #:asdf)
     118
     119(defvar *asdf-revision* (let* ((v "$Revision$")
     120                               (colon (or (position #\: v) -1))
     121                               (dot (position #\. v)))
     122                          (and v colon dot
     123                               (list (parse-integer v :start (1+ colon)
     124                                                      :junk-allowed t)
     125                                     (parse-integer v :start (1+ dot)
     126                                                      :junk-allowed t)))))
     127
     128(defvar *compile-file-warnings-behaviour* :warn)
     129
     130(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
     131
     132(defvar *verbose-out* nil)
     133
     134(defparameter +asdf-methods+
     135  '(perform explain output-files operation-done-p))
     136
     137;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     138;; utility stuff
     139
     140(defmacro aif (test then &optional else)
     141  `(let ((it ,test)) (if it ,then ,else)))
     142
     143(defun pathname-sans-name+type (pathname)
     144  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     145and NIL NAME and TYPE components"
     146  (make-pathname :name nil :type nil :defaults pathname))
     147
     148(define-modify-macro appendf (&rest args)
     149  append "Append onto list")
     150
     151;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     152;; classes, condiitons
     153
     154(define-condition system-definition-error (error) ()
     155  ;; [this use of :report should be redundant, but unfortunately it's not.
     156  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
     157  ;; over print-object; this is always conditions::%print-condition for
     158  ;; condition objects, which in turn does inheritance of :report options at
     159  ;; run-time.  fortunately, inheritance means we only need this kludge here in
     160  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
     161  #+cmu (:report print-object))
     162
     163(define-condition formatted-system-definition-error (system-definition-error)
     164  ((format-control :initarg :format-control :reader format-control)
     165   (format-arguments :initarg :format-arguments :reader format-arguments))
     166  (:report (lambda (c s)
     167             (apply #'format s (format-control c) (format-arguments c)))))
     168
     169(define-condition circular-dependency (system-definition-error)
     170  ((components :initarg :components :reader circular-dependency-components)))
     171
     172(define-condition duplicate-names (system-definition-error)
     173  ((name :initarg :name :reader duplicate-names-name)))
     174
     175(define-condition missing-component (system-definition-error)
     176  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
     177   (version :initform nil :reader missing-version :initarg :version)
     178   (parent :initform nil :reader missing-parent :initarg :parent)))
     179
     180(define-condition missing-dependency (missing-component)
     181  ((required-by :initarg :required-by :reader missing-required-by)))
     182
     183(define-condition operation-error (error)
     184  ((component :reader error-component :initarg :component)
     185   (operation :reader error-operation :initarg :operation))
     186  (:report (lambda (c s)
     187             (format s "~@<erred while invoking ~A on ~A~@:>"
     188                     (error-operation c) (error-component c)))))
     189(define-condition compile-error (operation-error) ())
     190(define-condition compile-failed (compile-error) ())
     191(define-condition compile-warned (compile-error) ())
     192
     193(defclass component ()
     194  ((name :accessor component-name :initarg :name :documentation
     195         "Component name: designator for a string composed of portable pathname characters")
     196   (version :accessor component-version :initarg :version)
     197   (in-order-to :initform nil :initarg :in-order-to)
     198   ;; XXX crap name
     199   (do-first :initform nil :initarg :do-first)
     200   ;; methods defined using the "inline" style inside a defsystem form:
     201   ;; need to store them somewhere so we can delete them when the system
     202   ;; is re-evaluated
     203   (inline-methods :accessor component-inline-methods :initform nil)
     204   (parent :initarg :parent :initform nil :reader component-parent)
     205   ;; no direct accessor for pathname, we do this as a method to allow
     206   ;; it to default in funky ways if not supplied
     207   (relative-pathname :initarg :pathname)
     208   (operation-times :initform (make-hash-table )
     209                    :accessor component-operation-times)
     210   ;; XXX we should provide some atomic interface for updating the
     211   ;; component properties
     212   (properties :accessor component-properties :initarg :properties
     213               :initform nil)))
     214
     215;;;; methods: conditions
     216
     217(defmethod print-object ((c missing-dependency) s)
     218  (format s "~@<~A, required by ~A~@:>"
     219          (call-next-method c nil) (missing-required-by c)))
     220
     221(defun sysdef-error (format &rest arguments)
     222  (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
     223
     224;;;; methods: components
     225
     226(defmethod print-object ((c missing-component) s)
     227  (format s "~@<component ~S not found~
     228             ~@[ or does not match version ~A~]~
     229             ~@[ in ~A~]~@:>"
     230          (missing-requires c)
     231          (missing-version c)
     232          (when (missing-parent c)
     233            (component-name (missing-parent c)))))
     234
     235(defgeneric component-system (component)
     236  (:documentation "Find the top-level system containing COMPONENT"))
     237
     238(defmethod component-system ((component component))
     239  (aif (component-parent component)
     240       (component-system it)
     241       component))
     242
     243(defmethod print-object ((c component) stream)
     244  (print-unreadable-object (c stream :type t :identity t)
     245    (ignore-errors
     246      (prin1 (component-name c) stream))))
     247
     248(defclass module (component)
     249  ((components :initform nil :accessor module-components :initarg :components)
     250   ;; what to do if we can't satisfy a dependency of one of this module's
     251   ;; components.  This allows a limited form of conditional processing
     252   (if-component-dep-fails :initform :fail
     253                           :accessor module-if-component-dep-fails
     254                           :initarg :if-component-dep-fails)
     255   (default-component-class :accessor module-default-component-class
     256     :initform 'cl-source-file :initarg :default-component-class)))
     257
     258(defgeneric component-pathname (component)
     259  (:documentation "Extracts the pathname applicable for a particular component."))
     260
     261(defun component-parent-pathname (component)
     262  (aif (component-parent component)
     263       (component-pathname it)
     264       *default-pathname-defaults*))
     265
     266(defgeneric component-relative-pathname (component)
     267  (:documentation "Extracts the relative pathname applicable for a particular component."))
     268
     269(defmethod component-relative-pathname ((component module))
     270  (or (slot-value component 'relative-pathname)
     271      (make-pathname
     272       :directory `(:relative ,(component-name component))
     273       :host (pathname-host (component-parent-pathname component)))))
     274
     275(defmethod component-pathname ((component component))
     276  (let ((*default-pathname-defaults* (component-parent-pathname component)))
     277    (merge-pathnames (component-relative-pathname component))))
     278
     279(defgeneric component-property (component property))
     280
     281(defmethod component-property ((c component) property)
     282  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
     283
     284(defgeneric (setf component-property) (new-value component property))
     285
     286(defmethod (setf component-property) (new-value (c component) property)
     287  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
     288    (if a
     289        (setf (cdr a) new-value)
     290        (setf (slot-value c 'properties)
     291              (acons property new-value (slot-value c 'properties))))))
     292
     293(defclass system (module)
     294  ((description :accessor system-description :initarg :description)
     295   (long-description
     296    :accessor system-long-description :initarg :long-description)
     297   (author :accessor system-author :initarg :author)
     298   (maintainer :accessor system-maintainer :initarg :maintainer)
     299   (licence :accessor system-licence :initarg :licence
     300            :accessor system-license :initarg :license)))
     301
     302;;; version-satisfies
     303
     304;;; with apologies to christophe rhodes ...
     305(defun split (string &optional max (ws '(#\Space #\Tab)))
     306  (flet ((is-ws (char) (find char ws)))
     307    (nreverse
     308     (let ((list nil) (start 0) (words 0) end)
     309       (loop
     310         (when (and max (>= words (1- max)))
     311           (return (cons (subseq string start) list)))
     312         (setf end (position-if #'is-ws string :start start))
     313         (push (subseq string start end) list)
     314         (incf words)
     315         (unless end (return list))
     316         (setf start (1+ end)))))))
     317
     318(defgeneric version-satisfies (component version))
     319
     320(defmethod version-satisfies ((c component) version)
     321  (unless (and version (slot-boundp c 'version))
     322    (return-from version-satisfies t))
     323  (let ((x (mapcar #'parse-integer
     324                   (split (component-version c) nil '(#\.))))
     325        (y (mapcar #'parse-integer
     326                   (split version nil '(#\.)))))
     327    (labels ((bigger (x y)
     328               (cond ((not y) t)
     329                     ((not x) nil)
     330                     ((> (car x) (car y)) t)
     331                     ((= (car x) (car y))
     332                      (bigger (cdr x) (cdr y))))))
     333      (and (= (car x) (car y))
     334           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     335
     336;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     337;;; finding systems
     338
     339(defvar *defined-systems* (make-hash-table :test 'equal))
     340(defun coerce-name (name)
     341  (typecase name
     342    (component (component-name name))
     343    (symbol (string-downcase (symbol-name name)))
     344    (string name)
     345    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     346
     347;;; for the sake of keeping things reasonably neat, we adopt a
     348;;; convention that functions in this list are prefixed SYSDEF-
     349
     350(defvar *system-definition-search-functions*
     351  '(sysdef-central-registry-search))
     352
     353(defun system-definition-pathname (system)
     354  (some (lambda (x) (funcall x system))
     355        *system-definition-search-functions*))
     356
     357(defvar *central-registry*
     358  '(*default-pathname-defaults*
     359    #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
     360    #+nil "telent:asdf;systems;"))
     361
     362(defun sysdef-central-registry-search (system)
     363  (let ((name (coerce-name system)))
     364    (block nil
     365      (dolist (dir *central-registry*)
     366        (let* ((defaults (eval dir))
     367               (file (and defaults
     368                          (make-pathname
     369                           :defaults defaults :version :newest
     370                           :name name :type "asd" :case :local))))
     371          (if (and file (probe-file file))
     372              (return file)))))))
     373
     374(defun make-temporary-package ()
     375  (flet ((try (counter)
     376           (ignore-errors
     377             (make-package (format nil "ASDF~D" counter)
     378                           :use '(:cl :asdf)))))
     379    (do* ((counter 0 (+ counter 1))
     380          (package (try counter) (try counter)))
     381         (package package))))
     382
     383(defun find-system (name &optional (error-p t))
     384  (let* ((name (coerce-name name))
     385         (in-memory (gethash name *defined-systems*))
     386         (on-disk (system-definition-pathname name)))
     387    (when (and on-disk
     388               (or (not in-memory)
     389                   (< (car in-memory) (file-write-date on-disk))))
     390      (let ((package (make-temporary-package)))
     391        (unwind-protect
     392             (let ((*package* package))
     393               (format
     394                *verbose-out*
     395                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     396                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
     397                ;; ON-DISK), but CMUCL barfs on that.
     398                on-disk
     399                *package*)
     400               (load on-disk))
     401          (delete-package package))))
     402    (let ((in-memory (gethash name *defined-systems*)))
     403      (if in-memory
     404          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
     405                 (cdr in-memory))
     406          (if error-p (error 'missing-component :requires name))))))
     407
     408(defun register-system (name system)
     409  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
     410  (setf (gethash (coerce-name  name) *defined-systems*)
     411        (cons (get-universal-time) system)))
     412
     413(defun system-registered-p (name)
     414  (gethash (coerce-name name) *defined-systems*))
     415
     416;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     417;;; finding components
     418
     419(defgeneric find-component (module name &optional version)
     420  (:documentation "Finds the component with name NAME present in the
     421MODULE module; if MODULE is nil, then the component is assumed to be a
     422system."))
     423
     424(defmethod find-component ((module module) name &optional version)
     425  (if (slot-boundp module 'components)
     426      (let ((m (find name (module-components module)
     427                     :test #'equal :key #'component-name)))
     428        (if (and m (version-satisfies m version)) m))))
     429
     430
     431;;; a component with no parent is a system
     432(defmethod find-component ((module (eql nil)) name &optional version)
     433  (let ((m (find-system name nil)))
     434    (if (and m (version-satisfies m version)) m)))
     435
     436;;; component subclasses
     437
     438(defclass source-file (component) ())
     439
     440(defclass cl-source-file (source-file) ())
     441(defclass c-source-file (source-file) ())
     442(defclass java-source-file (source-file) ())
     443(defclass static-file (source-file) ())
     444(defclass doc-file (static-file) ())
     445(defclass html-file (doc-file) ())
     446
     447(defgeneric source-file-type (component system))
     448(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
     449(defmethod source-file-type ((c c-source-file) (s module)) "c")
     450(defmethod source-file-type ((c java-source-file) (s module)) "java")
     451(defmethod source-file-type ((c html-file) (s module)) "html")
     452(defmethod source-file-type ((c static-file) (s module)) nil)
     453
     454(defmethod component-relative-pathname ((component source-file))
     455  (let ((relative-pathname (slot-value component 'relative-pathname)))
     456    (if relative-pathname
     457        (merge-pathnames
     458         relative-pathname
     459         (make-pathname
     460          :type (source-file-type component (component-system component))))
     461        (let* ((*default-pathname-defaults*
     462                (component-parent-pathname component))
     463               (name-type
     464                (make-pathname
     465                 :name (component-name component)
     466                 :type (source-file-type component
     467                                         (component-system component)))))
     468          name-type))))
     469
     470;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     471;;; operations
     472
     473;;; one of these is instantiated whenever (operate ) is called
     474
     475(defclass operation ()
     476  ((forced :initform nil :initarg :force :accessor operation-forced)
     477   (original-initargs :initform nil :initarg :original-initargs
     478                      :accessor operation-original-initargs)
     479   (visited-nodes :initform nil :accessor operation-visited-nodes)
     480   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     481   (parent :initform nil :initarg :parent :accessor operation-parent)))
     482
     483(defmethod print-object ((o operation) stream)
     484  (print-unreadable-object (o stream :type t :identity t)
     485    (ignore-errors
     486      (prin1 (operation-original-initargs o) stream))))
     487
     488(defmethod shared-initialize :after ((operation operation) slot-names
     489                                     &key force
     490                                     &allow-other-keys)
     491  (declare (ignore slot-names force))
     492  ;; empty method to disable initarg validity checking
     493  )
     494
     495(defgeneric perform (operation component))
     496(defgeneric operation-done-p (operation component))
     497(defgeneric explain (operation component))
     498(defgeneric output-files (operation component))
     499(defgeneric input-files (operation component))
     500
     501(defun node-for (o c)
     502  (cons (class-name (class-of o)) c))
     503
     504(defgeneric operation-ancestor (operation)
     505  (:documentation
     506   "Recursively chase the operation's parent pointer until we get to
     507the head of the tree"))
     508
     509(defmethod operation-ancestor ((operation operation))
     510  (aif (operation-parent operation)
     511       (operation-ancestor it)
     512       operation))
     513
     514
     515(defun make-sub-operation (c o dep-c dep-o)
     516  (let* ((args (copy-list (operation-original-initargs o)))
     517         (force-p (getf args :force)))
     518    ;; note explicit comparison with T: any other non-NIL force value
     519    ;; (e.g. :recursive) will pass through
     520    (cond ((and (null (component-parent c))
     521                (null (component-parent dep-c))
     522                (not (eql c dep-c)))
     523           (when (eql force-p t)
     524             (setf (getf args :force) nil))
     525           (apply #'make-instance dep-o
     526                  :parent o
     527                  :original-initargs args args))
     528          ((subtypep (type-of o) dep-o)
     529           o)
     530          (t
     531           (apply #'make-instance dep-o
     532                  :parent o :original-initargs args args)))))
     533
     534
     535(defgeneric visit-component (operation component data))
     536
     537(defmethod visit-component ((o operation) (c component) data)
     538  (unless (component-visited-p o c)
     539    (push (cons (node-for o c) data)
     540          (operation-visited-nodes (operation-ancestor o)))))
     541
     542(defgeneric component-visited-p (operation component))
     543
     544(defmethod component-visited-p ((o operation) (c component))
     545  (assoc (node-for o c)
     546         (operation-visited-nodes (operation-ancestor o))
     547         :test 'equal))
     548
     549(defgeneric (setf visiting-component) (new-value operation component))
     550
     551(defmethod (setf visiting-component) (new-value operation component)
     552  ;; MCL complains about unused lexical variables
     553  (declare (ignorable new-value operation component)))
     554
     555(defmethod (setf visiting-component) (new-value (o operation) (c component))
     556  (let ((node (node-for o c))
     557        (a (operation-ancestor o)))
     558    (if new-value
     559        (pushnew node (operation-visiting-nodes a) :test 'equal)
     560        (setf (operation-visiting-nodes a)
     561              (remove node  (operation-visiting-nodes a) :test 'equal)))))
     562
     563(defgeneric component-visiting-p (operation component))
     564
     565(defmethod component-visiting-p ((o operation) (c component))
     566  (let ((node (cons o c)))
     567    (member node (operation-visiting-nodes (operation-ancestor o))
     568            :test 'equal)))
     569
     570(defgeneric component-depends-on (operation component)
     571  (:documentation
     572   "Returns a list of dependencies needed by the component to perform
     573    the operation.  A dependency has one of the following forms:
     574
     575      (<operation> <component>*), where <operation> is a class
     576        designator and each <component> is a component
     577        designator, which means that the component depends on
     578        <operation> having been performed on each <component>; or
     579
     580      (FEATURE <feature>), which means that the component depends
     581        on <feature>'s presence in *FEATURES*.
     582
     583    Methods specialized on subclasses of existing component types
     584    should usually append the results of CALL-NEXT-METHOD to the
     585    list."))
     586
     587(defmethod component-depends-on ((op-spec symbol) (c component))
     588  (component-depends-on (make-instance op-spec) c))
     589
     590(defmethod component-depends-on ((o operation) (c component))
     591  (cdr (assoc (class-name (class-of o))
     592              (slot-value c 'in-order-to))))
     593
     594(defgeneric component-self-dependencies (operation component))
     595
     596(defmethod component-self-dependencies ((o operation) (c component))
     597  (let ((all-deps (component-depends-on o c)))
     598    (remove-if-not (lambda (x)
     599                     (member (component-name c) (cdr x) :test #'string=))
     600                   all-deps)))
     601
     602(defmethod input-files ((operation operation) (c component))
     603  (let ((parent (component-parent c))
     604        (self-deps (component-self-dependencies operation c)))
     605    (if self-deps
     606        (mapcan (lambda (dep)
     607                  (destructuring-bind (op name) dep
     608                    (output-files (make-instance op)
     609                                  (find-component parent name))))
     610                self-deps)
     611        ;; no previous operations needed?  I guess we work with the
     612        ;; original source file, then
     613        (list (component-pathname c)))))
     614
     615(defmethod input-files ((operation operation) (c module)) nil)
     616
     617(defmethod operation-done-p ((o operation) (c component))
     618  (flet ((fwd-or-return-t (file)
     619           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
     620           ;; user or some other agent has deleted an input file.  If
     621           ;; that's the case, well, that's not good, but as long as
     622           ;; the operation is otherwise considered to be done we
     623           ;; could continue and survive.
     624           (let ((date (file-write-date file)))
     625             (cond
     626               (date)
     627               (t
     628                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
     629                       operation ~S on component ~S as done.~@:>"
     630                      file o c)
     631                (return-from operation-done-p t))))))
     632    (let ((out-files (output-files o c))
     633          (in-files (input-files o c)))
     634      (cond ((and (not in-files) (not out-files))
     635             ;; arbitrary decision: an operation that uses nothing to
     636             ;; produce nothing probably isn't doing much
     637             t)
     638            ((not out-files)
     639             (let ((op-done
     640                    (gethash (type-of o)
     641                             (component-operation-times c))))
     642               (and op-done
     643                    (>= op-done
     644                        (apply #'max
     645                               (mapcar #'fwd-or-return-t in-files))))))
     646            ((not in-files) nil)
     647            (t
     648             (and
     649              (every #'probe-file out-files)
     650              (> (apply #'min (mapcar #'file-write-date out-files))
     651                 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
     652
     653;;; So you look at this code and think "why isn't it a bunch of
     654;;; methods".  And the answer is, because standard method combination
     655;;; runs :before methods most->least-specific, which is back to front
     656;;; for our purposes.  And CLISP doesn't have non-standard method
     657;;; combinations, so let's keep it simple and aspire to portability
     658
     659(defgeneric traverse (operation component))
     660(defmethod traverse ((operation operation) (c component))
     661  (let ((forced nil))
     662    (labels ((do-one-dep (required-op required-c required-v)
     663               (let* ((dep-c (or (find-component
     664                                  (component-parent c)
     665                                  ;; XXX tacky.  really we should build the
     666                                  ;; in-order-to slot with canonicalized
     667                                  ;; names instead of coercing this late
     668                                  (coerce-name required-c) required-v)
     669                                 (error 'missing-dependency
     670                                        :required-by c
     671                                        :version required-v
     672                                        :requires required-c)))
     673                      (op (make-sub-operation c operation dep-c required-op)))
     674                 (traverse op dep-c)))
     675             (do-dep (op dep)
     676               (cond ((eq op 'feature)
     677                      (or (member (car dep) *features*)
     678                          (error 'missing-dependency
     679                                 :required-by c
     680                                 :requires (car dep)
     681                                 :version nil)))
     682                     (t
     683                      (dolist (d dep)
     684                        (cond ((consp d)
     685                               (assert (string-equal
     686                                        (symbol-name (first d))
     687                                        "VERSION"))
     688                               (appendf forced
     689                                        (do-one-dep op (second d) (third d))))
     690                              (t
     691                               (appendf forced (do-one-dep op d nil)))))))))
     692      (aif (component-visited-p operation c)
     693           (return-from traverse
     694             (if (cdr it) (list (cons 'pruned-op c)) nil)))
     695      ;; dependencies
     696      (if (component-visiting-p operation c)
     697          (error 'circular-dependency :components (list c)))
     698      (setf (visiting-component operation c) t)
     699      (loop for (required-op . deps) in (component-depends-on operation c)
     700            do (do-dep required-op deps))
     701      ;; constituent bits
     702      (let ((module-ops
     703             (when (typep c 'module)
     704               (let ((at-least-one nil)
     705                     (forced nil)
     706                     (error nil))
     707                 (loop for kid in (module-components c)
     708                       do (handler-case
     709                              (appendf forced (traverse operation kid ))
     710                            (missing-dependency (condition)
     711                              (if (eq (module-if-component-dep-fails c) :fail)
     712                                  (error condition))
     713                              (setf error condition))
     714                            (:no-error (c)
     715                              (declare (ignore c))
     716                              (setf at-least-one t))))
     717                 (when (and (eq (module-if-component-dep-fails c) :try-next)
     718                            (not at-least-one))
     719                   (error error))
     720                 forced))))
     721        ;; now the thing itself
     722        (when (or forced module-ops
     723                  (not (operation-done-p operation c))
     724                  (let ((f (operation-forced (operation-ancestor operation))))
     725                    (and f (or (not (consp f))
     726                               (member (component-name
     727                                        (operation-ancestor operation))
     728                                       (mapcar #'coerce-name f)
     729                                       :test #'string=)))))
     730          (let ((do-first (cdr (assoc (class-name (class-of operation))
     731                                      (slot-value c 'do-first)))))
     732            (loop for (required-op . deps) in do-first
     733                  do (do-dep required-op deps)))
     734          (setf forced (append (delete 'pruned-op forced :key #'car)
     735                               (delete 'pruned-op module-ops :key #'car)
     736                               (list (cons operation c))))))
     737      (setf (visiting-component operation c) nil)
     738      (visit-component operation c (and forced t))
     739      forced)))
     740
     741
     742(defmethod perform ((operation operation) (c source-file))
     743  (sysdef-error
     744   "~@<required method PERFORM not implemented ~
     745    for operation ~A, component ~A~@:>"
     746   (class-of operation) (class-of c)))
     747
     748(defmethod perform ((operation operation) (c module))
     749  nil)
     750
     751(defmethod explain ((operation operation) (component component))
     752  (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
     753
     754;;; compile-op
     755
     756(defclass compile-op (operation)
     757  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
     758   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
     759                :initform *compile-file-warnings-behaviour*)
     760   (on-failure :initarg :on-failure :accessor operation-on-failure
     761               :initform *compile-file-failure-behaviour*)))
     762
     763(defmethod perform :before ((operation compile-op) (c source-file))
     764  (map nil #'ensure-directories-exist (output-files operation c)))
     765
     766(defmethod perform :after ((operation operation) (c component))
     767  (setf (gethash (type-of operation) (component-operation-times c))
     768        (get-universal-time))
     769  (load-preferences c operation))
     770
     771;;; perform is required to check output-files to find out where to put
     772;;; its answers, in case it has been overridden for site policy
     773(defmethod perform ((operation compile-op) (c cl-source-file))
     774  #-:broken-fasl-loader
     775  (let ((source-file (component-pathname c))
     776        (output-file (car (output-files operation c))))
     777    (multiple-value-bind (output warnings-p failure-p)
     778        (compile-file source-file :output-file output-file)
     779      (when warnings-p
     780        (case (operation-on-warnings operation)
     781          (:warn (warn
     782                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
     783                  operation c))
     784          (:error (error 'compile-warned :component c :operation operation))
     785          (:ignore nil)))
     786      (when failure-p
     787        (case (operation-on-failure operation)
     788          (:warn (warn
     789                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
     790                  operation c))
     791          (:error (error 'compile-failed :component c :operation operation))
     792          (:ignore nil)))
     793      (unless output
     794        (error 'compile-error :component c :operation operation)))))
     795
     796(defmethod output-files ((operation compile-op) (c cl-source-file))
     797  #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
     798  #+:broken-fasl-loader (list (component-pathname c)))
     799
     800(defmethod perform ((operation compile-op) (c static-file))
     801  nil)
     802
     803(defmethod output-files ((operation compile-op) (c static-file))
     804  nil)
     805
     806(defmethod input-files ((op compile-op) (c static-file))
     807  nil)
     808
     809
     810;;; load-op
     811
     812(defclass basic-load-op (operation) ())
     813
     814(defclass load-op (basic-load-op) ())
     815
     816(defmethod perform ((o load-op) (c cl-source-file))
     817  (mapcar #'load (input-files o c)))
     818
     819(defmethod perform ((operation load-op) (c static-file))
     820  nil)
     821(defmethod operation-done-p ((operation load-op) (c static-file))
     822  t)
     823
     824(defmethod output-files ((o operation) (c component))
     825  nil)
     826
     827(defmethod component-depends-on ((operation load-op) (c component))
     828  (cons (list 'compile-op (component-name c))
     829        (call-next-method)))
     830
     831;;; load-source-op
     832
     833(defclass load-source-op (basic-load-op) ())
     834
     835(defmethod perform ((o load-source-op) (c cl-source-file))
     836  (let ((source (component-pathname c)))
     837    (setf (component-property c 'last-loaded-as-source)
     838          (and (load source)
     839               (get-universal-time)))))
     840
     841(defmethod perform ((operation load-source-op) (c static-file))
     842  nil)
     843
     844(defmethod output-files ((operation load-source-op) (c component))
     845  nil)
     846
     847;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
     848(defmethod component-depends-on ((o load-source-op) (c component))
     849  (let ((what-would-load-op-do (cdr (assoc 'load-op
     850                                           (slot-value c 'in-order-to)))))
     851    (mapcar (lambda (dep)
     852              (if (eq (car dep) 'load-op)
     853                  (cons 'load-source-op (cdr dep))
     854                  dep))
     855            what-would-load-op-do)))
     856
     857(defmethod operation-done-p ((o load-source-op) (c source-file))
     858  (if (or (not (component-property c 'last-loaded-as-source))
     859          (> (file-write-date (component-pathname c))
     860             (component-property c 'last-loaded-as-source)))
     861      nil t))
     862
     863(defclass test-op (operation) ())
     864
     865(defmethod perform ((operation test-op) (c component))
     866  nil)
     867
     868(defgeneric load-preferences (system operation)
     869  (:documentation
     870   "Called to load system preferences after <perform operation
     871system>. Typical uses are to set parameters that don't exist until
     872after the system has been loaded."))
     873
     874(defgeneric preference-file-for-system/operation (system operation)
     875  (:documentation
     876   "Returns the pathname of the preference file for this system.
     877Called by 'load-preferences to determine what file to load."))
     878
     879(defmethod load-preferences ((s t) (operation t))
     880  ;; do nothing
     881  (values))
     882
     883(defmethod load-preferences ((s system) (operation basic-load-op))
     884  (let* ((*package* (find-package :common-lisp))
     885         (file (probe-file (preference-file-for-system/operation s operation))))
     886    (when file
     887      (when *verbose-out*
     888        (format *verbose-out*
     889                "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
     890                (component-name s)
     891                (type-of operation) file))
     892      (load file))))
     893
     894(defmethod preference-file-for-system/operation ((system t) (operation t))
     895  ;; cope with anything other than systems
     896  (preference-file-for-system/operation (find-system system t) operation))
     897
     898(defmethod preference-file-for-system/operation ((s system) (operation t))
     899  (let ((*default-pathname-defaults*
     900         (make-pathname :name nil :type nil
     901                        :defaults *default-pathname-defaults*)))
     902     (merge-pathnames
     903      (make-pathname :name (component-name s)
     904                     :type "lisp"
     905                     :directory '(:relative ".asdf"))
     906      (truename (user-homedir-pathname)))))
     907
     908;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     909;;; invoking operations
     910
     911(defvar *operate-docstring*
     912  "Operate does three things:
     913
     9141. It creates an instance of `operation-class` using any keyword parameters
     915as initargs.
     9162. It finds the  asdf-system specified by `system` (possibly loading
     917it from disk).
     9183. It then calls `traverse` with the operation and system as arguments
     919
     920The traverse operation is wrapped in `with-compilation-unit` and error
     921handling code. If a `version` argument is supplied, then operate also
     922ensures that the system found satisfies it using the `version-satisfies`
     923method.")
     924
     925(defun operate (operation-class system &rest args &key (verbose t) version
     926                &allow-other-keys)
     927  (let* ((op (apply #'make-instance operation-class
     928                    :original-initargs args
     929                    args))
     930         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
     931         (system (if (typep system 'component) system (find-system system))))
     932    (unless (version-satisfies system version)
     933      (error 'missing-component :requires system :version version))
     934    (let ((steps (traverse op system)))
     935      (with-compilation-unit ()
     936        (loop for (op . component) in steps do
     937                 (loop
     938                   (restart-case
     939                       (progn (perform op component)
     940                              (return))
     941                     (retry ()
     942                       :report
     943                       (lambda (s)
     944                         (format s "~@<Retry performing ~S on ~S.~@:>"
     945                                 op component)))
     946                     (accept ()
     947                       :report
     948                       (lambda (s)
     949                         (format s "~@<Continue, treating ~S on ~S as ~
     950                                   having been successful.~@:>"
     951                                 op component))
     952                       (setf (gethash (type-of op)
     953                                      (component-operation-times component))
     954                             (get-universal-time))
     955                       (return)))))))))
     956
     957(setf (documentation 'operate 'function)
     958      *operate-docstring*)
     959
     960(defun oos (operation-class system &rest args &key force (verbose t) version)
     961  (declare (ignore force verbose version))
     962  (apply #'operate operation-class system args))
     963
     964(setf (documentation 'oos 'function)
     965      (format nil
     966              "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
     967              *operate-docstring*))
     968
     969;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     970;;; syntax
     971
     972(defun remove-keyword (key arglist)
     973  (labels ((aux (key arglist)
     974             (cond ((null arglist) nil)
     975                   ((eq key (car arglist)) (cddr arglist))
     976                   (t (cons (car arglist) (cons (cadr arglist)
     977                                                (remove-keyword
     978                                                 key (cddr arglist))))))))
     979    (aux key arglist)))
     980
     981(defmacro defsystem (name &body options)
     982  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
     983                            &allow-other-keys)
     984      options
     985    (let ((component-options (remove-keyword :class options)))
     986      `(progn
     987         ;; system must be registered before we parse the body, otherwise
     988         ;; we recur when trying to find an existing system of the same name
     989         ;; to reuse options (e.g. pathname) from
     990         (let ((s (system-registered-p ',name)))
     991           (cond ((and s (eq (type-of (cdr s)) ',class))
     992                  (setf (car s) (get-universal-time)))
     993                 (s
     994                  #+clisp
     995                  (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
     996                  #-clisp
     997                  (change-class (cdr s) ',class))
     998                 (t
     999                  (register-system (quote ,name)
     1000                                   (make-instance ',class :name ',name)))))
     1001         (parse-component-form nil (apply
     1002                                    #'list
     1003                                    :module (coerce-name ',name)
     1004                                    :pathname
     1005                                    ;; to avoid a note about unreachable code
     1006                                    ,(if pathname-arg-p
     1007                                         pathname
     1008                                         `(or (when *load-truename*
     1009                                                (pathname-sans-name+type
     1010                                                 (resolve-symlinks
     1011                                                  *load-truename*)))
     1012                                              *default-pathname-defaults*))
     1013                                    ',component-options))))))
     1014
     1015
     1016(defun class-for-type (parent type)
     1017  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
     1018                              (find-symbol (symbol-name type)
     1019                                           (load-time-value
     1020                                            (package-name :asdf)))))
     1021         (class (dolist (symbol (if (keywordp type)
     1022                                    extra-symbols
     1023                                    (cons type extra-symbols)))
     1024                  (when (and symbol
     1025                             (find-class symbol nil)
     1026                             (subtypep symbol 'component))
     1027                    (return (find-class symbol))))))
     1028    (or class
     1029        (and (eq type :file)
     1030             (or (module-default-component-class parent)
     1031                 (find-class 'cl-source-file)))
     1032        (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
     1033
     1034(defun maybe-add-tree (tree op1 op2 c)
     1035  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
     1036Returns the new tree (which probably shares structure with the old one)"
     1037  (let ((first-op-tree (assoc op1 tree)))
     1038    (if first-op-tree
     1039        (progn
     1040          (aif (assoc op2 (cdr first-op-tree))
     1041               (if (find c (cdr it))
     1042                   nil
     1043                   (setf (cdr it) (cons c (cdr it))))
     1044               (setf (cdr first-op-tree)
     1045                     (acons op2 (list c) (cdr first-op-tree))))
     1046          tree)
     1047        (acons op1 (list (list op2 c)) tree))))
     1048
     1049(defun union-of-dependencies (&rest deps)
     1050  (let ((new-tree nil))
     1051    (dolist (dep deps)
     1052      (dolist (op-tree dep)
     1053        (dolist (op  (cdr op-tree))
     1054          (dolist (c (cdr op))
     1055            (setf new-tree
     1056                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
     1057    new-tree))
     1058
     1059
     1060(defun remove-keys (key-names args)
     1061  (loop for ( name val ) on args by #'cddr
     1062        unless (member (symbol-name name) key-names
     1063                       :key #'symbol-name :test 'equal)
     1064        append (list name val)))
     1065
     1066(defvar *serial-depends-on*)
     1067
     1068(defun parse-component-form (parent options)
     1069
     1070  (destructuring-bind
     1071        (type name &rest rest &key
     1072              ;; the following list of keywords is reproduced below in the
     1073              ;; remove-keys form.  important to keep them in sync
     1074              components pathname default-component-class
     1075              perform explain output-files operation-done-p
     1076              weakly-depends-on
     1077              depends-on serial in-order-to
     1078              ;; list ends
     1079              &allow-other-keys) options
     1080    (declare (ignorable perform explain output-files operation-done-p))
     1081    (check-component-input type name weakly-depends-on depends-on components in-order-to)
     1082
     1083    (when (and parent
     1084               (find-component parent name)
     1085               ;; ignore the same object when rereading the defsystem
     1086               (not
     1087                (typep (find-component parent name)
     1088                       (class-for-type parent type))))
     1089      (error 'duplicate-names :name name))
     1090
     1091    (let* ((other-args (remove-keys
     1092                        '(components pathname default-component-class
     1093                          perform explain output-files operation-done-p
     1094                          weakly-depends-on
     1095                          depends-on serial in-order-to)
     1096                        rest))
     1097           (ret
     1098            (or (find-component parent name)
     1099                (make-instance (class-for-type parent type)))))
     1100      (when weakly-depends-on
     1101        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
     1102      (when (boundp '*serial-depends-on*)
     1103        (setf depends-on
     1104              (concatenate 'list *serial-depends-on* depends-on)))
     1105      (apply #'reinitialize-instance ret
     1106             :name (coerce-name name)
     1107             :pathname pathname
     1108             :parent parent
     1109             other-args)
     1110      (when (typep ret 'module)
     1111        (setf (module-default-component-class ret)
     1112              (or default-component-class
     1113                  (and (typep parent 'module)
     1114                       (module-default-component-class parent))))
     1115        (let ((*serial-depends-on* nil))
     1116          (setf (module-components ret)
     1117                (loop for c-form in components
     1118                      for c = (parse-component-form ret c-form)
     1119                      collect c
     1120                      if serial
     1121                      do (push (component-name c) *serial-depends-on*))))
     1122
     1123        ;; check for duplicate names
     1124        (let ((name-hash (make-hash-table :test #'equal)))
     1125          (loop for c in (module-components ret)
     1126                do
     1127                (if (gethash (component-name c)
     1128                             name-hash)
     1129                    (error 'duplicate-names
     1130                           :name (component-name c))
     1131                    (setf (gethash (component-name c)
     1132                                   name-hash)
     1133                          t)))))
     1134
     1135      (setf (slot-value ret 'in-order-to)
     1136            (union-of-dependencies
     1137             in-order-to
     1138             `((compile-op (compile-op ,@depends-on))
     1139               (load-op (load-op ,@depends-on))))
     1140            (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
     1141
     1142      (%remove-component-inline-methods ret rest)
     1143
     1144      ret)))
     1145
     1146(defun %remove-component-inline-methods (ret rest)
     1147  (loop for name in +asdf-methods+
     1148        do (map 'nil
     1149                ;; this is inefficient as most of the stored
     1150                ;; methods will not be for this particular gf n
     1151                ;; But this is hardly performance-critical
     1152                (lambda (m)
     1153                  (remove-method (symbol-function name) m))
     1154                (component-inline-methods ret)))
     1155  ;; clear methods, then add the new ones
     1156  (setf (component-inline-methods ret) nil)
     1157  (loop for name in +asdf-methods+
     1158        for v = (getf rest (intern (symbol-name name) :keyword))
     1159        when v do
     1160        (destructuring-bind (op qual (o c) &body body) v
     1161          (pushnew
     1162           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
     1163                             ,@body))
     1164           (component-inline-methods ret)))))
     1165
     1166(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
     1167  "A partial test of the values of a component."
     1168  (when weakly-depends-on (warn "We got one! XXXXX"))
     1169  (unless (listp depends-on)
     1170    (sysdef-error-component ":depends-on must be a list."
     1171                            type name depends-on))
     1172  (unless (listp weakly-depends-on)
     1173    (sysdef-error-component ":weakly-depends-on must be a list."
     1174                            type name weakly-depends-on))
     1175  (unless (listp components)
     1176    (sysdef-error-component ":components must be NIL or a list of components."
     1177                            type name components))
     1178  (unless (and (listp in-order-to) (listp (car in-order-to)))
     1179    (sysdef-error-component ":in-order-to must be NIL or a list of components."
     1180                            type name in-order-to)))
     1181
     1182(defun sysdef-error-component (msg type name value)
     1183  (sysdef-error (concatenate 'string msg
     1184                             "~&The value specified for ~(~A~) ~A is ~W")
     1185                type name value))
     1186
     1187(defun resolve-symlinks (path)
     1188  #-allegro (truename path)
     1189  #+allegro (excl:pathname-resolve-symbolic-links path)
     1190  )
     1191
     1192;;; optional extras
     1193
     1194;;; run-shell-command functions for other lisp implementations will be
     1195;;; gratefully accepted, if they do the same thing.  If the docstring
     1196;;; is ambiguous, send a bug report
     1197
     1198(defun run-shell-command (control-string &rest args)
     1199  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
     1200synchronously execute the result using a Bourne-compatible shell, with
     1201output to *VERBOSE-OUT*.  Returns the shell's exit code."
     1202  (let ((command (apply #'format nil control-string args)))
     1203    (format *verbose-out* "; $ ~A~%" command)
     1204    #+sbcl
     1205    (sb-ext:process-exit-code
     1206     (sb-ext:run-program
     1207      #+win32 "sh" #-win32 "/bin/sh"
     1208      (list  "-c" command)
     1209      #+win32 #+win32 :search t
     1210      :input nil :output *verbose-out*))
     1211
     1212    #+(or cmu scl)
     1213    (ext:process-exit-code
     1214     (ext:run-program
     1215      "/bin/sh"
     1216      (list  "-c" command)
     1217      :input nil :output *verbose-out*))
     1218
     1219    #+allegro
     1220    (excl:run-shell-command command :input nil :output *verbose-out*)
     1221
     1222    #+lispworks
     1223    (system:call-system-showing-output
     1224     command
     1225     :shell-type "/bin/sh"
     1226     :output-stream *verbose-out*)
     1227
     1228    #+clisp                     ;XXX not exactly *verbose-out*, I know
     1229    (ext:run-shell-command  command :output :terminal :wait t)
     1230
     1231    #+openmcl
     1232    (nth-value 1
     1233               (ccl:external-process-status
     1234                (ccl:run-program "/bin/sh" (list "-c" command)
     1235                                 :input nil :output *verbose-out*
     1236                                 :wait t)))
     1237    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     1238    (si:system command)
     1239    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
     1240    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
     1241    ))
     1242
     1243
     1244(defgeneric hyperdocumentation (package name doc-type))
     1245(defmethod hyperdocumentation ((package symbol) name doc-type)
     1246  (hyperdocumentation (find-package package) name doc-type))
     1247
     1248(defun hyperdoc (name doc-type)
     1249  (hyperdocumentation (symbol-package name) name doc-type))
     1250
     1251(defun system-source-file (system-name)
     1252  (let ((system (asdf:find-system system-name)))
     1253    (make-pathname
     1254     :type "asd"
     1255     :name (asdf:component-name system)
     1256     :defaults (asdf:component-relative-pathname system))))
     1257
     1258(defun system-source-directory (system-name)
     1259  (make-pathname :name nil
     1260                 :type nil
     1261                 :defaults (system-source-file system-name)))
     1262
     1263(defun system-relative-pathname (system pathname &key name type)
     1264  (let ((directory (pathname-directory pathname)))
     1265    (when (eq (car directory) :absolute)
     1266      (setf (car directory) :relative))
     1267    (merge-pathnames
     1268     (make-pathname :name (or name (pathname-name pathname))
     1269                    :type (or type (pathname-type pathname))
     1270                    :directory directory)
     1271     (system-source-directory system))))
     1272
     1273
     1274(pushnew :asdf *features*)
     1275
     1276#+sbcl
     1277(eval-when (:compile-toplevel :load-toplevel :execute)
     1278  (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
     1279    (pushnew :sbcl-hooks-require *features*)))
     1280
     1281#+(and sbcl sbcl-hooks-require)
     1282(progn
     1283  (defun module-provide-asdf (name)
     1284    (handler-bind ((style-warning #'muffle-warning))
     1285      (let* ((*verbose-out* (make-broadcast-stream))
     1286             (system (asdf:find-system name nil)))
     1287        (when system
     1288          (asdf:operate 'asdf:load-op name)
     1289          t))))
     1290
     1291  (defun contrib-sysdef-search (system)
     1292    (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
     1293      (when (and home (not (string= home "")))
     1294        (let* ((name (coerce-name system))
     1295               (home (truename home))
     1296               (contrib (merge-pathnames
     1297                         (make-pathname :directory `(:relative ,name)
     1298                                        :name name
     1299                                        :type "asd"
     1300                                        :case :local
     1301                                        :version :newest)
     1302                         home)))
     1303          (probe-file contrib)))))
     1304
     1305  (pushnew
     1306   '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
     1307      (when (and home (not (string= home "")))
     1308        (merge-pathnames "site-systems/" (truename home))))
     1309   *central-registry*)
     1310
     1311  (pushnew
     1312   '(merge-pathnames ".sbcl/systems/"
     1313     (user-homedir-pathname))
     1314   *central-registry*)
     1315
     1316  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
     1317  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
     1318
     1319(provide 'asdf)
Note: See TracChangeset for help on using the changeset viewer.