source: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp @ 14817

Last change on this file since 14817 was 14817, checked in by Mark Evenson, 7 years ago

Place 'asdf' and 'abcl-contrib' at end of system compilation

ASDF-3.1.5 uses the long form of DEFSETF which caused the
%COMPILE-SYSTEM to fail as 'asdf' was being compiled before 'defsetf'.
Since ASDF should have all of Common Lisp available anyways, we place
it at the end of build compilation. Since 'abcl-contrib' uses 'asdf'
to locate contribs, we place that after ASDF.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 22.5 KB
Line 
1;;; compile-system.lisp
2;;;
3;;; Copyright (C) 2004-2008 Peter Graves
4;;; $Id: compile-system.lisp 14817 2015-09-15 13:19:02Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34(require "LOOP")
35(require "COLLECT")
36(require "COMPILE-FILE")
37
38(export '(grovel-java-definitions-in-file compile-system))
39
40
41(defun check-lisp-home ()
42  (loop
43    (cond ((and *lisp-home*
44                (probe-directory (pathname *lisp-home*)))
45           (return))
46          (t
47           (cerror "Continue"
48                   "*LISP-HOME* is NIL or invalid.~%  Please set *LISP-HOME* to the full pathname of the directory containing the Lisp system files.")))))
49
50(defun grovel-java-definitions-in-file (file out)
51  (with-open-file (in file)
52    (declare (type stream in))
53    (let ((system-package (find-package "SYSTEM"))
54          (line-number 1))
55      (loop
56        (let ((text (read-line in nil)))
57          (when (null text)
58            (return))
59          (let ((position (search "###" text)))
60            (when position
61                 (let* ((name (string (read-from-string (subseq text (+ position 3)))))
62                        (symbol (or (find-symbol name system-package) ; uses CL and EXT
63                                    (find-symbol name (find-package "MOP"))
64                                    (find-symbol name (find-package "JAVA")))))
65                   (when symbol
66                     ;; Force the symbol's package prefix to be written out
67                     ;; with "::" instead of ":" so there won't be a reader
68                     ;; error if a symbol that's external now is no longer
69                     ;; external when we read the tags file.
70                     (%format out "~A::~A ~S ~S~%"
71                              (package-name (symbol-package symbol))
72                              name
73                              file line-number)))))
74          (incf line-number))))))
75
76(defun grovel-java-definitions ()
77  (check-lisp-home)
78  (time
79   (let ((files (directory (merge-pathnames "*.java" *lisp-home*))))
80     (with-open-file (stream (merge-pathnames "tags" *lisp-home*)
81                             :direction :output :if-exists :supersede)
82       (dolist (file files)
83         (grovel-java-definitions-in-file file stream))))))
84
85
86;;
87;; Functions to generate autoloads.lisp
88;;
89
90(defun packages-from-combos (combos)
91  (remove-duplicates (mapcar #'symbol-package
92                             (mapcar #'sys:fdefinition-block-name
93                                     (mapcar #'second combos)))))
94
95(defun remove-multi-combo-symbols (combos)
96  (princ "; Removing multi-homed symbols")
97  (let ((sym-hash (make-hash-table :size (* 2 (length combos)))))
98    (dolist (combo combos)
99      (incf (gethash (second combo) sym-hash 0)))
100    (print (remove-if-not (lambda (x)
101                            (< 1 (gethash x sym-hash)))
102                          combos
103                          :key #'second))
104    (remove-if (lambda (x)
105                 (< 1 (gethash x sym-hash)))
106               combos
107               :key #'second)))
108
109(defun set-equal (set1 set2 &key test)
110  (or (eq set1 set2)
111      (equal set1 set2)
112      (and (subsetp set2 set1 :test test)
113           (subsetp set1 set2 :test test))))
114
115(defun combos-to-symbol-filesets (combos)
116  (let (filesets)
117    (dolist (combo combos)
118      (pushnew (list (second combo)) filesets :test #'equal :key #'first)
119      (pushnew (first combo)
120               (cdr (assoc (second combo) filesets :test #'equal))
121               :test #'string=))
122    filesets))
123
124(defun combos-to-fileset-symbols (combos)
125  (let (fileset-symbols)
126    (dolist (symbol-fileset (combos-to-symbol-filesets combos))
127      (pushnew (list (cdr symbol-fileset)) fileset-symbols
128               :test (lambda (x y) (set-equal x y :test #'string=))
129               :key #'first)
130      (pushnew (first symbol-fileset)
131               (cdr (assoc (cdr symbol-fileset) fileset-symbols
132                           :test (lambda (x y)
133                                   (set-equal x y :test #'string=))))))
134    fileset-symbols))
135
136(defun write-autoloader (stream package type fileset-symbols)
137  (when fileset-symbols
138    (write `(in-package ,package) :stream stream)
139    (terpri stream)
140    (let ((*package* (find-package package)))
141      (write `(dolist (fs ',fileset-symbols)
142                (funcall #',type (cdr fs) (car (car fs)))) :stream stream)
143      (terpri stream))))
144
145(defun write-package-filesets (stream package type filesets-symbols)
146  (let* ((filter-package (find-package package))
147         (filtered-filesets
148         (remove-if (lambda (x)
149                      (null (cdr x)))
150                    (mapcar (lambda (x)
151                               (cons (car x)
152                                    (remove-if-not (lambda (x)
153                                                      (and (symbolp x)
154                                                           (eq (symbol-package x)
155                                                               filter-package)))
156                                                   (cdr x))))
157                            filesets-symbols))))
158    (write-autoloader stream package type filtered-filesets)))
159
160(defun load-combos (path-spec)
161  (let (all-functions)
162    (dolist (functions-file (directory path-spec)
163             all-functions)
164      ;; every file has 1 form: the list of functions in it.
165      (let ((base-name (pathname-name functions-file)))
166        (unless (member base-name '("asdf" "gray-streams") :test #'string=)
167          ;; exclude ASDF and GRAY-STREAMS: they have external
168          ;; symbols we don't have until we load them, but we need
169          ;; those symbols to read the symbols files
170          (with-open-file (f functions-file
171                             :direction :input)
172            (dolist (function-name (read f))
173              (push (list base-name function-name) all-functions))))))))
174
175(defun generate-autoloads (symbol-files-pathspec)
176  (labels ((filter-combos (combos)
177             (remove-multi-combo-symbols
178              (remove-if (lambda (x)
179                           ;; exclude the symbols from the files
180                           ;; below: putting autoloaders on some of
181                           ;; the symbols conflicts with the bootstrapping
182                           ;; Primitives which have been defined Java-side
183                           (member x '( ;; function definitions to be excluded
184                                       "fdefinition" "early-defuns"
185                                       "require" "signal" "restart"
186
187                                       ;; extensible sequences override
188                                       ;; lots of default functions;
189                                       ;; java-collections implements
190                                       ;; extensible sequences
191                                       "extensible-sequences-base"
192                                       "extensible-sequences" "java-collections"
193
194                                       ;; macro definitions to be excluded
195                                       "macros" ;; "backquote"
196                                       "precompiler")
197                                   :test #'string=))
198                         combos
199                         :key #'first)))
200           (filter-setf-combos (combos)
201             (filter-combos 
202              (remove-multi-combo-symbols
203               (remove-if (lambda (x) (member x '("clos") :test #'string=)) combos :key #'first))))
204           (symbols-pathspec (filespec)
205             (merge-pathnames filespec symbol-files-pathspec)))
206    (let ((funcs (filter-combos (load-combos (symbols-pathspec "*.funcs"))))
207          (macs (filter-combos (load-combos (symbols-pathspec "*.macs"))))
208          (setf-functions (filter-setf-combos (load-combos (symbols-pathspec "*.setf-functions"))))
209          (setf-expanders (filter-setf-combos (load-combos (symbols-pathspec "*.setf-expanders"))))
210          (exps (filter-combos (load-combos (symbols-pathspec "*.exps")))))
211      (with-open-file (f (symbols-pathspec "autoloads-gen.lisp")
212                         :direction :output :if-does-not-exist :create
213                         :if-exists :supersede)
214        ;; Generate the lisp file. This file will be included after compilation,
215        ;; so any comments are just for debugging purposes.
216        (terpri f)
217        (write-line ";; ---- GENERATED CONTENT BELOW" f)
218        (terpri f)
219        (dolist (package '(:format :sequence :loop :mop :xp :precompiler
220                           :profiler :java :jvm :extensions :threads
221                           :top-level :system :cl))
222          ;; Limit the set of packages:
223          ;;  During incremental compilation, the packages GRAY-STREAMS
224          ;;    and ASDF are not being created. Nor are these packages
225          ;;    vital to the correct operation of the base system.
226
227          (let* ((*package* (find-package package))
228                 (all-exported-symbols
229                  (remove-duplicates (mapcar #'second exps)))
230                 (externals (remove-if-not (lambda (sym)
231                                             (eq (symbol-package sym)
232                                                 *package*))
233                                           all-exported-symbols)))
234            (when externals
235              (write-line ";; EXPORTS" f)
236              (write `(cl:in-package ,package) :stream f)
237              (terpri f)
238              (write `(cl:export ',externals) :stream f)
239              (terpri f)))
240
241
242          (terpri f)
243          (write-line ";; FUNCTIONS" f)
244          (terpri f)
245          (write-package-filesets f package 'ext:autoload
246                                  (combos-to-fileset-symbols funcs))
247          (terpri f)
248          (write-line ";; MACROS" f)
249          (terpri f)
250          (write-package-filesets f package 'ext:autoload-macro
251                                  (combos-to-fileset-symbols macs))
252
253          (terpri f)
254
255          (write-line ";; SETF-FUNCTIONS" f)
256          (terpri f)
257          (write-package-filesets f package 'ext:autoload-setf-function
258                                    (combos-to-fileset-symbols setf-functions))
259          (terpri f)
260          (write-line ";; SETF-EXPANDERS" f)
261          (terpri f)
262          (write-package-filesets f package 'ext:autoload-setf-expander
263                                  (combos-to-fileset-symbols setf-expanders)))))))
264
265;;
266;; --- End of autoloads.lisp
267;;
268
269
270(defun %compile-system (&key output-path)
271  (let ((*default-pathname-defaults* (pathname *lisp-home*))
272        (*warn-on-redefinition* nil)
273        (*prevent-fasl-circle-detection* t))
274    (unless output-path
275      (setf output-path *default-pathname-defaults*))
276    (flet ((do-compile (file &key (extract t))
277             (let ((out (make-pathname :type *compile-file-type*
278                                       :defaults (merge-pathnames
279                                                  file output-path))))
280               (compile-file-if-needed file
281                                       :output-file out
282                                       :extract-toplevel-funcs-and-macros extract))))
283      (load (do-compile "defstruct.lisp"))
284      (load (do-compile "coerce.lisp"))
285      (load (do-compile "open.lisp"))
286      (load (do-compile "dump-form.lisp"))
287      (load (do-compile "compiler-types.lisp"))
288      (load (do-compile "compile-file.lisp"))
289      (load (do-compile "precompiler.lisp"))
290      (load (do-compile "compiler-pass1.lisp"))
291      (load (do-compile "compiler-pass2.lisp"))
292      (load (do-compile "jvm-class-file.lisp"))
293      (load (do-compile "jvm.lisp"))
294      (load (do-compile "source-transform.lisp"))
295      (load (do-compile "compiler-macro.lisp"))
296      (load (do-compile "jvm-instructions.lisp"))
297      (load (do-compile "setf.lisp"))
298      (load (do-compile "extensible-sequences-base.lisp"))
299      (load (do-compile "require.lisp"))
300      (load (do-compile "substitute.lisp"))
301      (load (do-compile "clos.lisp"))
302      (load (do-compile "mop.lisp"))
303      ;; Order matters for these files.
304      (mapc #'do-compile '("collect.lisp"
305                           "macros.lisp"
306                           "loop.lisp"))
307      (load (do-compile "backquote.lisp"))
308      (load (do-compile "early-defuns.lisp"))
309      (load (do-compile "typep.lisp"))
310      (load (do-compile "subtypep.lisp"))
311      (load (do-compile "find.lisp"))
312      (load (do-compile "print.lisp"))
313      (load (do-compile "pprint-dispatch.lisp"))
314      (load (do-compile "pprint.lisp"))
315      (load (do-compile "format.lisp"))
316      (load (do-compile "delete.lisp"))
317      (load (do-compile "concatenate.lisp"))
318      (load (do-compile "ldb.lisp"))
319      (load (do-compile "destructuring-bind.lisp"))
320      ;; But not for these.
321      (mapc #'do-compile '("adjoin.lisp"
322                           "and.lisp"
323                           "apropos.lisp"
324                           "arrays.lisp"
325                           "assert.lisp"
326                           "assoc.lisp"
327                           "aver.lisp"
328                           "bit-array-ops.lisp"
329                           "boole.lisp"
330                           "butlast.lisp"
331                           "byte-io.lisp"
332                           "case.lisp"
333                           "chars.lisp"
334                           "check-type.lisp"
335                           "compile-file-pathname.lisp"
336                           "compile-system.lisp"
337                           "compiler-error.lisp"
338                           "cond.lisp"
339                           "copy-seq.lisp"
340                           "copy-symbol.lisp"
341                           "count.lisp"
342                           "digest.lisp"
343                           "debug.lisp"
344                           "define-modify-macro.lisp"
345                           "define-symbol-macro.lisp"
346                           "defmacro.lisp"
347                           "defpackage.lisp"
348                           "defsetf.lisp"
349                           "deftype.lisp"
350                           "delete-duplicates.lisp"
351                           "deposit-field.lisp"
352                           "describe.lisp"
353                           "describe-compiler-policy.lisp"
354                           "directory.lisp"
355                           "disassemble.lisp"
356                           "do-all-symbols.lisp"
357                           "do-external-symbols.lisp"
358                           "do-symbols.lisp"
359                           "do.lisp"
360                           "documentation.lisp"
361                           "dolist.lisp"
362                           "dotimes.lisp"
363                           "dribble.lisp"
364                           "dump-class.lisp"
365                           "ed.lisp"
366                           "enough-namestring.lisp"
367                           "ensure-directories-exist.lisp"
368                           "error.lisp"
369                           "extensible-sequences.lisp"
370                           "fasl-concat.lisp"
371                           "featurep.lisp"
372                           "fdefinition.lisp"
373                           "fill.lisp"
374                           "find-all-symbols.lisp"
375                           "gentemp.lisp"
376                           "gray-streams.lisp"
377                           "gui.lisp"
378                           "inline.lisp"
379                           "inspect.lisp"
380                           "java.lisp"
381                           "java-collections.lisp"
382                           "known-functions.lisp"
383                           "known-symbols.lisp"
384                           "late-setf.lisp"
385                           "lcm.lisp"
386                           "ldiff.lisp"
387                           "list-length.lisp"
388                           "list.lisp"
389                           "load.lisp"
390                           "make-hash-table.lisp"
391                           "make-load-form-saving-slots.lisp"
392                           "make-sequence.lisp"
393                           "make-string-output-stream.lisp"
394                           "make-string.lisp"
395                           "map-into.lisp"
396                           "map.lisp"
397                           "map1.lisp"
398                           "mask-field.lisp"
399                           "member-if.lisp"
400                           "mismatch.lisp"
401                           "multiple-value-bind.lisp"
402                           "multiple-value-list.lisp"
403                           "multiple-value-setq.lisp"
404                           "nsubstitute.lisp"
405                           "nth-value.lisp"
406                           "numbers.lisp"
407                           "or.lisp"
408                           "parse-integer.lisp"
409                           "parse-lambda-list.lisp"
410                           "package.lisp"
411                           "pathnames.lisp"
412                           "print-object.lisp"
413                           "print-unreadable-object.lisp"
414                           "proclaim.lisp"
415                           "profiler.lisp"
416                           "prog.lisp"
417                           "psetf.lisp"
418                           "query.lisp"
419                           "read-circle.lisp"
420                           "read-conditional.lisp"
421                           "read-from-string.lisp"
422                           "read-sequence.lisp"
423                           "reduce.lisp"
424                           "remf.lisp"
425                           "remove-duplicates.lisp"
426                           "remove.lisp"
427                           "replace.lisp"
428                           "restart.lisp"
429                           "revappend.lisp"
430                           "rotatef.lisp"
431                           "run-program.lisp"
432                           "run-shell-command.lisp"
433                           "runtime-class.lisp"
434                           "search.lisp"
435                           "sequences.lisp"
436                           "sets.lisp"
437                           "shiftf.lisp"
438                           "signal.lisp"
439                           "socket.lisp"
440                           "sort.lisp"
441                           "step.lisp"
442                           "strings.lisp"
443                           "sublis.lisp"
444                           "subst.lisp"
445                           "tailp.lisp"
446                           "threads.lisp"
447                           "time.lisp"
448                           "top-level.lisp"
449                           "trace.lisp"
450                           "tree-equal.lisp"
451                           "upgraded-complex-part-type.lisp"
452                           "with-accessors.lisp"
453                           "with-hash-table-iterator.lisp"
454                           "with-input-from-string.lisp"
455                           "with-open-file.lisp"
456                           "with-output-to-string.lisp"
457                           "with-package-iterator.lisp"
458                           "with-slots.lisp"
459                           "with-standard-io-syntax.lisp"
460                           "write-sequence.lisp"))
461
462      ;; Compile ASDF after the whole ANSI system has been
463      ;; constructed.
464      (load (do-compile "asdf.lisp"))
465      ;; ABCL-CONTRIB depends on ASDF
466      (load (do-compile "abcl-contrib.lisp"))
467
468
469      ;; With all files compiled, we need to use the symbols collected
470      ;; to generate and compile autoloads.lisp
471
472      ;; Generate the autoloads-gen file in the build directory in order
473      ;; not to clobber the source file - that should keep the system
474      ;; buildable
475
476      (format t "; Generating autoloads...~%")
477      (generate-autoloads output-path)
478      ;; Compile the file in the build directory instead of the one in the
479      ;; sources directory - the latter being for bootstrapping only.
480      (do-compile (merge-pathnames #p"autoloads-gen.lisp" output-path)
481        :extract nil)
482      (do-compile "autoloads.lisp"
483        :extract nil))
484    t))
485
486(defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path)
487  (let ((status -1)
488  (*compile-file-class-extension* cls-ext)
489  (*compile-file-type* abcl-ext))
490    (check-lisp-home)
491    (time
492     (with-compilation-unit ()
493       (let ((*compile-file-zip* zip)
494             failure-p)
495         (handler-bind (((or warning
496                             compiler-error)
497                         #'(lambda (c)
498                             (declare (ignore c))
499                             (setf failure-p t)
500                             ;; only register that we had this type of signal
501                             ;; defer the actual handling to another handler
502                             nil)))
503           (%compile-system :output-path output-path))
504         (unless failure-p
505           (setf status 0)))))
506    (create-system-logical-translations output-path)
507    (when quit
508      (quit :status status))))
509
510(defun create-system-logical-translations (output-path)
511  (let* ((dir (directory-namestring (pathname output-path)))
512         (system (merge-pathnames "system.lisp" dir))
513         (home (pathname *lisp-home*))
514         (src (format nil "~A**/*.*" home))
515         (java (format nil "~A../../../**/*.*" home)))
516    (with-open-file (s system :direction :output 
517                       :if-exists :supersede)
518      (pprint `(setf (logical-pathname-translations "sys")
519                    '(("SYS:SRC;**;*.*" ,src)
520                      ("SYS:JAVA;**;*.*" ,java)))
521       s))))
522     
Note: See TracBrowser for help on using the repository browser.