/[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.7 by ram, Wed Jun 5 14:00:25 1991 UTC revision 1.8 by ram, Fri Aug 30 15:40:53 1991 UTC
# Line 12  Line 12 
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; Dump the current lisp image into a core file.  All the real work is done  ;;; Dump the current lisp image into a core file.  All the real work is done
15  ;;; be C.  ;;; be C.  Also contains various high-level initialization stuff: loading init
16    ;;; files and parsing environment variables.
17  ;;;  ;;;
18  ;;; Written by William Lott.  ;;; Written by William Lott.
19  ;;;  ;;;
# Line 50  Line 51 
51    (file null-terminated-string))    (file null-terminated-string))
52    
53    
54    ;;; PARSE-UNIX-SEARCH-LIST  --  Internal
55    ;;;
56    ;;; Returns a list of the directories that are in the specified Unix
57    ;;; environment variable.  Return NIL if the variable is undefined.
58    ;;;
59    (defun parse-unix-search-list (var)
60      (let ((path (cdr (assoc var ext::*environment-list*))))
61        (when path
62          (do* ((i 0 (1+ p))
63                (p (position #\: path :start i)
64                   (position #\: path :start i))
65                (pl ()))
66               ((null p)
67                (let ((s (subseq path i)))
68                  (if (string= s "")
69                      (push "default:" pl)
70                      (push (concatenate 'simple-string s "/") pl)))
71                (nreverse pl))
72            (let ((s (subseq path i p)))
73              (if (string= s "")
74                  (push "default:" pl)
75                  (push (concatenate 'simple-string s "/") pl)))))))
76    
77    
78    ;;; ENVIRONMENT-INIT  --  Internal
79    ;;;
80    ;;;    Parse the LISP-ENVIRONMENT-LIST into a keyword alist.  Set up default
81    ;;; search lists.
82    ;;;
83    (defun environment-init ()
84      (dolist (ele lisp-environment-list)
85        (let ((=pos (position #\= (the simple-string ele))))
86          (when =pos
87            (push (cons (intern (string-upcase (subseq ele 0 =pos))
88                                *keyword-package*)
89                        (subseq ele (1+ =pos)))
90                  *environment-list*))))
91      (setf (search-list "default:") (list (default-directory)))
92      (setf (search-list "path:") (parse-unix-search-list :path))
93      (setf (search-list "library:") (parse-unix-search-list :cmucllib)))
94    
95    
96  (defun save-lisp (core-file-name &key  (defun save-lisp (core-file-name &key
97                                   (purify t)                                   (purify t)
98                                   (root-structures ())                                   (root-structures ())
# Line 58  Line 101 
101                                    #'(lambda ()                                    #'(lambda ()
102                                        (throw 'top-level-catcher nil)))                                        (throw 'top-level-catcher nil)))
103                                   (load-init-file t)                                   (load-init-file t)
104                                     (site-init "library:site-init")
105                                   (enable-gc t)                                   (enable-gc t)
106                                   (print-herald t)                                   (print-herald t)
107                                   (process-command-line t))                                   (process-command-line t))
# Line 86  Line 130 
130    :load-init-file    :load-init-file
131        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
132    file is resumed.    file is resumed.
133    
134      :site-init
135          If true, then the name of the site init file to load.  The default is
136          library:site-init.  No error if this does not exist.
137    
138    :print-herald    :print-herald
139        If true, print out the lisp system herald when starting.        If true, print out the lisp system herald when starting.
140    
141    :enable-gc    :enable-gc
142        If true, turn GC on if it was off."        If true, turn GC on if it was off."
143    
144    (eval:flush-interpreted-function-cache)    (when (fboundp 'eval:flush-interpreted-function-cache)
145        (eval:flush-interpreted-function-cache))
146    (if purify    (if purify
147        (purify :root-structures root-structures :constants constants)        (purify :root-structures root-structures :constants constants)
148        (gc))        (gc))
# Line 101  Line 150 
150      (dolist (f *before-save-initializations*) (funcall f))      (dolist (f *before-save-initializations*) (funcall f))
151      (dolist (f *after-save-initializations*) (funcall f))      (dolist (f *after-save-initializations*) (funcall f))
152      (reinit)      (reinit)
153      (dolist (ele lisp-environment-list)      (environment-init)
154        (let ((=pos (position #\= (the simple-string ele))))      (when site-init (load site-init :if-does-not-exist nil))
         (when =pos  
           (push (cons (intern (string-upcase (subseq ele 0 =pos))  
                               *keyword-package*)  
                       (subseq ele (1+ =pos)))  
                 *environment-list*))))  
     (setf (search-list "default:") (list (default-directory)))  
     (setf (search-list "path:") (setup-path-search-list))  
155      (when process-command-line (ext::process-command-strings))      (when process-command-line (ext::process-command-strings))
156      (setf *editor-lisp-p* nil)      (setf *editor-lisp-p* nil)
157      (macrolet ((find-switch (name)      (macrolet ((find-switch (name)
# Line 123  Line 165 
165        (when (and load-init-file        (when (and load-init-file
166                   (not (and process-command-line (find-switch "noinit"))))                   (not (and process-command-line (find-switch "noinit"))))
167          (let* ((cl-switch (find-switch "init"))          (let* ((cl-switch (find-switch "init"))
168                 (name (or (and cl-switch                 (name (and cl-switch
169                                (or (cmd-switch-value cl-switch)                            (or (cmd-switch-value cl-switch)
170                                    (car (cmd-switch-words cl-switch))                                (car (cmd-switch-words cl-switch))))))
171                                    "init"))            (if name
172                           "init")))                (load (merge-pathnames name (user-homedir-pathname))
173            (load (merge-pathnames name (user-homedir-pathname))                      :if-does-not-exist nil)
174                  :if-does-not-exist nil))))                (or (load "home:init" :if-does-not-exist nil)
175                      (load "home:.cmucl-init" :if-does-not-exist nil))))))
176      (when enable-gc      (when enable-gc
177        (gc-on))        (gc-on))
178      (when print-herald      (when print-herald
# Line 157  Line 200 
200        (write-string ", target ")        (write-string ", target ")
201        (write-string (c:backend-version c:*backend*)))        (write-string (c:backend-version c:*backend*)))
202      (terpri)      (terpri)
203      (write-line "Send bug reports and questions to cmucl-bugs+@cs.cmu.edu."))      (write-line "Send bug reports and questions to cmucl-bugs@cs.cmu.edu."))
204    (values))    (values))
205    
206    
# Line 170  Line 213 
213  (defun initial-init-function ()  (defun initial-init-function ()
214    (gc-on)    (gc-on)
215    (throw 'top-level-catcher nil))    (throw 'top-level-catcher nil))
   

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

  ViewVC Help
Powered by ViewVC 1.1.5