-#include <unistd.h>
-#include <sys/stat.h>
-
-#include <pwd.h>
-
-/*----- Common Lisp runes -------------------------------------------------*/
-
-/* A common preamble rune to do the necessary things.
- *
- * We need to ensure that `asdf' (and therefore `uiop') is loaded. And we
- * should arrange for `:runlisp-script' to find its way into the `*features*'
- * list so that scripts can notice that they're being invoked from the
- * command line rather than loaded into a resident session, and actually do
- * something useful.
- */
-#define COMMON_PRELUDE_RUNE \
- "(progn " \
- "(setf *load-verbose* nil *compile-verbose* nil) " \
- "(require \"asdf\") " \
- "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" " \
- "(find-package \"ASDF\")) " \
- "\"asdf\") " \
- "(set-dispatch-macro-character " \
- "#\\# #\\! " \
- "(lambda (#1=#:stream #2=#:char #3=#:arg) " \
- "(declare (ignore #2# #3#)) " \
- "(values (read-line #1#)))) " \
- "(pushnew :runlisp-script *features*))"
-
-/* Get `uiop' to re-check the command-line arguments following an image
- * restore.
- */
-#define IMAGE_RESTORE_RUNE \
- "(uiop:call-image-restore-hook)"
-
-/* Some Lisps leave crud in the `COMMON-LISP-USER' package. Clear it out. */
-#define CLEAR_CL_USER_RUNE \
- "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) " \
- "(with-package-iterator (#5=#:next #4# :internal) " \
- "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \
- "(#5#) " \
- "(declare (ignore #8#)) " \
- "(unless #6# (return)) " \
- "(unintern #7# #4#)))))"
-
-/*----- Handy macros ------------------------------------------------------*/
-
-#define N(v) (sizeof(v)/sizeof((v)[0]))
-
-#if defined(__GNUC__)
-# define GCC_VERSION_P(maj, min) \
- (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min)))
-#else
-# define GCC_VERSION_P(maj, min) 0
-#endif
-
-#ifdef __clang__
-# define CLANG_VERSION_P(maj, min) \
- (__clang_major__ > (maj) || (__clang_major__ == (maj) && \
- __clang_minor__ >= (min)))
-#else
-# define CLANG_VERSION_P(maj, min) 0
-#endif
-
-#if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3)
-# define NORETURN __attribute__((__noreturn__))
-# define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix)))
-#endif
-
-#if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3)
-# define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail)))
-#endif
-
-#define CTYPE_HACK(func, ch) (func((unsigned char)(ch)))
-#define ISSPACE(ch) CTYPE_HACK(isspace, ch)
-
-#define MEMCMP(x, op, y, n) (memcmp((x), (y), (n)) op 0)
-#define STRCMP(x, op, y) (strcmp((x), (y)) op 0)
-#define STRNCMP(x, op, y, n) (strncmp((x), (y), (n)) op 0)
-
-#define END ((const char *)0)
-
-/*----- The Lisp implementation table -------------------------------------*/
-
-/* The systems, in decreasing order of (not quite my personal) preference.
- * This list is used to initialize various tables and constants.
- */
-#define LISP_SYSTEMS(_) \
- _(sbcl) \
- _(ccl) \
- _(clisp) \
- _(ecl) \
- _(cmucl) \
- _(abcl)
-
-enum {
-#define DEFSYS(sys) sys##_INDEX,
- LISP_SYSTEMS(DEFSYS)
-#undef DEFSYS
- NSYS
-};
-
-enum {
-#define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX,
- LISP_SYSTEMS(DEFFLAG)
-#undef DEFFLAG
- ALL_SYSTEMS = 0
-#define SETFLAG(sys) | sys##_FLAG
- LISP_SYSTEMS(SETFLAG)
-#undef SETFLAG
-};
-
-struct argstate;
-struct argv;
-
-#define DECLENTRY(sys) \
-static void run_##sys(struct argstate *, const char *);
- LISP_SYSTEMS(DECLENTRY)
-#undef DECLENTRY
-
-static const struct systab {
- const char *name;
- unsigned f;
- void (*run)(struct argstate *, const char *);
-} systab[] = {
-#define SYSENTRY(sys) { #sys, sys##_FLAG, run_##sys },
- LISP_SYSTEMS(SYSENTRY)
-#undef SYSENTRY
-};
-
-/*----- Diagnostic utilities ----------------------------------------------*/
-
-static const char *progname = "runlisp";
-
-static void set_progname(const char *prog)
-{
- const char *p;
-
- p = strrchr(prog, '/');
- progname = p ? p + 1 : progname;
-}
-
-static void vmoan(const char *msg, va_list ap)
-{
- fprintf(stderr, "%s: ", progname);
- vfprintf(stderr, msg, ap);
- fputc('\n', stderr);
-}
-
-static PRINTF_LIKE(1, 2) void moan(const char *msg, ...)
- { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); }
-
-static NORETURN PRINTF_LIKE(1, 2) void lose(const char *msg, ...)
- { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); exit(127); }
-
-/*----- Memory allocation -------------------------------------------------*/
-
-static void *xmalloc(size_t n)
-{
- void *p;
-
- if (!n) return (0);
- p = malloc(n); if (!p) lose("failed to allocate memory");
- return (p);
-}
-
-static void *xrealloc(void *p, size_t n)
-{
- if (!n) { free(p); return (0); }
- else if (!p) return (xmalloc(n));
- p = realloc(p, n); if (!p) lose("failed to allocate memory");
- return (p);
-}
-
-static char *xstrdup(const char *p)
-{
- size_t n = strlen(p) + 1;
- char *q = xmalloc(n);
-
- memcpy(q, p, n);
- return (q);
-}
-
-/*----- Dynamic strings ---------------------------------------------------*/
-
-struct dstr {
- char *p;
- size_t len, sz;
~mdw / runlisp / blobdiff