1 &  ***********************************************************
  2 &  *                                                         *
  3 &  * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 &  *                                                         *
  5 &  ***********************************************************
  6 &
  7 &   ******************************************************
  8 &   *                                                    *
  9 &   *                                                    *
 10 &   * Copyright (c) 1981 by Massachusetts Institute of   *
 11 &   * Technology and Honeywell Information Systems, Inc. *
 12 &   *                                                    *
 13 &   *                                                    *
 14 &   ******************************************************
 15 &
 16 & Exec Com to dump the Emacs Lisp environments.
 17 &
 18 &  Written:  6 May      1981 RMSoley from many old tries.
 19 & Modified: 17 June     1981 RMSoley for Emacs reorganization.
 20 & Modified: 22 June     1981 RMSoley to fix alternate-key-bindings.
 21 & Modified:  1 July     1981 RMSoley to compile search list file.
 22 & Modified:  8 July     1981 RMSoley to dump version-named save file.
 23 & Modified: 13 August   1981 RMSoley for emacs/emacs_ compatibility.
 24 & Modified:  5 November 1981 RMSoley for "both" argument.
 25 & Modified:  8 November 1981 RMSoley for "no-break" initialization.
 26 & Modified: 12 April    1982 RMSoley for new site-dir, get rid of tty-ctl-dir.
 27 & Modified: 23 January  1984 Barmar  for e_option_defaults_.
 28 & Modified: 29 September 1984 Barmar to move e_self_documentor_ to regular Emacs.
 29 &
 30 & ARGUMENTS:
 31 & This EC takes two arguments, the first of which must be "emacs" or "emacs_",
 32 & specifying which kind of environment to dump.  The second must be
 33 & "unb", "exl", or "test", specifying which kind of exposure.
 34 &
 35 &command_line off
 36 &input_line off
 37 &
 38 &if [equal &n 2] &then &goto right_argno
 39 &print Syntax: make_emacs <emacs | emacs_ | both> <exl | test | unb>
 40 &quit
 41 &
 42 &label right_argno
 43 &if [equal &1 emacs]  &then &goto good_e_name
 44 &if [equal &1 emacs_] &then &goto good_e_name
 45 &if [equal &1 both]   &then &goto good_e_name
 46 &print First argument must be "emacs", "emacs_", or "both".
 47 &quit
 48 &
 49 &label good_e_name
 50 &if [equal &2 exl]  &then &goto good_name
 51 &if [equal &2 test] &then &goto good_name
 52 &if [equal &2 unb]  &then &goto good_name
 53 &print Second argument must be "exl", "test", or "unb".
 54 &quit
 55 &
 56 &label good_name
 57 &
 58 & Recurse if &1=both.
 59 &
 60 &if [not [equal &1 both]] &then &goto not_both
 61 &
 62 exec_com &ec_dir>&ec_name (emacs emacs_) &2
 63 &quit
 64 &
 65 &
 66 &label not_both
 67 &
 68 &attach
 69 lisp
 70 &
 71 (do ((in (read) (read))) ((eq in 'applesauce) '||) (eval in))
 72 &
 73 (sstatus feature Emacs)
 74 (setq NowDumpingEmacs t nobreak-functions ())
 75 (*array '*VIRGIN-OBARRAY* 'obarray t)
 76 &
 77 &if [not [equal &2 exl]] &then &goto skip_exl
 78 (setq env-dir                 ">exl>emacs_dir>executable"
 79       lisp-system-dir         ">exl>lisp_dir>executable"
 80       documentation-dir       ">exl>emacs_dir>info"
 81       site-dir                ">exl>emacs_dir>executable"
 82       include-dir             ">exl>include")
 83 &
 84 &goto got_dirs
 85 &label skip_exl
 86 &if [not [equal &2 test]] &then &goto skip_test
 87 (setq env-dir                 ">exl>emacs_dir>Test_Emacs"
 88       lisp-system-dir         ">exl>lisp_dir>executable"
 89       documentation-dir       ">exl>emacs_dir>info"
 90       site-dir                ">exl>emacs_dir>executable"
 91       include-dir             ">exl>emacs_dir>include")
 92 &
 93 &goto got_dirs
 94 &label skip_test
 95 (setq env-dir                 ">system_library_unbundled"
 96       lisp-system-dir         ">system_library_unbundled"
 97       documentation-dir       ">documentation>subsystem>emacs_dir"
 98       site-dir                ">system_library_unbundled"
 99       include-dir             ">library_dir_dir>include")
100 &
101 &label got_dirs
102 &
103 (defun &loader& (l)
104        (mapc '(lambda (x)
105                       (terpri)
106                       (princ "Loading ")
107                       (princ x)
108                       (princ " ....")
109                       (load x))
110              l))
111 &
112 & Load in basic emacs.
113 &
114 (&loader& '(e_defpl1_                   e_lap_
115             e_interact_                 e_multics_files_
116             e_binding_table_            e_option_defaults_
117             e_redisplay_                e_basic_
118             e_window_mgr_               e_listen_interface_
119             e_self_documentor_))
120 &
121 & Fix up alternate-key-bindings.
122 &
123 (do a 0 (1+ a) (= a 2)
124     (do b 0 (1+ b) (= b 128.)
125         (and (eq (key-bindings b a) 'self-insert)
126              (store (alternate-key-bindings b a) 'self-insert))))
127 (store (alternate-key-bindings 33 0) 'escape)
128 &
129 & Load full emacs if dumping complete emacs.
130 &
131 &if [equal &1 emacs_] &then &goto no_unb
132 &
133 &print
134 &print
135 &print Dumping full emacs.
136 &
137 (&loader& '(e_macops_))
138 &
139 &label no_unb
140 &
141 & Get current version number.
142 (setq emacs-version (e_lap_$rtrim (emacs$get_version)))
143 &
144 & Check for experimental installation.
145 &
146 &if [not [equal &2 unb]] &then &goto exl_dump
147 &
148 &print
149 &print
150 &print Dumping standard emacs.
151 &
152 (setq mode-line-herald (catenate "Emacs " emacs-version))
153 &
154 &goto join
155 &
156 &label exl_dump
157 &
158 &print
159 &print
160 &print Dumping experimental emacs.
161 &
162 (setq mode-line-herald (catenate "Emacs " emacs-version " EXL"))
163 &
164 (*rset t)
165 (sstatus uuolinks t)
166 &
167 &label join
168 &
169 &if [equal &2 unb] &then &goto no_carry
170 & For the sake of Carry, create saved environment segment
171 &
172 (cline (catenate "if [not [exists entry &1." emacs-version ".sv.lisp]]"
173           " -then ""create &1." emacs-version ".sv.lisp"""))
174 &
175 &label no_carry
176 &
177 (setplist '&loader& ())
178 (remob '&loader&)
179 &
180 (setq errlist (cons '(hcs_$initiate_count env-dir 'e_pl1_ 'e_pl1_ 0)
181                     errlist)) ;fix supdup output bug.
182 (setq NowDumpingEmacs nil)
183 (gctwa)
184 (gc)
185 (sstatus gctime 0)
186 &
187 applesauce
188 &
189 (eval (list 'save (catenate "&1." emacs-version)))
190 &detach
191 &print
192 &print Finished.
193 &quit