From 7414991525f65b6bb28d8a48a34b0e28ce0feb41 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 6 Dec 2016 05:37:47 -0500 Subject: [PATCH] Stefan's patch to write out and load "dumped.elc"; Oct 31 version. --- lisp/emacs-lisp/macroexp.el | 3 +- lisp/international/mule.el | 4 +- lisp/loadup.el | 146 +++++++++++++++++++++++++++++++++++- src/coding.c | 8 +- src/emacs.c | 6 +- 5 files changed, 158 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 9bc194c478c..2285968134e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -439,7 +439,8 @@ symbol itself." (or (memq symbol '(nil t)) (keywordp symbol) (if any-value - (or (memq symbol byte-compile-const-variables) + (or (and (boundp 'byte-compile-const-variables) + (memq symbol byte-compile-const-variables)) ;; FIXME: We should provide a less intrusive way to find out ;; if a variable is "constant". (and (boundp symbol) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 6cfb7e6d457..b6996d4b322 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -290,7 +290,7 @@ attribute." elt)) props)) (setcdr (assq :plist attrs) props) - + (put name 'internal--charset-args (mapcar #'cdr attrs)) (apply 'define-charset-internal name (mapcar 'cdr attrs)))) @@ -920,6 +920,8 @@ non-ASCII files. This attribute is meaningful only when (cons :name (cons name (cons :docstring (cons (purecopy docstring) props))))) (setcdr (assq :plist common-attrs) props) + (put name 'internal--cs-args + (mapcar #'cdr (append common-attrs spec-attrs))) (apply 'define-coding-system-internal name (mapcar 'cdr (append common-attrs spec-attrs))))) diff --git a/lisp/loadup.el b/lisp/loadup.el index af42cd97111..9a05004f6ee 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -1,4 +1,4 @@ -;;; loadup.el --- load up standardly loaded Lisp files for Emacs +;;; loadup.el --- load up standardly loaded Lisp files for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985-1986, 1992, 1994, 2001-2017 Free Software ;; Foundation, Inc. @@ -482,6 +482,150 @@ lost after dumping"))) invocation-directory) (expand-file-name name invocation-directory) t))) + (message "Dumping into dumped.elc...preparing...") + + ;; Dump the current state into a file so we can reload it! + (message "Dumping into dumped.elc...generating...") + (let ((faces '()) + (coding-systems '()) (coding-system-aliases '()) + (charsets '()) (charset-aliases '()) + (cmds '())) + (setcdr global-buffers-menu-map nil) ;; Get rid of buffer objects! + (mapatoms + (lambda (s) + (when (fboundp s) + (if (subrp (symbol-function s)) + ;; subr objects aren't readable! + (unless (equal (symbol-name s) (subr-name (symbol-function s))) + (push `(fset ',s (symbol-function ',(intern (subr-name (symbol-function s))))) cmds)) + (if (memq s '(rename-buffer)) + ;; FIXME: We need these, but they contain + ;; unprintable objects. + nil + (push `(fset ',s ,(macroexp-quote (symbol-function s))) + cmds)))) + (when (and (boundp s) + (not (macroexp--const-symbol-p s 'any-value)) + ;; I think we don't need/want these! + (not (memq s '(terminal-frame obarray + initial-window-system window-system + ;; custom-delayed-init-variables + exec-path + process-environment + command-line-args noninteractive)))) + ;; FIXME: Handle varaliases! + (let ((v (symbol-value s))) + (push `(set-default + ',s + ,(cond + ;; FIXME: (Correct) hack to avoid + ;; unprintable objects. + ((eq s 'undo-auto--undoably-changed-buffers) nil) + ;; FIXME: Incorrect hack to avoid + ;; unprintable objects. + ((eq s 'advertised-signature-table) + (make-hash-table :test 'eq :weakness 'key)) + ((subrp v) + `(symbol-function ',(intern (subr-name v)))) + ((and (markerp v) (null (marker-buffer v))) + '(make-marker)) + ((and (overlayp v) (null (overlay-buffer v))) + '(let ((ol (make-overlay (point-min) (point-min)))) + (delete-overlay ol) + ol)) + (v (macroexp-quote v)))) + cmds) + (push `(defvar ,s) cmds))) + (when (symbol-plist s) + (push `(setplist ',s ',(symbol-plist s)) cmds)) + (when (get s 'face-defface-spec) + (push s faces)) + (if (get s 'internal--cs-args) + (push s coding-systems)) + (when (and (coding-system-p s) + (not (eq s (car (coding-system-aliases s))))) + (push (cons s (car (coding-system-aliases s))) + coding-system-aliases)) + (if (get s 'internal--charset-args) + (push s charsets) + (when (and (charsetp s) + (not (eq s (get-charset-property s :name)))) + (push (cons s (get-charset-property s :name)) + charset-aliases)))) + obarray) + (message "Dumping into dumped.elc...printing...") + (with-current-buffer (generate-new-buffer "dumped.elc") + (insert ";ELC\^W\^@\^@\^@\n;;; Compiled\n;;; in Emacs version " + emacs-version "\n") + (let ((print-circle t) + (print-gensym t) + (print-quoted t) + (print-level nil) + (print-length nil) + (print-escape-newlines t) + (standard-output (current-buffer))) + (print `(progn . ,cmds)) + (terpri) + (print `(let ((css ',charsets)) + (dotimes (i 3) + (dolist (cs (prog1 css (setq css nil))) + ;; (message "Defining charset %S..." cs) + (condition-case nil + (progn + (apply #'define-charset-internal + cs (get cs 'internal--charset-args)) + ;; (message "Defining charset %S...done" cs) + ) + (error + ;; (message "Defining charset %S...postponed" + ;; cs) + (push cs css))))))) + (terpri) + (print `(dolist (cs ',charset-aliases) + (define-charset-alias (car cs) (cdr cs)))) + (terpri) + (print `(let ((css ',coding-systems)) + (dotimes (i 3) + (dolist (cs (prog1 css (setq css nil))) + ;; (message "Defining coding-system %S..." cs) + (condition-case nil + (progn + (apply #'define-coding-system-internal + cs (get cs 'internal--cs-args)) + ;; (message "Defining coding-system %S...done" cs) + ) + (error + ;; (message "Defining coding-system %S...postponed" + ;; cs) + (push cs css))))))) + (print `(dolist (f ',faces) + (face-spec-set f (get f 'face-defface-spec) + 'face-defface-spec))) + (terpri) + (print `(dolist (cs ',coding-system-aliases) + (define-coding-system-alias (car cs) (cdr cs)))) + (terpri) + (print `(progn + ;; (message "Done preloading!") + ;; (message "custom-delayed-init-variables = %S" + ;; custom-delayed-init-variables) + ;; (message "Running top-level = %S" top-level) + (setq debug-on-error t) + (use-global-map global-map) + (eval top-level) + ;; (message "top-level done!?") + )) + (terpri)) + (goto-char (point-min)) + (while (re-search-forward " (\\(defvar\\|setplist\\|fset\\) " nil t) + (goto-char (match-beginning 0)) + (delete-char 1) (insert "\n")) + (message "Dumping into dumped.elc...saving...") + (let ((coding-system-for-write 'emacs-internal)) + (write-region (point-min) (point-max) (buffer-name))) + (message "Dumping into dumped.elc...done") + )) + (kill-emacs))) ;; For machines with CANNOT_DUMP defined in config.h, diff --git a/src/coding.c b/src/coding.c index 50ad206be69..0205358e312 100644 --- a/src/coding.c +++ b/src/coding.c @@ -10337,8 +10337,9 @@ usage: (define-coding-system-internal ...) */) CHECK_NUMBER_CAR (reg_usage); CHECK_NUMBER_CDR (reg_usage); - request = Fcopy_sequence (args[coding_arg_iso2022_request]); - for (tail = request; CONSP (tail); tail = XCDR (tail)) + request = Qnil; + for (tail = args[coding_arg_iso2022_request]; + CONSP (tail); tail = XCDR (tail)) { int id; Lisp_Object tmp1; @@ -10350,7 +10351,8 @@ usage: (define-coding-system-internal ...) */) CHECK_NATNUM_CDR (val); if (XINT (XCDR (val)) >= 4) error ("Invalid graphic register number: %"pI"d", XINT (XCDR (val))); - XSETCAR (val, make_number (id)); + request = Fcons (Fcons (make_number (id), XCDR (val)), + request); } flags = args[coding_arg_iso2022_flags]; diff --git a/src/emacs.c b/src/emacs.c index 0fec7167588..bc5d4bc552f 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1673,9 +1673,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif Vtop_level = list2 (Qload, build_unibyte_string (file)); } - /* Unless next switch is -nl, load "loadup.el" first thing. */ - if (! no_loadup) - Vtop_level = list2 (Qload, build_string ("loadup.el")); + else if (! no_loadup) + /* Unless next switch is -nl, load "loadup.el" first thing. */ + Vtop_level = list2 (Qload, build_string ("../src/dumped.elc")); } /* Set up for profiling. This is known to work on FreeBSD, -- 2.39.5