-
Notifications
You must be signed in to change notification settings - Fork 1
/
package.lisp
54 lines (46 loc) · 2.21 KB
/
package.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
;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause
(uiop:define-package :prompter
(:use :common-lisp)
(:import-from :nclasses #:define-class #:define-generic)
(:import-from :serapeum #:export-always))
(in-package prompter)
(eval-when (:compile-toplevel :load-toplevel :execute)
(trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
(trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum)
(trivial-package-local-nicknames:add-package-local-nickname :lpara :lparallel)
(trivial-package-local-nicknames:add-package-local-nickname :lpara.queue :lparallel.queue))
(defmacro define-function (name args &body body)
"Eval ARGS then define function over the resulting lambda list.
All ARGS are declared as `ignorable'."
(let ((evaluated-args (eval args)))
`(defun ,name ,evaluated-args
(declare (ignorable ,@(set-difference (mapcar (lambda (arg) (if (listp arg) (first arg) arg))
evaluated-args)
lambda-list-keywords)))
,@body)))
(defun slot-names (class-specifier)
;; TODO: `slot-names' or `direct-slot-names'?
#-ecl
(mopu:slot-names class-specifier)
#+ecl
(mapcar #'c2mop:slot-definition-name (c2mop:class-slots (find-class class-specifier))))
(defun initargs (class-specifier)
"Return CLASS-SPECIFIER initargs as symbols (not keywords)."
(delete nil
(mapcar (lambda (slot)
(intern
(symbol-name
(first (getf (mopu:slot-properties class-specifier slot) :initargs)))
(symbol-package class-specifier)))
(slot-names class-specifier))))
(defun exported-p (sym)
(eq :external
(nth-value 1 (find-symbol (string sym) (symbol-package sym)))))
(defun public-initargs (class-specifier)
"Return CLASS-SPECIFIER initargs as symbols (not keywords)."
(delete-if (complement #'exported-p) (initargs class-specifier)))
(export-always '*debug-on-error*)
(defvar *debug-on-error* nil
"When non-nil, the Lisp debugger is invoked when a condition is raised.
Otherwise all errors occurring in threads are demoted to warnings.")