X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Floadup.el;h=fa64a15e9c54fc5dd32ac7596304d1113ff56471;hb=515ed47192a2fc212474dc246a875771890e0cbe;hp=68063a8cea170359e8df37b178b74118a4a4cd53;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/loadup.el b/lisp/loadup.el index 68063a8..fa64a15 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -34,21 +34,52 @@ ;;; Code: -(if (fboundp 'error) - (error "loadup.el already loaded!")) +(when (fboundp 'error) + (error "loadup.el already loaded!")) (defvar running-xemacs t "Non-nil when the current emacs is XEmacs.") (defvar preloaded-file-list nil "List of files preloaded into the XEmacs binary image.") +(defvar Installation-string nil + "Description of XEmacs installation.") + +;(start-profiling) + +(let ((gc-cons-threshold + ;; setting it low makes loadup incredibly fucking slow. + ;; no need to do it when not dumping. + (if (and purify-flag + (not (memq 'quick-build internal-error-checking))) + 30000 3000000))) + ;; This is awfully damn early to be getting an error, right? (call-with-condition-handler 'really-early-error-handler #'(lambda () - ;; message not defined yet ... - (setq load-path (split-path (getenv "EMACSBOOTSTRAPLOADPATH"))) + ;; Initialize Installation-string. We do it before loading + ;; anything so that dumped code can make use of its value. + (setq Installation-string + (save-current-buffer + (set-buffer (get-buffer-create (generate-new-buffer-name + " *temp*"))) + ;; insert-file-contents-internal bogusly calls + ;; format-decode without checking if it's defined. + (fset 'format-decode #'(lambda (f l &optional v) l)) + (insert-file-contents-internal "../Installation") + (fmakunbound 'format-decode) + (prog1 (buffer-substring) + (kill-buffer (current-buffer))))) + + (let ((build-root (expand-file-name ".." invocation-directory))) + (setq load-path (list (expand-file-name "lisp" build-root))) + (setq module-load-path (list (expand-file-name "modules" build-root)))) + + ;; message not defined yet ... (external-debugging-output (format "\nUsing load-path %s" load-path)) + (external-debugging-output (format "\nUsing module-load-path %s" + module-load-path)) ;; We don't want to have any undo records in the dumped XEmacs. (buffer-disable-undo (get-buffer "*scratch*")) @@ -64,7 +95,6 @@ ;; the package path. ;; #### This code is duplicated in two other places. (let ((temp-path (expand-file-name "." (car load-path)))) - (setq source-directory temp-path) (setq load-path (nconc (mapcar #'(lambda (i) (concat i "/")) (directory-files temp-path t "^[^-.]" @@ -80,15 +110,16 @@ ;; there will be lots of extra space in the data segment filled ;; with garbage-collected junk) (defun pureload (file) - (let ((full-path (locate-file file - load-path - (if load-ignore-elc-files - ".el:" - ".elc:.el:")))) + (let ((full-path + (locate-file file load-path + (if load-ignore-elc-files + '(".el" "") '(".elc" ".el" ""))))) (if full-path (prog1 (load full-path) - (garbage-collect)) + ;; but garbage collection really slows down loading. + (unless (memq 'quick-build internal-error-checking) + (garbage-collect))) (external-debugging-output (format "\nLoad file %s: not found\n" file)) ;; Uncomment in case of trouble @@ -96,21 +127,19 @@ ;;(print (format "guessed-roots: %S" (paths-find-emacs-roots invocation-directory invocation-name))) nil))) - (load (concat default-directory "../lisp/dumped-lisp.el")) + (load (expand-file-name "../lisp/dumped-lisp.el")) (let ((files preloaded-file-list) file) (while (setq file (car files)) - (or (pureload file) - (progn - (external-debugging-output "Fatal error during load, aborting") - (kill-emacs 1))) + (unless (pureload file) + (external-debugging-output "Fatal error during load, aborting") + (kill-emacs 1)) (setq files (cdr files))) - (if (not (featurep 'toolbar)) - (progn - ;; else still define a few functions. - (defun toolbar-button-p (obj) "No toolbar support." nil) - (defun toolbar-specifier-p (obj) "No toolbar support." nil))) + (when (not (featurep 'toolbar)) + ;; else still define a few functions. + (defun toolbar-button-p (obj) "No toolbar support." nil) + (defun toolbar-specifier-p (obj) "No toolbar support." nil)) (fmakunbound 'pureload)) (packages-load-package-dumped-lisps late-package-load-path) @@ -135,8 +164,9 @@ ;; But you must also cause them to be scanned when the DOC file ;; is generated. For VMS, you must edit ../../vms/makedoc.com. ;; For other systems, you must edit ../../src/Makefile.in.in. -(if (load "site-load" t) - (garbage-collect)) +(when (load "site-load" t) + (garbage-collect) +) ;;FSFmacs randomness ;;(if (fboundp 'x-popup-menu) @@ -145,7 +175,6 @@ ;;; for the sake of the next call to precompute-menubar-bindings. ;(setq define-key-rebound-commands nil) - ;; Note: all compiled Lisp files loaded above this point ;; must be among the ones parsed by make-docfile ;; to construct DOC. Any that are not processed @@ -159,51 +188,121 @@ (message "Finding pointers to doc strings...") (Snarf-documentation "DOC") (message "Finding pointers to doc strings...done") - (Verify-documentation) - ) + (Verify-documentation)) ;; Note: You can cause additional libraries to be preloaded ;; by writing a site-init.el that loads them. ;; See also "site-load" above. -(if (stringp site-start-file) - (load "site-init" t)) +(when (stringp site-start-file) + (load "site-init" t)) (setq current-load-list nil) (garbage-collect) ;;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") +) ;; frequent garbage collection + +;(stop-profiling) + +;; yuck! need to insert the function def here, and rewrite the dolist +;; loop below. + +;(defun loadup-profile-results (&optional info stream) +; "Print profiling info INFO to STREAM in a pretty format. +;If INFO is omitted, the current profiling info is retrieved using +; `get-profiling-info'. +;If STREAM is omitted, either a *Profiling Results* buffer or standard +; output are used, depending on whether the function was called +; interactively or not." +; (interactive) +; (setq info (if info +; (copy-alist info) +; (get-profiling-info))) +; (when (and (not stream) +; (interactive-p)) +; (pop-to-buffer (get-buffer-create "*Profiling Results*")) +; (erase-buffer)) +; (let ((standard-output (or stream (if (interactive-p) +; (current-buffer) +; standard-output))) +; ;; Calculate the longest function +; (maxfunlen (apply #'max +; (length "Function Name") +; (mapcar +; (lambda (el) +; ;; Functions longer than 50 characters (usually +; ;; anonymous functions) don't qualify +; (let ((l (length (format "%s" (car el))))) +; (if (< l 50) +; l 0))) +; info)))) +; (princ (format "%-*s Ticks %%/Total Call Count\n" +; maxfunlen "Function Name")) +; (princ (make-string maxfunlen ?=)) +; (princ " ===== ======= ==========\n") +; (let ((sum (float (apply #'+ (mapcar #'cdr info))))) +; (let (entry +; (entry-list (nreverse (sort info #'cdr-less-than-cdr)))) +; (while entry-list +; (setq entry (car entry-list)) +; (princ (format "%-*s %-5d %-6.3f %s\n" +; maxfunlen (car entry) (cdr entry) +; (* 100 (/ (cdr entry) sum)) +; (or (gethash (car entry) call-count-profile-table) +; ""))) +; (setq entry-list (cdr entry-list)))) +; (princ (make-string maxfunlen ?-)) +; (princ "---------------------------------\n") +; (princ (format "%-*s %-5d %-6.2f\n" maxfunlen "Total" sum 100.0)) +; (princ (format "\n\nOne tick = %g ms\n" +; (/ default-profiling-interval 1000.0))) +; (and (boundp 'internal-error-checking) +; internal-error-checking +; (princ " +;WARNING: Error checking is turned on in this XEmacs. This might make +; the measurements very unreliable.\n")))) +; (when (and (not stream) +; (interactive-p)) +; (goto-char (point-min)))) + +;(loadup-profile-results nil 'external-debugging-output) + ;; Dump into the name `xemacs' (only) (when (member "dump" command-line-args) - (message "Dumping under the name xemacs") - ;; This is handled earlier in the build process. - ;; (condition-case () (delete-file "xemacs") (file-error nil)) - (when (fboundp 'really-free) - (really-free)) - (dump-emacs (if (featurep 'infodock) "infodock" "xemacs") "temacs") - (kill-emacs)) + (message "Dumping under the name xemacs") + ;; This is handled earlier in the build process. + ;; (condition-case () (delete-file "xemacs") (file-error nil)) + (when (fboundp 'really-free) + (really-free)) + (dump-emacs + (cond + ((featurep 'infodock) "infodock") + ;; #### BILL!!! + ;; If we want to dump under a name other than `xemacs', do that here! + ;; ((featurep 'gtk) "xemacs-gtk") + (t "xemacs")) + "temacs") + (kill-emacs)) + +;; Avoid error if user loads some more libraries now. +(setq purify-flag nil) (when (member "run-temacs" command-line-args) (message "\nBootstrapping from temacs...") - (setq purify-flag nil) - (setq inhibit-early-packages t) - (setq inhibit-autoloads t) ;; Remove all args up to and including "run-temacs" (apply #'run-emacs-from-temacs (cdr (member "run-temacs" command-line-args))) ;; run-emacs-from-temacs doesn't actually return anyway. (kill-emacs)) -;; Avoid error if user loads some more libraries now. -(setq purify-flag nil) - ;; XEmacs change ;; If you are using 'recompile', then you should have used -l loadup-el.el ;; so that the .el files always get loaded (the .elc files may be out-of- ;; date or bad). (when (member "recompile" command-line-args) - (let ((command-line-args-left (cdr (member "recompile" command-line-args)))) - (batch-byte-recompile-directory) - (kill-emacs))) + (setq command-line-args-left (cdr (member "recompile" command-line-args))) + (batch-byte-recompile-directory) + (kill-emacs)) ;; For machines with CANNOT_DUMP defined in config.h, ;; this file must be loaded each time Emacs is run.