Coverage report: /home/ellis/comp/core/lib/cli/tools/sbcl.lisp

Kind	Covered	All	%
expression	72	121	59.5
branch	5	14	35.7

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

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* (find-exe "sbcl"))

14

15

(when *sbcl* (pushnew :sbcl *cli-tools*))

16

17

;; ref: section 3.3.1 of the manual

18

(defvar *sbcl-runtime-options*

19

'(help version core dynamic-space-size control-stack-size tls-limit

20

noinform disable-ldb lose-on-corruption merge-core-pages no-merge-core-pages))

21

22

(defvar *sbcl-toplevel-options*

23

   '(sysinit userinit no-sysinit no-userinit disable-debugger noprint script quit non-interactive eval load))

24

25

(defvar *sbcl-output* (make-synonym-stream '*standard-output*))

26

(defvar *sbcl-input* (make-synonym-stream '*standard-input*))

27

(defvar *sbcl-wait* t)

28

29

(defun parse-sbcl-option-keys (keys)

30

(let ((rt)

31

(tl))

32

(flet ((%push-opt-rt (opt v)

33

(appendf

34

rt

35

(etypecase v

36

(boolean (list opt))

37

(string (list opt v)))))

38

(%push-opt-tl (opt v)

39

(appendf

40

tl

41

(etypecase v

42

(boolean (list opt))

43

(string (list opt v))))))

44

(sb-int:doplist (k v) keys

45

(unless (null v)

46

(let ((opt (format nil "--~A" (string-downcase (symbol-name k)))))

47

(cond

48

((member k *sbcl-runtime-options* :test 'string=) (%push-opt-rt opt v))

49

((member k *sbcl-toplevel-options* :test 'string=) (%push-opt-tl opt v))

50

((eql k :input) (setf *sbcl-input* v))

51

((eql k :output) (setf *sbcl-output* v))

52

((eql k :wait) (setf *sbcl-wait* v))

53

(t (sbcl-error "Invalid option: ~A ~A" opt v))))))

54

;; append and reverse

55

(nreverse (append tl rt)))))

56

57

(defun run-sbcl (&rest args)

58

(let ((proc (sb-ext:run-program *sbcl* (or args nil) :output *sbcl-output* :input *sbcl-input*)))

59

(if (eq 0 (sb-ext:process-exit-code proc))

60

nil

61

(sbcl-error "SBCL command failed: ~A ~A" *sbcl* (or args "")))))

62

63

(defmacro with-sbcl ((&rest keys) &body body)

64

"Convenience macro for running an external SBCL process in its own shell. The

65

keys are the same as those listed in `sbcl --help` and the BODY is wrapped in

66

a PROGN and passed to the --eval flag."

67

`(run-sbcl ,@(when keys (parse-sbcl-option-keys keys))

68

              ,@(when body (list "--eval" (with-output-to-string (s) (prin1 `(progn ,@body) s))))))