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

Last change on this file since 13304 was 13304, checked in by Mark Evenson, 10 years ago

Untabify.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 13.3 KB
Line 
1;;; compile-system.lisp
2;;;
3;;; Copyright (C) 2004-2008 Peter Graves
4;;; $Id: compile-system.lisp 13304 2011-05-27 14:13:27Z 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(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(defun %compile-system (&key output-path)
83  (let ((*default-pathname-defaults* (pathname *lisp-home*))
84        (*warn-on-redefinition* nil))
85    (unless output-path
86      (setf output-path *default-pathname-defaults*))
87    (flet ((do-compile (file)
88             (let ((out (make-pathname :type "abcl"
89                                       :defaults (merge-pathnames
90                                                  file output-path))))
91               (compile-file-if-needed file :output-file out))))
92      (load (do-compile "coerce.lisp"))
93      (load (do-compile "open.lisp"))
94      (load (do-compile "dump-form.lisp"))
95      (load (do-compile "compiler-types.lisp"))
96      (load (do-compile "compile-file.lisp"))
97      (load (do-compile "precompiler.lisp"))
98      (load (do-compile "compiler-pass1.lisp"))
99      (load (do-compile "compiler-pass2.lisp"))
100      (load (do-compile "jvm-class-file.lisp"))
101      (load (do-compile "jvm.lisp"))
102      (load (do-compile "source-transform.lisp"))
103      (load (do-compile "compiler-macro.lisp"))
104      (load (do-compile "jvm-instructions.lisp"))
105      (load (do-compile "setf.lisp"))
106      (load (do-compile "extensible-sequences-base.lisp"))
107      (load (do-compile "require.lisp"))
108      (load (do-compile "substitute.lisp"))
109      (load (do-compile "clos.lisp"))
110      ;; Order matters for these files.
111      (mapc #'do-compile '("collect.lisp"
112                           "macros.lisp"
113                           "loop.lisp"))
114      (load (do-compile "backquote.lisp"))
115      (load (do-compile "early-defuns.lisp"))
116      (load (do-compile "typep.lisp"))
117      (load (do-compile "subtypep.lisp"))
118      (load (do-compile "find.lisp"))
119      (load (do-compile "print.lisp"))
120      (load (do-compile "pprint-dispatch.lisp"))
121      (load (do-compile "pprint.lisp"))
122      (load (do-compile "format.lisp"))
123      (load (do-compile "delete.lisp"))
124      (load (do-compile "concatenate.lisp"))
125      (load (do-compile "ldb.lisp"))
126      (load (do-compile "destructuring-bind.lisp"))
127      (load (do-compile "asdf.lisp"))
128      ;; But not for these.
129      (mapc #'do-compile '("abcl-contrib.lisp"
130                           "adjoin.lisp"
131                           "and.lisp"
132                           "apropos.lisp"
133                           "arrays.lisp"
134                           "assert.lisp"
135                           "assoc.lisp"
136                           "autoloads.lisp"
137                           "aver.lisp"
138                           "bit-array-ops.lisp"
139                           "boole.lisp"
140                           ;;"boot.lisp"
141                           "butlast.lisp"
142                           "byte-io.lisp"
143                           "case.lisp"
144                           "chars.lisp"
145                           "check-type.lisp"
146                           "compile-file-pathname.lisp"
147                           "compile-system.lisp"
148                           "compiler-error.lisp"
149                           "cond.lisp"
150                           "copy-seq.lisp"
151                           "copy-symbol.lisp"
152                           "count.lisp"
153                           "debug.lisp"
154                           "define-modify-macro.lisp"
155                           "define-symbol-macro.lisp"
156                           "defmacro.lisp"
157                           "defpackage.lisp"
158                           "defsetf.lisp"
159                           "defstruct.lisp"
160                           "deftype.lisp"
161                           "delete-duplicates.lisp"
162                           "deposit-field.lisp"
163                           "describe.lisp"
164                           "describe-compiler-policy.lisp"
165                           "directory.lisp"
166                           "disassemble.lisp"
167                           "do-all-symbols.lisp"
168                           "do-external-symbols.lisp"
169                           "do-symbols.lisp"
170                           "do.lisp"
171                           "dolist.lisp"
172                           "dotimes.lisp"
173                           "dribble.lisp"
174                           "dump-class.lisp"
175                           "ed.lisp"
176                           "enough-namestring.lisp"
177                           "ensure-directories-exist.lisp"
178                           "error.lisp"
179                           "extensible-sequences.lisp"
180                           "featurep.lisp"
181                           "fdefinition.lisp"
182                           "fill.lisp"
183                           "find-all-symbols.lisp"
184                           "gentemp.lisp"
185                           "gray-streams.lisp"
186                           "gui.lisp"
187                           "inline.lisp"
188                           "inspect.lisp"
189                           ;;"j.lisp"
190                           "java.lisp"
191                           "java-collections.lisp"
192                           "known-functions.lisp"
193                           "known-symbols.lisp"
194                           "late-setf.lisp"
195                           "lcm.lisp"
196                           "ldiff.lisp"
197                           "list-length.lisp"
198                           "list.lisp"
199                           "load.lisp"
200                           "make-hash-table.lisp"
201                           "make-load-form-saving-slots.lisp"
202                           "make-sequence.lisp"
203                           "make-string-output-stream.lisp"
204                           "make-string.lisp"
205                           "map-into.lisp"
206                           "map.lisp"
207                           "map1.lisp"
208                           "mask-field.lisp"
209                           "member-if.lisp"
210                           "mismatch.lisp"
211                           "multiple-value-bind.lisp"
212                           "multiple-value-list.lisp"
213                           "multiple-value-setq.lisp"
214                           "nsubstitute.lisp"
215                           "nth-value.lisp"
216                           "numbers.lisp"
217                           "or.lisp"
218                           "parse-integer.lisp"
219                           "parse-lambda-list.lisp"
220                           "package.lisp"
221                           "pathnames.lisp"
222                           "print-object.lisp"
223                           "print-unreadable-object.lisp"
224                           "proclaim.lisp"
225                           "profiler.lisp"
226                           "prog.lisp"
227                           "psetf.lisp"
228                           "query.lisp"
229                           "read-circle.lisp"
230                           "read-conditional.lisp"
231                           "read-from-string.lisp"
232                           "read-sequence.lisp"
233                           "reduce.lisp"
234                           "remf.lisp"
235                           "remove-duplicates.lisp"
236                           "remove.lisp"
237                           "replace.lisp"
238                           "restart.lisp"
239                           "revappend.lisp"
240                           "rotatef.lisp"
241                           ;;"run-benchmarks.lisp"
242                           "run-program.lisp"
243                           "run-shell-command.lisp"
244                           ;;"runtime-class.lisp"
245                           "search.lisp"
246                           "sequences.lisp"
247                           "sets.lisp"
248                           "shiftf.lisp"
249                           "signal.lisp"
250                           "socket.lisp"
251                           "sort.lisp"
252                           "step.lisp"
253                           "strings.lisp"
254                           "sublis.lisp"
255                           "subst.lisp"
256                           "tailp.lisp"
257                           "threads.lisp"
258                           "time.lisp"
259                           "top-level.lisp"
260                           "trace.lisp"
261                           "tree-equal.lisp"
262                           "upgraded-complex-part-type.lisp"
263                           "with-accessors.lisp"
264                           "with-hash-table-iterator.lisp"
265                           "with-input-from-string.lisp"
266                           "with-open-file.lisp"
267                           "with-output-to-string.lisp"
268                           "with-package-iterator.lisp"
269                           "with-slots.lisp"
270                           "with-standard-io-syntax.lisp"
271                           "write-sequence.lisp")))
272    t))
273
274(defun compile-system (&key quit (zip t) output-path)
275  (let ((status -1))
276    (check-lisp-home)
277    (time
278     (with-compilation-unit ()
279       (let ((*compile-file-zip* zip)
280             failure-p)
281         (handler-bind (((or warning
282                             compiler-error)
283                         #'(lambda (c)
284                             (declare (ignore c))
285                             (setf failure-p t)
286                             ;; only register that we had this type of signal
287                             ;; defer the actual handling to another handler
288                             nil)))
289           (%compile-system :output-path output-path))
290         (unless failure-p
291           (setf status 0)))))
292    (create-system-logical-translations output-path)
293    (when quit
294      (quit :status status))))
295
296(defun create-system-logical-translations (output-path)
297  (let* ((dir (directory-namestring (pathname output-path)))
298         (system (merge-pathnames "system.lisp" dir))
299         (home (pathname *lisp-home*))
300         (src (format nil "~A**/*.*" home))
301         (java (format nil "~A../../../**/*.*" home)))
302    (with-open-file (s system :direction :output 
303                       :if-exists :supersede)
304      (pprint `(setf (logical-pathname-translations "sys")
305                    '(("SYS:SRC;**;*.*" ,src)
306                      ("SYS:JAVA;**;*.*" ,java)))
307       s))))
308     
Note: See TracBrowser for help on using the repository browser.