When accessing class slots, instead of writing
(defmethod get-name ((somebody person) (slot-value somebody 'name))
is it possible to use the dot notation aka C++, namely
(defmethod get-name ((somebody person) somebody.name) ?
Otherwise, when there are many slot operations in a method, (slot-value... creates a lot of boilerplate code.
I have figured out the answer today and I am just posting it as a Q&A, but if there are better solutions or there are problems I should expect with my solution, feel free to add new answers or comments.
The library access provides a dot notation reader macro for accessing slots (and hash-tables and other things). After enabling the reader macro by calling (access:enable-dot-syntax) you'll able to use #D. to access a slot name with the dot syntax popular in other languages.
(defclass person ()
((name :initarg :name :reader name)))
CL-USER> (access:enable-dot-syntax)
; No values
CL-USER> (defvar *foo* (make-instance 'person :name "John Smith"))
*FOO*
CL-USER> #D*foo*
#<PERSON #x302001F1E5CD>
CL-USER> #D*foo*.name
"John Smith"
There is also a with-dot macro if you don't want to use a reader macro
CL-USER> (access:with-dot () *foo*.name)
"John Smith"
You should not write accessors by hand, nor use slot-value (outside of object lifecycle functions, where the accessors may not have been created yet). Use the class slot options instead:
(defclass foo ()
((name :reader foo-name
:initarg :name)
(bar :accessor foo-bar
:initarg :bar)))
Now you can use the named accessors:
(defun example (some-foo new-bar)
(let ((n (foo-name some-foo))
(old-bar (foo-bar some-foo)))
(setf (foo-bar some-foo) new-bar)
(values n old-bar)))
Often, you want your classes to be "immutable", you'd use :reader instead of :accessor then, which only creates the reader, not the setf expansion.
The easiest solutions seems to be a reader macro that overloads . so that (slot-value somebody 'name) can be written as .somebody.name My strategy is to read somebody.name as a string (we need to define a non-terminating macro character so that the reader does not stop mid-string), and then process the string to construct the appropriate (slot-value...
I will need two helper functions:
(defun get-symbol (str)
"Make an uppercase symbol"
(intern (string-upcase str)))
(defun split-string (str sep &optional (start 0))
"Split a string into lists given a character separator"
(let ((end (position sep str :start start)))
(cons (subseq str start end) (if end (split-string str sep (1+ end))))))
And then I can define my reader macro:
(defun dot-reader (stream char)
(declare (ignore char))
(labels ((make-query (list)
(let ((car (car list))
(cdr (cdr list)))
(if cdr `(slot-value ,(make-query cdr) (quote ,(get-symbol car)))
(get-symbol car)))))
(make-query (nreverse (split-string (symbol-name (read stream)) #\.)))))
Finally, I need to register this reader macro:
(set-macro-character #\. #'dot-reader t)
Now it is possible to write:
(defmethod get-name ((somebody person) .somebody.name)
or, if name is itself a class,
(defmethod get-name ((somebody person) .somebody.name.first-name)
One restriction is that s-expressions will not work between the dots, say
.(get-my-class).name
won't work.
Related
I want some reader macros to print as as shortened expression that the macro understands. Lets say I want to extend the #' macro to take #'~[rest-of-symbol] and turn that into (complement #'rest-of-symbol).
What controls how that is printed? On SBCL, for instance, '(function +) prints as #'+. How do i make '(complement #'listp) print as #~listp?
My first thought was
(defmethod print-object :around ((obj cons) stream)
;; if #'~fn-name / (complement (function fn-name))
;; => fn-name otherwise NIL
(let ((fn-name
(ignore-errors
(destructuring-bind (complement (function fn-name))
obj
(when (and (eq complement 'complement)
(eq function 'function))
fn-name)))))
(if fn-name
(format stream "#'~~~S" fn-name)
(call-next-method))))
This works insofar as (print-object '(complement #'evenp) *standard-output*) prints it the way I want, but the REPL doesn't. Also (print-object '#'+ *standard-output*) prints it as (function +) so the REPL isn't using print-object. With defining the print-object method for user defined classes the REPL always picks up on the new definition.
This is my first post and I'm sorry I can't get the code to format properly. If someone can put a link on how to do that I would appreciate it.
Evaluation time
You are mixing code with data in your example:
(function +)
Is a special form that evaluates to a function object, which admits a shorter syntax:
#'+
But when you are writing:
'(function +)
or
'(complement fn)
Then in both cases you are writing quoted, literal lists, which evaluates to themselves (namely a list starting with symbol function or complement, followed respectively by symbol + and fn).
However, you want the code to be evaluated at runtime to actual function objects; if you type this in the REPL:
(complement #'alpha-char-p)
The result is a value that is printed as follows:
#<FUNCTION (LAMBDA (&REST SB-IMPL::ARGUMENTS) :IN COMPLEMENT) {101AAC8D9B}>
You have an actual function object that you can funcall. In other words, by the time you reach print-object, you no longer have access to source code, you are manipulating data at runtime which happens to be functions. So you cannot use destructuring-bind to get the complement symbol that was present in the source code.
What you need to do instead is to attach metadata to your function. There is a way to do that in Common Lisp by defining a new type of function, thanks to the Meta-Object Protocol.
Funcallable objects
I'm relying on Closer-MOP for all the symbols prefixed with c2cl: below. I define a new class of functions, annotated-fn, which is a function with addditional data:
(defclass annotated-fn (c2cl:funcallable-standard-object)
((data :initform :data :initarg :data :reader annotated-fn-data))
(:metaclass c2cl:funcallable-standard-class))
Notice that this class is a funcallable-standard-object (like the usual functions), and its metaclass is funcallable-standard-class. Such an object has an additional implicit slot that is a function to call.
More precisely, you have to call c2cl:set-funcallable-instance-function to set a function associated with the object, and when later you use funcall or apply with the object, then the wrapped function is called instead. So you can transparently use this class of functions wherever you usually use a function. It just has additional slots (here data).
For example, here is how I instantiate it, with a function to wrap additional data:
(defun annotate-fn (function data)
(let ((object (make-instance 'annotated-fn :data data)))
(prog1 object
(c2cl:set-funcallable-instance-function object function))))
Let's try it:
(describe
(annotate-fn (constantly 3)
'(:category :constantly)))
#<ANNOTATED-FN {1006275C7B}>
[funcallable-instance]
Lambda-list: UNKNOWN
Derived type: FUNCTION
Documentation:
T
Source file: SYS:SRC;CODE;FUNUTILS.LISP
Slots with :INSTANCE allocation:
DATA = (:CATEGORY :CONSTANTLY)
You can also use this object like any other function.
Now, your reader macros can expand into calls to annotate-fn, and add any kind of additional metadata you need to the function.
Reader macro
For our example, imagine you define a reader macros for constant functions:
(set-macro-character #\[ 'read-constantly t)
(set-macro-character #\] (get-macro-character #\) nil))
(defun read-constantly (stream char)
(declare (ignore char))
(let* ((list (read-delimited-list #\] stream t))
(value (if (rest list) list (first list)))
(var (gensym)))
`(let ((,var ,value))
(annotate-fn (constantly ,var)
(list :category :constantly
:constant ,var)))))
Using this syntax:
> [(+ 8 5)]
=> #<ANNOTATED-FN ...>
By the way, the syntax I defined also allows the following:
> [+ 8 5]
Pretty-printing
Let's define a generic function that prints an annotated function given its :category field:
(defgeneric print-for-category (category data object stream))
(defmethod print-object ((o annotated-fn) s)
(let* ((data (annotated-fn-data o))
(category (getf data :category)))
(print-for-category category data o s)))
Then, we can specialize it for :constantly, and here we assume also that the data associated with the function contains a :constant field:
(defmethod print-for-category ((_ (eql :constantly)) data o s)
(format s "[~s]" (getf data :constant)))
For example:
(let ((value (+ 8 6)))
(annotate-fn (constantly value)
`(:constant ,value
:category :constantly)))
This above is printed as:
[14]
Which would be the same as your hypothetical reader macro.
To do this you need to understand the pretty printer. I have understood it in the past but no longer do completely. It dispatches on type and the trick for things like this is that you can specify very specific types for trees of conses, although doing so is verbose.
Here is an example which is almost certainly not completely correct, but does achieve what you want in this case:
(defparameter *ppd* (copy-pprint-dispatch))
(defun pprint-complement-function (s form)
;; This is the thing that the pretty printer will call. It can
;; assume that the form it wants to print is already correct.
(destructuring-bind (complement (function name)) form
(declare (ignore complement function))
(format s "#'~~~W" name)))
;;; Now set this in the table with a suitable hairy type specification
;;;
(set-pprint-dispatch '(cons (eql complement)
(cons (cons (eql function)
(cons t null))
null))
'pprint-complement-function
0
*ppd*)
And now
> (let ((*print-pprint-dispatch* *ppd*))
(pprint '(complement (function foo)))
(pprint '((complement (function foo)) (function foo))))
#'~foo
(#'~foo #'foo)
You can make the awful nested cons type specifier easier by defining this (which, perhaps, should be the compound type specifier for list except you can't do that):
(deftype list-of-types (&rest types)
(labels ((lot (tt)
(if (null tt)
'null
`(cons ,(first tt) ,(lot (rest tt))))))
(lot types)))
And then
(set-pprint-dispatch '(list-of-types (eql complement)
(list-of-types (eql function)
*))
'pprint-complement-function
0
*ppd*)
is perhaps easier to read.
I am trying to use generic functions' ability to specify behaviour based on the first argument of a list.
In other words, I want the list (atypelist 1 2 3) and the list (btypelist 1 2 3) to have their individual behaviour when passed to foo. So far, this is what I came up with:
(deftype atypelist (lst)
`(eq (car ,lst) 'atypelist))
(deftype btypelist (lst)
`(eq (car ,lst) 'btypelist))
(defmethod foo ((lst atypelist))
(format nil "success atypelist: ~S" lst))
(defmethod foo ((lst btypelist))
(format nil "success btypelist: ~S" lst))
However, when I call (typep (list 'atypelist 1 2 3) 'atypelist) I get the following error:
error while parsing arguments to DEFTYPE ATYPELIST:
too few elements in
()
to satisfy lambda list
(LST):
exactly 1 expected, but got 0
I am guessing the error is in my definition of atypelist.
Questions:
Is there a better way to get the functionality I am looking for?
If yes - what is the way?
If not - how to properly define a type on a list/cons that has a particular symbol in the car?
Before I start: what you want to do can't work, and is confused in two ways.
Firstly deftype defines a type in terms of other type specifiers: the body of a deftype form must expand into a type specifier, not an expression, as yours does. And deftype's arguments are not the thing you want to check the type for, they are parts of the type specification.
In this case you want to specify that the thing is a cons, and that its car is eql to something. Fortunately there are specializing type specifiers for both of these things, and you end up with something like this:
(deftype cons-with-specified-car (x)
`(cons (eql ,x) t))
And now
> (typep '(1) '(cons-with-specified-car 1))
t
> (typep '(a) '(cons-with-specified-car a))
t
> (typep '() '(cons-with-specified-car a))
nil
And if you want:
(deftype cons-with-a ()
'(cons-with-specified-car a))
and now
> (typep '(a) 'cons-with-a)
t
Secondly none of this will work because this it not how CLOS works. CLOS dispatches on classes not types, and you have merely defined a type, not a class: your method definitions simply cannot work, since classes cannot be parametrized in this way like types can.
Some ways you might achieve what you want.
If what you want to do is to dispatch on the first element of a list, then the obvious approach, if you want to use CLOS, is to use a two-level approach where you first dispatch on the class of the thing (cons is a class), and then use eql specializers to pick out the things you want.
(defgeneric select (it)
(:method ((it cons))
(select* (car it) it))
(:method (it)
nil))
(defgeneric select* (key it)
(:method (key it)
(format t "~&unknown key ~S in ~S~%" key it)))
(defmethod select* ((key (eql 'a)) it)
(format t "~&~S begins with a~%" it))
However in a case like this, unless you very much want the extensibility that CLOS gets you (which is a good reason to use CLOS here), I'd just use typecase. You could do this using the type defined above:
(defun select (it)
(typecase it
((cons-with-specified-car a)
'(cons a))
(cons
'cons)
(t
nil)))
or, probably simpler, just use what the deftype expands into:
(defun select (it)
(typecase it
((cons (eql a) t)
'(cons a))
(cons
'cons)
(t
nil)))
Finally probably what anyone doing this would actually write (again, assuming you do not want the extensibility CLOS gets you) is:
(defun select (it)
(typecase it
(cons
(case (car it)
...))
(t
...)))
Here is a possible solution, using the type specifier satisfies:
CL-USER> (defun is-atypelist (list)
(eq (car list) 'atypelist))
IS-ATYPELIST
CL-USER> (defun is-btypelist (list)
(eq (car list) 'btypelist))
IS-BTYPELIST
CL-USER> (deftype atypelist ()
`(satisfies is-atypelist))
ATYPELIST
CL-USER> (deftype btypelist ()
`(satisfies is-btypelist))
BTYPELIST
CL-USER> (typep (list 'atypelist 1 2 3) 'atypelist)
T
CL-USER> (typep (list 'atypelist 1 2 3) 'btypelist)
NIL
Note that this does not define a class, but a type, if this is what you need.
Is there a better way to get the functionality I am looking for?
1. Wrap your lists in container types
(defclass lst () ((items :initarg :items :reader items)))
(defclass alst (lst) ())
(defclass blst (lst) ())
It may be a little bit more cumbersome to work with but this is pretty much straightforward and not too suprising.
2. Douple-dispatch
(defgeneric foo (val))
(defgeneric foo/tag (tag val))
For example:
(defmethod foo ((c cons))
(destructuring-bind (tag . list) c
(foo/tag tag list)))
3. Define a custom method combination
It should be possible to hack the meta-object protocol dispatch mechanism to dispatch on the first item of a list. I wouldn't recommend it however.
4. Use a different dispatch mechanism
Use a completely different dispatching mechanism outside of CLOS, like pprint-dispatch does. For example you may want to use trivia or optima pattern-matching libraries, or cl-algebraic-data-type. This may be more useful if you are dealing with trees of symbols.
I have a struct with :name and :value that I'd like to use as arguments to a macro. But I'm not sure how to tell lisp that.
I can write out the call like
(sxql:yield (sxql:set= :name "a" :value 1))
"SET name = ?, value = ?"
("a" 1)
But I'd like to use an already existing structure
(defstruct my-struct name value)
(setq x (make-my-struct :name "a" :value 1))
; #S(MY-STRUCT :NAME "a" :VALUE 1)
using answers from Common LISP: convert (unknown) struct object to plist?
I've made
(defun struct-plist (x)
"make struct X into a property list. ugly kludge"
(let* ((slots (sb-mop:class-slots (class-of x)))
(names (mapcar 'sb-mop:slot-definition-name slots)))
(alexandria:flatten
(mapcar (lambda (n) (list (intern (string n) "KEYWORD")
(slot-value x n)))
names))))
(setq p (struct-plist x)) ; (:NAME "a" :VALUE 1)
My naive attempts are
(sxql:set= p) ; error in FORMAT: No more argument SET ~{~A = ~A~^, ~}
(funcall 'sxql:set= p) ; SXQL:SET= is a macro, not a function.
(macroexpand (sxql:set= p)) ; error in FORMAT ...
I imagine this is an easy/fundamental lisp programming question. But I'm not sure how to ask it (or search for answers). I'm also hoping there is an better struct<->plist story than what I've stumbled across so far.
EDIT: In case this is really an xy-problem. I've used flydata:defmodel to create the struct and I want to insert to a database using the same model.
This is definitely an xy problem: unfortunately I don't understand y (flydata?) well enough to answer the y part.
Here's why what you are trying to do can't work however. Consider this code in a file being compiled:
(defstruct mine name value)
...
(sxql:set= <anything derived from mine>)
Compiling this file must satisfy two constraints:
It does not fully create the structure type mine (see defstruct);
It must macroexpand sxql:set=.
What these constraints mean is that sxql:set= can't know about the structure at the time it is expanded. So any trick which relies on information about the structure must make that information available at compile time.
As I said, I don't understand the y part well enough to understand what you are trying to do, but a hacky approach to this is:
write a wrapper for defstruct which stashes information at compile time (strictly: at macro-expansion time);
write a wrapper for sxql:set= which uses that information to expand into something which makes sense.
Here is a mindless wrapper for defstruct. Note that this is mindless: it can only understand the most simple defstruct forms, and even then it may be wrong. It exists only as an example.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *structure-information* '()))
(defmacro define-mindless-structure (name &body slots)
(assert (and (symbolp name)
(every #'symbolp slots))
(name slots)
"I am too mindless")
(let ((found (or (assoc name *structure-information*)
(car (push (list name) *structure-information*)))))
(setf (cdr found) (mapcar (lambda (slot)
(list slot (intern (symbol-name slot)
(find-package "KEYWORD"))
(intern (concatenate 'string
(symbol-name name)
"-"
(symbol-name slot)))))
slots)))
`(defstruct ,name ,#slots))
So now
(define-mindless-structure mine
name value)
Will expand into (defstruct mine name value) and, at macroexpansion time will stash some information about this structure in *structure-information*.
Now I stop really understanding what you need to do because I don't know what sxql:set= is meant to do, but it might be something like this:
(defmacro mindless-set= ((s o))
(let ((info (assoc s *structure-information*))
(ov (make-symbol "O")))
(unless info
(error "no information for ~A" s))
`(let ((,ov ,o))
(sxql:set= ,#(loop for (slot initarg accessor) in (cdr info)
;; the compiler will whine about slot annoyingly
collect initarg
collect `(,accessor ,ov))))))
So with this macro, assuming a suitable define-mindless-structure for mine form has been seen by the time the macro is expanded, then
(mindless-set= (mine it))
Will expand into
(let ((#:o it))
(set= :name (mine-name #:o) :value (mine-value #:o)))
But, as I said, I am not sure what the expansion you actually want is.
Finally, before even thinking about using anything like the above, it would be worth looking around to see if there are portability libraries which provide compile/macroexpansion-time functionality like this: there very well may be such, as I don't keep up with things.
I am working through the MP3 database example in Peter Seibel's Practical Common Lisp. Seibel demonstrates how macros can be used to shorten the code for the where function; so now, I am trying to use a macro to shorten the code for the update function. (The original version of the update function is included for reference.) When I run my code, the following error originates from the second-to-last line --
*** - CAR: TERMS is not a list
What am I doing wrong? Here is my code.
(defvar *db* nil)
(defun add-record (cd)
(push cd *db*))
(defun dump-db ()
(dolist (cd *db*)
(format t "~{~a:~10t~a~%~}~%" cd)))
(defun make-cd (title artist rating ripped)
(list :title title :artist artist :rating rating :ripped ripped))
(defun prompt-read (prompt)
(format *query-io* "~a: " prompt)
(force-output *query-io*)
(read-line *query-io*))
(defun prompt-for-cd ()
(make-cd
(prompt-read "Title")
(prompt-read "Artist")
(or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
(y-or-n-p "Ripped [y/n]: ")))
(defun add-cds ()
(loop (add-record (prompt-for-cd) )
(if (not (y-or-n-p "Another? [y/n]: ")) (return) )))
(defun save-db (filename)
(with-open-file (out filename
:direction :output
:if-exists :supersede)
(with-standard-io-syntax
(print *db* out))))
(defun load-db (filename)
(with-open-file (in filename)
(with-standard-io-syntax
(setf *db* (read in) ))))
(defun select (selector-fn)
(remove-if-not selector-fn *db*))
(defun make-comparison-expr (field value)
`(equal (getf cd ,field) ,value))
(defun make-comparison-list (func fields)
(loop while fields
collecting (funcall func (pop fields) (pop fields))))
(defmacro where (&rest clauses)
`#'(lambda (cd) (and ,#(make-comparison-list 'make-comparison-expr clauses))))
(defun make-update-expr (field value)
`(setf (getf row ,field) ,value))
(defmacro make-update-list (fields)
(make-comparison-list 'make-update-expr fields))
(defun update (selector-fn &rest terms)
(print (type-of terms))
(setf *db*
(mapcar
#'(lambda (row)
(when (funcall selector-fn row)
(make-update-list terms))
row)
*db*)))
;(defun update (selector-fn &key title artist rating (ripped nil ripped-p))
; (setf *db*
; (mapcar
; #'(lambda (row)
; (when (funcall selector-fn row)
; (if title (setf (getf row :title) title) )
; (if artist (setf (getf row :artist) artist) )
; (if rating (setf (getf row :rating) rating) )
; (if ripped-p (setf (getf row :ripped) ripped) ))
; row)
; *db*)))
(defun delete-rows (selector-fn)
(setf *db* (remove-if selector-fn *db*)))
;(loop (print (eval (read))))
(add-record (make-cd "Be" "Common" 9 nil))
(add-record (make-cd "Like Water for Chocolate" "Common" 9 nil))
(add-record (make-cd "Be" "Beatles" 9 nil))
(dump-db)
(update (where :artist "Common" :title "Be") :rating 8)
(dump-db)
-----Edit-----
I figured it out. The solution was to make update a macro and to make make-update-list a function. This way, make-update-list could evaluate fields at run-time and update can still abstract away some tedious if statements. Here is the updated update and make-update-list below:
(defun make-update-list (fields)
(make-comparison-list 'make-update-expr fields))
(defmacro update (selector-fn &rest terms)
`(setf *db*
(mapcar
#'(lambda (row)
(when (funcall ,selector-fn row)
,#(make-update-list terms))
row)
*db*)))
Macroexpansion of that make-update-list is done in a separate phase (called "macroexpansion phase") - which occurs around the time a piece of code is compiled or loaded; in this case we're talking about compilation / loading of update. The macro gets expanded with fields bound to the symbol terms, which (the symbol itself) is used as a value in make-comparison-list; I suppose that was not what you expected.
Note, if you go and compile the file line-by-line (C-c C-c in Emacs + SLIME), it'll tell you right during compilation of update that the macro expansion fails because "the value TERMS is not of type LIST".
Generally, think of macros as functions that take in their arguments unevaluated - i.e. a form (make-update-list foo) will get expanded with the macro parameter's fields value bound to foo. What you're trying to achieve here - code generation based on run-time values - is a bit more difficult to do.
You are trying to take the car of a symbol!
> (car 'terms)
*** - CAR: TERMS is not a list
Think of macros as a function that, when used, replaces the code with the result of the macro function everywhere it's used. At this time variables are just symbols and have no meaning besides that.
When you do (make-update-list terms) it will call the macro function with the argument fields being the symbol you passed, which is terms. Since it's a symbol it cannot be iterated like you are trying. You may iterate it at runtime when it surely is a list, but as a macro it isn't a list until you are passing it a list like (make-update-list (title artist rating ripped)).
If it is dynamic in runtime then your macro needs to expand to code that does most of its magic at runtime. Thus a macro is just a source rewriting service and should not have anything to do with what variable might be at runtime since then it has already done its thing.
When working in a top level REPL, I sometimes forget what definitions I've entered into the running lisp system.
I use Clozure CL and it provides the option of saving the application as an image, which I do and can continue where I left off, but at this point it becomes impossible to review all the code, unless I had separately typed and saved the code to xyz file already.
Is there a way to get/extract/view the definitions that I entered, so I can save them as a source file?
The following will extract all the function definitions entered in a package:
(defun get-all-symbols (&optional package)
(let ((lst nil)
(package (find-package package)) )
(do-all-symbols (s lst)
(when (fboundp s)
(unless (and package (not (eql (symbol-package s) package)))
(push (cons s (function-lambda-expression s)) lst) )))))
Try something like:
(get-all-symbols *package*)
Common Lisp (in general) does not provide any standard way to “recover” the source code of a definition once it has been compiled. Normally, it's found in whatever file or buffer you're working-from.
(As Leo's answer points out, there is Function-Lambda-Expression, which can give you some function definitions. It won't help with, say, constants or classes, and it won't always work — as CLHS says, “Any implementation may legitimately return nil as the lambda-expression of any function.” http://clhs.lisp.se/Body/f_fn_lam.htm — his solution is certainly useful in the most common case(s), but it is not “as general” as this one.)
You could use a set of “wrapper” macros which store the forms you pass to them in a global hash-table, and then recover the source from that. Writing that sounded like an interesting little challenge, so the below is my attempt to do something like that.
My Silly Wrappers Solution
Note that the “source” forms stashed in this way won't preserve reader macros, comments, or the like, and will probably choke on some things like defmethod in subtly horrible ways. That's because I blindly store the definitions keyed off the defining form — eg, defun — and the second word, only. It's not smart enough to notice if you rebound a function as a macro or generic function (all three conflicting definitions would be saved), it doesn't read method combinations or lambda lists to save various methods, or any of that. There are lots of other things you might do — eg, (SetF (FDefinition 'FOO) …) — that could bypass these and go unnoticed, so it's far from “foolproof.” Caveat Lector.
The macros here try to inherit the documentation and lambda lists from the underlying forms, so they should work pretty nicely with most IDE's. They do well enough, in Slime.
One way to work with these would be to directly call them; eg, in your REPL you could directly
My-Package> (use-package :wrap-defining-form)
My-Package> (defun$ my-fn (x) (+ x (sqrt x)))
A more dangerous/interesting way is provided in the package Wrap-Defining-Form.Shadowing, in which the macros shadow the real Common-Lisp package definitions …
CL-User> (in-package :CL-USER$)
CL-User$> (defun blah (n) (loop repeat n do (format t "~&Blah …")))
When you're ready to “save” things, run (dump-definitions).
I wrote and tested this in SBCL, but tried to take care that it should work on many/most other implementations. In particular, I used one non-ANSI function: SB-Introspect:Function-Lambda-List. The function here Wrap-Defining-Form::Find-Function-Lambda-List will search all packages for your implementation's version of that function. If it can't find one, all is not lost; but you won't get hints from your IDE about the lambda-list of the wrapped function. (Clozure's seems to work — kinda — for functions, but not macros. That can probably be improved.)
CL-USER> (describe 'defun$)
WRAP-DEFINING-FORM:DEFUN$
[symbol]
DEFUN$ names a macro:
Lambda-list: (NAME LAMBDA-LIST &BODY BODY)
Documentation:
Wrap `DEFUN' and save the original form.
DEFUN: Define a function at top level.
Source file: /home/brpocock/Private/wrap-defining-form.lisp
; No value
Without Function-Lambda-List, the wrapper looks like
Lambda-list: (&REST UNKNOWN-LAMBDA-LIST)
… which is not very helpful.
wrap-defining-form.lisp
EDIT: Debugged in Clozure. Posted to https://github.com/brpocock/wrap-defining-forms also.
;;;; Wrap--Defining-Forms
;;; -*- Lisp -*-
(defpackage wrap-defining-forms
(:use :common-lisp)
(:documentation "Wrap defining forms so that they (try to) save the
source code of the definition being passed.")
(:export #:wrap-defining-form #:dump-definitions
#:defclass$
#:defconstant$
#:defgeneric$
#:define-compiler-macro$
#:define-condition$
#:define-method-combination$
#:define-modify-macro$
#:define-setf-expander$
#:define-symbol-macro$
#:defmacro$
#:defmethod$
#:defpackage$
#:defparameter$
#:defsetf$
#:defstruct$
#:deftype$
#:defun$
#:defvar$))
(defpackage wrap-defining-forms.shadowing
(:documentation "Wrapped forms like DEFUN$ are exported here with the
names of the forms that they wrap, like DEFUN, for
shadowing imports.")
(:export #:defclass
#:defconstant
#:defgeneric
#:define-compiler-macro
#:define-condition
#:define-method-combination
#:define-modify-macro
#:define-setf-expander
#:define-symbol-macro
#:defmacro
#:defmethod
#:defpackage
#:defparameter
#:defsetf
#:defstruct
#:deftype
#:defun
#:defvar)
(:use))
;; Clozure appears to be “smart” and adds Common-Lisp even though we
;; didn't ask for it (and explicily don't want it)
#+ccl (unuse-package '(:ccl :common-lisp)
:wrap-defining-forms.shadowing)
(defpackage :common-lisp-user/save-defs
(:nicknames :cl-user$)
(:use :common-lisp :common-lisp-user)
(:import-from :wrap-defining-forms #:dump-definitions)
(:shadowing-import-from :wrap-defining-forms.shadowing
#:defclass
#:defconstant
#:defgeneric
#:define-compiler-macro
#:define-condition
#:define-method-combination
#:define-modify-macro
#:define-setf-expander
#:define-symbol-macro
#:defmacro
#:defmethod
#:defpackage
#:defparameter
#:defsetf
#:defstruct
#:deftype
#:defun
#:defvar))
;; Clone any other functions you may have packed into CL-User.
(with-package-iterator (next-symbol :common-lisp-user :internal)
(loop for symbol = (next-symbol)
while symbol
for sibling = (intern (symbol-name symbol) (find-package :cl-user$))
when (and (fboundp symbol)
(not (fboundp sibling)))
do (setf (fdefinition sibling) (fdefinition symbol))))
(in-package "WRAP-DEFINING-FORMS")
(defvar *definitions* (make-hash-table)
"Copies of forms defined by the wrappers created by
`WRAP-DEFINING-FORM' which can be stashed with `DUMP-DEFINITIONS'")
#+ccl
(defun ccl-mock-lambda-list (function)
(if (macro-function function)
(list '&rest 'macro-lambda-list)
(multiple-value-bind (required optional restp
keywords)
(ccl:function-args (fdefinition function))
(concatenate ' list
(loop repeat required
collect (gensym "ARG-"))
(when (and optional (plusp optional))
(cons '&optional
(loop repeat optional
collect (gensym "OPT-"))))
(when restp
(list '&rest 'rest))
(when (and keywords (plusp keywords))
(list '&key '&allow-other-keys))))))
(defun find-function-lambda-list ()
"Find the implementation's version of `FUNCTION-LAMBDA-LIST' if there
is one. That way, Slime and friends can still give the proper
lambda-list for the wrapped form. If it can't be found, this will
return a stub with just a &rest-var."
(or
#+sbcl #'sb-introspect:function-lambda-list
#+ccl #'ccl-mock-lambda-list
#-(or ccl sbcl)
(dolist (package (list-all-packages))
(let ((sym (find-symbol "FUNCTION-LAMBDA-LIST" package)))
(when (fboundp sym)
(return-from find-function-lambda-list sym))))
(lambda (function)
(declare (ignore function))
(list '&rest 'unknown-lambda-list))))
(defmacro wrap-defining-form (cl-form)
"Assuming that CL-FORM is a symbol for a macro or function which
defines something interesting (eg, “Defun”), this will create a macro
with the same name with a trailing “$” that will save the source tree
before passing on the form to CL-FORM.
EG: (wrap-defining-form defun) provides a “defun$” which has the
additional side effect of storing the source form in *DEFINITIONS*.
Definitions saved can be recovered by `DUMP-DEFINITIONS'.
This is not industrial-strength; in particular, I expect it to cope
poorly with DEFMETHOD."
(check-type cl-form symbol)
(let ((wrapper (intern (concatenate 'string (symbol-name cl-form) "$")))
(wrapper.shadow (intern (symbol-name cl-form) :wrap-defining-forms.shadowing))
(wrapped-lambda-list (funcall (find-function-lambda-list) 'defun)))
(setf (gethash cl-form *definitions*) (make-hash-table))
`(prog1
(defmacro ,wrapper (&whole whole ,#wrapped-lambda-list)
(declare (ignore ,#(remove-if (lambda (form) (member form lambda-list-keywords))
wrapped-lambda-list)))
,(concatenate 'string "Wrap `" (symbol-name cl-form) "' and save the original form." #(#\newline #\newline)
(symbol-name cl-form) ": " (or (documentation cl-form 'function)
"(see CLHS; no documentation here)"))
(let ((defined (cons ',cl-form (cdr whole))))
(setf (gethash (second whole) (gethash ',cl-form *definitions*))
defined)
defined))
(defmacro ,wrapper.shadow (&whole whole ,#wrapped-lambda-list)
(declare (ignore ,#(remove-if (lambda (form) (member form lambda-list-keywords))
wrapped-lambda-list)))
,(concatenate 'string "Wrap `COMMON-LISP:" (symbol-name cl-form) "' and save the original form."
#(#\newline #\newline)
(symbol-name cl-form) ": " (or (documentation cl-form 'function)
"(see CLHS; no documentation here)"))
(let ((defined (cons ',cl-form (cdr whole))))
(setf (gethash (second whole) (gethash ',cl-form *definitions*))
defined)
defined)))))
(wrap-defining-form defclass)
(wrap-defining-form defconstant)
(wrap-defining-form defgeneric)
(wrap-defining-form define-compiler-macro)
(wrap-defining-form define-condition)
(wrap-defining-form define-method-combination)
(wrap-defining-form define-modify-macro)
(wrap-defining-form define-setf-expander)
(wrap-defining-form define-symbol-macro)
(wrap-defining-form defmacro)
(wrap-defining-form defmethod)
(wrap-defining-form defpackage)
(wrap-defining-form defparameter)
(wrap-defining-form defsetf)
(wrap-defining-form defstruct)
(wrap-defining-form deftype)
(wrap-defining-form defun)
(wrap-defining-form defvar)
(defun dump-definitions (&optional pathname)
"Write out the definitions saved by `WRAP-DEFINING-FORM'-built
wrappers to PATHNAME (or *STANDARD-OUTPUT*)."
(let (output
(*print-case* :capitalize)
;; If writing to file, set margin at 79, but try to keep things under 72.
(*print-right-margin* (if pathname 79 *print-right-margin*))
(*print-miser-width* (if pathname 72 *print-miser-width*)))
(unwind-protect
(progn (setq output (if pathname
(open pathname :direction :output
:if-exists :rename
:if-does-not-exist :create)
*standard-output*))
(multiple-value-bind (sec min hr d m y) (decode-universal-time (get-universal-time))
(declare (ignore sec))
(format output
"~&~|~%;;; definitions as of ~d-~d-~d # ~d:~2,'0d:
\(In-Package #:~a)
~{~{~2%~:<~W ~#_~:I~W ~:_~W~1I ~_~W~:>~}~^~|~}~%~|~%" ; from CLHS 22.2.2 SIMPLE-PPRINT-DEFUN
y m d hr min
(package-name *package*)
(remove-if #'null
(loop for form being the hash-keys of *definitions*
for defs = (gethash form *definitions*)
collect (loop for definition being the hash-values of defs
collect definition))))))
(when output (ignore-errors (close output))))))
Sample Usage
CL-USER> (load "wrap-defining-form.lisp")
T
CL-USER> (use-package :wrap-defining-form)
T
CL-USER> (defun$ trash-word (word)
(let ((s (string word)))
(sort (remove-if-not #'alpha-char-p s) #'char<)))
WARNING: redefining COMMON-LISP-USER::TRASH-WORD in DEFUN
TRASH-WORD
CL-USER> (trash-word 'Blatherscythe)
"ABCEEHHLRSTTY"
CL-USER> (describe 'trash-word)
COMMON-LISP-USER::TRASH-WORD
[symbol]
TRASH-WORD names a compiled function:
Lambda-list: (WORD)
Derived type: (FUNCTION (T) (VALUES SEQUENCE &OPTIONAL))
Source form:
(SB-INT:NAMED-LAMBDA TRASH-WORD
(WORD)
(BLOCK TRASH-WORD
(LET ((S (STRING WORD)))
(SORT (REMOVE-IF-NOT #'ALPHA-CHAR-P S) #'CHAR<))))
; No value
CL-USER> (macroexpand-1 '(defun$ trash-word (word)
(let ((s (string word)))
(sort (remove-if-not #'alpha-char-p s) #'char<))))
(DEFUN TRASH-WORD (WORD)
(LET ((S (STRING WORD)))
(SORT (REMOVE-IF-NOT #'ALPHA-CHAR-P S) #'CHAR<)))
T
CL-USER> (dump-definitions)
;;; definitions as of 2016-12-1 # 15:23:
(In-Package #:COMMON-LISP-USER)
(Defun Trash-Word (Word)
(Let ((S (String Word)))
(Sort (Remove-If-Not #'Alpha-Char-P S) #'Char<)))
NIL
CL-USER> (in-package :Common-Lisp-User/Save-Defs)
#<PACKAGE "COMMON-LISP-USER/SAVE-DEFS">
CL-USER$> (defun 2+ (n) (+ 2 n))
2+
CL-USER$> (describe '2+)
COMMON-LISP-USER/SAVE-DEFS::2+
[symbol]
2+ names a compiled function:
Lambda-list: (N)
Derived type: (FUNCTION (T) (VALUES NUMBER &OPTIONAL))
Source form:
(SB-INT:NAMED-LAMBDA 2+
(N)
(BLOCK 2+ (+ 2 N)))
; No value
CL-USER$> (macroexpand-1 '(defun 2+ (n) (+ 2 n)))
(COMMON-LISP:DEFUN 2+ (N) (+ 2 N))
T
CL-USER$> (documentation 'defun 'function)
"Wrap `COMMON-LISP:DEFUN' and save the original form.
DEFUN: Define a function at top level."
CL-USER$> (dump-definitions)
;;; definitions as of 2016-12-1 # 15:32:
(In-Package #:COMMON-LISP-USER/SAVE-DEFS)
(Common-Lisp:Defun 2+ (N) (+ 2 N))
(Common-Lisp:Defun Trash-Word (Word)
(Let ((S (String Word)))
(Sort (Remove-If-Not #'Alpha-Char-P S) #'Char<)))
NIL
File Backup
Dump-Definitions also will write to a file. (It sets :If-Exists :Rename, so you could have one-level-UNDO protection as well.)
CL-USER$> (dump-definitions "saved.lisp")
NIL
Here is an interactive session with CCL:
? (declaim (optimize (debug 3)))
NIL
The above is not strictly required here, but it doesn't hurt to develop with high debugging levels.
? (defun foo (x) (+ 3 x))
FOO
? (inspect 'foo)
[0] FOO
[1] Type: SYMBOL
[2] Class: #<BUILT-IN-CLASS SYMBOL>
Function
[3] INTERNAL in package: #<Package "COMMON-LISP-USER">
[4] Print name: "FOO"
[5] Value: #<Unbound>
[6] Function: #<Compiled-function FOO #x3020004B3F7F>
[7] Arglist: (X)
[8] Plist: NIL
Inspect> 6
[0] #<Compiled-function FOO #x3020004B3F7F>
[1] Name: FOO
[2] Arglist (analysis): (X)
[3] Bits: 8388864
[4] Plist: (CCL::PC-SOURCE-MAP #(17 70 15 22) CCL::FUNCTION-SYMBOL-MAP
(#(X) . #(63 17 70)) CCL::%FUNCTION-SOURCE-NOTE ...)
[5] Source Location: #<SOURCE-NOTE Interactive "(defun foo (x) (+ 3 x))">
Inspect 1> 5
[0] #<SOURCE-NOTE Interactive "(defun foo (x) (+ 3 x))">
[1] Type: SOURCE-NOTE
[2] Class: #<STRUCTURE-CLASS SOURCE-NOTE>
[3] SOURCE: #(40 100 101 102 117 ...)
[4] FILENAME: NIL
[5] FILE-RANGE: 23
You can see that even from within the REPL, and without running Slime which might also store information about the Emacs environment, you can have access to the source code of FOO. This can be used if you know which function you want to recover. For a recording of your interactive session, follow jkiiski's advice about DRIBBLE.
Perhaps you can easily implement something like this yourself:
(defun my-repl (&optional (file-path "cl-history.lisp"))
"Saves commands to a file"
(loop
(with-open-file (stream file-path
:direction :output
:if-does-not-exist :create
:if-exists :append)
(print '>)
(let ((input (read)))
(format stream "~A~%" input)
(print (eval input))))))
To exit the inner loop you should type (quit).
Alternatively you can use com.informatimago.common-lisp.interactive.interactive:repl