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

Last change on this file since 14196 was 14196, checked in by Mark Evenson, 8 years ago

SYS:SHA256 efficiently computes cryptographic hashs on pathnames.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 21.4 KB
Line 
1;;; compile-system.lisp
2;;;
3;;; Copyright (C) 2004-2008 Peter Graves
4;;; $Id: compile-system.lisp 14196 2012-10-14 10:54:05Z 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                                                     ;;; ### TODO: Support SETF functions
154                                                     (and (symbolp x)
155                                                          (eq (symbol-package x)
156                                                              filter-package)))
157                                                   (cdr x))))
158                            filesets-symbols))))
159    (write-autoloader stream package type filtered-filesets)))
160
161(defun load-combos (path-spec)
162  (let (all-functions)
163    (dolist (functions-file (directory path-spec)
164             all-functions)
165      ;; every file has 1 form: the list of functions in it.
166      (let ((base-name (pathname-name functions-file)))
167        (unless (member base-name '("asdf" "gray-streams") :test #'string=)
168          ;; exclude ASDF and GRAY-STREAMS: they have external
169          ;; symbols we don't have until we load them, but we need
170          ;; those symbols to read the symbols files
171          (with-open-file (f functions-file
172                             :direction :input)
173            (dolist (function-name (read f))
174              (push (list base-name function-name) all-functions))))))))
175
176(defun generate-autoloads (symbol-files-pathspec)
177  (flet ((filter-combos (combos)
178           (remove-multi-combo-symbols
179            (remove-if (lambda (x)
180                         ;; exclude the symbols from the files
181                         ;; below: putting autoloaders on some of
182                         ;; the symbols conflicts with the bootstrapping
183                         ;; Primitives which have been defined Java-side
184                         (member x '( ;; function definitions to be excluded
185                                     "fdefinition" "early-defuns"
186                                     "require" "signal" "restart"
187
188                                     ;; extensible sequences override
189                                     ;; lots of default functions;
190                                     ;; java-collections implements
191                                     ;; extensible sequences
192                                     "extensible-sequences-base"
193                                     "extensible-sequences" "java-collections"
194
195                                     ;; macro definitions to be excluded
196                                     "macros" ;; "backquote"
197                                     "precompiler")
198                                 :test #'string=))
199                       combos
200                       :key #'first)))
201         (symbols-pathspec (filespec)
202           (merge-pathnames filespec symbol-files-pathspec)))
203    (let ((funcs (filter-combos (load-combos (symbols-pathspec "*.funcs"))))
204          (macs (filter-combos (load-combos (symbols-pathspec "*.macs"))))
205          (exps (filter-combos (load-combos (symbols-pathspec "*.exps")))))
206      (with-open-file (f (symbols-pathspec "autoloads-gen.lisp")
207                         :direction :output :if-does-not-exist :create
208                         :if-exists :supersede)
209        ;; Generate the lisp file. This file will be included after compilation,
210        ;; so any comments are just for debugging purposes.
211        (terpri f)
212        (write-line ";; ---- GENERATED CONTENT BELOW" f)
213        (terpri f)
214        (dolist (package '(:format :sequence :loop :mop :xp :precompiler
215                           :profiler :java :jvm :extensions :threads
216                           :top-level :system :cl))
217          ;; Limit the set of packages:
218          ;;  During incremental compilation, the packages GRAY-STREAMS
219          ;;    and ASDF are not being created. Nor are these packages
220          ;;    vital to the correct operation of the base system.
221
222          (let* ((*package* (find-package package))
223                 (all-exported-symbols
224                  (remove-duplicates (mapcar #'second exps)))
225                 (externals (remove-if-not (lambda (sym)
226                                             (eq (symbol-package sym)
227                                                 *package*))
228                                           all-exported-symbols)))
229            (when externals
230              (write-line ";; EXPORTS" f)
231              (write `(cl:in-package ,package) :stream f)
232              (terpri f)
233              (write `(cl:export ',externals) :stream f)
234              (terpri f)))
235
236
237          (terpri f)
238          (write-line ";; FUNCTIONS" f)
239          (terpri f)
240          (write-package-filesets f package 'ext:autoload
241                                  (combos-to-fileset-symbols funcs))
242          (terpri f)
243          (write-line ";; MACROS" f)
244          (terpri f)
245          (write-package-filesets f package 'ext:autoload-macro
246                                  (combos-to-fileset-symbols macs)))))))
247
248
249;;
250;; --- End of autoloads.lisp
251;;
252
253
254(defun %compile-system (&key output-path)
255  (let ((*default-pathname-defaults* (pathname *lisp-home*))
256        (*warn-on-redefinition* nil)
257        (*prevent-fasl-circle-detection* t))
258    (unless output-path
259      (setf output-path *default-pathname-defaults*))
260    (flet ((do-compile (file &key (extract t))
261             (let ((out (make-pathname :type *compile-file-type*
262                                       :defaults (merge-pathnames
263                                                  file output-path))))
264               (compile-file-if-needed file
265                                       :output-file out
266                                       :extract-toplevel-funcs-and-macros extract))))
267      (load (do-compile "defstruct.lisp"))
268      (load (do-compile "coerce.lisp"))
269      (load (do-compile "open.lisp"))
270      (load (do-compile "dump-form.lisp"))
271      (load (do-compile "compiler-types.lisp"))
272      (load (do-compile "compile-file.lisp"))
273      (load (do-compile "precompiler.lisp"))
274      (load (do-compile "compiler-pass1.lisp"))
275      (load (do-compile "compiler-pass2.lisp"))
276      (load (do-compile "jvm-class-file.lisp"))
277      (load (do-compile "jvm.lisp"))
278      (load (do-compile "source-transform.lisp"))
279      (load (do-compile "compiler-macro.lisp"))
280      (load (do-compile "jvm-instructions.lisp"))
281      (load (do-compile "setf.lisp"))
282      (load (do-compile "extensible-sequences-base.lisp"))
283      (load (do-compile "require.lisp"))
284      (load (do-compile "substitute.lisp"))
285      (load (do-compile "clos.lisp"))
286      (load (do-compile "mop.lisp"))
287      ;; Order matters for these files.
288      (mapc #'do-compile '("collect.lisp"
289                           "macros.lisp"
290                           "loop.lisp"))
291      (load (do-compile "backquote.lisp"))
292      (load (do-compile "early-defuns.lisp"))
293      (load (do-compile "typep.lisp"))
294      (load (do-compile "subtypep.lisp"))
295      (load (do-compile "find.lisp"))
296      (load (do-compile "print.lisp"))
297      (load (do-compile "pprint-dispatch.lisp"))
298      (load (do-compile "pprint.lisp"))
299      (load (do-compile "format.lisp"))
300      (load (do-compile "delete.lisp"))
301      (load (do-compile "concatenate.lisp"))
302      (load (do-compile "ldb.lisp"))
303      (load (do-compile "destructuring-bind.lisp"))
304      (load (do-compile "asdf.lisp"))
305      ;; But not for these.
306      (mapc #'do-compile '("abcl-contrib.lisp"
307                           "adjoin.lisp"
308                           "and.lisp"
309                           "apropos.lisp"
310                           "arrays.lisp"
311                           "assert.lisp"
312                           "assoc.lisp"
313                           "aver.lisp"
314                           "bit-array-ops.lisp"
315                           "boole.lisp"
316                           "butlast.lisp"
317                           "byte-io.lisp"
318                           "case.lisp"
319                           "chars.lisp"
320                           "check-type.lisp"
321                           "compile-file-pathname.lisp"
322                           "compile-system.lisp"
323                           "compiler-error.lisp"
324                           "cond.lisp"
325                           "copy-seq.lisp"
326                           "copy-symbol.lisp"
327                           "count.lisp"
328                           "digest.lisp"
329                           "debug.lisp"
330                           "define-modify-macro.lisp"
331                           "define-symbol-macro.lisp"
332                           "defmacro.lisp"
333                           "defpackage.lisp"
334                           "defsetf.lisp"
335                           "deftype.lisp"
336                           "delete-duplicates.lisp"
337                           "deposit-field.lisp"
338                           "describe.lisp"
339                           "describe-compiler-policy.lisp"
340                           "directory.lisp"
341                           "disassemble.lisp"
342                           "do-all-symbols.lisp"
343                           "do-external-symbols.lisp"
344                           "do-symbols.lisp"
345                           "do.lisp"
346                           "dolist.lisp"
347                           "dotimes.lisp"
348                           "dribble.lisp"
349                           "dump-class.lisp"
350                           "ed.lisp"
351                           "enough-namestring.lisp"
352                           "ensure-directories-exist.lisp"
353                           "error.lisp"
354                           "extensible-sequences.lisp"
355                           "featurep.lisp"
356                           "fdefinition.lisp"
357                           "fill.lisp"
358                           "find-all-symbols.lisp"
359                           "gentemp.lisp"
360                           "gray-streams.lisp"
361                           "gui.lisp"
362                           "inline.lisp"
363                           "inspect.lisp"
364                           "java.lisp"
365                           "java-collections.lisp"
366                           "known-functions.lisp"
367                           "known-symbols.lisp"
368                           "late-setf.lisp"
369                           "lcm.lisp"
370                           "ldiff.lisp"
371                           "list-length.lisp"
372                           "list.lisp"
373                           "load.lisp"
374                           "make-hash-table.lisp"
375                           "make-load-form-saving-slots.lisp"
376                           "make-sequence.lisp"
377                           "make-string-output-stream.lisp"
378                           "make-string.lisp"
379                           "map-into.lisp"
380                           "map.lisp"
381                           "map1.lisp"
382                           "mask-field.lisp"
383                           "member-if.lisp"
384                           "mismatch.lisp"
385                           "multiple-value-bind.lisp"
386                           "multiple-value-list.lisp"
387                           "multiple-value-setq.lisp"
388                           "nsubstitute.lisp"
389                           "nth-value.lisp"
390                           "numbers.lisp"
391                           "or.lisp"
392                           "parse-integer.lisp"
393                           "parse-lambda-list.lisp"
394                           "package.lisp"
395                           "pathnames.lisp"
396                           "print-object.lisp"
397                           "print-unreadable-object.lisp"
398                           "proclaim.lisp"
399                           "profiler.lisp"
400                           "prog.lisp"
401                           "psetf.lisp"
402                           "query.lisp"
403                           "read-circle.lisp"
404                           "read-conditional.lisp"
405                           "read-from-string.lisp"
406                           "read-sequence.lisp"
407                           "reduce.lisp"
408                           "remf.lisp"
409                           "remove-duplicates.lisp"
410                           "remove.lisp"
411                           "replace.lisp"
412                           "restart.lisp"
413                           "revappend.lisp"
414                           "rotatef.lisp"
415                           "run-program.lisp"
416                           "run-shell-command.lisp"
417                           "runtime-class.lisp"
418                           "search.lisp"
419                           "sequences.lisp"
420                           "sets.lisp"
421                           "shiftf.lisp"
422                           "signal.lisp"
423                           "socket.lisp"
424                           "sort.lisp"
425                           "step.lisp"
426                           "strings.lisp"
427                           "sublis.lisp"
428                           "subst.lisp"
429                           "tailp.lisp"
430                           "threads.lisp"
431                           "time.lisp"
432                           "top-level.lisp"
433                           "trace.lisp"
434                           "tree-equal.lisp"
435                           "upgraded-complex-part-type.lisp"
436                           "with-accessors.lisp"
437                           "with-hash-table-iterator.lisp"
438                           "with-input-from-string.lisp"
439                           "with-open-file.lisp"
440                           "with-output-to-string.lisp"
441                           "with-package-iterator.lisp"
442                           "with-slots.lisp"
443                           "with-standard-io-syntax.lisp"
444                           "write-sequence.lisp"))
445      ;; With all files compiled, we need to use the symbols collected
446      ;; to generate and compile autoloads.lisp
447
448      ;; Generate the autoloads-gen file in the build directory in order
449      ;; not to clobber the source file - that should keep the system
450      ;; buildable
451
452      (format t "; Generating autoloads...~%")
453      (generate-autoloads output-path)
454      ;; Compile the file in the build directory instead of the one in the
455      ;; sources directory - the latter being for bootstrapping only.
456      (do-compile (merge-pathnames #p"autoloads-gen.lisp" output-path)
457        :extract nil)
458      (do-compile "autoloads.lisp"
459        :extract nil))
460    t))
461
462(defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path)
463  (let ((status -1)
464  (*compile-file-class-extension* cls-ext)
465  (*compile-file-type* abcl-ext))
466    (check-lisp-home)
467    (time
468     (with-compilation-unit ()
469       (let ((*compile-file-zip* zip)
470             failure-p)
471         (handler-bind (((or warning
472                             compiler-error)
473                         #'(lambda (c)
474                             (declare (ignore c))
475                             (setf failure-p t)
476                             ;; only register that we had this type of signal
477                             ;; defer the actual handling to another handler
478                             nil)))
479           (%compile-system :output-path output-path))
480         (unless failure-p
481           (setf status 0)))))
482    (create-system-logical-translations output-path)
483    (when quit
484      (quit :status status))))
485
486(defun create-system-logical-translations (output-path)
487  (let* ((dir (directory-namestring (pathname output-path)))
488         (system (merge-pathnames "system.lisp" dir))
489         (home (pathname *lisp-home*))
490         (src (format nil "~A**/*.*" home))
491         (java (format nil "~A../../../**/*.*" home)))
492    (with-open-file (s system :direction :output 
493                       :if-exists :supersede)
494      (pprint `(setf (logical-pathname-translations "sys")
495                    '(("SYS:SRC;**;*.*" ,src)
496                      ("SYS:JAVA;**;*.*" ,java)))
497       s))))
498     
Note: See TracBrowser for help on using the repository browser.