[Emacs-diffs] scratch/raeburn-startup 8f37b82 08/17: Stefan's patch to write out and load "dumped.elc"; Oct 31 version.

[Ken Raeburn]

branch: scratch/raeburn-startup
commit 8f37b82dbf65fa213be72504d8a3ce977cb0e3ca
Author: Stefan Monnier <address@hidden>
Commit: Ken Raeburn <address@hidden>

    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 6d89145..47f8513 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 5bc0e9c..b8efb71 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))))
 
 
@@ -911,6 +911,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 5c16464..4a13003 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-2016 Free Software
 ;; Foundation, Inc.
@@ -474,6 +474,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 ";address@hidden@address@hidden;;; 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 feed9c8..973e313 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -10335,8 +10335,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;
@@ -10348,7 +10349,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 f633f09..50e3abf 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1654,9 +1654,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,