Many resources are needed to download a project. Please understand that we have to compensate our server costs. Thank you in advance. Project price only 1 $
You can buy this project and download/modify it how often you want.
;;; compile-system.lisp
;;;
;;; Copyright (C) 2004-2008 Peter Graves
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
(in-package "SYSTEM")
(require "LOOP")
(require "COLLECT")
(require "COMPILE-FILE")
(export '(grovel-java-definitions-in-file compile-system))
(defun check-lisp-home ()
(loop
(cond ((and *lisp-home*
(probe-directory (pathname *lisp-home*)))
(return))
(t
(cerror "Continue"
"*LISP-HOME* is NIL or invalid.~% Please set *LISP-HOME* to the full pathname of the directory containing the Lisp system files.")))))
(defun grovel-java-definitions-in-file (file out)
(with-open-file (in file)
(declare (type stream in))
(let ((system-package (find-package "SYSTEM"))
(line-number 1))
(loop
(let ((text (read-line in nil)))
(when (null text)
(return))
(let ((position (search "###" text)))
(when position
(let* ((name (string (read-from-string (subseq text (+ position 3)))))
(symbol (or (find-symbol name system-package) ; uses CL and EXT
(find-symbol name (find-package "MOP"))
(find-symbol name (find-package "JAVA")))))
(when symbol
;; Force the symbol's package prefix to be written out
;; with "::" instead of ":" so there won't be a reader
;; error if a symbol that's external now is no longer
;; external when we read the tags file.
(%format out "~A::~A ~S ~S~%"
(package-name (symbol-package symbol))
name
file line-number)))))
(incf line-number))))))
(defun grovel-java-definitions ()
(check-lisp-home)
(time
(let ((files (directory (merge-pathnames "*.java" *lisp-home*))))
(with-open-file (stream (merge-pathnames "tags" *lisp-home*)
:direction :output :if-exists :supersede)
(dolist (file files)
(grovel-java-definitions-in-file file stream))))))
;;
;; Functions to generate autoloads.lisp
;;
(defun packages-from-combos (combos)
(remove-duplicates (mapcar #'symbol-package
(mapcar #'sys:fdefinition-block-name
(mapcar #'second combos)))))
(defun remove-multi-combo-symbols (combos)
(princ "; Removing multi-homed symbols")
(let ((sym-hash (make-hash-table :size (* 2 (length combos)))))
(dolist (combo combos)
(incf (gethash (second combo) sym-hash 0)))
(print (remove-if-not (lambda (x)
(< 1 (gethash x sym-hash)))
combos
:key #'second))
(remove-if (lambda (x)
(< 1 (gethash x sym-hash)))
combos
:key #'second)))
(defun set-equal (set1 set2 &key test)
(or (eq set1 set2)
(equal set1 set2)
(and (subsetp set2 set1 :test test)
(subsetp set1 set2 :test test))))
(defun combos-to-symbol-filesets (combos)
(let (filesets)
(dolist (combo combos)
(pushnew (list (second combo)) filesets :test #'equal :key #'first)
(pushnew (first combo)
(cdr (assoc (second combo) filesets :test #'equal))
:test #'string=))
filesets))
(defun combos-to-fileset-symbols (combos)
(let (fileset-symbols)
(dolist (symbol-fileset (combos-to-symbol-filesets combos))
(pushnew (list (cdr symbol-fileset)) fileset-symbols
:test (lambda (x y) (set-equal x y :test #'string=))
:key #'first)
(pushnew (first symbol-fileset)
(cdr (assoc (cdr symbol-fileset) fileset-symbols
:test (lambda (x y)
(set-equal x y :test #'string=))))))
fileset-symbols))
(defun write-autoloader (stream package type fileset-symbols)
(when fileset-symbols
(write `(in-package ,package) :stream stream)
(terpri stream)
(let ((*package* (find-package package)))
(write `(dolist (fs ',fileset-symbols)
(funcall #',type (cdr fs) (car (car fs)))) :stream stream)
(terpri stream))))
(defun write-package-filesets (stream package type filesets-symbols)
(let* ((filter-package (find-package package))
(filtered-filesets
(remove-if (lambda (x)
(null (cdr x)))
(mapcar (lambda (x)
(cons (car x)
(remove-if-not (lambda (x)
(and (symbolp x)
(eq (symbol-package x)
filter-package)))
(cdr x))))
filesets-symbols))))
(write-autoloader stream package type filtered-filesets)))
(defun load-combos (path-spec)
(let (all-functions)
(dolist (functions-file (directory path-spec)
all-functions)
;; every file has 1 form: the list of functions in it.
(let ((base-name (pathname-name functions-file)))
(unless (member base-name '("asdf" "gray-streams") :test #'string=)
;; exclude ASDF and GRAY-STREAMS: they have external
;; symbols we don't have until we load them, but we need
;; those symbols to read the symbols files
(with-open-file (f functions-file
:direction :input)
(dolist (function-name (read f))
(push (list base-name function-name) all-functions))))))))
(defun generate-autoloads (symbol-files-pathspec)
(labels ((filter-combos (combos)
(remove-multi-combo-symbols
(remove-if (lambda (x)
;; exclude the symbols from the files
;; below: putting autoloaders on some of
;; the symbols conflicts with the bootstrapping
;; Primitives which have been defined Java-side
(member x '( ;; function definitions to be excluded
"fdefinition" "early-defuns"
"require" "signal" "restart"
;; extensible sequences override
;; lots of default functions;
;; java-collections implements
;; extensible sequences
"extensible-sequences-base"
"extensible-sequences" "java-collections"
;; macro definitions to be excluded
"macros" ;; "backquote"
"precompiler")
:test #'string=))
combos
:key #'first)))
(filter-setf-combos (combos)
(filter-combos
(remove-multi-combo-symbols
(remove-if (lambda (x) (member x '("clos") :test #'string=)) combos :key #'first))))
(symbols-pathspec (filespec)
(merge-pathnames filespec symbol-files-pathspec)))
(let ((funcs (filter-combos (load-combos (symbols-pathspec "*.funcs"))))
(macs (filter-combos (load-combos (symbols-pathspec "*.macs"))))
(setf-functions (filter-setf-combos (load-combos (symbols-pathspec "*.setf-functions"))))
(setf-expanders (filter-setf-combos (load-combos (symbols-pathspec "*.setf-expanders"))))
(exps (filter-combos (load-combos (symbols-pathspec "*.exps")))))
(with-open-file (f (symbols-pathspec "autoloads-gen.lisp")
:direction :output :if-does-not-exist :create
:if-exists :supersede)
;; Generate the lisp file. This file will be included after compilation,
;; so any comments are just for debugging purposes.
(terpri f)
(write-line ";; ---- GENERATED CONTENT BELOW" f)
(terpri f)
(dolist (package '(:format :sequence :loop :mop :xp :precompiler
:profiler :java :jvm :extensions :threads
:top-level :system :cl))
;; Limit the set of packages:
;; During incremental compilation, the packages GRAY-STREAMS
;; and ASDF are not being created. Nor are these packages
;; vital to the correct operation of the base system.
(let* ((*package* (find-package package))
(all-exported-symbols
(remove-duplicates (mapcar #'second exps)))
(externals (remove-if-not (lambda (sym)
(eq (symbol-package sym)
*package*))
all-exported-symbols)))
(when externals
(write-line ";; EXPORTS" f)
(write `(cl:in-package ,package) :stream f)
(terpri f)
(write `(cl:export ',externals) :stream f)
(terpri f)))
(terpri f)
(write-line ";; FUNCTIONS" f)
(terpri f)
(write-package-filesets f package 'ext:autoload
(combos-to-fileset-symbols funcs))
(terpri f)
(write-line ";; MACROS" f)
(terpri f)
(write-package-filesets f package 'ext:autoload-macro
(combos-to-fileset-symbols macs))
(terpri f)
(write-line ";; SETF-FUNCTIONS" f)
(terpri f)
(write-package-filesets f package 'ext:autoload-setf-function
(combos-to-fileset-symbols setf-functions))
(terpri f)
(write-line ";; SETF-EXPANDERS" f)
(terpri f)
(write-package-filesets f package 'ext:autoload-setf-expander
(combos-to-fileset-symbols setf-expanders)))))))
;;
;; --- End of autoloads.lisp
;;
(defun %compile-system (&key output-path)
(let ((*default-pathname-defaults* (pathname *lisp-home*))
(*warn-on-redefinition* nil)
(*prevent-fasl-circle-detection* t))
(unless output-path
(setf output-path *default-pathname-defaults*))
(flet ((do-compile (file &key (extract t))
(let ((out (make-pathname :type *compile-file-type*
:defaults (merge-pathnames
file output-path))))
(compile-file-if-needed file
:output-file out
:extract-toplevel-funcs-and-macros extract))))
(load (do-compile "defstruct.lisp"))
(load (do-compile "coerce.lisp"))
(load (do-compile "open.lisp"))
(load (do-compile "dump-form.lisp"))
(load (do-compile "compiler-types.lisp"))
(load (do-compile "compile-file.lisp"))
(load (do-compile "precompiler.lisp"))
(load (do-compile "compiler-pass1.lisp"))
(load (do-compile "compiler-pass2.lisp"))
(load (do-compile "jvm-class-file.lisp"))
(load (do-compile "jvm.lisp"))
(load (do-compile "source-transform.lisp"))
(load (do-compile "compiler-macro.lisp"))
(load (do-compile "jvm-instructions.lisp"))
(load (do-compile "setf.lisp"))
(load (do-compile "extensible-sequences-base.lisp"))
(load (do-compile "require.lisp"))
(load (do-compile "substitute.lisp"))
(load (do-compile "clos.lisp"))
(load (do-compile "mop.lisp"))
;; Order matters for these files.
(mapc #'do-compile '("collect.lisp"
"macros.lisp"
"loop.lisp"))
(load (do-compile "backquote.lisp"))
(load (do-compile "early-defuns.lisp"))
(load (do-compile "typep.lisp"))
(load (do-compile "subtypep.lisp"))
(load (do-compile "find.lisp"))
(load (do-compile "print.lisp"))
(load (do-compile "pprint-dispatch.lisp"))
(load (do-compile "pprint.lisp"))
(load (do-compile "format.lisp"))
(load (do-compile "delete.lisp"))
(load (do-compile "concatenate.lisp"))
(load (do-compile "ldb.lisp"))
(load (do-compile "destructuring-bind.lisp"))
(load (do-compile "featurep.lisp"))
;; But not for these.
(mapc #'do-compile '("adjoin.lisp"
"and.lisp"
"apropos.lisp"
"arrays.lisp"
"assert.lisp"
"assoc.lisp"
"aver.lisp"
"bit-array-ops.lisp"
"boole.lisp"
"butlast.lisp"
"byte-io.lisp"
"case.lisp"
"chars.lisp"
"check-type.lisp"
"compile-file-pathname.lisp"
"compile-system.lisp"
"compiler-error.lisp"
"cond.lisp"
"copy-seq.lisp"
"copy-symbol.lisp"
"count.lisp"
"digest.lisp"
"debug.lisp"
"define-modify-macro.lisp"
"define-symbol-macro.lisp"
"defmacro.lisp"
"defpackage.lisp"
"defsetf.lisp"
"deftype.lisp"
"delete-duplicates.lisp"
"deposit-field.lisp"
"describe.lisp"
"describe-compiler-policy.lisp"
"directory.lisp"
"disassemble.lisp"
"do-all-symbols.lisp"
"do-external-symbols.lisp"
"do-symbols.lisp"
"do.lisp"
"documentation.lisp"
"dolist.lisp"
"dotimes.lisp"
"dribble.lisp"
"dump-class.lisp"
"ed.lisp"
"enough-namestring.lisp"
"ensure-directories-exist.lisp"
"error.lisp"
"extensible-sequences.lisp"
"fasl-concat.lisp"
"fdefinition.lisp"
"fill.lisp"
"find-all-symbols.lisp"
"get-pid.lisp"
"gentemp.lisp"
"gray-streams.lisp"
"gui.lisp"
"inline.lisp"
"inspect.lisp"
"java.lisp"
"java-collections.lisp"
"known-functions.lisp"
"known-symbols.lisp"
"late-setf.lisp"
"lcm.lisp"
"ldiff.lisp"
"list-length.lisp"
"list.lisp"
"load.lisp"
"make-hash-table.lisp"
"make-load-form-saving-slots.lisp"
"make-sequence.lisp"
"make-string-output-stream.lisp"
"make-string.lisp"
"map-into.lisp"
"map.lisp"
"map1.lisp"
"mask-field.lisp"
"member-if.lisp"
"mismatch.lisp"
"multiple-value-bind.lisp"
"multiple-value-list.lisp"
"multiple-value-setq.lisp"
"nsubstitute.lisp"
"nth-value.lisp"
"numbers.lisp"
"or.lisp"
"parse-integer.lisp"
"parse-lambda-list.lisp"
"package.lisp"
"pathnames.lisp"
"print-object.lisp"
"print-unreadable-object.lisp"
"proclaim.lisp"
"profiler.lisp"
"prog.lisp"
"psetf.lisp"
"query.lisp"
"read-circle.lisp"
"read-conditional.lisp"
"read-from-string.lisp"
"read-sequence.lisp"
"reduce.lisp"
"remf.lisp"
"remove-duplicates.lisp"
"remove.lisp"
"replace.lisp"
"restart.lisp"
"revappend.lisp"
"rotatef.lisp"
"run-program.lisp"
"run-shell-command.lisp"
"runtime-class.lisp"
"search.lisp"
"sequences.lisp"
"sets.lisp"
"shiftf.lisp"
"signal.lisp"
"socket.lisp"
"sort.lisp"
"step.lisp"
"strings.lisp"
"sublis.lisp"
"subst.lisp"
"tailp.lisp"
"threads.lisp"
"time.lisp"
"top-level.lisp"
"trace.lisp"
"tree-equal.lisp"
"upgraded-complex-part-type.lisp"
"with-accessors.lisp"
"with-hash-table-iterator.lisp"
"with-input-from-string.lisp"
"with-open-file.lisp"
"with-output-to-string.lisp"
"with-package-iterator.lisp"
"with-slots.lisp"
"with-standard-io-syntax.lisp"
"write-sequence.lisp"))
;; Compile ASDF after the whole ANSI system has been
;; constructed.
(load (do-compile "asdf.lisp"))
;; ABCL-CONTRIB depends on ASDF
(load (do-compile "abcl-contrib.lisp"))
;; With all files compiled, we need to use the symbols collected
;; to generate and compile autoloads.lisp
;; Generate the autoloads-gen file in the build directory in order
;; not to clobber the source file - that should keep the system
;; buildable
(format t "; Generating autoloads...~%")
(generate-autoloads output-path)
;; Compile the file in the build directory instead of the one in the
;; sources directory - the latter being for bootstrapping only.
(do-compile (merge-pathnames #p"autoloads-gen.lisp" output-path)
:extract nil)
(do-compile "autoloads.lisp"
:extract nil))
t))
(defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path)
(let ((status -1)
(*compile-file-class-extension* cls-ext)
(*compile-file-type* abcl-ext))
(check-lisp-home)
(time
(with-compilation-unit ()
(let ((*compile-file-zip* zip)
failure-p)
(handler-bind (((or warning
compiler-error)
#'(lambda (c)
(declare (ignore c))
(setf failure-p t)
;; only register that we had this type of signal
;; defer the actual handling to another handler
nil)))
(%compile-system :output-path output-path))
(unless failure-p
(setf status 0)))))
(create-system-logical-translations output-path)
(when quit
(quit :status status))))
(defun create-system-logical-translations (output-path)
(let* ((dir (directory-namestring (pathname output-path)))
(system (merge-pathnames "system.lisp" dir))
(home (pathname *lisp-home*))
(src (format nil "~A**/*.*" home))
(java (format nil "~A../../../**/*.*" home)))
(with-open-file (s system :direction :output
:if-exists :supersede)
(pprint `(setf (logical-pathname-translations "sys")
'(("SYS:SRC;**;*.*" ,src)
("SYS:JAVA;**;*.*" ,java)))
s))))
