Instruction:
Generate a defmacro form that transforms code like this:
(define-simple-definition-resolver symbol-macro designator-symbol-macro-p)

Pattern to recognize: Macro call that should be transformed by define-simple-definition-resolver

Input: (define-simple-definition-resolver symbol-macro designator-symbol-macro-p)

Output:
(defmacro define-simple-definition-resolver (class lookup-function &body body)
  (let ((package (gensym "PACKAGE")))
    `(define-definition-resolver ,class (,class ,package)
       (when (ignore-errors ,(if body
                                 `(let ((,(first lookup-function) ,class))
                                    ,@body)
                                 `(,lookup-function ,class)))
         (list (make-instance ',class :designator ,class :package ,package))))))

(define-definition-resolver symbol-macro (symbol-macro #:package141) (when (ignore-errors (designator-symbol-macro-p symbol-macro)) (list (make-instance (quote symbol-macro) :designator symbol-macro :package #:package141))))


Instruction:
Define a macro that eliminates this repetitive pattern:
($/ "[_]*.mr." "i")

Issue: Macro call that should be transformed by $/

Input: ($/ "[_]*.mr." "i")

Output:
(defmacro $/ (regex options)
  `(make-bson-regex (empty-str ,regex) ,options))

(make-bson-regex (empty-str "[_]*.mr.") "i")


Instruction:
Define a macro that eliminates this repetitive pattern:
(cond->)

Issue: Macro call that should be transformed by COND->

Input: (cond->)

Output: (defmacro COND-> ...)


Instruction:
Write a Common Lisp macro to handle this code pattern:
(enable-sharp-boolean-syntax)

Problem: Macro call that should be transformed by ENABLE-SHARP-BOOLEAN-SYNTAX

Input: (enable-sharp-boolean-syntax)

Output: (defmacro ENABLE-SHARP-BOOLEAN-SYNTAX ...)

(eval-when (:compile-toplevel :execute)
  (setf *readtable* (copy-readtable *readtable*))
  (set-sharp-boolean-syntax-in-readtable)
  (values))


Instruction:
Generate a defmacro form that transforms code like this:
(collect-file nil nil)

Pattern to recognize: Macro call that should be transformed by COLLECT-FILE

Input: (collect-file nil nil)

Output: (defmacro COLLECT-FILE ...)

(common-lisp:let* ((#:generator-542 (generator nil)) #:items-536 (#:out-538 t))
  (declare (type generator #:generator-542)
           (type boolean #:out-538))
  (with-open-file (#:outfile-535 nil :direction :output)
    (tagbody
     #:ll-543
      (setq #:items-536 (next-in #:generator-542 (go end)))
      (common-lisp:funcall #'print #:items-536 #:outfile-535)
      (go #:ll-543)
     end))
  #:out-538)


Instruction:
Write a Common Lisp macro to handle this code pattern:
(enable-readtime-wrapper-syntax 'some-name)

Problem: Macro call that should be transformed by ENABLE-READTIME-WRAPPER-SYNTAX

Input: (enable-readtime-wrapper-syntax 'some-name)

Output: (defmacro ENABLE-READTIME-WRAPPER-SYNTAX ...)

(eval-when (:compile-toplevel :execute)
  (setf *readtable* (copy-readtable *readtable*))
  (set-readtime-wrapper-syntax-in-readtable 'some-name #\RIGHT_CURLY_BRACKET)
  (values))


Instruction:
Define a macro that eliminates this repetitive pattern:
(true "Happy")

Issue: Macro call that should be transformed by true

Input: (true "Happy")

Output:
(defmacro true (form &optional description &rest format-args)
  `(eval-in-context
    *context*
    (make-instance 'comparison-result
                   :expression '(true ,form)
                   :value-form ',form
                   :body (lambda () ,form)
                   :expected 'T
                   :comparison 'geq
                   ,@(when description
                       `(:description (format NIL ,description ,@format-args))))))

(eval-in-context *context* (make-instance (quote comparison-result) :expression (quote (true "Happy")) :value-form (quote "Happy") :body (lambda nil "Happy") :expected (quote t) :comparison (quote geq)))


Instruction:
Define a macro that eliminates this repetitive pattern:
(defhandler labels (labels bindings &rest body) `(with-imposed-bindings (,labels ,(clean-fbindings bindings) ,(declare-fbindings-ignorable bindings) (list* ',labels ,(dump-fbindings bindings) (m-list ,@body)))))

Issue: Macro call that should be transformed by defhandler

Input: (defhandler labels (labels bindings &rest body) `(with-imposed-bindings (,labels ,(clean-fbindings bindings) ,(declare-fbindings-ignorable bindings) (list* ',labels ,(dump-fbindings bindings) (m-list ,@body)))))

Output:
(defmacro defhandler (symbol lambda-list &body body)
  (let ((syms (force-list symbol)))
    (let ((func (intern (format nil "~A~A" 'hander- (first syms)))))
      `(progn
         (defun ,func ,lambda-list
           ,@body)
         (setf
          ,@(loop for sym in syms
               collect `(gethash ',sym *form-handler*)
               collect `',func))))))

(progn (defun hander-labels (labels bindings &rest body) (sb-int:quasiquote (with-imposed-bindings (#S(sb-impl::comma :expr labels :kind 0) #S(sb-impl::comma :expr (clean-fbindings bindings) :kind 0) #S(sb-impl::comma :expr (declare-fbindings-ignorable bindings) :kind 0) (list* (quote #S(sb-impl::comma :expr labels :kind 0)) #S(sb-impl::comma :expr (dump-fbindings bindings) :kind 0) (m-list #S(sb-impl::comma :expr body :kind 2))))))) (setf (gethash (quote labels) *form-handler*) (quote hander-labels)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(some->> nil)

What needs to change: Macro call that should be transformed by SOME->>

Input: (some->> nil)

Output: (defmacro SOME->> ...)


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(define-binary-op-mapping-definer define-comparison-ops `(progn (defmethod ,op ((x memptr) (y memptr)) (if (and (eq (memptr-mem x) (memptr-mem y)) (,cl (memptr-ptr x) (memptr-ptr y))) 1 0)) (defmethod ,op ((x number) (y number)) (if (,cl x y) 1 0))))

Write a macro that addresses: Macro call that should be transformed by define-binary-op-mapping-definer

Input: (define-binary-op-mapping-definer define-comparison-ops `(progn (defmethod ,op ((x memptr) (y memptr)) (if (and (eq (memptr-mem x) (memptr-mem y)) (,cl (memptr-ptr x) (memptr-ptr y))) 1 0)) (defmethod ,op ((x number) (y number)) (if (,cl x y) 1 0))))

Output:
(defmacro define-binary-op-mapping-definer (name &body body)
  `(defmacro ,name (&rest map)
     `(progn ,@(loop for (vacietis cl) on map by #'cddr collect
                    (let ((op (find-symbol (symbol-name vacietis) '#:vacietis.c)))
                      ,@body)))))

(defmacro define-comparison-ops (&rest map) (sb-int:quasiquote (progn #S(sb-impl::comma :expr (loop for (vacietis cl) on map by (function cddr) collect (let ((op (find-symbol (symbol-name vacietis) (quote #:vacietis.c)))) (sb-int:quasiquote (progn (defmethod #S(sb-impl::comma :expr op :kind 0) ((x memptr) (y memptr)) (if (and (eq (memptr-mem x) (memptr-mem y)) (#S(sb-impl::comma :expr cl :kind 0) (memptr-ptr x) (memptr-ptr y))) 1 0)) (defmethod #S(sb-impl::comma :expr op :kind 0) ((x number) (y number)) (if (#S(sb-impl::comma :expr cl :kind 0) x y) 1 0)))))) :kind 2))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(false (sleep 1))

Write a macro that addresses: Macro call that should be transformed by false

Input: (false (sleep 1))

Output:
(defmacro false (form &optional description &rest format-args)
  `(eval-in-context
    *context*
    (make-instance 'comparison-result
                   :expression '(false ,form)
                   :value-form ',form
                   :body (lambda () ,form)
                   :expected 'NIL
                   :comparison 'geq
                   ,@(when description
                       `(:description (format NIL ,description ,@format-args))))))

(eval-in-context *context* (make-instance (quote comparison-result) :expression (quote (false (sleep 1))) :value-form (quote (sleep 1)) :body (lambda nil (sleep 1)) :expected (quote nil) :comparison (quote geq)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(destructure-specialized-lambda-list descriptive-lambda-list vanilla-lambda-list type-list specialized-lambda-list (with-effective-qualifier generic-function qualifier `(%lay-method-base-for-dispatch ,generic-function ,qualifier ,type-list ,descriptive-lambda-list (dispatch ,generic-function ,qualifier ,specialized-lambda-list) ,@body)))

What needs to change: Macro call that should be transformed by destructure-specialized-lambda-list

Input: (destructure-specialized-lambda-list descriptive-lambda-list vanilla-lambda-list type-list specialized-lambda-list (with-effective-qualifier generic-function qualifier `(%lay-method-base-for-dispatch ,generic-function ,qualifier ,type-list ,descriptive-lambda-list (dispatch ,generic-function ,qualifier ,specialized-lambda-list) ,@body)))

Output:
(defmacro destructure-specialized-lambda-list (descriptive-lambda-list-sym vanilla-lambda-list-sym type-list-sym specialized-lambda-list &body body)
  "if specialized-lambda-list is ((a integer) b):
descriptive-lambda-list will be ((x integer) (x t))
type-list will be (integer t) and vanilla-lambda-list is (a b)"
  (let ((item (gensym)))
    `(let* ((,descriptive-lambda-list-sym
             (loop :for ,item :in ,specialized-lambda-list
                :if (listp ,item)
                :collect ,item
                :else :collect (list ,item t)))
            (,vanilla-lambda-list-sym (mapcar #'first ,descriptive-lambda-list-sym))
            (,type-list-sym (mapcar #'second ,descriptive-lambda-list-sym)))
       (declare (ignorable ,descriptive-lambda-list-sym ,vanilla-lambda-list-sym ,type-list-sym))
       ,@body)))

(let* ((descriptive-lambda-list (loop :for #:g125 :in specialized-lambda-list :if (listp #:g125) :collect #:g125 :else :collect (list #:g125 t))) (vanilla-lambda-list (mapcar (function first) descriptive-lambda-list)) (type-list (mapcar (function second) descriptive-lambda-list))) (declare (ignorable descriptive-lambda-list vanilla-lambda-list type-list)) (with-effective-qualifier generic-function qualifier (sb-int:quasiquote (%lay-method-base-for-dispatch #S(sb-impl::comma :expr generic-function :kind 0) #S(sb-impl::comma :expr qualifier :kind 0) #S(sb-impl::comma :expr type-list :kind 0) #S(sb-impl::comma :expr descriptive-lambda-list :kind 0) (dispatch #S(sb-impl::comma :expr generic-function :kind 0) #S(sb-impl::comma :expr qualifier :kind 0) #S(sb-impl::comma :expr specialized-lambda-list :kind 0)) #S(sb-impl::comma :expr body :kind 2)))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(defmethod* nil
    nil)

Write a macro that addresses: Macro call that should be transformed by DEFMETHOD*

Input:
(defmethod* nil
    nil)

Output: (defmacro DEFMETHOD* ...)


Instruction:
Generate a defmacro form that transforms code like this:
(mvlet* ((x)) x)

Pattern to recognize: Macro call that should be transformed by mvlet*

Input: (mvlet* ((x)) x)

Output:
(defmacro mvlet* ((&rest bindings) &body body &environment env)
  "Expand a series of nested `multiple-value-bind' forms.

`mvlet*' is similar in intent to Scheme’s `let-values', but with a
different and less parenthesis-intensive syntax. Each binding is a
list of

    (var var*... expr)

A simple example should suffice to show both the implementation and
the motivation:

    (defun uptime (seconds)
      (mvlet* ((minutes seconds (truncate seconds 60))
               (hours minutes (truncate minutes 60))
               (days hours (truncate hours 24)))
        (declare ((integer 0 *) days hours minutes seconds))
        (fmt \"~d day~:p, ~d hour~:p, ~d minute~:p, ~d second~:p\"
             days hours minutes seconds)))

Note that declarations work just like `let*'."
  (cond ((null bindings)
         `(locally ,@body))
        ((every #'simple-binding-p bindings)
         `(let* ,bindings ,@body))
        (t (multiple-value-bind (body decls)
               (parse-body body)
             (let* ((bindings (canonicalize-bindings bindings))
                    (mvbinds (member-if-not #'simple-binding-p bindings))
                    (simple-binds (ldiff bindings mvbinds)))
               (if simple-binds
                   (multiple-value-bind (local other)
                       (partition-declarations (mapcar #'car simple-binds) decls env)
                     `(let* ,simple-binds
                        ,@local
                        (mvlet* ,mvbinds
                          ,@other
                          ,@body)))
                   (let* ((vars (butlast (car bindings)))
                          (expr (lastcar (car bindings))))
                     (multiple-value-bind (local other)
                         (partition-declarations vars decls env)
                       `(multiple-value-bind ,vars
                            ,expr
                          ,@local
                          (mvlet* ,(cdr bindings)
                            ,@other
                            ,@body))))))))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(form-fiddle:lambda-forms `(lambda () ,@body))

Issue: Macro call that should be transformed by for

Input: (form-fiddle:lambda-forms `(lambda () ,@body))

Output:
(defmacro for (&environment env bindings &body body)
  (let ((*environment* env))
    (multiple-value-bind (bind-init bind-forms bind-exit bind-post) (convert-bindings bindings)
      (multiple-value-bind (clause-init body-forms clause-exit) (convert-clauses body)
        `(with-interleaving
           ,@bind-init
           ,@clause-init
           (with-for-block ()
             (with-for-tagbody
                 (progn ,@bind-forms
                        ,@body-forms
                        ,@bind-post)
               (return-for
                ,@clause-exit
                ,@bind-exit))))))))

(form-fiddle:lambda-forms (sb-int:quasiquote (lambda nil #S(sb-impl::comma :expr body :kind 2))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(signal-syntax-error* error-pos "No character for hex-code ~X." number)

Issue: Macro call that should be transformed by signal-syntax-error*

Input: (signal-syntax-error* error-pos "No character for hex-code ~X." number)

Output:
(defmacro signal-syntax-error* (pos format-control &rest format-arguments)
  `(error 'ppcre-syntax-error
          :pos ,pos
          :format-control ,format-control
          :format-arguments (list ,@format-arguments)))

(error (quote ppcre-syntax-error) :pos error-pos :format-control "No character for hex-code ~X." :format-arguments (list number))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(nth-value-or 1 (values 1 nil 1) (values 2 2 2))

What needs to change: Macro call that should be transformed by nth-value-or

Input: (nth-value-or 1 (values 1 nil 1) (values 2 2 2))

Output:
(defmacro nth-value-or (nth-value &body forms)
  "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
of the forms is true. It then returns all the values returned by evaluating
that form. If none of the forms return a true nth value, this form returns
NIL."
  (once-only (nth-value)
    (with-gensyms (values)
      `(let ((,values (multiple-value-list ,(first forms))))
         (if (nth ,nth-value ,values)
             (values-list ,values)
             ,(if (rest forms)
                  `(nth-value-or ,nth-value ,@(rest forms))
                  nil))))))

(let ((#:nth-value149 1)) (let ((#:values150 (multiple-value-list (values 1 nil 1)))) (if (nth #:nth-value149 #:values150) (values-list #:values150) (nth-value-or #:nth-value149 (values 2 2 2)))))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(defdata (point :mutable t) (rect float float))

Problem: Macro call that should be transformed by defdata

Input: (defdata (point :mutable t) (rect float float))

Output:
(defmacro defdata (adt-name &body constructors)
  "Define a new ADT. ADT-name has the following grammar:

ADT-NAME := <symbol>
          | (<symbol> <options>*)

There is no difference between specifying it as a symbol or as a
singleton list. There are two possible options, specified as a
property list:

    * :MUTABLE {T, NIL} (default: NIL): Specifies whether the fields
      of the type are mutable, allowing the use of SET-DATA.

    * :INCLUDE <adt-type>: Specifies whether another defined ADT
      should be inherited.

Constructors is a list of clauses with the following grammar:

<clause> := <symbol>
          | (<symbol> <type-specifier>*)

Each clause defines a constructor for the ADT. Nullary constructors
will define constants and all other constructors will define
functions."
  ;; Do some extreme sanity checking.
  (assert
   (or
    ;; Must be a symbol, or...
    (symbolp adt-name)
    (and
     ;; a list that is...
     (listp adt-name)
     ;; non-empty
     (not (null adt-name))
     ;; whose first element is a symbol (the name of the adt)
     (symbolp (first adt-name))
     ;; and the rest is a property list
     (property-list-p (rest adt-name))))
   (adt-name)
   "ADT-NAME must either be a symbol, a singleton list with the ADT ~
      name as a symbol, or a list of two elements with the ADT name ~
      and :MUTABLE respectively. Given ~S."
   adt-name)
  (let ((valid-options (list ':mutable ':include)))
    (when (and (listp adt-name) (= (mod (length (rest adt-name)) 2) 0))
      (loop for opt in (rest adt-name) by #'cddr do
	   (when (not (member opt valid-options))
	     (error "Option ~A is not valid, valid options are member of ~A." opt valid-options)))))

  (let ((adt-name (ensure-car adt-name))
        (mutable? (and (listp adt-name)
                       (getf (rest adt-name) ':mutable)
                       t))
        (include (or (and (listp adt-name)
                          (getf (rest adt-name) ':include))
                     'algebraic-data-type))
        (object (gensym "OBJECT-"))
        (stream (gensym "STREAM-"))
        (depth (gensym "DEPTH-"))
        (env (gensym "ENVIRONMENT-"))
        (documentation
          (when (stringp (car constructors))
            (pop constructors))))

    ;; Sanity check that INCLUDE is a proper algebraic data type.
    (assert (algebraic-data-type-p include)
            ()
            "When defining the algebraic data type ~S, the :INCLUDE option ~
             was specified with ~S, which is not another algebraic data ~
             type."
            adt-name
            include)

    ;; Add constructors and their arity to the database.
    (flet ((constructor-and-arity (ctor)
             (if (listp ctor)
                 (list (first ctor) (length (rest ctor)))
                 (list ctor 0))))
      (set-constructors adt-name (append (get-constructors include)
                                         (mapcar #'constructor-and-arity constructors))))

    (flet ((make-printer (name &optional (nfields 0))
             "Make a printer function for the structs."
             `(lambda (,object ,stream ,depth)
                (declare (ignore ,depth)
                         (ignorable ,object))
                ;; We don't check *PRINT-READABLY* because these can
                ;; be readably printed always, provided the arguments
                ;; can be printed readably.
                ;;
                ;; However, we do respect a convenience option
                ;; *PRINT-ADT-READABLY* in case someone finds the
                ;; printing of the #. to be annoying.
                (when *print-adt-readably*
                  (write-string "#." ,stream))
                ,(when (plusp nfields)
                   `(write-char #\( ,stream))
                (prin1 ',name ,stream)
                ,@(when (plusp nfields)
                    (loop :for i :below nfields
                          :append (list
                                   `(write-char #\Space ,stream)
                                   `(prin1 (,(field name i) ,object)
                                           ,stream))))
                ,(when (plusp nfields)
                   `(write-char #\) ,stream)))))
      ;; Define everything.
      (let ((component-documentation
             ;; Force the adt-name symbol to print with a package
             ;; prefix
             (let ((*package* (find-package :keyword)))
               (format nil "A component of ADT ~S" adt-name))))
        `(eval-when (:compile-toplevel :load-toplevel :execute)
           ;; Define the data type.
           (defstruct (,adt-name (:constructor nil)
                                 (:copier nil)
                                 (:predicate nil)
                                 (:include ,include))
             ,@(unsplice documentation))

           ;; Define each of the field constructors.
           ,@(loop :for ctor :in (unwrap-singletons constructors)
                   :collect
                   (etypecase ctor
                     ;; Nullary constructor
                     (symbol `(progn
                                (eval-when (:compile-toplevel :load-toplevel :execute)
                                  (defstruct
                                      (,ctor
                                       (:include ,adt-name)
                                       (:constructor ,(internal ctor))
                                       (:copier nil)
                                       (:predicate nil)
                                       (:print-function ,(make-printer ctor)))
                                    ,component-documentation))
                                #+sbcl (declaim (sb-ext:freeze-type ,ctor))
                                (defmethod make-load-form ((,object ,ctor) &optional ,env)
                                  (make-load-form-saving-slots ,object
                                                               :slot-names nil
                                                               :environment ,env))
                                (define-constant ,ctor (,(internal ctor))
                                  ,component-documentation)
                                (fmakunbound ',(internal ctor))))

                     ;; N-ary constructors
                     (list (let* ((ctor-name (first ctor))
                                  (field-types (rest ctor))
                                  (field-names (gen-names (length field-types))))
                             `(progn
                                (defstruct (,ctor-name
                                            (:include ,adt-name)
                                            (:constructor ,ctor-name (,@field-names))
                                            (:conc-name ,ctor-name)
                                            (:copier nil)
                                            (:predicate nil)
                                            (:print-function
                                             ,(make-printer ctor-name
                                                            (length field-names))))
                                  ,component-documentation
                                  ,@(mapcar (lambda (name type)
                                              `(,name (error "Unspecified field.")
                                                      :type ,type
                                                      ,@(if mutable?
                                                            nil
                                                            '(:read-only t))))
                                     field-names
                                     field-types))
                                #+sbcl (declaim (sb-ext:freeze-type ,ctor-name))
                                (defmethod make-load-form ((,object ,ctor-name) &optional ,env)
                                  (make-load-form-saving-slots ,object
                                                               :slot-names ',field-names
                                                               :environment ,env)))))))
           ;; Return the type name
           ',adt-name)))))

(eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (point (:constructor nil) (:copier nil) (:predicate nil) (:include algebraic-data-type))) (progn (defstruct (rect (:include point) (:constructor rect (%0 %1)) (:conc-name rect) (:copier nil) (:predicate nil) (:print-function (lambda (#:object-141 #:stream-142 #:depth-143) (declare (ignore #:depth-143) (ignorable #:object-141)) (when *print-adt-readably* (write-string "#." #:stream-142)) (write-char #\LEFT_PARENTHESIS #:stream-142) (prin1 (quote rect) #:stream-142) (write-char #\Space #:stream-142) (prin1 (rect%0 #:object-141) #:stream-142) (write-char #\Space #:stream-142) (prin1 (rect%1 #:object-141) #:stream-142) (write-char #\RIGHT_PARENTHESIS #:stream-142)))) #A((48) base-char . "A component of ADT CL-ALGEBRAIC-DATA-TYPE::POINT") (%0 (error "Unspecified field.") :type float) (%1 (error "Unspecified field.") :type float)) (declaim (sb-ext:freeze-type rect)) (defmethod make-load-form ((#:object-141 rect) &optional #:environment-144) (make-load-form-saving-slots #:object-141 :slot-names (quote (%0 %1)) :environment #:environment-144))) (quote point))


Instruction:
Generate a defmacro form that transforms code like this:
(defvar* nil nil)

Pattern to recognize: Macro call that should be transformed by DEFVAR*

Input: (defvar* nil nil)

Output: (defmacro DEFVAR* ...)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(define-simple-definition-resolver special-operator special-operator-p)

What needs to change: Macro call that should be transformed by define-simple-definition-resolver

Input: (define-simple-definition-resolver special-operator special-operator-p)

Output:
(defmacro define-simple-definition-resolver (class lookup-function &body body)
  (let ((package (gensym "PACKAGE")))
    `(define-definition-resolver ,class (,class ,package)
       (when (ignore-errors ,(if body
                                 `(let ((,(first lookup-function) ,class))
                                    ,@body)
                                 `(,lookup-function ,class)))
         (list (make-instance ',class :designator ,class :package ,package))))))

(define-definition-resolver special-operator (special-operator #:package131) (when (ignore-errors (special-operator-p special-operator)) (list (make-instance (quote special-operator) :designator special-operator :package #:package131))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(newq nil nil)

Write a macro that addresses: Macro call that should be transformed by NEWQ

Input: (newq nil nil)

Output: (defmacro NEWQ ...)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(when shared `(make-node ,shared))

What needs to change: Macro call that should be transformed by when

Input: (when shared `(make-node ,shared))

Output:
(defmacro when (test &body forms)
  `(if ,test
	   ,(cl:if (cadr forms)
			   `(progn ,@forms)
			   (car forms))))

(if shared (sb-int:quasiquote (make-node #S(sb-impl::comma :expr shared :kind 0))))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(case nil (progn))

Problem: Macro call that should be transformed by CASE

Input: (case nil (progn))

Output: (defmacro CASE ...)

(let ((#:nil nil))
  (declare (ignorable #:nil))
  (cond ((eql #:nil 'progn) nil)))


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-html-string (:link :rel :stylesheet))

Issue: Macro call that should be transformed by with-html

Input: (with-html-string (:link :rel :stylesheet))

Output:
(defmacro with-html (&body body &environment env)
  "Interpret BODY as HTML. Consult README.txt for the syntax."
  `(let ((*html* (ensure-html-stream *html*)))
     ,(if (and (null (cdr body)) (atom (car body)))
          (car body)
          `(progn ,@(parse-html body env)))))

(with-output-to-string (*html*) (with-html (:link :rel :stylesheet)))


Instruction:
Define a macro that eliminates this repetitive pattern:
(-> :p (a) (+ a 1))

Issue: Macro call that should be transformed by ->

Input: (-> :p (a) (+ a 1))

Output:
(defmacro -> (invariant &body args)
  "See flow:atomically"
  `(atomically ,invariant ,@args))


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-yield (loop for line = (read-line stream nil 'eof) until (eq line 'eof) do (yield line)))

Issue: Macro call that should be transformed by with-yield

Input: (with-yield (loop for line = (read-line stream nil 'eof) until (eq line 'eof) do (yield line)))

Output:
(defmacro with-yield (&body body)
  (let ((point (gensym))
        (current (gensym)))
    `(let (,point ,current)
       (with-call/cc
	 (labels ((yield (&rest values)
		    (setf ,current values)
		    (let/cc k
		      (setf ,point k))))
	   ,@body
	   (setf ,point nil)))
       (gen-lambda ()
	 (cond ((null ,point)
		'generator-stop)
	       (t
		(let ((current ,current))
		  (funcall ,point nil)
		  ;values-handler: see gen-lambda
		  (apply #'values (funcall values-handler current)))))))))

(let (#:g135 #:g136) (with-call/cc (labels ((yield (&rest values) (setf #:g136 values) (let/cc k (setf #:g135 k)))) (loop for line = (read-line stream nil (quote eof)) until (eq line (quote eof)) do (yield line)) (setf #:g135 nil))) (gen-lambda nil (cond ((null #:g135) (quote generator-stop)) (t (let ((current #:g136)) (funcall #:g135 nil) (apply (function values) (funcall values-handler current)))))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(of-type symbol 'foo)

Issue: Macro call that should be transformed by of-type

Input: (of-type symbol 'foo)

Output:
(defmacro of-type (type form &optional description &rest format-args)
  `(eval-in-context
    *context*
    (make-instance 'comparison-result
                   :expression '(of-type ,type ,form)
                   :value-form ',form
                   :body (lambda () ,form)
                   :expected ',(maybe-unquote type)
                   :comparison 'typep
                   ,@(when description
                       `(:description (format NIL ,description ,@format-args))))))

(eval-in-context *context* (make-instance (quote comparison-result) :expression (quote (of-type symbol (quote foo))) :value-form (quote (quote foo)) :body (lambda nil (quote foo)) :expected (quote symbol) :comparison (quote typep)))


Instruction:
Define a macro that eliminates this repetitive pattern:
(ematch0 more (nil nil) ((list* gen sub more) (let ((newsub (correct-pattern sub))) (list* gen newsub (let ((*lexvars* (append (variables newsub) *lexvars*))) (%correct-more-patterns more))))))

Issue: Macro call that should be transformed by ematch0

Input: (ematch0 more (nil nil) ((list* gen sub more) (let ((newsub (correct-pattern sub))) (list* gen newsub (let ((*lexvars* (append (variables newsub) *lexvars*))) (%correct-more-patterns more))))))

Output:
(defmacro ematch0 (what &body clauses)
  `(match0 ,what
     ,@clauses
     (_ (error "level0 match error!"))))

(match0 more (nil nil) ((list* gen sub more) (let ((newsub (correct-pattern sub))) (list* gen newsub (let ((*lexvars* (append (variables newsub) *lexvars*))) (%correct-more-patterns more))))) (_ (error "level0 match error!")))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(with-form-fields (name) form (print (field-value name)))

Write a macro that addresses: Macro call that should be transformed by with-form

Input: (with-form-fields (name) form (print (field-value name)))

Output:
(defmacro with-form (form &body body)
  "Bind *FORM* to FORM and evaluate BODY in that context."
  `(call-with-form ,form (lambda () ,@body)))

(let ((name (get-field form (quote name)))) (print (field-value name)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(define-error no-version-in-context () (env) "No supported version found in context:~%~a" (v-context env))

What needs to change: Macro call that should be transformed by define-error

Input: (define-error no-version-in-context () (env) "No supported version found in context:~%~a" (v-context env))

Output:
(defmacro define-error (name (&key (error-type 'varjo-error) (prefix "Varjo"))
                            (&rest args) error-string &body body)
  `(defcondition ,name (:error-type ,error-type :prefix ,prefix) ,args
       ,error-string ,@body))

(defcondition no-version-in-context (:error-type varjo-error :prefix "Varjo") (env) "No supported version found in context:~%~a" (v-context env))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(with-wcs-math-error-handling ((quot rem) (ftruncate x y)) (check-wcs-math-result) rem)

What needs to change: Macro call that should be transformed by with-wcs-math-error-handling

Input: (with-wcs-math-error-handling ((quot rem) (ftruncate x y)) (check-wcs-math-result) rem)

Output:
(defmacro with-wcs-math-error-handling
    ((var-or-var-list
      (function x &optional (y nil y-supplied-p))
      &rest keyargs
      &key underflow-value)
     &body body)
  (declare (ignorable underflow-value))
  (let ((x_ (gensym)) (y_ (gensym)) (args_ (gensym))
        (var-list (ensure-list var-or-var-list)))
    `(let* ((,x_ ,x)
            (,y_ ,y)
            (,args_ (list ,x_ ,@(if y-supplied-p `(,y_)))))
       (declare (ignorable ,y_)
                (type list ,args_)
                (dynamic-extent ,args_))
       (catch 'return-from-with-wcs-math-error-handling
         (multiple-value-bind ,var-list
             (call-with-wcs-math-error-handler ',function ,args_
                                               ,@keyargs)
           (flet ((check-wcs-math-result
                      (&optional (ret ,(first var-list))
                                 (arg-list ,args_))
                    (check-wcs-math-result ret arg-list)))
             ,@body))))))

(let* ((#:g254 x) (#:g255 y) (#:g256 (list #:g254 #:g255))) (declare (ignorable #:g255) (type list #:g256) (dynamic-extent #:g256)) (catch (quote return-from-with-wcs-math-error-handling) (multiple-value-bind (quot rem) (call-with-wcs-math-error-handler (quote ftruncate) #:g256) (flet ((check-wcs-math-result (&optional (ret quot) (arg-list #:g256)) (check-wcs-math-result ret arg-list))) (check-wcs-math-result) rem))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(keep-bops nil :key nil)

Write a macro that addresses: Macro call that should be transformed by KEEP-BOPS

Input: (keep-bops nil :key nil)

Output: (defmacro KEEP-BOPS ...)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (progn
   (init-binfix)
   (unless nil
     (setq *binfix*
             (delete nil
                     (mapcar
                      (lambda (bs)
                        (setq bs
                                (delete-if
                                 (lambda (b)
                                   (unless (member (car b) '(nil :key nil))
                                     (remprop (car b) 'properties)
                                     t))
                                 bs)))
                      *binfix*)))
     (assign-properties))))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
($ "value-1" 610)

What needs to change: Macro call that should be transformed by $

Input: ($ "value-1" 610)

Output:
(defmacro $ (&rest args)
  `(kv ,@args))


Instruction:
Generate a defmacro form that transforms code like this:
(cond-<>)

Pattern to recognize: Macro call that should be transformed by COND-<>

Input: (cond-<>)

Output: (defmacro COND-<> ...)


Instruction:
Generate a defmacro form that transforms code like this:
($> "l" -900)

Pattern to recognize: Macro call that should be transformed by $>

Input: ($> "l" -900)

Output:
(defmacro $> (&rest args)
  `($op "$gt" ,@args))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(without-dependency-capture)

Problem: Macro call that should be transformed by WITHOUT-DEPENDENCY-CAPTURE

Input: (without-dependency-capture)

Output: (defmacro WITHOUT-DEPENDENCY-CAPTURE ...)


Instruction:
Generate a defmacro form that transforms code like this:
(do+ (options :atomic-updates nil) (for k (in '(a b c d e))) (for x (across #(1 2 3 4) :index index)) (returning (list x k :index index)))

Pattern to recognize: Macro call that should be transformed by do+

Input: (do+ (options :atomic-updates nil) (for k (in '(a b c d e))) (for x (across #(1 2 3 4) :index index)) (returning (list x k :index index)))

Output:
(defmacro do+ (&body body)
  "High-level, extensible iteration construct. Refer to the manual for syntax and semantics."
  `(do+/internal nil ,@body))

(do+/internal nil (options :atomic-updates nil) (for k (in (quote (a b c d e)))) (for x (across #(1 2 3 4) :index index)) (returning (list x k :index index)))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(enable-readtime-wrapper-syntax)

Write a macro that addresses: Macro call that should be transformed by ENABLE-READTIME-WRAPPER-SYNTAX

Input: (enable-readtime-wrapper-syntax)

Output: (defmacro ENABLE-READTIME-WRAPPER-SYNTAX ...)

(eval-when (:compile-toplevel :execute)
  (setf *readtable* (copy-readtable *readtable*))
  (set-readtime-wrapper-syntax-in-readtable #\LEFT_CURLY_BRACKET
                                            #\RIGHT_CURLY_BRACKET)
  (values))


Instruction:
Define a macro that eliminates this repetitive pattern:
(defhandler sb-int:named-lambda (named-lambda name lambda-list &rest body) `(list* ',named-lambda ,(apply 'dump-fbinding name lambda-list body)))

Issue: Macro call that should be transformed by defhandler

Input: (defhandler sb-int:named-lambda (named-lambda name lambda-list &rest body) `(list* ',named-lambda ,(apply 'dump-fbinding name lambda-list body)))

Output:
(defmacro defhandler (symbol lambda-list &body body)
  (let ((syms (force-list symbol)))
    (let ((func (intern (format nil "~A~A" 'hander- (first syms)))))
      `(progn
         (defun ,func ,lambda-list
           ,@body)
         (setf
          ,@(loop for sym in syms
               collect `(gethash ',sym *form-handler*)
               collect `',func))))))

(progn (defun hander-named-lambda (named-lambda name lambda-list &rest body) (sb-int:quasiquote (list* (quote #S(sb-impl::comma :expr named-lambda :kind 0)) #S(sb-impl::comma :expr (apply (quote dump-fbinding) name lambda-list body) :kind 0)))) (setf (gethash (quote sb-int:named-lambda) *form-handler*) (quote hander-named-lambda)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(is-true nil)

What needs to change: Macro call that should be transformed by is

Input: (is-true nil)

Output:
(defmacro is (test &rest reason-args)
  "The DWIM checking operator.

If TEST returns a true value a test-passed result is generated,
otherwise a test-failure result is generated. The reason, unless
REASON-ARGS is provided, is generated based on the form of TEST:

 (predicate expected actual) - Means that we want to check
 whether, according to PREDICATE, the ACTUAL value is
 in fact what we EXPECTED.

 (predicate value) - Means that we want to ensure that VALUE
 satisfies PREDICATE.

 Wrapping the TEST form in a NOT simply produces a negated reason
 string."
  (assert (listp test)
          (test)
          "Argument to IS must be a list, not ~S" test)
  (let (bindings effective-test default-reason-args)
    (with-gensyms (e a v)
      (flet ((process-entry (predicate expected actual &optional negatedp)
               ;; make sure EXPECTED is holding the entry that starts with 'values
               (when (and (consp actual)
                          (eq (car actual) 'values))
                 (assert (not (and (consp expected)
                                   (eq (car expected) 'values))) ()
                                   "Both the expected and actual part is a values expression.")
                 (rotatef expected actual))
               (let ((setf-forms))
                 (if (and (consp expected)
                          (eq (car expected) 'values))
                     (progn
                       (setf expected (copy-list expected))
                       (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
                                              for i from 0
                                              while cell
                                              when (eq (car cell) '*)
                                              collect `(setf (elt ,a ,i) nil)
                                              and do (setf (car cell) nil)))
                       (setf bindings (list (list e `(list ,@(rest expected)))
                                            (list a `(multiple-value-list ,actual)))))
                     (setf bindings (list (list e expected)
                                          (list a actual))))
                 (setf effective-test `(progn
                                         ,@setf-forms
                                         ,(if negatedp
                                              `(not (,predicate ,e ,a))
                                              `(,predicate ,e ,a)))))))
        (list-match-case test
          ((not (?predicate ?expected ?actual))
           (process-entry ?predicate ?expected ?actual t)
           (setf default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
                       `',?actual a `',?predicate e)))
          ((not (?satisfies ?value))
           (setf bindings (list (list v ?value))
                 effective-test `(not (,?satisfies ,v))
                 default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
                       `',?value v `',?satisfies)))
          ((?predicate ?expected ?actual)
           (process-entry ?predicate ?expected ?actual)
           (setf default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%"
                       `',?actual a `',?predicate e)))
          ((?satisfies ?value)
           (setf bindings (list (list v ?value))
                 effective-test `(,?satisfies ,v)
                 default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
                       `',?value v `',?satisfies)))
          (?_
           (setf bindings '()
                 effective-test test
                 default-reason-args (list "~2&~S~2% was NIL." `',test)))))
      `(let ,bindings
         (if ,effective-test
             (add-result 'test-passed :test-expr ',test)
             (process-failure ',test
                              ,@(or reason-args default-reason-args)))))))

(if nil (add-result (quote test-passed) :test-expr (quote nil)) (process-failure (quote nil) "~S did not return a true value" (quote nil)))


Instruction:
Define a macro that eliminates this repetitive pattern:
(member (first tree) stop-on :test #'eq)

Issue: Macro call that should be transformed by m

Input: (member (first tree) stop-on :test #'eq)

Output:
(defmacro m (form &environment *env*)
  (e form))

(member (first tree) stop-on :test (function eq))


Instruction:
Define a macro that eliminates this repetitive pattern:
(deferror "08006" connection-failure)

Issue: Macro call that should be transformed by deferror

Input: (deferror "08006" connection-failure)

Output:
(defmacro deferror (code typename &optional (superclass 'database-error))
  `(progn (define-condition ,typename (,superclass) ())
          (setf (gethash ,code *error-table*) ',typename)))

(progn (define-condition connection-failure (database-error) nil) (setf (gethash "08006" *error-table*) (quote connection-failure)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(defsynonym nil (progn))

What needs to change: Macro call that should be transformed by DEFSYNONYM

Input: (defsynonym nil (progn))

Output: (defmacro DEFSYNONYM ...)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (get 'nil 'iterate::synonym) '(progn)))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(assert-values ("assert fresh initialization") (foo 'nothing) (foo+1 'nothing) (bar 'nothing) (bar-1 'nothing))

Problem: Macro call that should be transformed by assert-values

Input: (assert-values ("assert fresh initialization") (foo 'nothing) (foo+1 'nothing) (bar 'nothing) (bar-1 'nothing))

Output:
(defmacro assert-values ((desc) &body objects-and-values)
  `(progn
     (trc ,desc)
     ,@(loop for (obj val) in objects-and-values
	    collect `(assert (eql (value ,obj) ,val)))))

(progn (trc "assert fresh initialization") (assert (eql (value foo) (quote nothing))) (assert (eql (value foo+1) (quote nothing))) (assert (eql (value bar) (quote nothing))) (assert (eql (value bar-1) (quote nothing))))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(iterate:display-iterate-clauses)

What needs to change: Macro call that should be transformed by iter

Input: (iterate:display-iterate-clauses)

Output:
(defmacro iter (&body body &environment env)
  "Jonathan Amsterdam's powerful and extensible iteration facility,
providing multiple accumulation, generators, memory of previous
iterations, over 50 clauses to start with and a Lisp-like syntax.
Evaluate (iterate:display-iterate-clauses) for an overview of clauses"
  (let* ((*env* env)
	 (*result-var* (genvar 'result))
	 (*type-alist* nil)
	 (*declare-variables* *always-declare-variables*)
	 (*bindings* nil)
	 (*internal-variables* nil)
	 (*previous-vars-alist* nil)
	 (*declarations* nil)
	 (*loop-body-wrappers* nil)
	 (*accum-var-alist* nil)
	 (*shared-bindings-alist* nil)
	 (*top-level?* t)
	 (*binding-context?* nil)
	 (*temps* nil)
	 (*temps-in-use* nil)
	 (*driver-info-alist* nil)
	 (*loop-name* (if (symbolp (car body))
			  (car body)
			  (gensym "ITERATE")))
	 (*block-name* (if (symbolp (car body))
			   (pop body)
			   nil))
	 (*loop-top* (symbol-append 'loop-top- *block-name*))
	 (*loop-step* (symbol-append 'loop-step- *block-name*))
	 (*loop-end* (symbol-append 'loop-end- *block-name*))
	 (*loop-step-used?* nil)
	 (*loop-end-used?* nil))
    (process-top-level-decls body)
    (multiple-value-bind (body decls init-code steppers final-code final-prot)
	(walk-list body)
      (multiple-value-bind (init step)
	  (insert-previous-code)
	(augment init-code init)
	(augment steppers step))
      (prepend (default-driver-code) body)
      (let* ((it-bod `(block ,*loop-name*
			(tagbody
			  (progn ,.init-code)
			  ,*loop-top*
			  (progn ,.body)
			  ,.(if *loop-step-used?* (list *loop-step*))
			  (progn ,.steppers)
			  (go ,*loop-top*)
			  ,.(if *loop-end-used?* (list *loop-end*))
			  (progn ,.final-code))
			,(if (member *result-var* *bindings* :key #'car)
			   *result-var*
			   nil)))
	     (it-bod (if (eql *block-name* nil)
			 `(block nil ,it-bod)
			 it-bod)))
	(wrap-form *loop-body-wrappers*
		   `(let* ,(nreverse *bindings*)
		     ,.(if *declarations*
			   `((declare .,*declarations*)))
		     ,.decls
		     ,(if final-prot
			  `(unwind-protect ,it-bod .,final-prot)
			  it-bod)))))))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(define-class some-class (some super classes) ((slot1 :unbound)) (:accessor-name-package (find-package :nclasses/test.dummy)))

What needs to change: Macro call that should be transformed by define-class

Input: (define-class some-class (some super classes) ((slot1 :unbound)) (:accessor-name-package (find-package :nclasses/test.dummy)))

Output:
(defmacro define-class (name supers slots &rest options)
  "Convenience wrapper of `defclass'.

It automates a lot of boilerplate (like exporting all the accessors of a class)
plus adds some new features.

Slot options:

- The initform can be specified as the second value.

- `:accessor', `:reader' and `:writer' can be set to either a name, NIL or T.
  If NIL, the method is not generated.
  If T, the method is generated using the `:accessor-name-transformer' class option value.

- The `:export' option allows to control the slot-name export on a per-slot basis.

New class options (defaults are NIL unless specified):

- `:slot-definition-transformer' (default: `default-slot-definition-transformer').
  A function that takes a SLOT-DEFINITION and returns a new one.

- `:accessor-name-package': The package of the generated accessors.  See
  `:accessor-name-transformer'.  Some special values are accepted:
  - `:slot-name': The package of the slot-name.
  - `:default': The current package.

- `:accessor-name-transformer' (default `default-accessor-name-transformer').

  A function of (SLOT-NAME SLOT-DEFINITION) arguments that returns the accessor
  name (a symbol).  Other transformer: `dwim-accessor-name-transformer'.

- `:automatic-accessors-p': Whether to generate accessor names automatically for
  all slots.

  As a special case, the accessor is not generated if all following conditions are met:
  - `:accessor-name-package' is `:slot-name',
  - slot name package is different from current package,
  - if the `:accessor' slot option is not provided,

- `:initarg-name-transformer' (default: `default-initarg-name-transformer'.)

  A function of (SLOT-NAME SLOT-DEFINITION) arguments that returns the accessor
  name (a symbol.

- `:automatic-initargs-p' (default: T): Whether to generate accessor names
  automatically for all slots.

- `:predicate-name-transformer' (default: `default-predicate-name-transformer').

  A function of (SLOT-NAME SLOT-DEFINITION) arguments that returns the predicate
  name (a symbol).

- `:automatic-predicates-p' (default: T): Whether to generate a predicate
  for the class.

- `:type-inference' (default: `default-type-inference').

  Function that returns the type of a slot definition (with an initform).  It
  takes 3 arguments:

  - The initform.
  - The slot name.
  - The rest of the slot definition.

- `:automatic-types-p': Whether to generate the type automatically for all
  slots.  The type can still be specified manually with the `:type' slot option.

- Self-explanatory export options (all NIL by default):
  - `:export-class-name-p'
  - `:export-accessor-names-p'
  - `:export-slot-names-p'
  - `:export-predicate-name'"
  (build-defclass-like-expansion
   name supers slots options
   (lambda (processed-slots clean-options)
     `(defclass ,name ,supers
        ,processed-slots
        ,@clean-options))))

(progn (defclass some-class (some super classes) ((slot1 :accessor slot1 :initarg :slot1))) (unless (fboundp (quote some-class-p)) (define-generic some-class-p (object) #A((75) base-char . "Auto-generated predicate for whether OBJECT is an instance of `some-class'.") (declare (sb-ext:muffle-conditions style-warning)) (typep object (quote some-class)))) (setf (documentation (quote slot1) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot SLOT1.")) (ignore-errors (setf (documentation (fdefinition (quote slot1)) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot SLOT1."))) (ignore-errors (setf (documentation (fdefinition (quote (setf slot1))) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot SLOT1."))) (find-class (quote some-class) nil))


Instruction:
Generate a defmacro form that transforms code like this:
(define-modf-function aref 1 (new-val array &rest idx) (let ((new-arr (alexandria:copy-array array))) (setf (apply #'aref new-arr idx) new-val) new-arr))

Pattern to recognize: Macro call that should be transformed by define-modf-function

Input: (define-modf-function aref 1 (new-val array &rest idx) (let ((new-arr (alexandria:copy-array array))) (setf (apply #'aref new-arr idx) new-val) new-arr))

Output:
(defmacro define-modf-function (name nth-arg (new-val &rest args) &body body)
  "Define a new modf function.  It inverts NAME forms by modifying the NTH-ARG
term of the arguments of the place form in the MODF macro."
  ;; Side effect in a macro, I know.  How can you do this via EVAL-WHEN if I
  ;; want it to run even if not a toplevel macro?
  (setf (gethash name *modf-nth-arg*)
        nth-arg)
  `(progn
     (eval-when (:compile-toplevel :load-toplevel :execute)
       (setf (gethash ',name *modf-nth-arg*)
             ,nth-arg))
     (defun ,(intern (modf-name name) :modf) (,new-val ,@args)
       ,@body)))

(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash (quote aref) *modf-nth-arg*) 1)) (defun |BUILDER:COMMON-LISP:AREF| (new-val array &rest idx) (let ((new-arr (alexandria:copy-array array))) (setf (apply (function aref) new-arr idx) new-val) new-arr)))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(with-packages-unlocked nil
  :key
  nil)

Problem: Macro call that should be transformed by WITH-PACKAGES-UNLOCKED

Input:
(with-packages-unlocked nil
  :key
  nil)

Output: (defmacro WITH-PACKAGES-UNLOCKED ...)

(let ((#:|packages123| (locked-packages 'nil)))
  (unlock-packages #:|packages123|)
  (unwind-protect :key nil (lock-packages #:|packages123|)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(defclause across (vector &rest args &key index start end by) "Synonym for in-vector." (declare (ignore index start end by)) `(in-vector ,vector ,@args))

What needs to change: Macro call that should be transformed by defclause

Input: (defclause across (vector &rest args &key index start end by) "Synonym for in-vector." (declare (ignore index start end by)) `(in-vector ,vector ,@args))

Output:
(defmacro defclause (name arglist &body body)
  "Same as cl:defmacro, but additionally records <name> in *clauses* as a known clause macro."
  `(progn
     (defmacro ,name ,arglist ,@body)
     (pushnew ',name *clauses*)))

(progn (defmacro across (vector &rest args &key index start end by) "Synonym for in-vector." (declare (ignore index start end by)) (sb-int:quasiquote (in-vector #S(sb-impl::comma :expr vector :kind 0) #S(sb-impl::comma :expr args :kind 2)))) (pushnew (quote across) *clauses*))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(define-value-binding ranging ((var (if ascending (- from by) (+ from by))) from to &key (by 1) &aux (ascending (< from to))) (declare (type real var from to by) (type boolean ascending)) (declare (ignore from)) `(cond (,ascending (incf ,var ,by) (when (< ,to ,var) (end-for))) (T (decf ,var ,by) (when (< ,var ,to) (end-for)))))

What needs to change: Macro call that should be transformed by define-value-binding

Input: (define-value-binding ranging ((var (if ascending (- from by) (+ from by))) from to &key (by 1) &aux (ascending (< from to))) (declare (type real var from to by) (type boolean ascending)) (declare (ignore from)) `(cond (,ascending (incf ,var ,by) (when (< ,to ,var) (end-for))) (T (decf ,var ,by) (when (< ,var ,to) (end-for)))))

Output:
(defmacro define-value-binding (name (var &rest args) &body body)
  (let ((vars (lambda-fiddle:extract-lambda-vars (lambda-fiddle:remove-aux-part args))))
    (emit-binding-definition name var args body :extra-vars vars)))

(define-direct-binding ranging (var from to &key (by 1)) (let ((#:ascending171 (gensym #A((9) base-char . "ASCENDING"))) (#:from168 (gensym #A((4) base-char . "FROM"))) (#:to169 (gensym #A((2) base-char . "TO"))) (#:by170 (gensym #A((2) base-char . "BY")))) (values* (sb-int:quasiquote (with-interleaving (let* #S(sb-impl::comma :expr (list* (list #:from168 from) (list #:to169 to) (list #:by170 by) (list #:ascending171 (list (quote <) #:from168 #:to169)) (loop for #:var167 in (lambda-fiddle:extract-lambda-vars (enlist var)) collect (list #:var167 (list (quote if) #:ascending171 (list (quote -) #:from168 #:by170) (list (quote +) #:from168 #:by170))))) :kind 0) (declare (ignorable #S(sb-impl::comma :expr #:ascending171 :kind 0) #S(sb-impl::comma :expr #:from168 :kind 0) #S(sb-impl::comma :expr #:to169 :kind 0) #S(sb-impl::comma :expr #:by170 :kind 0))) #S(sb-impl::comma :expr (sb-int:quasiquote (declare (type #S(sb-impl::comma :expr (quote real) :kind 0) #S(sb-impl::comma :expr var :kind 0)))) :kind 0) #S(sb-impl::comma :expr (sb-int:quasiquote (declare (type #S(sb-impl::comma :expr (quote real) :kind 0) #S(sb-impl::comma :expr #:from168 :kind 0)))) :kind 0) #S(sb-impl::comma :expr (sb-int:quasiquote (declare (type #S(sb-impl::comma :expr (quote real) :kind 0) #S(sb-impl::comma :expr #:to169 :kind 0)))) :kind 0) #S(sb-impl::comma :expr (sb-int:quasiquote (declare (type #S(sb-impl::comma :expr (quote real) :kind 0) #S(sb-impl::comma :expr #:by170 :kind 0)))) :kind 0) #S(sb-impl::comma :expr (sb-int:quasiquote (declare (type #S(sb-impl::comma :expr (quote boolean) :kind 0) #S(sb-impl::comma :expr #:ascending171 :kind 0)))) :kind 0)) #S(sb-impl::comma :expr nil :kind 0))) (let ((ascending #:ascending171) (from #:from168) (to #:to169) (by #:by170)) (declare (ignorable ascending from to by)) (declare (ignore from)) (sb-int:quasiquote (cond (#S(sb-impl::comma :expr ascending :kind 0) (incf #S(sb-impl::comma :expr var :kind 0) #S(sb-impl::comma :expr by :kind 0)) (when (< #S(sb-impl::comma :expr to :kind 0) #S(sb-impl::comma :expr var :kind 0)) (end-for))) (t (decf #S(sb-impl::comma :expr var :kind 0) #S(sb-impl::comma :expr by :kind 0)) (when (< #S(sb-impl::comma :expr var :kind 0) #S(sb-impl::comma :expr to :kind 0)) (end-for)))))))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(as->* 'some-name)

Write a macro that addresses: Macro call that should be transformed by AS->*

Input: (as->* 'some-name)

Output: (defmacro AS->* ...)


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(with-html-string (:li (:div :class "status col-xs-2 col-md-1" (:span :class "text-success" (:a :href "https://en.wikipedia.org/wiki/List_of_HTTP_status_codes#200" 200)))))

Write a macro that addresses: Macro call that should be transformed by with-html

Input: (with-html-string (:li (:div :class "status col-xs-2 col-md-1" (:span :class "text-success" (:a :href "https://en.wikipedia.org/wiki/List_of_HTTP_status_codes#200" 200)))))

Output:
(defmacro with-html (&body body &environment env)
  "Interpret BODY as HTML. Consult README.txt for the syntax."
  `(let ((*html* (ensure-html-stream *html*)))
     ,(if (and (null (cdr body)) (atom (car body)))
          (car body)
          `(progn ,@(parse-html body env)))))

(with-output-to-string (*html*) (with-html (:li (:div :class "status col-xs-2 col-md-1" (:span :class "text-success" (:a :href "https://en.wikipedia.org/wiki/List_of_HTTP_status_codes#200" 200))))))


Instruction:
Generate a defmacro form that transforms code like this:
(iterate
  'some-name)

Pattern to recognize: Macro call that should be transformed by ITERATE

Input:
(iterate
  'some-name)

Output: (defmacro ITERATE ...)


Instruction:
Generate a defmacro form that transforms code like this:
(define-error if-form-type-mismatch () (test-form then-form then-type else-form else-type) "The result if ~a is true is ~a which has type ~a however the false case returns ~a which has type ~a This is incompatible" test-form then-form then-type else-form else-type)

Pattern to recognize: Macro call that should be transformed by define-error

Input: (define-error if-form-type-mismatch () (test-form then-form then-type else-form else-type) "The result if ~a is true is ~a which has type ~a however the false case returns ~a which has type ~a This is incompatible" test-form then-form then-type else-form else-type)

Output:
(defmacro define-error (name (&key (error-type 'varjo-error) (prefix "Varjo"))
                            (&rest args) error-string &body body)
  `(defcondition ,name (:error-type ,error-type :prefix ,prefix) ,args
       ,error-string ,@body))

(defcondition if-form-type-mismatch (:error-type varjo-error :prefix "Varjo") (test-form then-form then-type else-form else-type) "The result if ~a is true is ~a which has type ~a however the false case returns ~a which has type ~a This is incompatible" test-form then-form then-type else-form else-type)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(define-class foo-type-infer () ((name "foo") (nickname street-name) (age 1) (height 2.0) (width 2 :type number) (lisper t) (nil-is-not-bool nil) (empty-list '()) (nonempty-list '(1 2 3)) (mark :foo) (binding :unbound) (sym 'sims) (fun #'list) (composite (error "Should not eval, type should not be inferred"))) (:automatic-types-p t))

What needs to change: Macro call that should be transformed by define-class

Input: (define-class foo-type-infer () ((name "foo") (nickname street-name) (age 1) (height 2.0) (width 2 :type number) (lisper t) (nil-is-not-bool nil) (empty-list '()) (nonempty-list '(1 2 3)) (mark :foo) (binding :unbound) (sym 'sims) (fun #'list) (composite (error "Should not eval, type should not be inferred"))) (:automatic-types-p t))

Output:
(defmacro define-class (name supers slots &rest options)
  "Convenience wrapper of `defclass'.

It automates a lot of boilerplate (like exporting all the accessors of a class)
plus adds some new features.

Slot options:

- The initform can be specified as the second value.

- `:accessor', `:reader' and `:writer' can be set to either a name, NIL or T.
  If NIL, the method is not generated.
  If T, the method is generated using the `:accessor-name-transformer' class option value.

- The `:export' option allows to control the slot-name export on a per-slot basis.

New class options (defaults are NIL unless specified):

- `:slot-definition-transformer' (default: `default-slot-definition-transformer').
  A function that takes a SLOT-DEFINITION and returns a new one.

- `:accessor-name-package': The package of the generated accessors.  See
  `:accessor-name-transformer'.  Some special values are accepted:
  - `:slot-name': The package of the slot-name.
  - `:default': The current package.

- `:accessor-name-transformer' (default `default-accessor-name-transformer').

  A function of (SLOT-NAME SLOT-DEFINITION) arguments that returns the accessor
  name (a symbol).  Other transformer: `dwim-accessor-name-transformer'.

- `:automatic-accessors-p': Whether to generate accessor names automatically for
  all slots.

  As a special case, the accessor is not generated if all following conditions are met:
  - `:accessor-name-package' is `:slot-name',
  - slot name package is different from current package,
  - if the `:accessor' slot option is not provided,

- `:initarg-name-transformer' (default: `default-initarg-name-transformer'.)

  A function of (SLOT-NAME SLOT-DEFINITION) arguments that returns the accessor
  name (a symbol.

- `:automatic-initargs-p' (default: T): Whether to generate accessor names
  automatically for all slots.

- `:predicate-name-transformer' (default: `default-predicate-name-transformer').

  A function of (SLOT-NAME SLOT-DEFINITION) arguments that returns the predicate
  name (a symbol).

- `:automatic-predicates-p' (default: T): Whether to generate a predicate
  for the class.

- `:type-inference' (default: `default-type-inference').

  Function that returns the type of a slot definition (with an initform).  It
  takes 3 arguments:

  - The initform.
  - The slot name.
  - The rest of the slot definition.

- `:automatic-types-p': Whether to generate the type automatically for all
  slots.  The type can still be specified manually with the `:type' slot option.

- Self-explanatory export options (all NIL by default):
  - `:export-class-name-p'
  - `:export-accessor-names-p'
  - `:export-slot-names-p'
  - `:export-predicate-name'"
  (build-defclass-like-expansion
   name supers slots options
   (lambda (processed-slots clean-options)
     `(defclass ,name ,supers
        ,processed-slots
        ,@clean-options))))

(progn (defclass foo-type-infer nil ((name :initform "foo" :accessor name :initarg :name :type string) (nickname :initform street-name :accessor nickname :initarg :nickname) (age :initform 1 :accessor age :initarg :age :type integer) (height :initform 2.0 :accessor height :initarg :height :type number) (width :initform 2 :accessor width :initarg :width :type number) (lisper :initform t :accessor lisper :initarg :lisper :type boolean) (nil-is-not-bool :initform nil :accessor nil-is-not-bool :initarg :nil-is-not-bool) (empty-list :initform (quote nil) :accessor empty-list :initarg :empty-list :type list) (nonempty-list :initform (quote (1 2 3)) :accessor nonempty-list :initarg :nonempty-list :type list) (mark :initform :foo :accessor mark :initarg :mark :type keyword) (binding :accessor binding :initarg :binding) (sym :initform (quote sims) :accessor sym :initarg :sym :type symbol) (fun :initform (function list) :accessor fun :initarg :fun :type function) (composite :initform (error "Should not eval, type should not be inferred") :accessor composite :initarg :composite))) (unless (fboundp (quote foo-type-infer-p)) (define-generic foo-type-infer-p (object) #A((79) base-char . "Auto-generated predicate for whether OBJECT is an instance of `foo-type-infer'.") (declare (sb-ext:muffle-conditions style-warning)) (typep object (quote foo-type-infer)))) (setf (documentation (quote composite) (quote function)) #A((52) base-char . "Auto-generated accessor function for slot COMPOSITE.")) (ignore-errors (setf (documentation (fdefinition (quote composite)) (quote function)) #A((52) base-char . "Auto-generated accessor function for slot COMPOSITE."))) (ignore-errors (setf (documentation (fdefinition (quote (setf composite))) (quote function)) #A((52) base-char . "Auto-generated accessor function for slot COMPOSITE."))) (setf (documentation (quote fun) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot FUN.")) (ignore-errors (setf (documentation (fdefinition (quote fun)) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot FUN."))) (ignore-errors (setf (documentation (fdefinition (quote (setf fun))) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot FUN."))) (setf (documentation (quote sym) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot SYM.")) (ignore-errors (setf (documentation (fdefinition (quote sym)) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot SYM."))) (ignore-errors (setf (documentation (fdefinition (quote (setf sym))) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot SYM."))) (setf (documentation (quote binding) (quote function)) #A((50) base-char . "Auto-generated accessor function for slot BINDING.")) (ignore-errors (setf (documentation (fdefinition (quote binding)) (quote function)) #A((50) base-char . "Auto-generated accessor function for slot BINDING."))) (ignore-errors (setf (documentation (fdefinition (quote (setf binding))) (quote function)) #A((50) base-char . "Auto-generated accessor function for slot BINDING."))) (setf (documentation (quote mark) (quote function)) #A((47) base-char . "Auto-generated accessor function for slot MARK.")) (ignore-errors (setf (documentation (fdefinition (quote mark)) (quote function)) #A((47) base-char . "Auto-generated accessor function for slot MARK."))) (ignore-errors (setf (documentation (fdefinition (quote (setf mark))) (quote function)) #A((47) base-char . "Auto-generated accessor function for slot MARK."))) (setf (documentation (quote nonempty-list) (quote function)) #A((56) base-char . "Auto-generated accessor function for slot NONEMPTY-LIST.")) (ignore-errors (setf (documentation (fdefinition (quote nonempty-list)) (quote function)) #A((56) base-char . "Auto-generated accessor function for slot NONEMPTY-LIST."))) (ignore-errors (setf (documentation (fdefinition (quote (setf nonempty-list))) (quote function)) #A((56) base-char . "Auto-generated accessor function for slot NONEMPTY-LIST."))) (setf (documentation (quote empty-list) (quote function)) #A((53) base-char . "Auto-generated accessor function for slot EMPTY-LIST.")) (ignore-errors (setf (documentation (fdefinition (quote empty-list)) (quote function)) #A((53) base-char . "Auto-generated accessor function for slot EMPTY-LIST."))) (ignore-errors (setf (documentation (fdefinition (quote (setf empty-list))) (quote function)) #A((53) base-char . "Auto-generated accessor function for slot EMPTY-LIST."))) (setf (documentation (quote nil-is-not-bool) (quote function)) #A((58) base-char . "Auto-generated accessor function for slot NIL-IS-NOT-BOOL.")) (ignore-errors (setf (documentation (fdefinition (quote nil-is-not-bool)) (quote function)) #A((58) base-char . "Auto-generated accessor function for slot NIL-IS-NOT-BOOL."))) (ignore-errors (setf (documentation (fdefinition (quote (setf nil-is-not-bool))) (quote function)) #A((58) base-char . "Auto-generated accessor function for slot NIL-IS-NOT-BOOL."))) (setf (documentation (quote lisper) (quote function)) #A((49) base-char . "Auto-generated accessor function for slot LISPER.")) (ignore-errors (setf (documentation (fdefinition (quote lisper)) (quote function)) #A((49) base-char . "Auto-generated accessor function for slot LISPER."))) (ignore-errors (setf (documentation (fdefinition (quote (setf lisper))) (quote function)) #A((49) base-char . "Auto-generated accessor function for slot LISPER."))) (setf (documentation (quote width) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot WIDTH.")) (ignore-errors (setf (documentation (fdefinition (quote width)) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot WIDTH."))) (ignore-errors (setf (documentation (fdefinition (quote (setf width))) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot WIDTH."))) (setf (documentation (quote height) (quote function)) #A((49) base-char . "Auto-generated accessor function for slot HEIGHT.")) (ignore-errors (setf (documentation (fdefinition (quote height)) (quote function)) #A((49) base-char . "Auto-generated accessor function for slot HEIGHT."))) (ignore-errors (setf (documentation (fdefinition (quote (setf height))) (quote function)) #A((49) base-char . "Auto-generated accessor function for slot HEIGHT."))) (setf (documentation (quote age) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot AGE.")) (ignore-errors (setf (documentation (fdefinition (quote age)) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot AGE."))) (ignore-errors (setf (documentation (fdefinition (quote (setf age))) (quote function)) #A((46) base-char . "Auto-generated accessor function for slot AGE."))) (setf (documentation (quote nickname) (quote function)) #A((51) base-char . "Auto-generated accessor function for slot NICKNAME.")) (ignore-errors (setf (documentation (fdefinition (quote nickname)) (quote function)) #A((51) base-char . "Auto-generated accessor function for slot NICKNAME."))) (ignore-errors (setf (documentation (fdefinition (quote (setf nickname))) (quote function)) #A((51) base-char . "Auto-generated accessor function for slot NICKNAME."))) (setf (documentation (quote name) (quote function)) #A((47) base-char . "Auto-generated accessor function for slot NAME.")) (ignore-errors (setf (documentation (fdefinition (quote name)) (quote function)) #A((47) base-char . "Auto-generated accessor function for slot NAME."))) (ignore-errors (setf (documentation (fdefinition (quote (setf name))) (quote function)) #A((47) base-char . "Auto-generated accessor function for slot NAME."))) (find-class (quote foo-type-infer) nil))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(define-declaration nil
    nil)

What needs to change: Macro call that should be transformed by DEFINE-DECLARATION

Input:
(define-declaration nil
    nil)

Output: (defmacro DEFINE-DECLARATION ...)

(sb-cltl2:define-declaration nil
    nil)


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-unique-js-names 'some-name)

Issue: Macro call that should be transformed by WITH-UNIQUE-JS-NAMES

Input: (with-unique-js-names 'some-name)

Output: (defmacro WITH-UNIQUE-JS-NAMES ...)


Instruction:
Write a Common Lisp macro to handle this code pattern:
(with* nil
  (progn))

Problem: Macro call that should be transformed by WITH*

Input:
(with* nil
  (progn))

Output: (defmacro WITH* ...)


Instruction:
Generate a defmacro form that transforms code like this:
(dlet nil
  (progn))

Pattern to recognize: Macro call that should be transformed by DLET

Input:
(dlet nil
  (progn))

Output: (defmacro DLET ...)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(with-html-string (:html (:head) (:body (:a "hai"))))

What needs to change: Macro call that should be transformed by with-html

Input: (with-html-string (:html (:head) (:body (:a "hai"))))

Output:
(defmacro with-html (&body body &environment env)
  "Interpret BODY as HTML. Consult README.txt for the syntax."
  `(let ((*html* (ensure-html-stream *html*)))
     ,(if (and (null (cdr body)) (atom (car body)))
          (car body)
          `(progn ,@(parse-html body env)))))

(with-output-to-string (*html*) (with-html (:html (:head) (:body (:a "hai")))))


Instruction:
Generate a defmacro form that transforms code like this:
(with-attributes nil
    (progn))

Pattern to recognize: Macro call that should be transformed by WITH-ATTRIBUTES

Input:
(with-attributes nil
    (progn))

Output: (defmacro WITH-ATTRIBUTES ...)

(let ((#:unit161 (progn)))
  (symbol-macrolet ()))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(make-name-transformer \"FOO-\" name \"-BAR\") Use the slot name directly: :accessor-name-transformer (make-name-transformer name)" `(lambda (name definition) (declare (ignorable definition)) (concatenate-symbol ,@(mapcar (lambda (el) (if (and (symbolp el) (string= (symbol-name el) "NAME")) 'name el)) elements))))

Problem: Macro call that should be transformed by make-name-transformer

Input: (make-name-transformer \"FOO-\" name \"-BAR\") Use the slot name directly: :accessor-name-transformer (make-name-transformer name)" `(lambda (name definition) (declare (ignorable definition)) (concatenate-symbol ,@(mapcar (lambda (el) (if (and (symbolp el) (string= (symbol-name el) "NAME")) 'name el)) elements))))

Output:
(defmacro make-name-transformer (&rest elements)
  "Return an accessor name transformer.
The unquoted `name' symbol argument is substituted for the slot name.
Class option examples:

  :accessor-name-transformer (make-name-transformer \"FOO-\" name \"-BAR\")

Use the slot name directly:

  :accessor-name-transformer (make-name-transformer name)"
  `(lambda (name definition)
    (declare (ignorable definition))
    (concatenate-symbol ,@(mapcar (lambda (el)
                                    (if (and (symbolp el)
                                             (string= (symbol-name el) "NAME"))
                                        'name
                                        el))
                                  elements))))

(lambda (name definition) (declare (ignorable definition)) (concatenate-symbol |"FOO-"| name |"-BAR"|))


Instruction:
Generate a defmacro form that transforms code like this:
(aif 1 (sif it it))

Pattern to recognize: Macro call that should be transformed by aif

Input: (aif 1 (sif it it))

Output:
(defmacro aif (test then &optional else)
  "Like IF, except binds the result of the test to IT (via LET) for
the scope of the then and else expressions."
  `(anaphoric if ,test ,then ,else))


Instruction:
Define a macro that eliminates this repetitive pattern:
(define-dispatch dispatch-for-no-result (args specific-hooks) (mapc (lambda (f) (apply f args)) specific-hooks))

Issue: Macro call that should be transformed by define-dispatch

Input: (define-dispatch dispatch-for-no-result (args specific-hooks) (mapc (lambda (f) (apply f args)) specific-hooks))

Output:
(defmacro define-dispatch (name lambda-list &body body)
  "the lambda list should accept two arguments:
the list of arguments given by the current method call.
the specific hooks (as named or unamed functions) for the qualified method (that we will be dispatching from).

you should then use the arguments to dispatch the specific hooks as you wish in the body.
if the body returns a result, by default the method will also return that result, this can be overriden with finalize-dispatch-method.

See finalize-dispatch-method
See dispatch"
  `(let ((new-dispatch (make-dispatcher (lambda ,lambda-list ,@body))))
     (setf (gethash ',name *dispatch-table*)
           new-dispatch)))

(let ((new-dispatch (make-dispatcher (lambda (args specific-hooks) (mapc (lambda (f) (apply f args)) specific-hooks))))) (setf (gethash (quote dispatch-for-no-result) *dispatch-table*) new-dispatch))


Instruction:
Define a macro that eliminates this repetitive pattern:
(true 4)

Issue: Macro call that should be transformed by true

Input: (true 4)

Output:
(defmacro true (form &optional description &rest format-args)
  `(eval-in-context
    *context*
    (make-instance 'comparison-result
                   :expression '(true ,form)
                   :value-form ',form
                   :body (lambda () ,form)
                   :expected 'T
                   :comparison 'geq
                   ,@(when description
                       `(:description (format NIL ,description ,@format-args))))))

(eval-in-context *context* (make-instance (quote comparison-result) :expression (quote (true 4)) :value-form (quote 4) :body (lambda nil 4) :expected (quote t) :comparison (quote geq)))


Instruction:
Generate a defmacro form that transforms code like this:
(finalize-savepoint :rolled-back (call-next-method conn identifier))

Pattern to recognize: Macro call that should be transformed by finalize-savepoint

Input: (finalize-savepoint :rolled-back (call-next-method conn identifier))

Output:
(defmacro finalize-savepoint (new-state &body body)
  `(let ((state (get-transaction-state conn)))
     (unless (typep state 'savepoint-state)
       (error "Please, use release-savepoint inside of with-savepoint block."))
     (unless (equal (get-identifier state)
                    identifier)
       ;; TODO: probably optional `identifier' parameter
       ;;       is excessive and should be removed?
       (error "Identifier mismatch"))

     (multiple-value-prog1
         (progn ,@body)
       (setf (get-state state)
             ,new-state))))

(let ((state (get-transaction-state conn))) (unless (typep state (quote savepoint-state)) (error "Please, use release-savepoint inside of with-savepoint block.")) (unless (equal (get-identifier state) identifier) (error "Identifier mismatch")) (multiple-value-prog1 (progn (call-next-method conn identifier)) (setf (get-state state) :rolled-back)))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(builder (when t `(:sample :out ,(lambda (out) (format t "Got: ~a" out)))) *app*)

Problem: Macro call that should be transformed by builder

Input: (builder (when t `(:sample :out ,(lambda (out) (format t "Got: ~a" out)))) *app*)

Output:
(defmacro builder (&rest app-or-middlewares)
  (let ((middlewares (butlast app-or-middlewares)))
    `(reduce #'funcall
             (remove-if
              #'null
              (list
               ,@(loop for mw in middlewares
                       when mw
                         collect (convert-to-middleware-form mw))))
             :initial-value (to-app ,(car (last app-or-middlewares)))
             :from-end t)))

(reduce (function funcall) (remove-if (function null) (list (let ((#:res183 (when t (sb-int:quasiquote (:sample :out #S(sb-impl::comma :expr (lambda (out) (format t "Got: ~a" out)) :kind 0)))))) (typecase #:res183 (keyword (find-middleware #:res183)) (cons (if (keywordp (car #:res183)) (let ((#:res-mw182 (find-middleware (car #:res183)))) (lambda (#:app181) (apply #:res-mw182 #:app181 (cdr #:res183)))) #:res183)) (standard-object (lambda (#:app181) (funcall (intern (string :wrap) :clack.middleware) #:res183 #:app181))) (otherwise #:res183))))) :initial-value (to-app *app*) :from-end t)


Instruction:
Define a macro that eliminates this repetitive pattern:
(define-error unknown-variable-type () (name) "Could not establish the type of the variable: ~s" name)

Issue: Macro call that should be transformed by define-error

Input: (define-error unknown-variable-type () (name) "Could not establish the type of the variable: ~s" name)

Output:
(defmacro define-error (name (&key (error-type 'varjo-error) (prefix "Varjo"))
                            (&rest args) error-string &body body)
  `(defcondition ,name (:error-type ,error-type :prefix ,prefix) ,args
       ,error-string ,@body))

(defcondition unknown-variable-type (:error-type varjo-error :prefix "Varjo") (name) "Could not establish the type of the variable: ~s" name)


Instruction:
Write a Common Lisp macro to handle this code pattern:
(aggregate-scope-progv *array-scope-variables* (aggregate-scope-progv *aggregate-scope-variables* (funcall *beginning-of-array-handler*) (multiple-value-bind (type token) (peek-json-token stream) (if (and (eql type :punct) (char= token #\])) (progn (read-json-token stream) (return-from decode-json-array (funcall *end-of-array-handler*))) (funcall *array-member-handler* (funcall *internal-decoder* stream)))) (loop (multiple-value-bind (type token) (read-json-token stream) (if (eql type :punct) (case token (#\] (return-from decode-json-array (funcall *end-of-array-handler*))) (#\, (setq token nil)))) (if token (json-syntax-error stream "Token out of place in Array on JSON input: `~A'" token))) (funcall *array-member-handler* (funcall *internal-decoder* stream)))))

Problem: Macro call that should be transformed by aggregate-scope-progv

Input: (aggregate-scope-progv *array-scope-variables* (aggregate-scope-progv *aggregate-scope-variables* (funcall *beginning-of-array-handler*) (multiple-value-bind (type token) (peek-json-token stream) (if (and (eql type :punct) (char= token #\])) (progn (read-json-token stream) (return-from decode-json-array (funcall *end-of-array-handler*))) (funcall *array-member-handler* (funcall *internal-decoder* stream)))) (loop (multiple-value-bind (type token) (read-json-token stream) (if (eql type :punct) (case token (#\] (return-from decode-json-array (funcall *end-of-array-handler*))) (#\, (setq token nil)))) (if token (json-syntax-error stream "Token out of place in Array on JSON input: `~A'" token))) (funcall *array-member-handler* (funcall *internal-decoder* stream)))))

Output:
(defmacro aggregate-scope-progv (variables &body body)
  "Establish a dynamic environment where all VARIABLES are freshly
bound (to their current values), and execute BODY in it, returning the
result."
  `(progv ,variables (mapcar #'symbol-value ,variables)
     ,@body))

(progv *array-scope-variables* (mapcar (function symbol-value) *array-scope-variables*) (aggregate-scope-progv *aggregate-scope-variables* (funcall *beginning-of-array-handler*) (multiple-value-bind (type token) (peek-json-token stream) (if (and (eql type :punct) (char= token #\RIGHT_SQUARE_BRACKET)) (progn (read-json-token stream) (return-from decode-json-array (funcall *end-of-array-handler*))) (funcall *array-member-handler* (funcall *internal-decoder* stream)))) (loop (multiple-value-bind (type token) (read-json-token stream) (if (eql type :punct) (case token (#\RIGHT_SQUARE_BRACKET (return-from decode-json-array (funcall *end-of-array-handler*))) (#\COMMA (setq token nil)))) (if token (json-syntax-error stream "Token out of place in Array on JSON input: `~A'" token))) (funcall *array-member-handler* (funcall *internal-decoder* stream)))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(builder (when t :sample) *app*)

Issue: Macro call that should be transformed by builder

Input: (builder (when t :sample) *app*)

Output:
(defmacro builder (&rest app-or-middlewares)
  (let ((middlewares (butlast app-or-middlewares)))
    `(reduce #'funcall
             (remove-if
              #'null
              (list
               ,@(loop for mw in middlewares
                       when mw
                         collect (convert-to-middleware-form mw))))
             :initial-value (to-app ,(car (last app-or-middlewares)))
             :from-end t)))

(reduce (function funcall) (remove-if (function null) (list (let ((#:res180 (when t :sample))) (typecase #:res180 (keyword (find-middleware #:res180)) (cons (if (keywordp (car #:res180)) (let ((#:res-mw179 (find-middleware (car #:res180)))) (lambda (#:app178) (apply #:res-mw179 #:app178 (cdr #:res180)))) #:res180)) (standard-object (lambda (#:app178) (funcall (intern (string :wrap) :clack.middleware) #:res180 #:app178))) (otherwise #:res180))))) :initial-value (to-app *app*) :from-end t)


Instruction:
Define a macro that eliminates this repetitive pattern:
(send nil nil)

Issue: Macro call that should be transformed by SEND

Input: (send nil nil)

Output: (defmacro SEND ...)


Instruction:
Generate a defmacro form that transforms code like this:
(defrule nil
  nil)

Pattern to recognize: Macro call that should be transformed by DEFRULE

Input:
(defrule nil
  nil)

Output: (defmacro DEFRULE ...)

(setf (gethash #A((3) base-char . "NIL") cl-rules.core::*rules*)
        '#S(cl-rules.core::rule
            :name #A((3) base-char . "NIL")
            :conditions (#S(cl-rules.core::condn
                            :name #A((3) base-char . "NIL")
                            :args nil))
            :actions nil))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(define TMP_MAX 1024)

Problem: Macro call that should be transformed by define

Input: (define TMP_MAX 1024)

Output:
(defmacro define (name value &rest docstring)
  "Like a #define but also visible to Lisp code."
  `(progn
     (eval-when (:compile-toplevel :load-toplevel :execute)
       (defvar ,(pp-defines *package*) (make-hash-table))
       (setf (gethash ',name ,(pp-defines *package*)) ,(prin1-to-string value)))
     (defparameter ,name ,value ,@docstring)))

(progn (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *preprocessor-defines* (make-hash-table)) (setf (gethash (quote tmp_max) *preprocessor-defines*) #A((4) base-char . "1024"))) (defparameter tmp_max 1024))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(is (= result 0))

Write a macro that addresses: Macro call that should be transformed by is

Input: (is (= result 0))

Output:
(defmacro is (test &rest reason-args)
  "The DWIM checking operator.

If TEST returns a true value a test-passed result is generated,
otherwise a test-failure result is generated. The reason, unless
REASON-ARGS is provided, is generated based on the form of TEST:

 (predicate expected actual) - Means that we want to check
 whether, according to PREDICATE, the ACTUAL value is
 in fact what we EXPECTED.

 (predicate value) - Means that we want to ensure that VALUE
 satisfies PREDICATE.

 Wrapping the TEST form in a NOT simply produces a negated reason
 string."
  (assert (listp test)
          (test)
          "Argument to IS must be a list, not ~S" test)
  (let (bindings effective-test default-reason-args)
    (with-gensyms (e a v)
      (flet ((process-entry (predicate expected actual &optional negatedp)
               ;; make sure EXPECTED is holding the entry that starts with 'values
               (when (and (consp actual)
                          (eq (car actual) 'values))
                 (assert (not (and (consp expected)
                                   (eq (car expected) 'values))) ()
                                   "Both the expected and actual part is a values expression.")
                 (rotatef expected actual))
               (let ((setf-forms))
                 (if (and (consp expected)
                          (eq (car expected) 'values))
                     (progn
                       (setf expected (copy-list expected))
                       (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
                                              for i from 0
                                              while cell
                                              when (eq (car cell) '*)
                                              collect `(setf (elt ,a ,i) nil)
                                              and do (setf (car cell) nil)))
                       (setf bindings (list (list e `(list ,@(rest expected)))
                                            (list a `(multiple-value-list ,actual)))))
                     (setf bindings (list (list e expected)
                                          (list a actual))))
                 (setf effective-test `(progn
                                         ,@setf-forms
                                         ,(if negatedp
                                              `(not (,predicate ,e ,a))
                                              `(,predicate ,e ,a)))))))
        (list-match-case test
          ((not (?predicate ?expected ?actual))
           (process-entry ?predicate ?expected ?actual t)
           (setf default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
                       `',?actual a `',?predicate e)))
          ((not (?satisfies ?value))
           (setf bindings (list (list v ?value))
                 effective-test `(not (,?satisfies ,v))
                 default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
                       `',?value v `',?satisfies)))
          ((?predicate ?expected ?actual)
           (process-entry ?predicate ?expected ?actual)
           (setf default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%"
                       `',?actual a `',?predicate e)))
          ((?satisfies ?value)
           (setf bindings (list (list v ?value))
                 effective-test `(,?satisfies ,v)
                 default-reason-args
                 (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
                       `',?value v `',?satisfies)))
          (?_
           (setf bindings '()
                 effective-test test
                 default-reason-args (list "~2&~S~2% was NIL." `',test)))))
      `(let ,bindings
         (if ,effective-test
             (add-result 'test-passed :test-expr ',test)
             (process-failure ',test
                              ,@(or reason-args default-reason-args)))))))

(let ((#:e173 result) (#:a174 0)) (if (progn (= #:e173 #:a174)) (add-result (quote test-passed) :test-expr (quote (= result 0))) (process-failure (quote (= result 0)) "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%" (quote 0) #:a174 (quote =) #:e173)))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(define-definition-resolver transform (designator package) (let ((fun-info (when (symbolp designator) (sb-int:info :function :info designator)))) (when fun-info (loop for transform in (sb-c::fun-info-transforms fun-info) collect (make-instance 'transform :designator designator :package package :transform transform)))))

Problem: Macro call that should be transformed by define-definition-resolver

Input: (define-definition-resolver transform (designator package) (let ((fun-info (when (symbolp designator) (sb-int:info :function :info designator)))) (when fun-info (loop for transform in (sb-c::fun-info-transforms fun-info) collect (make-instance 'transform :designator designator :package package :transform transform)))))

Output:
(defmacro define-definition-resolver (name args &body body)
  `(progn (setf (definition-resolver ',name)
                (lambda ,args ,@body))
          ',name))

(progn (setf (definition-resolver (quote transform)) (lambda (designator package) (let ((fun-info (when (symbolp designator) (sb-int:info :function :info designator)))) (when fun-info (loop for transform in (sb-c::fun-info-transforms fun-info) collect (make-instance (quote transform) :designator designator :package package :transform transform)))))) (quote transform))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(collect nil nil)

What needs to change: Macro call that should be transformed by COLLECT

Input: (collect nil nil)

Output: (defmacro COLLECT ...)

(common-lisp:let* ((#:generator-591 (generator nil))
                   #:items-584
                   #:seq-585
                   (#:limit-586
                    (common-lisp:multiple-value-bind (x y)
                        (decode-seq-type (list 'quote nil))
                      (declare (ignore x))
                      y))
                   (#:lst-587 nil))
  (declare (type generator #:generator-591)
           (type (null-or nonnegative-integer) #:limit-586)
           (type list #:lst-587))
  (tagbody
   #:ll-592
    (setq #:items-584 (next-in #:generator-591 (go end)))
    (setq #:lst-587 (cons #:items-584 #:lst-587))
    (go #:ll-592)
   end)
  (common-lisp:let ((num (length #:lst-587)))
    (declare (type nonnegative-integer num))
    (setq #:seq-585 (make-sequence nil (or #:limit-586 num)))
    (do ((i (1- num) (1- i)))
        ((minusp i))
      (setf (elt #:seq-585 i) (pop #:lst-587))))
  #:seq-585)


Instruction:
Generate a defmacro form that transforms code like this:
(with-mapping-collector 'some-name)

Pattern to recognize: Macro call that should be transformed by WITH-MAPPING-COLLECTOR

Input: (with-mapping-collector 'some-name)

Output: (defmacro WITH-MAPPING-COLLECTOR ...)

(let ((#:col125 (make-collector)))
  (map-aggregation (#:col125 (lambda some-name))
    (flet ((quote (&rest #:flet-args126) (apply #:col125 #:flet-args126))))))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(none-of 'some-name)

What needs to change: Macro call that should be transformed by NONE-OF

Input: (none-of 'some-name)

Output: (defmacro NONE-OF ...)


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-reducer 'some-name)

Issue: Macro call that should be transformed by WITH-REDUCER

Input: (with-reducer 'some-name)

Output: (defmacro WITH-REDUCER ...)

(let ((#:reducer128
       (make-reducer some-name :initial-value (or nil nil) :place-setter nil)))
  (flet ((quote (&rest items) (apply #:reducer128 items)))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(integer-writer 2)

Write a macro that addresses: Macro call that should be transformed by integer-writer

Input: (integer-writer 2)

Output:
(defmacro integer-writer (bytes)
  "Create a function to write integers to a binary stream."
  (let ((bits (* 8 bytes)))
    `(progn
       (declaim (inline ,(integer-writer-name bytes t)
                        ,(integer-writer-name bytes nil)))
       (defun ,(integer-writer-name bytes nil) (socket value)
         (declare (type stream socket)
                  (type (unsigned-byte ,bits) value)
                  #.*optimize*)
         ,@(if (= bytes 1)
               `((write-byte value socket))
               (loop :for byte :from (1- bytes) :downto 0
                     :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
                                           socket)))
         (values))
       (defun ,(integer-writer-name bytes t) (socket value)
         (declare (type stream socket)
                  (type (signed-byte ,bits) value)
                  #.*optimize*)
         ,@(if (= bytes 1)
               `((write-byte (ldb (byte 8 0) value) socket))
               (loop :for byte :from (1- bytes) :downto 0
                     :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
                                           socket)))
         (values)))))

(progn (declaim (inline write-int2 write-uint2)) (defun write-uint2 (socket value) (declare (type stream socket) (type (unsigned-byte 16) value) (optimize (speed 3) (safety 0) (space 1) (debug 1) (compilation-speed 0))) (write-byte (ldb (byte 8 8) value) socket) (write-byte (ldb (byte 8 0) value) socket) (values)) (defun write-int2 (socket value) (declare (type stream socket) (type (signed-byte 16) value) (optimize (speed 3) (safety 0) (space 1) (debug 1) (compilation-speed 0))) (write-byte (ldb (byte 8 8) value) socket) (write-byte (ldb (byte 8 0) value) socket) (values)))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(with-reader-case nil
  (progn))

Write a macro that addresses: Macro call that should be transformed by WITH-READER-CASE

Input:
(with-reader-case nil
  (progn))

Output: (defmacro WITH-READER-CASE ...)

(let ()
  (let ((#:previous-case180 (readtable-case *readtable*)))
    (setf (readtable-case *readtable*) nil)
    (unwind-protect (progn (progn))
      (setf (readtable-case *readtable*) #:previous-case180))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(def-neo4j-fun create-index ((type :node) name config) :post (:uri-spec (format nil "index/~A" (string-downcase (symbol-name type)))) (:encode (cons (cons :name name) config) :string) (:status-handlers (201 (decode-neo4j-json-output body))))

Issue: Macro call that should be transformed by def-neo4j-fun

Input: (def-neo4j-fun create-index ((type :node) name config) :post (:uri-spec (format nil "index/~A" (string-downcase (symbol-name type)))) (:encode (cons (cons :name name) config) :string) (:status-handlers (201 (decode-neo4j-json-output body))))

Output:
(defmacro def-neo4j-fun (name lambda-list method &rest args)
  `(progn
     (defun ,name (&key ,@lambda-list)
       (let ((uri ,(cadr (assoc :uri-spec args)))
             (json (encode-neo4j-json-payload ,@(aif (assoc :encode args)
                                                     (cdr it)
                                                     (list '() :string)))))
         (make-neo4j-request ,method uri json
                             (list ,@(mapcar (lambda (handler)
                                               `(list ,(car handler) (lambda (body uri json)
                                                                  ,(cadr handler))))
                                             (cdr (assoc :status-handlers args)))))))))

(progn (defun create-index (&key (type :node) name config) (let ((uri (format nil "index/~A" (string-downcase (symbol-name type)))) (json (encode-neo4j-json-payload (cons (cons :name name) config) :string))) (make-neo4j-request :post uri json (list (list 201 (lambda (body uri json) (decode-neo4j-json-output body))))))))