home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / save.lisp < prev    next >
Encoding:
Text File  |  1992-08-06  |  8.1 KB  |  238 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: save.lisp,v 1.16 92/08/06 01:44:17 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Dump the current lisp image into a core file.  All the real work is done
  15. ;;; be C.  Also contains various high-level initialization stuff: loading init
  16. ;;; files and parsing environment variables.
  17. ;;;
  18. ;;; Written by William Lott.
  19. ;;; 
  20. ;;;
  21. (in-package "LISP")
  22.  
  23. (in-package "EXTENSIONS")
  24. (export '(print-herald *herald-items* save-lisp *before-save-initializations*
  25.       *after-save-initializations* *environment-list* *editor-lisp-p*))
  26. (in-package "LISP")
  27.  
  28. (defvar *before-save-initializations* nil
  29.   "This is a list of functions which are called before creating a saved core
  30.   image.  These functions are executed in the child process which has no ports,
  31.   so they cannot do anything that tries to talk to the outside world.")
  32.  
  33. (defvar *after-save-initializations* nil
  34.   "This is a list of functions which are called when a saved core image starts
  35.   up.  The system itself should be initialized at this point, but applications
  36.   might not be.")
  37.  
  38. (defvar *environment-list* nil
  39.   "An alist mapping environment variables (as keywords) to either values")
  40.  
  41. (defvar *editor-lisp-p* nil
  42.   "This is true if and only if the lisp was started with the -edit switch.")
  43.  
  44.  
  45.  
  46. ;;; Filled in by the startup code.
  47. (defvar lisp-environment-list)
  48.  
  49.  
  50. (alien:def-alien-routine "save" (alien:boolean)
  51.   (file c-call:c-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.   (setq *environment-list* ())
  85.   (dolist (ele lisp-environment-list)
  86.     (let ((=pos (position #\= (the simple-string ele))))
  87.       (when =pos
  88.     (push (cons (intern (string-upcase (subseq ele 0 =pos))
  89.                 *keyword-package*)
  90.             (subseq ele (1+ =pos)))
  91.           *environment-list*))))
  92.   (setf (search-list "default:") (list (default-directory)))
  93.   (setf (search-list "path:") (parse-unix-search-list :path))
  94.   (setf (search-list "home:")
  95.     (or (parse-unix-search-list :home)
  96.         (list (default-directory))))
  97.  
  98.   (setf (search-list "library:")
  99.     (or (parse-unix-search-list :cmucllib)
  100.         '("/usr/misc/.cmucl/lib/"))))
  101.  
  102. (defun save-lisp (core-file-name &key
  103.                  (purify t)
  104.                  (root-structures ())
  105.                  (constants nil)
  106.                  (init-function
  107.                   #'(lambda ()
  108.                       (throw 'top-level-catcher nil)))
  109.                  (load-init-file t)
  110.                  (site-init "library:site-init")
  111.                  (print-herald t)
  112.                  (process-command-line t))
  113.   "Saves a CMU Common Lisp core image in the file of the specified name.  The
  114.   following keywords are defined:
  115.   
  116.   :purify
  117.       If true, do a purifying GC which moves all dynamically allocated
  118.   objects into static space so that they stay pure.  This takes somewhat
  119.   longer than the normal GC which is otherwise done, but GC's will done
  120.   less often and take less time in the resulting core file.
  121.  
  122.   :root-structures
  123.   :constants
  124.       These should be a list of the main entry points in any newly loaded
  125.   systems and a list of any large data structures that will never again
  126.   be changed.  These need not be supplied, but locality and/or GC performance
  127.   will be better if they are.  They are meaningless if :purify is NIL.
  128.   
  129.   :init-function
  130.       This is a function which is called when the created core file is
  131.   resumed.  The default function simply aborts to the top level
  132.   read-eval-print loop.  If the function returns it will be the value
  133.   of Save-Lisp.
  134.   
  135.   :load-init-file
  136.       If true, then look for an init.lisp or init.fasl file when the core
  137.   file is resumed.
  138.  
  139.   :site-init
  140.       If true, then the name of the site init file to load.  The default is
  141.       library:site-init.  No error if this does not exist.
  142.  
  143.   :print-herald
  144.       If true, print out the lisp system herald when starting."
  145.  
  146.   (when (fboundp 'eval:flush-interpreted-function-cache)
  147.     (eval:flush-interpreted-function-cache))
  148.   (if purify
  149.       (purify :root-structures root-structures :constants constants)
  150.       (gc))
  151.   (unless (save (unix-namestring core-file-name nil))
  152.     (reinit)
  153.     (dolist (f *before-save-initializations*) (funcall f))
  154.     (dolist (f *after-save-initializations*) (funcall f))
  155.     (environment-init)
  156.     (when site-init (load site-init :if-does-not-exist nil :verbose nil))
  157.     (when process-command-line (ext::process-command-strings))
  158.     (setf *editor-lisp-p* nil)
  159.     (macrolet ((find-switch (name)
  160.          `(find ,name *command-line-switches*
  161.             :key #'cmd-switch-name
  162.             :test #'(lambda (x y)
  163.                   (declare (simple-string x y))
  164.                   (string-equal x y)))))
  165.       (when (and process-command-line (find-switch "edit"))
  166.     (setf *editor-lisp-p* t))
  167.       (when (and load-init-file
  168.          (not (and process-command-line (find-switch "noinit"))))
  169.     (let* ((cl-switch (find-switch "init"))
  170.            (name (and cl-switch
  171.               (or (cmd-switch-value cl-switch)
  172.                   (car (cmd-switch-words cl-switch))))))
  173.       (if name
  174.           (load (merge-pathnames name #p"home:") :if-does-not-exist nil)
  175.           (or (load "home:init" :if-does-not-exist nil)
  176.           (load "home:.cmucl-init" :if-does-not-exist nil))))))
  177.     (when process-command-line
  178.       (ext::invoke-switch-demons *command-line-switches*
  179.                  *command-switch-demons*))
  180.     (when print-herald
  181.       (print-herald))
  182.     (funcall init-function)))
  183.  
  184.  
  185. (defvar *herald-items* ()
  186.   "Determines what PRINT-HERALD prints (the system startup banner.)  This is a
  187.    database which can be augmented by each loaded system.  The format is a
  188.    property list which maps from subsystem names to the banner information for
  189.    that system.  This list can be manipulated with GETF -- entries are printed
  190.    in, reverse order, so the newest entry is printed last.  Usually the system
  191.    feature keyword is used as the system name.  A given banner is a list of
  192.    strings and functions (or function names).  Strings are printed, and
  193.    functions are called with an output stream argument.")
  194.  
  195. (setf (getf *herald-items* :common-lisp)
  196.       `("CMU Common Lisp "
  197.     ,#'(lambda (stream)
  198.          (write-string (lisp-implementation-version) stream))
  199.     ", running on "
  200.     ,#'(lambda (stream) (write-string (machine-instance) stream))))
  201.  
  202. (setf (getf *herald-items* :bugs)
  203.       '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu."
  204.     terpri
  205.     "Loaded subsystems:"))
  206.  
  207. ;;; PRINT-HERALD  --  Public
  208. ;;;
  209. (defun print-herald (&optional (stream *standard-output*))
  210.   "Print some descriptive information about the Lisp system version and
  211.    configuration."
  212.   (let ((res ()))
  213.     (do ((item *herald-items* (cddr item)))
  214.     ((null item))
  215.       (push (second item) res))
  216.  
  217.     (fresh-line stream)
  218.     (dolist (item res)
  219.       (dolist (thing item)
  220.     (typecase thing
  221.       (string
  222.        (write-string thing stream))
  223.       (function (funcall thing stream))
  224.       ((or symbol cons)
  225.        (funcall (fdefinition thing) stream))
  226.       (t
  227.        (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
  228.       (fresh-line stream)))
  229.  
  230.   (values))
  231.  
  232.  
  233. ;;;; Random functions used by worldload.
  234.  
  235. (defun assert-user-package ()
  236.   (unless (eq *package* (find-package "USER"))
  237.     (error "Change *PACKAGE* to the USER package and try again.")))
  238.