chiark - git - mdw - runlisp/blob - dump-ecl

   1 ### -*-sh-*-
   2 ###
   3 ### Auxiliary script for dumping ECL
   4 ###
   5 ### (c) 2020 Mark Wooding
   6 ###
   7
   8 ###----- Licensing notice ---------------------------------------------------
   9 ###
  10 ### This file is part of Runlisp, a tool for invoking Common Lisp scripts.
  11 ###
  12 ### Runlisp is free software: you can redistribute it and/or modify it
  13 ### under the terms of the GNU General Public License as published by the
  14 ### Free Software Foundation; either version 3 of the License, or (at your
  15 ### option) any later version.
  16 ###
  17 ### Runlisp is distributed in the hope that it will be useful, but WITHOUT
  18 ### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  19 ### FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20 ### for more details.
  21 ###
  22 ### You should have received a copy of the GNU General Public License
  23 ### along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 set -e
  26
  27 case $# in 4) ;; *) echo >&2 "usage: $0 IMAGE ECL ECLOPT TMP"; exit 2 ;; esac
  28 image=$1 ecl=$2 eclopt=$3 tmp=$4
  29
  30 run () { echo "$*"; "$@"; }
  31
  32 ## Start by compiling a copy of ASDF.
  33 cat >"$tmp/ecl-build.lisp" <<EOF
  34 (require "asdf")
  35
  36 (defparameter *asdf* (asdf:find-system "asdf"))
  37
  38 (defun right-here (pathname pattern)
  39   (declare (ignore pattern))
  40   (merge-pathnames
  41    (make-pathname :name (concatenate 'string
  42                                      (string-downcase
  43                                       (lisp-implementation-type))
  44                                      "-"
  45                                      (pathname-name pathname))
  46                   :type nil
  47                   :version nil
  48                   :defaults *default-pathname-defaults*)
  49    pathname))
  50 (asdf:initialize-output-translations '(:output-translations
  51                                        ((#p"/" :**/ :*.*.*)
  52                                         (:function right-here))
  53                                        :ignore-inherited-configuration))
  54
  55 (asdf:operate 'asdf:lib-op *asdf*)
  56 (si:quit 0)
  57 EOF
  58 (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp")
  59
  60 ## And now compile our driver code.
  61 cat >"$tmp/ecl-run.lisp" <<EOF
  62 (cl:defpackage #:runlisp
  63   (:use #:common-lisp))
  64 (cl:in-package #:runlisp)
  65
  66 (defun main ()
  67   $ignore_shebang_rune
  68   (asdf:register-immutable-system "asdf")
  69   (let ((pkg (find-package "COMMON-LISP-USER")))
  70     (with-package-iterator (next pkg :internal)
  71       (loop (multiple-value-bind (anyp sym how) (next)
  72               (declare (ignore how))
  73               (unless anyp (return))
  74               (unintern sym pkg)))))
  75   $set_script_feature_rune
  76   (let ((winning t) (script nil) (marker nil)
  77         (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
  78     (labels ((lose (msg &rest args)
  79                (format *error-output* "~&~A: ~?~%" prog msg args)
  80                (setf winning nil))
  81              (quit (rc)
  82                (si:quit rc))
  83              (usage (stream)
  84                (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
  85                        prog))
  86              (getarg ()
  87                (and (< i argc) (prog1 (si:argv i) (incf i)))))
  88       (loop (let ((arg (getarg)))
  89               (cond ((null arg) (return))
  90                     ((string= arg "--") (setf marker t) (return))
  91                     ((string= arg "-s") (setf script (getarg)))
  92                     ((string= arg "-h") (usage *standard-output*) (quit 0))
  93                     (t (lose "unrecognized option \`~A'" arg)))))
  94       (unless script (lose "nothing to do"))
  95       (unless marker (lose "unexpected end of options (missing \`--'?)"))
  96       (unless winning (usage *error-output*) (quit 255))
  97       (handler-case
  98           (let ((*package* (find-package "COMMON-LISP-USER")))
  99             (load script :verbose nil :print nil))
 100         (error (err)
 101           (format *error-output* "~&~A (uncaught error): ~A~%" prog err)
 102           (quit 255)))
 103       (quit 0))))
 104 (main)
 105 EOF
 106 (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \
 107   -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")
 108
 109 ## Finally link everything together.
 110 run "$ecl" ${eclopt}norc -o "$image"\
 111   ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o"
 112
 113 ###----- That's all, folks --------------------------------------------------