I am putting together a macro to generate simple functions of the style:
(defun hello ()
(format t "hello~&"))
Each new function will have hello replaced.
(defmacro generate-echoers (list)
`(let ((list-of-functions
(loop for var in ,list
collect
`(defun ,(intern var) ()
(format t ,(concatenate var "~&"))))))
`(progn
,list-of-functions)))
I developed the above function, which demonstrates conclusively that I have not yet masted quote-times and phases of expansion.
The desired usage is as follows:
(generate-echoers '("hi" "ping" "pong")) => ;A list of functions that each say their name, as HELLO does above.
A function to generate:
(defun hello ()
(format t "hello~&"))
I would first write a function which creates above code:
(defun make-echoers (name)
`(defun ,(intern (string-upcase name)) ()
(format t ,(concatenate 'string name "~&"))))
Note that symbols are by default uppercase in Common Lisp - so we are using uppercase, too.
Then you can test it:
CL-USER 1 > (make-echoers "hello")
(DEFUN HELLO NIL (FORMAT T "hello~&"))
Works. Now let's use it:
(defmacro generate-echoers (list)
`(progn ,#(mapcar #'make-echoers list)))
Test it:
CL-USER 2 > (macroexpand-1 '(generate-echoers ("hi" "ping" "pong")))
(PROGN
(DEFUN HI NIL (FORMAT T "hi~&"))
(DEFUN PING NIL (FORMAT T "ping~&"))
(DEFUN PONG NIL (FORMAT T "pong~&")))
Your code can be simplified and made more correct like this:
(defmacro generate-echoers (list)
`(progn ,#(loop :for var :in list
:collect `(defun ,(intern (format nil "~:#(~A~)" var)) ()
(format t ,(concatenate 'string var "~&"))))))
First of all, you've got to splice the loop's result into the generated body.
Also you've forgotten, that concatenate takes type parameter and to upcase all your vars (otherwise you'll get function names like |foo|).
If you pass symbols to the generate-echoers macro (instead of strings), the intern call is no longer necessary:
(defmacro generate-echoers (&rest echoers)
`(progn
,#(mapcar (lambda (var)
`(defun ,var ()
(format t ,(format nil "~(~a~)~&" var))))
echoers)))
Related
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
How can I use cl-letf or similar to override a symbol's function value during an async call? I want to stop a buffer being displayed after calls to start-process or start-process-shell-command, and instead get back a string instead.
Here is a simplified example where binding display-buffer works for the synchronous version but not the async version. Also, I have set lexical-binding to true.
(defun tst-fun-sync (url)
(call-process "wget" nil "*wget*" nil url "-O" "-")
(with-current-buffer "*wget*"
(display-buffer (current-buffer))))
(defun tst-fun-async (url)
(set-process-sentinel
(start-process "wget" "*wget*" "wget" url "-O" "-")
#'(lambda (p _m)
(when (zerop (process-exit-status p))
(with-current-buffer (process-buffer p)
(display-buffer (current-buffer)))))))
(defun tst-fun-no-display (fun &rest args)
(cl-letf (((symbol-function 'display-buffer)
#'(lambda (&rest _ignored)
(message "%s" (buffer-string)))))
(apply fun args)))
;; The first has desired result, but not the second
;; (tst-fun-no-display 'tst-fun-sync "http://www.stackoverflow.com")
;; (tst-fun-no-display 'tst-fun-async "http://www.stackoverflow.com")
Let's define a macro which temporarily rebinds set-process-sentinel so that the sentinel function can be decorated with a wrapper function.
(defmacro with-sentinel-wrapper (wrapper-fn &rest body)
(let ((sps (gensym))
(proc (gensym))
(fn (gensym)))
`(let ((,sps (symbol-function 'set-process-sentinel)))
(cl-letf (((symbol-function 'set-process-sentinel)
(lambda (,proc ,fn)
(funcall ,sps ,proc (funcall ,wrapper-fn ,fn)))))
,#body))))
The wrapper can change the dynamic context in which the sentinel is called, by establishing any useful dynamic bindings. Here, I reuse your cl-letf to change what display does:
(with-sentinel-wrapper (lambda (fn)
(lexical-let ((fun fn))
(lambda (p m)
(cl-letf (((symbol-function 'display-buffer)
#'(lambda (&rest _ignored)
(message "%s" (buffer-string)))))
(funcall fun p m)))))
(tst-fun-async "http://www.stackoverflow.com"))
Now, if you aren't sure that the asynchronous process actually calls set-process-sentinel, you may have to hack other functions.
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.
This is a macro defined in "clx-user-callable.lisp" I'm trying to use.
(in-package :clx-gui)
(defmacro get-callback-wrapper (callback)
(declare (ignorable callback))
(let* ((func-name (gensym))
(wrapper-name (intern (format nil "WRAPPER-~a" func-name) )))
`(defun ,wrapper-name (caller-instance)
(funcall ,callback) ;; User callbacks wont have arguments
(closemenu caller-instance))))
I call this macro in this manner and it works properly.
(in-package :clx-gui-test-app)
(create-user-menuitem "MyUserMenu" "MyEntryDialog"
(get-callback-wrapper 'my-callback))
(create-user-menuitem "MyUserMenu" "MyChoiceDialog"
(get-callback-wrapper 'my-callback2))
(create-user-menuitem "MyUserMenu" "MyMessageDialog"
(get-callback-wrapper 'my-callback3))
If I change the code to use the macro this way, by passing the symbol name of the callback to a function that calls the macro, it does not return different wrapper functions, but always returns the same wrapper function. The function that calls the macro is in the same file and package as the macro definition.
(in-package :clx-gui-test-app)
(create-user-menuitem "MyUserMenu" "MyEntryDialog" 'my-callback)
(create-user-menuitem "MyUserMenu" "MyChoiceDialog" 'my-callback2)
(create-user-menuitem "MyUserMenu" "MyMessageDialog" 'my-callback3)
I have tried adding the package to the macro definition, but that doesn't help.
(wrapper-name (intern (format nil "WRAPPER-~a" func-name)
(symbol-package callback) )))
What am I doing incorrectly?
I'm working with SBCL-1.0.57 and Slime.
CL-USER>
(defparameter foo1 (gensym))
FOO1
CL-USER>
foo1
#:G4619
CL-USER>
(defparameter foo2 '#:G4619)
FOO2
CL-USER>
foo2
#:G4619
CL-USER>
(eq foo1 foo2)
NIL
CL-USER>
~
Or another fun exercise:
(defmacro make-fun ()
`(defun ,(intern (format nil "WRAPPER-~a" (gensym))) ()
'bar))
CL-USER>
(make-fun)
WRAPPER-G4726
CL-USER>
(make-fun)
WRAPPER-G4730
CL-USER>
(make-fun)
WRAPPER-G4734
CL-USER>
(make-fun)
WRAPPER-G4738
CL-USER>
(defun WRAPPER-G4745 ()
'foo)
WRAPPER-G4745
CL-USER>
(make-fun)
WRAPPER-G4745
CL-USER> (wrapper-G4745)
BAR
CL-USER>
Oh man, we just wrote over that function!
If you want to notate a gensym with some sort of prefix name, do it in the gensym call (as an optional argument). But all of this is just an exercise, b/c I would still just use lambda in the OP problem.
Here's an alternative implementation that is (IMO) simpler, and should work for your needs:
(defun get-callback-wrapper (callback)
(lambda (caller-instance)
(funcall callback)
(closemenu caller-instance)))
This generates the lexical closure that I think you're after.