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

Last change on this file since 14107 was 14107, checked in by rschlatte, 9 years ago

restore build - ed.lisp needs make-socket to be exported

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