/[cmucl]/src/code/save.lisp
ViewVC logotype

Diff of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.16 by ram, Thu Aug 6 01:44:17 1992 UTC revision 1.17 by wlott, Wed Apr 28 01:56:52 1993 UTC
# Line 47  Line 47 
47  (defvar lisp-environment-list)  (defvar lisp-environment-list)
48    
49    
 (alien:def-alien-routine "save" (alien:boolean)  
   (file c-call:c-string))  
   
   
50  ;;; PARSE-UNIX-SEARCH-LIST  --  Internal  ;;; PARSE-UNIX-SEARCH-LIST  --  Internal
51  ;;;  ;;;
52  ;;; Returns a list of the directories that are in the specified Unix  ;;; Returns a list of the directories that are in the specified Unix
# Line 99  Line 95 
95          (or (parse-unix-search-list :cmucllib)          (or (parse-unix-search-list :cmucllib)
96              '("/usr/misc/.cmucl/lib/"))))              '("/usr/misc/.cmucl/lib/"))))
97    
98    
99    
100    ;;;; SAVE-LISP itself.
101    
102    (alien:def-alien-routine "save" (alien:boolean)
103      (file c-call:c-string)
104      (initial-function (alien:unsigned #.vm:word-bits)))
105    
106  (defun save-lisp (core-file-name &key  (defun save-lisp (core-file-name &key
107                                   (purify t)                                   (purify t)
108                                   (root-structures ())                                   (root-structures ())
109                                   (constants nil)                                   (constants nil)
110                                   (init-function                                   (init-function #'%top-level)
                                   #'(lambda ()  
                                       (throw 'top-level-catcher nil)))  
111                                   (load-init-file t)                                   (load-init-file t)
112                                   (site-init "library:site-init")                                   (site-init "library:site-init")
113                                   (print-herald t)                                   (print-herald t)
# Line 128  Line 130 
130    
131    :init-function    :init-function
132        This is a function which is called when the created core file is        This is a function which is called when the created core file is
133    resumed.  The default function simply aborts to the top level    resumed.  The default function simply invokes the top level
134    read-eval-print loop.  If the function returns it will be the value    read-eval-print loop.  If the function returns the lisp will exit.
   of Save-Lisp.  
135    
136    :load-init-file    :load-init-file
137        If true, then look for an init.lisp or init.fasl file when the core        If true, then look for an init.lisp or init.fasl file when the core
# Line 148  Line 149 
149    (if purify    (if purify
150        (purify :root-structures root-structures :constants constants)        (purify :root-structures root-structures :constants constants)
151        (gc))        (gc))
152    (unless (save (unix-namestring core-file-name nil))    (flet
153      (reinit)        ((restart-lisp ()
154      (dolist (f *before-save-initializations*) (funcall f))           (catch '%end-of-the-world
155      (dolist (f *after-save-initializations*) (funcall f))             (with-simple-restart (abort "Skip remaining initializations.")
156      (environment-init)               (catch 'top-level-catcher
157      (when site-init (load site-init :if-does-not-exist nil :verbose nil))                 (reinit)
158      (when process-command-line (ext::process-command-strings))                 (dolist (f *before-save-initializations*) (funcall f))
159      (setf *editor-lisp-p* nil)                 (dolist (f *after-save-initializations*) (funcall f))
160      (macrolet ((find-switch (name)                 (environment-init)
161                   `(find ,name *command-line-switches*                 (when site-init
162                          :key #'cmd-switch-name                   (load site-init :if-does-not-exist nil :verbose nil))
163                          :test #'(lambda (x y)                 (when process-command-line
164                                    (declare (simple-string x y))                   (ext::process-command-strings))
165                                    (string-equal x y)))))                 (setf *editor-lisp-p* nil)
166        (when (and process-command-line (find-switch "edit"))                 (macrolet ((find-switch (name)
167          (setf *editor-lisp-p* t))                              `(find ,name *command-line-switches*
168        (when (and load-init-file                                     :key #'cmd-switch-name
169                   (not (and process-command-line (find-switch "noinit"))))                                     :test #'(lambda (x y)
170          (let* ((cl-switch (find-switch "init"))                                               (declare (simple-string x y))
171                 (name (and cl-switch                                               (string-equal x y)))))
172                            (or (cmd-switch-value cl-switch)                   (when (and process-command-line (find-switch "edit"))
173                                (car (cmd-switch-words cl-switch))))))                     (setf *editor-lisp-p* t))
174            (if name                   (when (and load-init-file
175                (load (merge-pathnames name #p"home:") :if-does-not-exist nil)                              (not (and process-command-line
176                (or (load "home:init" :if-does-not-exist nil)                                        (find-switch "noinit"))))
177                    (load "home:.cmucl-init" :if-does-not-exist nil))))))                     (let* ((cl-switch (find-switch "init"))
178      (when process-command-line                            (name (and cl-switch
179        (ext::invoke-switch-demons *command-line-switches*                                       (or (cmd-switch-value cl-switch)
180                                   *command-switch-demons*))                                           (car (cmd-switch-words
181      (when print-herald                                                 cl-switch))))))
182        (print-herald))                       (if name
183      (funcall init-function)))                           (load (merge-pathnames name #p"home:")
184                                   :if-does-not-exist nil)
185                             (or (load "home:init" :if-does-not-exist nil)
186                                 (load "home:.cmucl-init"
187                                       :if-does-not-exist nil))))))
188                   (when process-command-line
189                     (ext::invoke-switch-demons *command-line-switches*
190                                                *command-switch-demons*))
191                   (when print-herald
192                     (print-herald))))
193               (funcall init-function))
194             (unix:unix-exit 0)))
195        (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
196          (without-gcing
197            (save (unix-namestring core-file-name nil) initial-function))))
198      nil)
199    
200    
201    
202    ;;;; PRINT-HERALD support.
203    
204  (defvar *herald-items* ()  (defvar *herald-items* ()
205    "Determines what PRINT-HERALD prints (the system startup banner.)  This is a    "Determines what PRINT-HERALD prints (the system startup banner.)  This is a

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

  ViewVC Help
Powered by ViewVC 1.1.5