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

Last change on this file was 14931, checked in by Mark Evenson, 4 years ago

Bless EXT:GET-PID as the offical way to get procees id

Regenerate TeX artifacts. My they were a bit dusty…

N.b. under pure Threaded OS platforms such as Microsoft Windows, there
is no valid process id.

  • 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 14931 2016-12-27 20:06:20Z 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      (load (do-compile "featurep.lisp"))
321
322      ;; But not for these.
323      (mapc #'do-compile '("adjoin.lisp"
324                           "and.lisp"
325                           "apropos.lisp"
326                           "arrays.lisp"
327                           "assert.lisp"
328                           "assoc.lisp"
329                           "aver.lisp"
330                           "bit-array-ops.lisp"
331                           "boole.lisp"
332                           "butlast.lisp"
333                           "byte-io.lisp"
334                           "case.lisp"
335                           "chars.lisp"
336                           "check-type.lisp"
337                           "compile-file-pathname.lisp"
338                           "compile-system.lisp"
339                           "compiler-error.lisp"
340                           "cond.lisp"
341                           "copy-seq.lisp"
342                           "copy-symbol.lisp"
343                           "count.lisp"
344                           "digest.lisp"
345                           "debug.lisp"
346                           "define-modify-macro.lisp"
347                           "define-symbol-macro.lisp"
348                           "defmacro.lisp"
349                           "defpackage.lisp"
350                           "defsetf.lisp"
351                           "deftype.lisp"
352                           "delete-duplicates.lisp"
353                           "deposit-field.lisp"
354                           "describe.lisp"
355                           "describe-compiler-policy.lisp"
356                           "directory.lisp"
357                           "disassemble.lisp"
358                           "do-all-symbols.lisp"
359                           "do-external-symbols.lisp"
360                           "do-symbols.lisp"
361                           "do.lisp"
362                           "documentation.lisp"
363                           "dolist.lisp"
364                           "dotimes.lisp"
365                           "dribble.lisp"
366                           "dump-class.lisp"
367                           "ed.lisp"
368                           "enough-namestring.lisp"
369                           "ensure-directories-exist.lisp"
370                           "error.lisp"
371                           "extensible-sequences.lisp"
372                           "fasl-concat.lisp"
373                           "fdefinition.lisp"
374                           "fill.lisp"
375                           "find-all-symbols.lisp"
376                           "get-pid.lisp"
377                           "gentemp.lisp"
378                           "gray-streams.lisp"
379                           "gui.lisp"
380                           "inline.lisp"
381                           "inspect.lisp"
382                           "java.lisp"
383                           "java-collections.lisp"
384                           "known-functions.lisp"
385                           "known-symbols.lisp"
386                           "late-setf.lisp"
387                           "lcm.lisp"
388                           "ldiff.lisp"
389                           "list-length.lisp"
390                           "list.lisp"
391                           "load.lisp"
392                           "make-hash-table.lisp"
393                           "make-load-form-saving-slots.lisp"
394                           "make-sequence.lisp"
395                           "make-string-output-stream.lisp"
396                           "make-string.lisp"
397                           "map-into.lisp"
398                           "map.lisp"
399                           "map1.lisp"
400                           "mask-field.lisp"
401                           "member-if.lisp"
402                           "mismatch.lisp"
403                           "multiple-value-bind.lisp"
404                           "multiple-value-list.lisp"
405                           "multiple-value-setq.lisp"
406                           "nsubstitute.lisp"
407                           "nth-value.lisp"
408                           "numbers.lisp"
409                           "or.lisp"
410                           "parse-integer.lisp"
411                           "parse-lambda-list.lisp"
412                           "package.lisp"
413                           "pathnames.lisp"
414                           "print-object.lisp"
415                           "print-unreadable-object.lisp"
416                           "proclaim.lisp"
417                           "profiler.lisp"
418                           "prog.lisp"
419                           "psetf.lisp"
420                           "query.lisp"
421                           "read-circle.lisp"
422                           "read-conditional.lisp"
423                           "read-from-string.lisp"
424                           "read-sequence.lisp"
425                           "reduce.lisp"
426                           "remf.lisp"
427                           "remove-duplicates.lisp"
428                           "remove.lisp"
429                           "replace.lisp"
430                           "restart.lisp"
431                           "revappend.lisp"
432                           "rotatef.lisp"
433                           "run-program.lisp"
434                           "run-shell-command.lisp"
435                           "runtime-class.lisp"
436                           "search.lisp"
437                           "sequences.lisp"
438                           "sets.lisp"
439                           "shiftf.lisp"
440                           "signal.lisp"
441                           "socket.lisp"
442                           "sort.lisp"
443                           "step.lisp"
444                           "strings.lisp"
445                           "sublis.lisp"
446                           "subst.lisp"
447                           "tailp.lisp"
448                           "threads.lisp"
449                           "time.lisp"
450                           "top-level.lisp"
451                           "trace.lisp"
452                           "tree-equal.lisp"
453                           "upgraded-complex-part-type.lisp"
454                           "with-accessors.lisp"
455                           "with-hash-table-iterator.lisp"
456                           "with-input-from-string.lisp"
457                           "with-open-file.lisp"
458                           "with-output-to-string.lisp"
459                           "with-package-iterator.lisp"
460                           "with-slots.lisp"
461                           "with-standard-io-syntax.lisp"
462                           "write-sequence.lisp"))
463
464      ;; Compile ASDF after the whole ANSI system has been
465      ;; constructed.
466      (load (do-compile "asdf.lisp"))
467      ;; ABCL-CONTRIB depends on ASDF
468      (load (do-compile "abcl-contrib.lisp"))
469
470
471      ;; With all files compiled, we need to use the symbols collected
472      ;; to generate and compile autoloads.lisp
473
474      ;; Generate the autoloads-gen file in the build directory in order
475      ;; not to clobber the source file - that should keep the system
476      ;; buildable
477
478      (format t "; Generating autoloads...~%")
479      (generate-autoloads output-path)
480      ;; Compile the file in the build directory instead of the one in the
481      ;; sources directory - the latter being for bootstrapping only.
482      (do-compile (merge-pathnames #p"autoloads-gen.lisp" output-path)
483        :extract nil)
484      (do-compile "autoloads.lisp"
485        :extract nil))
486    t))
487
488(defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path)
489  (let ((status -1)
490  (*compile-file-class-extension* cls-ext)
491  (*compile-file-type* abcl-ext))
492    (check-lisp-home)
493    (time
494     (with-compilation-unit ()
495       (let ((*compile-file-zip* zip)
496             failure-p)
497         (handler-bind (((or warning
498                             compiler-error)
499                         #'(lambda (c)
500                             (declare (ignore c))
501                             (setf failure-p t)
502                             ;; only register that we had this type of signal
503                             ;; defer the actual handling to another handler
504                             nil)))
505           (%compile-system :output-path output-path))
506         (unless failure-p
507           (setf status 0)))))
508    (create-system-logical-translations output-path)
509    (when quit
510      (quit :status status))))
511
512(defun create-system-logical-translations (output-path)
513  (let* ((dir (directory-namestring (pathname output-path)))
514         (system (merge-pathnames "system.lisp" dir))
515         (home (pathname *lisp-home*))
516         (src (format nil "~A**/*.*" home))
517         (java (format nil "~A../../../**/*.*" home)))
518    (with-open-file (s system :direction :output 
519                       :if-exists :supersede)
520      (pprint `(setf (logical-pathname-translations "sys")
521                    '(("SYS:SRC;**;*.*" ,src)
522                      ("SYS:JAVA;**;*.*" ,java)))
523       s))))
524     
Note: See TracBrowser for help on using the repository browser.