roswell.roswell/lisp/dump.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|Dump image for faster startup or Make Executable
exec ros -- $0 "$@"
|#

(progn
  (roswell:include "util")
  (unless (find-package :uiop)
    #-quicklisp(require :uiop)
    #+quicklisp(ql:quickload :uiop :silent t)))

(defpackage :ros.script.dump.3672012101
  (:use :cl :roswell.util))
(in-package :ros.script.dump.3672012101)

(defun dump-dir ()
  (merge-pathnames (format nil "impls/~A/~A/~A/dump/"
                           (uname-m) (uname) (opt "impl"))
                   (homedir)))

(defun output (func params &optional force)
  (flet ((%dump (path &optional mode)
           (if (and (not force)
                    (probe-file path))
               ;; idea??
               ;; (y-or-n-p "Output file exists. Overwrite? [Y,n]")
               (if (eql mode :normal)
                   (format *error-output* "dump ~s already exists~%" (pathname-name path))
                   (format *error-output* "file ~s already exists~%" path))
               (funcall func :output path))))
    (cond
      ((null params)
       (format *error-output* "Usage: ~A [OPTIONS] dump output [-f] [-o OUTPUT] NAME~%" (opt "argv0")))
      ((equal "-f" (first params))
       (output func (rest params) t))
      ((equal "-o" (first params))
       (if (> (length params) 1)
           (%dump (second params))
           (format *error-output* "Missing the pathname for an image.~%")))
      (t (let ((path (merge-pathnames (format nil "~A.~A" (first params) (core-extention))
                                      (dump-dir))))
           (%dump (ensure-directories-exist path) :normal))))))

(defun executable (func params)
  (if params
      (let* ((cmds (let ((*read-eval*))
                     (read-from-string
                      (format nil "(~A)"
                              (opt "restart")))))
             (script (first params))
             (output (or (when (equal (second params) "-o")
                           (or (third params)
                               (warn "Missing argument to -o OUTPUT, falling back to default behavior")))
                         (if (string-equal (pathname-type script) "ros")
                             (make-pathname :type
                                            #-win32 nil
                                            #+win32 "exe"
                                            :defaults script)
                             script))))
        (when (string-equal ; odd people may use uppercase extension...
               (pathname-type script) "ros")
          ;; Note: Why CMDS needs to be updated?
          ;; If you use -l,-r or other options, information on the
          ;; corresponding startup commands are stored in CMDS.
          ;; we just augment it with MAIN function information, because
          ;; we can for ros file.
          ;; Fixme: What is the use case when SCRIPT is not a roswell script?
          (let ((*package* (find-package :cl-user))
                roswell:*cmd*)
            ;; loading script
            (roswell:script script)) ; <--- !!!WARNING!!! Side-effect on roswell:*main*
          (let ((main-list (let ((*package* (find-package :keyword)))
                             `((:entry ,(format nil "~S" roswell:*main*))))))
            (setf cmds (if (first cmds)
                           (append cmds main-list)
                           main-list))))
        (unless cmds
          ;; Fixme: when STRING-EQUAL is not satisfied, cmds is something like
          ;; ((:entry "COMMON-LISP:NIL")), which eventually fails.
          ;; it is better to capture this.
          (warn "dumping an executable without specifing the initial behaviour."))
        (funcall func :executable cmds output script))
      (format *error-output* "Usage: ros dump executable help~%")))

(defvar *subcmds*
  '(output
    executable))

(defun main (&rest r)
  (let ((module (module "dump" (or
                                #+ccl "ccl"
                                #+cmucl "cmucl"
                                (remove #\Space (string-downcase (lisp-implementation-type)))))))
    (cond
      ((and module r)
       (let ((func (find (first r) (funcall module :query *subcmds*)
                         :test 'equal
                         :key 'string-downcase)))
         (if func
             (funcall func module (rest r))
             (format *error-output* "'~A' is not a valid command for '~A' subcommand for ~A ~%"
                     (first r) (pathname-name *load-pathname*) (lisp-implementation-type)))))
      (module
       (format *error-output* "Possible subcmd~%~%~{~(~A~)~%~}" (funcall module :query *subcmds*)))
      (t
       (format *error-output* "'~A' is not supported for ~A ~%"
               (pathname-name *load-pathname*) (lisp-implementation-type))))))
;;; vim: set ft=lisp lisp: