@@@ work in progress

[runlisp] / dump-ecl

### -*-sh-*-
###
### Auxiliary script for dumping ECL
###
### (c) 2020 Mark Wooding
###

###----- Licensing notice ---------------------------------------------------
###
### This file is part of Runlisp, a tool for invoking Common Lisp scripts.
###
### Runlisp is free software: you can redistribute it and/or modify it
### under the terms of the GNU General Public License as published by the
### Free Software Foundation; either version 3 of the License, or (at your
### option) any later version.
###
### Runlisp is distributed in the hope that it will be useful, but WITHOUT
### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
### FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
### for more details.
###
### You should have received a copy of the GNU General Public License
### along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.

set -e

case $# in 4) ;; *) echo >&2 "usage: $0 IMAGE ECL ECLOPT TMP"; exit 2 ;; esac
image=$1 ecl=$2 eclopt=$3 tmp=$4

run () { echo "$*"; "$@"; }

## Start by compiling a copy of ASDF.
cat >"$tmp/ecl-build.lisp" <<EOF
(require "asdf")

(defparameter *asdf* (asdf:find-system "asdf"))

(defun right-here (pathname pattern)
  (declare (ignore pattern))
  (merge-pathnames
   (make-pathname :name (concatenate 'string
				     (string-downcase
				      (lisp-implementation-type))
				     "-"
				     (pathname-name pathname))
		  :type nil
		  :version nil
		  :defaults *default-pathname-defaults*)
   pathname))
(asdf:initialize-output-translations '(:output-translations
				       ((#p"/" :**/ :*.*.*)
					(:function right-here))
				       :ignore-inherited-configuration))

(asdf:operate 'asdf:lib-op *asdf*)
(si:quit 0)
EOF
(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp")

## And now compile our driver code.
cat >"$tmp/ecl-run.lisp" <<EOF
(cl:defpackage #:runlisp
  (:use #:common-lisp))
(cl:in-package #:runlisp)

(defun main ()
  $ignore_shebang_rune
  (asdf:register-immutable-system "asdf")
  (let ((pkg (find-package "COMMON-LISP-USER")))
    (with-package-iterator (next pkg :internal)
      (loop (multiple-value-bind (anyp sym how) (next)
	      (declare (ignore how))
	      (unless anyp (return))
	      (unintern sym pkg)))))
  $set_script_feature_rune
  (let ((winning t) (script nil) (marker nil)
	(prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
    (labels ((lose (msg &rest args)
	       (format *error-output* "~&~A: ~?~%" prog msg args)
	       (setf winning nil))
	     (quit (rc)
	       (si:quit rc))
	     (usage (stream)
	       (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
		       prog))
	     (getarg ()
	       (and (< i argc) (prog1 (si:argv i) (incf i)))))
      (loop (let ((arg (getarg)))
	      (cond ((null arg) (return))
		    ((string= arg "--") (setf marker t) (return))
		    ((string= arg "-s") (setf script (getarg)))
		    ((string= arg "-h") (usage *standard-output*) (quit 0))
		    (t (lose "unrecognized option \`~A'" arg)))))
      (unless script (lose "nothing to do"))
      (unless marker (lose "unexpected end of options (missing \`--'?)"))
      (unless winning (usage *error-output*) (quit 255))
      (handler-case
	  (let ((*package* (find-package "COMMON-LISP-USER")))
	    (load script :verbose nil :print nil))
	(error (err)
	  (format *error-output* "~&~A (uncaught error): ~A~%" prog err)
	  (quit 255)))
      (quit 0))))
(main)
EOF
(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \
  -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")

## Finally link everything together.
run "$ecl" ${eclopt}norc -o "$image"\
  ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o"

###----- That's all, folks --------------------------------------------------