-
Notifications
You must be signed in to change notification settings - Fork 3
/
commands.lisp
150 lines (123 loc) · 6.9 KB
/
commands.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
;;; Shell command-line interface for XCVB
#+xcvb
(module (:depends-on ("specials" "macros")))
(in-package :xcvb)
(declaim (optimize (speed 2) (safety 3) (compilation-speed 0) (debug 3)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Command Spec ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro define-option-spec (name options)
`(eval-now
(defparameter ,name ,options)))
(defmacro define-command (name-keys (names args options
short-description description
&optional ignorable)
&body body)
(let* ((name-keys (ensure-list name-keys))
(name (first name-keys))
(keys (rest name-keys))
(option-spec-var (conc-symbol '+ name '-option-spec+))
(option-spec-val (eval options))
(option-args (mapcar (lambda (option) (intern (string-upcase (caar option))))
option-spec-val))
(ignore (case ignorable ((ignore ignorable) ignorable) (otherwise 'ignore)))
(ignored (if (consp ignorable) (set-difference option-args ignorable) option-args)))
`(progn
,@(when options ;; make it available immediately as well as in further commands
(setf (symbol-value option-spec-var) option-spec-val)
`((define-option-spec ,option-spec-var ,options)))
(register-command-properties
',name :names ',names :option-spec ,(when options option-spec-var)
:short-description ,short-description :description ,description
,@(when keys `(:handle-command-line-keys ',keys)))
(register-command ',name)
(defun ,name
,(append (or args '(&key)) option-args)
,@(when ignorable `((declare (,ignore ,@ignored))))
,@body))))
(defun register-command-properties
(name &rest keys &key
names option-spec short-description description handle-command-line-keys)
"Register the properties associated to a function as a command"
(declare (ignore names option-spec short-description description handle-command-line-keys))
(setf (get name 'command) keys))
(defun registered-command-properties (name)
"Registered properties associated to a function as a command"
(get name 'command))
(defvar *commands* (cons () (make-hash-table :test 'equal))
"A registry of command-line accessible commands, as a cons cell
whose car is a list of command function symbols in reverse,
and whose cdr is a hash-table mapping command-line names to command symbols.
Each symbol must have registered 'command properties.")
(defun commands () ;; associated with current package. Meh.
(symbol-value (conc-symbol '*commands*)))
(defun register-command (command)
(let ((properties (registered-command-properties command))
(commands (commands)))
(pushnew command (car commands))
(dolist (name (getf properties :names))
(setf (gethash name (cdr commands)) command))))
(defun lookup-command (command-name)
"Lookup the command spec for the given command name, or return nil if the
given command name is invalid."
(let ((command (gethash command-name (cdr (commands)))))
(cons command (registered-command-properties command))))
(defun interpret-command (arguments)
(let* ((command (first arguments))
(args (rest arguments))
(registered (lookup-command command))
(fun (first registered))
(properties (rest registered))
(option-spec (getf properties :option-spec))
(keys (getf properties :handle-command-line-keys)))
(cond
(option-spec
(apply 'handle-command-line
option-spec fun
:command-line args :name command
keys))
(fun
(funcall fun args))
((not command)
(errexit 2 "~:@(~A~) requires a command -- try '~:*~A help'." *program*))
(t
(errexit 2 "Invalid ~:@(~A~) command ~S -- try '~2:*~A help'." *program* command)))))
;;;; Common Option Specs
(define-option-spec +xcvb-program-option-spec+
'((("xcvb-program" #\X) :type string :optional t
:documentation "specify where to find the xcvb binary")
(("required-xcvb-version" #\V) :type string :optional t
:documentation "specify a minimum xcvb version")))
(define-option-spec +source-registry-option-spec+
'((("source-registry" #\S) :type string :optional t
:documentation "override your source-registry")))
(define-option-spec +lisp-implementation-option-spec+
'((("lisp-implementation" #\l) :type string :initial-value "sbcl" :documentation "specify type of Lisp implementation")
(("lisp-binary-path" #\p) :type string :optional t :documentation "specify path of Lisp executable")
(("define-feature" #\D) :type string :list t :optional t :documentation "define a CL into the target")
(("undefine-feature" #\U) :type string :list t :optional t :documentation "undefine a CL from the target")))
(define-option-spec +cfasl-option-spec+
'((("disable-cfasl" #\d) :type boolean :optional t :documentation "disable the CFASL feature")))
(define-option-spec +verbosity-option-spec+
'((("verbosity" #\v) :type integer :initial-value 5 :documentation "set verbosity")
(("debugging" #\Z) :type boolean :optional t :initial-value nil :documentation "debug")))
(define-option-spec +setup-option-spec+
'((("setup" #\s) :type string :optional t :documentation "specify a Lisp setup file")))
(define-option-spec +base-image-option-spec+
'((("use-base-image" #\B) :type boolean :optional t :initial-value t :documentation "use a base image")))
(define-option-spec +profiling-option-spec+
'((("profiling" #\P) :type boolean :optional t :documentation "profiling")))
(define-option-spec +workspace-option-spec+
'((("workspace" #\W) :type string :optional t :documentation "specify workspace directory")
(("cache" #\C) :type string :optional t :documentation "specify cache directory")
(("object-cache" #\O) :type string :optional t :documentation "specify object-cache directory")))
(define-option-spec +install-option-spec+
'((("install-prefix") :type string :optional t :documentation "specify install directory prefix")
(("install-program") :type string :optional t :documentation "specify program install directory")
(("install-configuration") :type string :optional t :documentation "specify configuration install directory")
(("install-data") :type string :optional t :documentation "specify data install directory")
(("install-library") :type string :optional t :documentation "specify library install directory")
(("install-image") :type string :optional t :documentation "specify image install directory")
(("install-lisp") :type string :optional t :documentation "specify lisp code install directory")))
(define-option-spec +build-option-spec+
'((("build" #\b) :type string :optional nil :documentation "specify what build to process")))
(define-option-spec +multi-build-option-spec+
'((("build" #\b) :type string :list t :optional nil :documentation "specify what builds to process")))