changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/cli/tools/sbcl.lisp

changeset 698: 96958d3eb5b0
parent: af486e0a40c9
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; sbcl.lisp --- SBCL Tools
     2 
     3 ;; 
     4 
     5 ;;; Code:
     6 (in-package :cli/tools/sbcl)
     7 
     8 (deferror sbcl-error (simple-error error) ())
     9 
    10 (defun sbcl-error (fmt &rest args)
    11   (error 'sbcl-error :format-arguments args :format-control fmt))
    12 
    13 (defparameter *sbcl* (or sb-ext:*runtime-pathname* (find-exe "sbcl")))
    14 
    15 ;; ref: section 3.3.1 of the manual
    16 (defvar *sbcl-runtime-options*
    17   '(help version core dynamic-space-size control-stack-size tls-limit
    18     noinform disable-ldb lose-on-corruption merge-core-pages no-merge-core-pages))
    19 
    20 (defvar *sbcl-toplevel-options*
    21   '(sysinit userinit no-sysinit no-userinit disable-debugger noprint script quit non-interactive eval load))
    22 
    23 (defun parse-sbcl-option-keys (keys)
    24   (let ((ret))
    25     (sb-int:doplist (k v) keys
    26       (unless (null v)
    27         (push (format nil "--~A" (string-downcase (symbol-name k))) ret)
    28         (etypecase v
    29           (boolean nil)
    30           (string (push v ret)))))
    31     (nreverse ret)))
    32 
    33 (defun run-sbcl (&rest args)
    34   (let ((proc (sb-ext:run-program *sbcl* (or args nil) :output :stream)))
    35     (with-open-stream (s (sb-ext:process-output proc))
    36       (loop for l = (read-line s nil nil)
    37             while l
    38             do (write-line l)))
    39     (if (eq 0 (sb-ext:process-exit-code proc))
    40         nil
    41         (sbcl-error "SBCL command failed: ~A ~A" *sbcl* (or args "")))))
    42 
    43 (defmacro with-sbcl ((&rest keys) &body body)
    44   "Convenience macro for running an external SBCL process in its own shell. The
    45 keys are the same as those listed in `sbcl --help` and the BODY is wrapped in
    46 a PROGN and passed to the --eval flag."
    47   `(run-sbcl ,@(when keys (parse-sbcl-option-keys keys))
    48              ,@(when body
    49                  (flatten
    50                   (mapcar (lambda (x) (list "--eval" (with-output-to-string (s) (prin1 x s))))
    51                           body)))))