Instruction:
Generate a defmacro form that transforms code like this:
(augment post-code `((setq ,extra-save-var ,var)))

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

Input: (augment post-code `((setq ,extra-save-var ,var)))

Output:
(defmacro augment (var stuff)
  `(setf ,var (nconc ,var ,stuff)))

(setf post-code (nconc post-code (sb-int:quasiquote ((setq #S(sb-impl::comma :expr extra-save-var :kind 0) #S(sb-impl::comma :expr var :kind 0))))))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(*> +period+ +any-digit+ +digits+)

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

Input: (*> +period+ +any-digit+ +digits+)

Output:
(defmacro *> (parser &rest parsers)
  "Combination of parsers yielding the result of the rightmost one."
  (let ((offset (gensym "*>-OFFSET")))
    `(lambda (,offset)
       ,(reduce (lambda (i p)
                  (let ((res  (gensym "*>-RES"))
                        (next (gensym "*>-NEXT")))
                    `(multiple-value-bind (,res ,next) ,i
                       (if (ok? ,res)
                           (funcall ,p ,next)
                           (fail ,next)))))
                parsers
                :initial-value `(funcall ,parser ,offset)))))

(lambda (#:*>-offset184) (multiple-value-bind (#:*>-res187 #:*>-next188) (multiple-value-bind (#:*>-res185 #:*>-next186) (funcall +period+ #:*>-offset184) (if (ok? #:*>-res185) (funcall +any-digit+ #:*>-next186) (fail #:*>-next186))) (if (ok? #:*>-res187) (funcall +digits+ #:*>-next188) (fail #:*>-next188))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-env [assoc-list 'c])

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

Input: (with-env [assoc-list 'c])

Output:
(defmacro with-env (&body body)
  (let ((body-value (gensym)))
    `(let (,body-value)
       (defclass foo () ((a :initform 3)))
       (defmethod get-val ((object foo) &rest slot/s) (slot-value object (car slot/s)))
       (defmethod (setf get-val) (new-value (object foo) &rest slot/s)
         (setf (slot-value object (car slot/s)) new-value))
       (defstruct bar a)
       (setq ,body-value
             (let ((str (alexandria:copy-array "abcde"))
                   (vec (alexandria:copy-array #(a b c d e)))
                   (arr (alexandria:copy-array #2A((1 2 3)
                                                   (4 5 6))))
                   (list      (copy-list '(a b c d e)))
                   (ht        (eval (read-from-string "{'a 'b 'c 'd}")))
                   (ht-eq     (eval (read-from-string "{eq \"a\" 1
                                                    \"b\" 2}")))
                   (ht-equalp (eval (read-from-string "{equalp '(1 2 3) \"a\"
                                                               '(4 5 6) \"b\"}")))
                   (assoc-list (copy-tree '((a . 1) (b . 2))))
                   (plist      (copy-list '(:a 4 :c 5)))
                   (clos-object (make-instance 'foo))
                   (struct      (make-bar :a 3)))
               (declare (ignorable str vec arr list ht ht-eq ht-equalp
                                   assoc-list plist clos-object struct))
               ,@body))
       (setf (find-class 'foo nil) nil)
       (setf (find-class 'bar nil) nil)
       ,body-value))

(let (#:g128) (defclass foo nil ((a :initform 3))) (defmethod get-val ((object foo) &rest slot/s) (slot-value object (car slot/s))) (defmethod (setf get-val) (new-value (object foo) &rest slot/s) (setf (slot-value object (car slot/s)) new-value)) (defstruct bar a) (setq #:g128 (let ((str (alexandria:copy-array "abcde")) (vec (alexandria:copy-array #(a b c d e))) (arr (alexandria:copy-array #2A((1 2 3) (4 5 6)))) (list (copy-list (quote (a b c d e)))) (ht (eval (read-from-string "{'a 'b 'c 'd}"))) (ht-eq (eval (read-from-string "{eq \"a\" 1
                                                    \"b\" 2}"))) (ht-equalp (eval (read-from-string "{equalp '(1 2 3) \"a\"
                                                               '(4 5 6) \"b\"}"))) (assoc-list (copy-tree (quote ((a . 1) (b . 2))))) (plist (copy-list (quote (:a 4 :c 5)))) (clos-object (make-instance (quote foo))) (struct (make-bar :a 3))) (declare (ignorable str vec arr list ht ht-eq ht-equalp assoc-list plist clos-object struct)) [assoc-list (quote c]))) (setf (find-class (quote foo) nil) nil) (setf (find-class (quote bar) nil) nil) #:g128)


Instruction:
Write a Common Lisp macro to handle this code pattern:
(define-test partially-correct (true "Happy") (is = (get-universal-time) 2962566000))

Problem: Macro call that should be transformed by define-test

Input: (define-test partially-correct (true "Happy") (is = (get-universal-time) 2962566000))

Output:
(defmacro define-test (name &body arguments-and-body)
  (destructuring-bind (nparent name) (if (listp name) name (list NIL name))
    (form-fiddle:with-body-options (body options parent home (test-class 'test) (compile-at :compile-time) defun) arguments-and-body
      (let ((body (remove 'define-test body :key (lambda (a) (when (listp a) (car a))) :test #'eql))
            (defs (remove 'define-test body :key (lambda (a) (when (listp a) (car a))) :test-not #'eql))
            (home-form (or home `(find-package ,(package-name *package*)))))
        (when (and parent nparent)
          (error "Cannot specify parent through name and through a keyword argument at the same time!"))
        `(let ((*package* (find-package ,(package-name *package*)))) ; Make sure package stays consistent throughout initialisation.
           (setf (find-test ',name ,home-form)
                 (ensure-test ',test-class
                              :name ',name
                              :home ,home-form
                              :tests (list ,@(loop for form in body
                                                   collect (ecase compile-at
                                                             (:compile-time `(lambda () ,form))
                                                             (:execute `(lambda () (call-compile ',form))))))
                              :parent ',(or parent nparent)
                              ,@(loop for option in options
                                      collect `',option)))
           ,@(loop for (def subname . body) in defs
                   collect `(,def (,name ,subname)
                              :home ,home
                              ,@body))
           ,@(when defun
               `((defun ,(if (stringp name) (read-symbol name) name) (&rest test-args)
                   (apply #'test (find-test ',name ,home-form) test-args))))
           ',name)))))

(let ((*package* (find-package #A((9) base-char . "PARACHUTE")))) (setf (find-test (quote partially-correct) (find-package #A((9) base-char . "PARACHUTE"))) (ensure-test (quote test) :name (quote partially-correct) :home (find-package #A((9) base-char . "PARACHUTE")) :tests (list (lambda nil (true "Happy")) (lambda nil (is = (get-universal-time) 2962566000))) :parent (quote nil))) (quote partially-correct))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(is (< 0 1))

Problem: Macro call that should be transformed by is

Input: (is (< 0 1))

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 ((#:e179 0) (#:a180 1)) (if (progn (< #:e179 #:a180)) (add-result (quote test-passed) :test-expr (quote (< 0 1))) (process-failure (quote (< 0 1)) "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%" (quote 1) #:a180 (quote <) #:e179)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(%destructure-defhook-args args (destructure-specialized-lambda-list descriptive-lambda-list vanilla-lambda-list type-list specialized-lambda-list (with-effective-qualifier generic-function qualifier (intern-hook generic-function hook-name type-list qualifier) `(progn (%defhook-fun ,hook-name ,vanilla-lambda-list ,@body) (%define-method-dispatch ,generic-function ,qualifier ,specialized-lambda-list)))))

What needs to change: Macro call that should be transformed by %destructure-defhook-args

Input: (%destructure-defhook-args args (destructure-specialized-lambda-list descriptive-lambda-list vanilla-lambda-list type-list specialized-lambda-list (with-effective-qualifier generic-function qualifier (intern-hook generic-function hook-name type-list qualifier) `(progn (%defhook-fun ,hook-name ,vanilla-lambda-list ,@body) (%define-method-dispatch ,generic-function ,qualifier ,specialized-lambda-list)))))

Output:
(defmacro %destructure-defhook-args (args &body body)
  (let ((args-sym (gensym)))
    `(let* ((,args-sym ,args)
            (qualifier
            (cond ((and (symbolp (car ,args-sym)) (not (null (car ,args-sym))))
                   (prog1 (car ,args-sym) (setf ,args-sym (cdr ,args-sym))))
                  (t :use-default))))
       (destructuring-bind (specialized-lambda-list &body body) ,args-sym
         ,@body))))

(let* ((#:g122 args) (qualifier (cond ((and (symbolp (car #:g122)) (not (null (car #:g122)))) (prog1 (car #:g122) (setf #:g122 (cdr #:g122)))) (t :use-default)))) (destructuring-bind (specialized-lambda-list &body body) #:g122 (destructure-specialized-lambda-list descriptive-lambda-list vanilla-lambda-list type-list specialized-lambda-list (with-effective-qualifier generic-function qualifier (intern-hook generic-function hook-name type-list qualifier) (sb-int:quasiquote (progn (%defhook-fun #S(sb-impl::comma :expr hook-name :kind 0) #S(sb-impl::comma :expr vanilla-lambda-list :kind 0) #S(sb-impl::comma :expr body :kind 2)) (%define-method-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))))))))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(define-template nil :key nil)

Problem: Macro call that should be transformed by DEFINE-TEMPLATE

Input: (define-template nil :key nil)

Output: (defmacro DEFINE-TEMPLATE ...)

(defmacro define-nil (:key &optional (#:name128))
  (flet ((template-unfulfillable ()
           (error 'template-unfulfillable :template 'nil :arguments
                  (list :key))))
    (declare (ignorable (function template-unfulfillable)))
    (let ((body (progn)) (name (or #:name128 (compose-name #\SOLIDUS 'nil))))
      `(progn
        (declaim
         (ftype
          (function
           ,(loop with types = (declared-variable-types body)
                  for arg in (quote nil)
                  collect (or (second (assoc arg types)) (quote t)))
           ,(declared-return-type body))
          ,name)
         ,@(when (find (quote inline) (declarations body)) `((inline ,name))))
        (defun ,name ,'nil
          (declare (optimize speed (safety 0) (debug 0) (compilation-speed 0))
                   ,@(remove (quote inline) (declarations body)))
          ,@(remove-if #'declaration-p body))))))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(define-fixture-restore function (symbol value) (setf (fdefinition symbol) value))

Problem: Macro call that should be transformed by define-fixture-restore

Input: (define-fixture-restore function (symbol value) (setf (fdefinition symbol) value))

Output:
(defmacro define-fixture-restore (name args &body body)
  `(progn (setf (gethash ',name *fixture-restores*)
                (lambda ,args ,@body))
          ',name))

(progn (setf (gethash (quote function) *fixture-restores*) (lambda (symbol value) (setf (fdefinition symbol) value))) (quote function))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(define-hook (:boot foreign-libraries (- most-positive-fixnum 10)) () (status 0 "Reloading foreign libraries.") (flet ((maybe-load (lib) (let ((lib (ensure-library lib)) #+sbcl(sb-ext:*muffled-warnings* 'style-warning)) (unless (or (library-open-p lib) (library-dont-open-p lib)) (status 1 "Loading foreign library ~a." lib) (open-library lib))))) (dolist (lib *foreign-libraries-to-reload*) (maybe-load lib))))

Problem: Macro call that should be transformed by define-hook

Input: (define-hook (:boot foreign-libraries (- most-positive-fixnum 10)) () (status 0 "Reloading foreign libraries.") (flet ((maybe-load (lib) (let ((lib (ensure-library lib)) #+sbcl(sb-ext:*muffled-warnings* 'style-warning)) (unless (or (library-open-p lib) (library-dont-open-p lib)) (status 1 "Loading foreign library ~a." lib) (open-library lib))))) (dolist (lib *foreign-libraries-to-reload*) (maybe-load lib))))

Output:
(defmacro define-hook ((type name &optional (priority 0)) args &body body)
  (ecase type (:pre-load) (:load) (:build) (:deploy) (:boot) (:quit))
  (check-type name symbol)
  `(let ((,name (or (hook ,type ',name)
                    (make-instance 'hook :name ',name :type ,type))))
     (setf (hook-priority ,name) ,priority)
     (setf (hook-function ,name) (flet ((,name (&key ,@args &allow-other-keys)
                                          ,@body))
                                   #',name))
     (setf (hook ,type ',name) ,name)
     (setf (docstring ,name) ,(if (stringp (car body)) (car body)))
     ',name))

(let ((foreign-libraries (or (hook :boot (quote foreign-libraries)) (make-instance (quote hook) :name (quote foreign-libraries) :type :boot)))) (setf (hook-priority foreign-libraries) (- most-positive-fixnum 10)) (setf (hook-function foreign-libraries) (flet ((foreign-libraries (&key &allow-other-keys) (status 0 "Reloading foreign libraries.") (flet ((maybe-load (lib) (let ((lib (ensure-library lib)) (sb-ext:*muffled-warnings* (quote style-warning))) (unless (or (library-open-p lib) (library-dont-open-p lib)) (status 1 "Loading foreign library ~a." lib) (open-library lib))))) (dolist (lib *foreign-libraries-to-reload*) (maybe-load lib))))) (function foreign-libraries))) (setf (hook :boot (quote foreign-libraries)) foreign-libraries) (setf (docstring foreign-libraries) nil) (quote foreign-libraries))


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

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

Input:
(lambda* nil
  (progn))

Output: (defmacro LAMBDA* ...)


Instruction:
Write a Common Lisp macro to handle this code pattern:
(collect-min 'some-name)

Problem: Macro call that should be transformed by COLLECT-MIN

Input: (collect-min 'some-name)

Output: (defmacro COLLECT-MIN ...)

(common-lisp:let* ((#:generator-320 (generator 'some-name))
                   #:numbers-314
                   (#:number-316 nil))
  (declare (type generator #:generator-320))
  (tagbody
   #:ll-321
    (setq #:numbers-314 (next-in #:generator-320 (go end)))
    (if (or (null #:number-316) (> #:number-316 #:numbers-314))
        (setq #:number-316 #:numbers-314))
    (go #:ll-321)
   end)
  (if (null #:number-316)
      (setq #:number-316 nil))
  #:number-316)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(is = 5 6)

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

Input: (is = 5 6)

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

(eval-in-context *context* (make-instance (quote comparison-result) :expression (quote (is = 5 6)) :value-form (quote 6) :body (lambda nil 6) :expected 5 :comparison (quote =)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(defclause-driver (for var in-stream stream &optional using (reader '#'read)) "Forms in a stream (which will be closed at the end)" (top-level-check) (return-stream-driver-code var stream reader :stream generate))

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

Input: (defclause-driver (for var in-stream stream &optional using (reader '#'read)) "Forms in a stream (which will be closed at the end)" (top-level-check) (return-stream-driver-code var stream reader :stream generate))

Output:
(defmacro defclause (clause-template &body body)
  (define-clause 'defun clause-template body nil))

(eval-when (:compile-toplevel :load-toplevel :execute) (defun clause-for-in-stream-7 (&key ((:for var)) ((:in-stream stream)) ((:using reader) (quote (function read))) generate) "Forms in a stream (which will be closed at the end)" (top-level-check) (return-stream-driver-code var stream reader :stream generate)) (install-clause-info (quote (for :in-stream)) (quote (for :in-stream &optional :using)) (quote clause-for-in-stream-7) "Forms in a stream (which will be closed at the end)" t) (quote (for var in-stream stream &optional using (reader (quote (function read))))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(defun/1 ungetc (c fd) (handler-case (progn (unread-char (code-char c) (fd-stream fd)) c) (error () (setf (ferror fd) EIO) EOF)))

Issue: Macro call that should be transformed by defun/1

Input: (defun/1 ungetc (c fd) (handler-case (progn (unread-char (code-char c) (fd-stream fd)) c) (error () (setf (ferror fd) EIO) EOF)))

Output:
(defmacro defun/1 (name arglist &body body)
  "Lisp-1 defun; makes function pointers work."
  `(progn
     (defun ,name ,arglist
       (declare (optimize (speed 0) (debug 3)
                          ;; FIXME: Why do minor warnings result in load errors?
                          #+sbcl (sb-ext:inhibit-warnings 3)))

       ,@body)
     (defparameter ,name (vacietis.c:mkptr& (symbol-function ',name)))))

(progn (defun ungetc (c fd) (declare (optimize (speed 0) (debug 3) (sb-ext:inhibit-warnings 3))) (handler-case (progn (unread-char (code-char c) (fd-stream fd)) c) (error nil (setf (ferror fd) eio) eof))) (defparameter ungetc (vacietis.c:mkptr& (symbol-function (quote ungetc)))))


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

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

Input:
(with-yield
  nil
  :key
  nil)

Output: (defmacro WITH-YIELD ...)

(isolate-cont
  (enable-yield
    nil
    nil
    :key
    nil))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(aggregate-scope-progv *string-scope-variables* (aggregate-scope-progv *aggregate-scope-variables* (loop initially (funcall *beginning-of-string-handler*) for c = (read-json-string-char stream) while c do (funcall *string-char-handler* c) finally (return (funcall *end-of-string-handler*)))))

What needs to change: Macro call that should be transformed by aggregate-scope-progv

Input: (aggregate-scope-progv *string-scope-variables* (aggregate-scope-progv *aggregate-scope-variables* (loop initially (funcall *beginning-of-string-handler*) for c = (read-json-string-char stream) while c do (funcall *string-char-handler* c) finally (return (funcall *end-of-string-handler*)))))

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 *string-scope-variables* (mapcar (function symbol-value) *string-scope-variables*) (aggregate-scope-progv *aggregate-scope-variables* (loop initially (funcall *beginning-of-string-handler*) for c = (read-json-string-char stream) while c do (funcall *string-char-handler* c) finally (return (funcall *end-of-string-handler*)))))


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

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

Input: (gatherlet nil)

Output: (defmacro GATHERLET ...)


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

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

Input:
(cond->
  'some-name)

Output: (defmacro COND-> ...)


Instruction:
Define a macro that eliminates this repetitive pattern:
(define-cruft %associate-name-with-readtable (name readtable) "Associate NAME with READTABLE for FIND-READTABLE to work." #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable) #+ :common-lisp (setf (gethash name *named-readtables*) readtable))

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

Input: (define-cruft %associate-name-with-readtable (name readtable) "Associate NAME with READTABLE for FIND-READTABLE to work." #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable) #+ :common-lisp (setf (gethash name *named-readtables*) readtable))

Output:
(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
  (assert (typep docstring 'string) (docstring) "Docstring missing!")
  (assert (not (null alternatives)))
  `(progn
     (declaim (inline ,name))
     (defun ,name ,lambda-list ,docstring ,(first alternatives))))

(progn (declaim (inline %associate-name-with-readtable)) (defun %associate-name-with-readtable (name readtable) "Associate NAME with READTABLE for FIND-READTABLE to work." (setf (gethash name *named-readtables*) readtable)))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(defjs test_sum() (let ((l (make-array 1 2 3 4)) (sum 0)) (dolist (c l) (incf sum c)) (return sum)))

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

Input: (defjs test_sum() (let ((l (make-array 1 2 3 4)) (sum 0)) (dolist (c l) (incf sum c)) (return sum)))

Output:
(defmacro defjs (name args &body body)
  "Define client side javascript. Works like defun; body is in lisp, with parenscript
   additions, like return. So (defjs hello (x y) (return (+ x y))) defines an adder.
   macro creates a lisp function which sends the javascript function over to the mongo
   server to be evaluated. Result is processed and returned to the reader.
   This will execute 10 times on the server :
   (mapcar (lambda (x) (hello 10 x)) (list 1 2 3 4 5 6 7 8 9 10))"
  `(let* ((js-body (parenscript:ps (lambda ,args ,@body))))
     (setf (gethash ',name *js-definitions*) js-body)
     (defun ,name ,args
       (get-element "retval" (car (docs (db.eval js-body ,@args)))))))

(let* ((js-body (parenscript:ps (lambda nil (let ((l (make-array 1 2 3 4)) (sum 0)) (dolist (c l) (incf sum c)) (return sum)))))) (setf (gethash (quote test_sum) *js-definitions*) js-body) (defun test_sum nil (get-element "retval" (car (docs (db.eval js-body))))))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(defclause (minimize expr &optional into var) "Minimize value of an expression" (return-extremum-code expr var 'min))

Problem: Macro call that should be transformed by defclause

Input: (defclause (minimize expr &optional into var) "Minimize value of an expression" (return-extremum-code expr var 'min))

Output:
(defmacro defclause (clause-template &body body)
  (define-clause 'defun clause-template body nil))

(eval-when (:compile-toplevel :load-toplevel :execute) (defun clause-minimize-13 (&key ((:minimize expr)) ((:into var))) "Minimize value of an expression" (return-extremum-code expr var (quote min))) (install-clause-info (quote (minimize)) (quote (minimize &optional :into)) (quote clause-minimize-13) "Minimize value of an expression" nil) (quote (minimize expr &optional into var)))


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

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

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

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

(let ((#:|packages122| (locked-packages 'nil)))
  (unlock-packages #:|packages122|)
  (unwind-protect (progn) (lock-packages #:|packages122|)))


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

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

Input:
(dlet* nil
  :key
  nil)

Output: (defmacro DLET* ...)


Instruction:
Generate a defmacro form that transforms code like this:
(doseq (elem sequence :from-end from-end :start start :end end) (when (funcall test (funcall key elem)) (incf count)))

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

Input: (doseq (elem sequence :from-end from-end :start start :end end) (when (funcall test (funcall key elem)) (incf count)))

Output:
(defmacro doseq (name/seq &body body)
  "Iterate over the elements of a single sequence SEQUENCE.

   Same as DO-SEQUENCES but for the special case of iterating over a
   single sequence.

   The macro arguments can be in one of the following two forms:

    1. (NAME (ELEMENT SEQUENCE &REST ARGS) &BODY BODY)

    2. ((ELEMENT SEQUENCE &REST ARGS) &BODY BODY)

   NAME is the block name, NIL if not given.

   ELEMENT is the variable to which each element of the sequence is
   bound.

   SEQUENCE is the sequence, with ARGS being the remaining arguments
   passed to the ITERATOR function.

   BODY is the list of forms evaluated on each iteration."

  (let-if ((name name/seq)
           (seq (first body) name/seq)
           (body (rest body) body))
      (symbolp name/seq)

    (destructuring-bind (element sequence &rest args) seq
      `(do-sequences ,name
         ((,element ,sequence ,@args))
         ,@body))))

(do-sequences nil ((elem sequence :from-end from-end :start start :end end)) (when (funcall test (funcall key elem)) (incf count)))


Instruction:
Define a macro that eliminates this repetitive pattern:
(once-only* args (let ((else `(error 'match-error :values (list ,@args) :patterns ',(mapcar #'car clauses)))) (compile-match args clauses else)))

Issue: Macro call that should be transformed by once-only*

Input: (once-only* args (let ((else `(error 'match-error :values (list ,@args) :patterns ',(mapcar #'car clauses)))) (compile-match args clauses else)))

Output:
(defmacro once-only* (symbol &body body)
  (with-unique-names (form var vars bindings)
    `(let (,vars ,bindings)
       (dolist (,form ,symbol)
         (if (symbolp ,form)
             (push ,form ,vars)
             (let ((,var (gensym "VAR")))
               (push ,var ,vars)
               (push (list ,var ,form) ,bindings))))
       (setq ,vars (nreverse ,vars)
             ,bindings (nreverse ,bindings))
       (if ,bindings
           `(let ,,bindings
              ;(declare (ignorable ,@(mapcar #'car ,bindings)))
              ,(let ((,symbol ,vars))
                 ,@body))
           (progn ,@body)))))

(let (#:vars166 #:bindings167) (dolist (#:form164 args) (if (symbolp #:form164) (push #:form164 #:vars166) (let ((#:var165 (gensym "VAR"))) (push #:var165 #:vars166) (push (list #:var165 #:form164) #:bindings167)))) (setq #:vars166 (nreverse #:vars166) #:bindings167 (nreverse #:bindings167)) (if #:bindings167 (sb-int:quasiquote (let #S(sb-impl::comma :expr #:bindings167 :kind 0) #S(sb-impl::comma :expr (let ((args #:vars166)) (let ((else (sb-int:quasiquote (error (quote match-error) :values (list #S(sb-impl::comma :expr args :kind 2)) :patterns (quote #S(sb-impl::comma :expr (mapcar (function car) clauses) :kind 0)))))) (compile-match args clauses else))) :kind 0))) (progn (let ((else (sb-int:quasiquote (error (quote match-error) :values (list #S(sb-impl::comma :expr args :kind 2)) :patterns (quote #S(sb-impl::comma :expr (mapcar (function car) clauses) :kind 0)))))) (compile-match args clauses else)))))


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

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

Input: (keep-bops 'some-name)

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) '('some-name))
                                     (remprop (car b) 'properties)
                                     t))
                                 bs)))
                      *binfix*)))
     (assign-properties))))


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

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

Output: (defmacro F_N ...)


Instruction:
Write a Common Lisp macro to handle this code pattern:
($+ result)

Problem: Macro call that should be transformed by $+

Input: ($+ result)

Output:
(defmacro $+ (arg &rest args)
  `(construct-$+- +1 ,arg ,@args))


Instruction:
Define a macro that eliminates this repetitive pattern:
(min-of nil)

Issue: Macro call that should be transformed by MIN-OF

Input: (min-of nil)

Output: (defmacro MIN-OF ...)


Instruction:
Define a macro that eliminates this repetitive pattern:
(secase (car x) (:y (setf it :no)))

Issue: Macro call that should be transformed by secase

Input: (secase (car x) (:y (setf it :no)))

Output:
(defmacro secase (keyform &body cases)
  "Like ECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
scope of the cases. IT can be set with SETF."
  `(symbolic ecase ,keyform ,@cases))

(symbolic ecase (car x) (:y (setf it :no)))


Instruction:
Generate a defmacro form that transforms code like this:
(define-op (:= infix-op))

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

Input: (define-op (:= infix-op))

Output:
(defmacro define-op ((op-name struct-type &key sql-op-name include-slots (package (find-package '#:sxql/operator))) &body body)
  (check-type op-name symbol)
  (let ((struct-name (intern (concatenate 'string (symbol-name op-name) #.(string :-op)) package)))
    `(defstruct (,struct-name (:include ,struct-type
                               (name ,(or sql-op-name
                                          (with-output-to-string (s)
                                            (loop for c across (symbol-name op-name)
                                                  if (char= c #\-)
                                                    do (write-char #\Space s)
                                                  else
                                                    do (write-char c s)))))
                               ,@include-slots)
                              (:constructor ,(intern (concatenate 'string
                                                                  #.(string :make-)
                                                                  (symbol-name op-name)
                                                                  #.(string :-op))
                                                     package)
                                  ,(ecase struct-type
                                     ((unary-op
                                       unary-splicing-op
                                       unary-postfix-op) '(var))
                                     ((infix-op
                                       infix-splicing-op
                                       infix-list-op) '(left right))
                                     (conjunctive-op '(&rest expressions)))))
       ,@body)))

(defstruct (=-op (:include infix-op (name "=")) (:constructor make-=-op (left right))))


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

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

Input:
(-<>
  'some-name)

Output: (defmacro -<> ...)


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5)) ((:writable-accessors (my-a a) (my-c c) (d the-d)) obj)) (setf my-a 42) (list d my-c my-a (a obj)))

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

Input: (bind ((obj (make-instance 'metabang-bind-class-2 :a 1 :b 2 :c 3 :d 4 :e 5)) ((:writable-accessors (my-a a) (my-c c) (d the-d)) obj)) (setf my-a 42) (list d my-c my-a (a obj)))

Output:
(defmacro bind ((&rest bindings) &body body)
  "Bind is a replacement for let*, destructuring-bind, multiple-value-bind and more.

An example is probably the best way to describe its syntax:

    \(bind \(\(a 2\)
           \(\(b &rest args &key \(c 2\) &allow-other-keys\) '\(:a :c 5 :d 10 :e 54\)\)
           \(\(:values d e\) \(truncate 4.5\)\)
           \(\(:structure xxx- slot1 slot2\) \(make-xxx\)\)
           \(\(:flet name \(arg1 arg2\)\) \(+ arg1 arg2\)\)\)
         \(list a b c d e args\)\)

Simple bindings are as in let*. Destructuring is done if the first item
in a binding is a list. Multiple value binding is done if the first item
in a binding is a list and the first item in the list is ':values'. Other
forms have their own syntax. For example, :structure first has the conc
name and then slot names whereas :flet has the function name and a list
of arguments and then the function body (in an implicit progn)."
  (let (declarations)
    (loop while (and (consp (car body)) (eq (caar body) 'declare)) do
          (push (first body) declarations)
          (setf body (rest body)))
    (if bindings
	(let ((*all-declarations* (bind-expand-declarations (nreverse declarations))))
	  (prog1
	      (bind-macro-helper bindings body)
	    (check-for-unused-variable-declarations *all-declarations*)))
        `(locally
             ,@declarations
           ,@body))))

(let* ((obj (make-instance (quote metabang-bind-class-2) :a 1 :b 2 :c 3 :d 4 :e 5)) (#:|values-177| obj)) (declare (ignorable #:|values-177|)) (with-accessors ((my-a a) (my-c c) (d the-d)) #:|values-177| (progn (setf my-a 42) (list d my-c my-a (a obj)))))


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

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

Input: (ƒ→ nil :key nil)

Output: (defmacro Ƒ→ ...)

(defn nil :key (&optional α)
      (let ((α (or α t)))
        (cond)))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(define-generic generic (a b &key c) (declare (optimize (speed 1))) (+ a b c))

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

Input: (define-generic generic (a b &key c) (declare (optimize (speed 1))) (+ a b c))

Output:
(defmacro define-generic (name (&rest arglist) &body body)
  "Convenience macro to define generics as if they were methods.
ARGLIST can be a method arglist, in which case it's parsed into
generic function arglist by removing method-specific args.

BODY can be a list of `defgeneric' options (processed as-is, even
:method ones) intermixed with other Lisp forms:
- If there's a docstring as the first form, it's processed into
  :documentation option of `defgeneric'.
- If there are non-option forms, they are put together into a separate
  :method option under ARGLIST.
- If there's a `declare' form:
  - If it's generic-friendly (optimize for speed or space), then it's
    put into both generic body and :method body (if any).
  - Otherwise it's only put into :method (creating it if necessary).
- If there's an `:export-generic-name-p' boolean option, export (T) or
  don't export (NIL) the generic symbol.

Example:

\(define-generic add ((a integer) (b integer) &key coerce-to-fixnum &allow-other-keys)
  \"Adds A and B, coercing them to fixnum if the sum is too big.\"
  (if coerce-to-fixnum
      (coerce (+ a b) 'fixnum)
      (+ a b))
  (:method ((a string) (b integer))
   (error \"Cannot use `add' on strings!\")))
=>
\(defgeneric add (a b &key &allow-other-keys)
  (:method ((a integer) (b integer) &key coerce-to-fixnum &allow-other-keys)
   (if coerce-to-fixnum
      (coerce (+ a b) 'fixnum)
      (+ a b)))
  (:method ((a string) (b integer))
   (error \"Cannot use `add' on strings!\"))
  (:documentation \"Adds A and B, coercing them to fixnum if the sum is too big.\"))"
  (multiple-value-bind (body declarations documentation)
      (uiop:parse-body body :documentation t)
    (when (and (= 1 (length body))
               (stringp (first body)))
      (style-warn "Body of DEFINE-GENERIC contains a single string:
~s.
It's interpreted as a method body by default.

If you meant this string to be a generic docstring, and not a method
body, add an explicit NIL or some other body form:
(define-generic name (arg1 arg2)
  \"Docstring\"
  'body-form)

If you meant it as a body form, do nothing, or provide explicit
documentation or any other option:
(define-generic name (arg1 arg2)
  \"Docstring\"
  (:documentation \"Real docstring\"))" (first body)))
    (let* ((generic-declarations (remove-if (lambda (d)
                                              (or (> (length d) 2)
                                                  (not (eq 'optimize (first (second d))))
                                                  (notevery (lambda (o)
                                                              (let ((feature (first (uiop:ensure-list o))))
                                                                (or (eq feature 'speed)
                                                                    (eq feature 'space))))
                                                            (rest (second d)))))
                                            declarations))
           (options (remove-if-not (lambda (form)
                                     (keywordp (first (uiop:ensure-list form))))
                                   body))
           (method-body (remove-if (lambda (f) (member f options :test #'equal)) body))
           (export-generic-name-p (find :export-generic-name-p options :key #'first))
           (options (remove export-generic-name-p options :test #'equal))
           (export-p (if export-generic-name-p
                         (second export-generic-name-p)
                         *export-generic-name-p*))
           (generalized-arglist (generalize-arglist arglist)))
      (when (and (not (equal generalized-arglist arglist))
                 (every #'null (list method-body options)))
        (style-warn "Specialized arglist used without method body in define-generic: ~a" arglist))
      `(prog1
           (defgeneric ,name ,generalized-arglist
             ,@generic-declarations
             ,@(when (or method-body
                         (not (equal generic-declarations
                                     declarations)))
                 `((:method ,arglist
                     ,@declarations
                     ,@method-body)))
             ,@options
             ,@(when documentation
                 `((:documentation ,documentation))))
         ;; FIXME: Maybe only export if package of generic function name
         ;; matches *PACKAGE*?
         ,@(when export-p
             `((eval-when (:compile-toplevel :load-toplevel :execute)
                 (export ',name ,(package-name *package*)))))
         ,@(let ((documentation (or documentation
                                    (second (first (member :documentation options :key #'first))))))
             (when documentation
               `((setf (documentation ',name 'function) ,documentation)
                 (setf (documentation (fdefinition ',name) 'function) ,documentation))))))))

(prog1 (defgeneric generic (a b &key c) (declare (optimize (speed 1))) (:method (a b &key c) (declare (optimize (speed 1))) (+ a b c))))


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

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

Input:
(cond-<>
  nil
  :key
  nil)

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


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

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

Input: (is (plusp 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 ((#:v191 0)) (if (plusp #:v191) (add-result (quote test-passed) :test-expr (quote (plusp 0))) (process-failure (quote (plusp 0)) "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%" (quote 0) #:v191 (quote plusp))))


Instruction:
Generate a defmacro form that transforms code like this:
(lret* ((type `(integer ,start (,end))) (len (- end start)) (vector (make-array len :element-type type))) (nlet lp ((i 0) (n start)) (declare (type array-index i n)) (if (= i len) vector (progn (setf (aref vector i) n) (lp (1+ i) (1+ n))))))

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

Input: (lret* ((type `(integer ,start (,end))) (len (- end start)) (vector (make-array len :element-type type))) (nlet lp ((i 0) (n start)) (declare (type array-index i n)) (if (= i len) vector (progn (setf (aref vector i) n) (lp (1+ i) (1+ n))))))

Output:
(defmacro lret* ((&rest bindings) &body body)
  "Cf. `lret'."
  `(lret-aux let* ,bindings
     ,@body))

(lret-aux let* ((type (sb-int:quasiquote (integer #S(sb-impl::comma :expr start :kind 0) (#S(sb-impl::comma :expr end :kind 0))))) (len (- end start)) (vector (make-array len :element-type type))) (nlet lp ((i 0) (n start)) (declare (type array-index i n)) (if (= i len) vector (progn (setf (aref vector i) n) (lp (1+ i) (1+ n))))))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(letmatch nil
    :key
  nil)

Problem: Macro call that should be transformed by LETMATCH

Input:
(letmatch nil
    :key
  nil)

Output: (defmacro LETMATCH ...)

(ifmatch (nil :key nil (error "LETMATCH:  mismatch.")))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(match list ((list x) when (oddp x) x))

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

Input: (match list ((list x) when (oddp x) x))

Output:
(defmacro match (arg &body clauses)
  "Matches ARG with CLAUSES. CLAUSES is a list of the form of (PATTERN
. BODY) where PATTERN is a pattern specifier and BODY is an implicit
progn. If ARG matches some PATTERN, `match` then evaluates
the corresponding BODY and returns the evaluated value.  If no pattern matches,
then returns NIL.

Evaluating a form (FAIL) in the clause body causes the latest pattern
matching to fail. For example,

    (match 1
      (x (if (eql x 1)
             (fail)
             x))
      (_ 'ok))

returns OK, because the form (FAIL) in the first clause is
evaluated.

If BODY starts with the symbols WHEN or UNLESS, then the next form
will be used to introduce (FAIL). That is,

    (match list ((list x) when (oddp x) x))
    (match list ((list x) unless (evenp x) x))

will be translated to

    (match list ((list x) (if (oddp x) x (fail))))
    (match list ((list x) (if (evenp x) (fail) x)))

Examples:

    (match 1 (1 1))
    => 1
    (match 1 (2 2))
    => 2
    (match 1 (x x))
    => 1
    (match (list 1 2 3)
      (list x y z) (+ x y z))
    => 6"
  (compile-match-1 arg clauses nil))

(%or (%if (consp list) (let ((#:g140 (car list)) (#:g141 (cdr list))) (declare (ignorable #:g140 #:g141)) (%if (%equals #:g141 nil) (%or (let ((x #:g140)) (if (oddp x) x (fail))) (fail)) (fail))) (fail)) nil)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(defclass/std unknown () ((slot :unknown keywords :without-values)))

What needs to change: Macro call that should be transformed by defclass/std

Input: (defclass/std unknown () ((slot :unknown keywords :without-values)))

Output:
(defmacro defclass/std (name direct-superclasses direct-slots &rest options
                        &environment env)
  "Shortcut macro to the DEFCLASS macro.

  (defclass/std example ()
    ((slot1 slot2 slot3)))

  expands to:

  (DEFCLASS EXAMPLE ()
    ((SLOT1 :ACCESSOR SLOT1 :INITARG :SLOT1 :INITFORM NIL)
    (SLOT2 :ACCESSOR SLOT2 :INITARG :SLOT2 :INITFORM NIL)
    (SLOT3 :ACCESSOR SLOT3 :INITARG :SLOT3 :INITFORM NIL)))

  Each slot definition accepts options:

    :std 1 => changes the :initform to 1. It can be :unbound.
    :with or :with-prefix => creates accessors with the class name as prefix.

  See the README for more.

  See also `class/std' and `print-object/std'.
  "
  `(defclass ,name ,direct-superclasses
     ,(process-slots env direct-slots name)
     ,@options))

(defclass unknown nil ((slot :accessor slot :initarg :slot :initform nil :unknown keywords :without-values)))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(when (eql (top-sign) 'skip-first-funcall) (pop-sign))

Problem: Macro call that should be transformed by when

Input: (when (eql (top-sign) 'skip-first-funcall) (pop-sign))

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

(if (eql (top-sign) (quote skip-first-funcall)) (pop-sign))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(without-symbol-access
  nil
  (progn))

What needs to change: Macro call that should be transformed by WITHOUT-SYMBOL-ACCESS

Input:
(without-symbol-access
  nil
  (progn))

Output: (defmacro WITHOUT-SYMBOL-ACCESS ...)

(let ((*symbol-access* nil))
  nil
  (progn))


Instruction:
Define a macro that eliminates this repetitive pattern:
(defsynonym repeat :repeat)

Issue: Macro call that should be transformed by defsynonym

Input: (defsynonym repeat :repeat)

Output:
(defmacro defsynonym (symbol synonym)
  "Set SYNONYM for a SYMBOL. "
  `(eval-always
     (setf (get ',symbol 'synonym) ',synonym)))

(eval-always (setf (get (quote repeat) (quote synonym)) (quote :repeat)))


Instruction:
Generate a defmacro form that transforms code like this:
(defun-compile-time screamer-error (header &rest args) (apply #'error (concatenate 'string header "~2%There are eight types of nondeterministic contexts: 1. the body of a function defined with SCREAMER::DEFUN 2. the body of a FOR-EFFECTS macro invocation 3. the body of an ALL-VALUES macro invocation 4. the first argument of a ONE-VALUE macro invocation 5. the body of a PRINT-VALUES macro invocation 6. the second argument of an ITH-VALUE macro invocation 7. the body of a POSSIBLY? macro invocation 8. the body of a NECESSARILY? macro invocation. Note that the default forms of &OPTIONAL and &KEY arguments and the initialization forms of &AUX variables are always deterministic contexts even though they may appear inside a SCREAMER::DEFUN.") args))

Pattern to recognize: Macro call that should be transformed by defun-compile-time

Input: (defun-compile-time screamer-error (header &rest args) (apply #'error (concatenate 'string header "~2%There are eight types of nondeterministic contexts: 1. the body of a function defined with SCREAMER::DEFUN 2. the body of a FOR-EFFECTS macro invocation 3. the body of an ALL-VALUES macro invocation 4. the first argument of a ONE-VALUE macro invocation 5. the body of a PRINT-VALUES macro invocation 6. the second argument of an ITH-VALUE macro invocation 7. the body of a POSSIBLY? macro invocation 8. the body of a NECESSARILY? macro invocation. Note that the default forms of &OPTIONAL and &KEY arguments and the initialization forms of &AUX variables are always deterministic contexts even though they may appear inside a SCREAMER::DEFUN.") args))

Output:
(defmacro defun-compile-time (function-name lambda-list &body body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (cl:defun ,function-name ,lambda-list ,@body)
     (eval-when (:compile-toplevel) (compile ',function-name))))

(eval-when (:compile-toplevel :load-toplevel :execute) (common-lisp:defun screamer-error (header &rest args) (apply (function error) (concatenate (quote string) header "~2%There are eight types of nondeterministic contexts: 1. the body of a function defined with SCREAMER::DEFUN 2. the body of a FOR-EFFECTS macro invocation 3. the body of an ALL-VALUES macro invocation 4. the first argument of a ONE-VALUE macro invocation 5. the body of a PRINT-VALUES macro invocation 6. the second argument of an ITH-VALUE macro invocation 7. the body of a POSSIBLY? macro invocation 8. the body of a NECESSARILY? macro invocation. Note that the default forms of &OPTIONAL and &KEY arguments and the initialization forms of &AUX variables are always deterministic contexts even though they may appear inside a SCREAMER::DEFUN.") args)) (eval-when (:compile-toplevel) (compile (quote screamer-error))))


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

Pattern to recognize: Macro call that should be transformed by DYNAMIC-PROGV

Input:
(dynamic-progv nil
    (progn))

Output: (defmacro DYNAMIC-PROGV ...)

(let* ((#:fixed-symbols238 nil)
       (#:fixed-bindings239 (compute-bindings #:fixed-symbols238 (progn))))
  (dynamic-wind
    :proceed
    #:proceed240
    (progv #:fixed-symbols238 #:fixed-bindings239 (#:proceed240))))


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

Problem: Macro call that should be transformed by ->*

Input: (->* nil nil)

Output: (defmacro ->* ...)


Instruction:
Write a Common Lisp macro to handle this code pattern:
(receive () (values 1))

Problem: Macro call that should be transformed by receive

Input: (receive () (values 1))

Output:
(defmacro receive (formals expr &body body)
  "Stricter version of `multiple-value-bind'.

Use `receive' when you want to enforce that EXPR should return a
certain number of values, or a minimum number of values.

If FORMALS is a proper list, then EXPR must return exactly as many
values -- no more and no less -- as there are variables in FORMALS.

If FORMALS is an improper list (VARS . REST), then EXPR must return at
least as many values as there are VARS, and any further values are
bound, as a list, to REST.

Lastly, if FORMALS is a symbol, bind that symbol to all the values
returned by EXPR, as if by `multiple-value-list'.

From Scheme (SRFI-8)."
  ;; It's probably not worth stack-allocating the thunk.
  (cond ((null formals)
         `(multiple-value-call
              (lambda ()
                ,@body)
            ,expr))
        ((atom formals)
         ;; This could also be written:
         #+(or) `(let ((,formals (multiple-value-list ,expr)))
                   ,@body)
         ;; But I want it to be possible to declare FORMALS to have
         ;; dynamic extent, and most Lisps support that for &rest
         ;; lists.
         `(multiple-value-call
              (lambda (&rest ,formals)
                ,@body)
            ,expr))
        ((proper-list-p formals)
         (when (intersection formals lambda-list-keywords)
           (error "Lambda list keywords in formals: ~a" formals))
         `(multiple-value-call
              (lambda ,formals
                ,@body)
            ,expr))
        (t (let* ((last (last formals))
                  (vars (append (butlast formals)
                                (list (car last))))
                  (rest (cdr last)))
             (when (intersection (cons rest vars) lambda-list-keywords)
               (error "Lambda list keywords in formals: ~a" formals))
             `(multiple-value-call
                  (lambda (,@vars &rest ,rest)
                    ,@body)
                ,expr)))))

(multiple-value-call (lambda nil) (values 1))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(-> :g () (put 1) 2)

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

Input: (-> :g () (put 1) 2)

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


Instruction:
Write a Common Lisp macro to handle this code pattern:
(destructuring-methods nil
    nil)

Problem: Macro call that should be transformed by DESTRUCTURING-METHODS

Input:
(destructuring-methods nil
    nil)

Output: (defmacro DESTRUCTURING-METHODS ...)

(let ((#:g131 nil))
  (typecase #:g131 ((not list) nil)))


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

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

Input: (some-<> 'some-name)

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


Instruction:
Write a Common Lisp macro to handle this code pattern:
(defhandler function (function name) `(list ',function ,(if (function-name-p name) `',name (e name))))

Problem: Macro call that should be transformed by defhandler

Input: (defhandler function (function name) `(list ',function ,(if (function-name-p name) `',name (e name))))

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-function (function name) (sb-int:quasiquote (list (quote #S(sb-impl::comma :expr function :kind 0)) #S(sb-impl::comma :expr (if (function-name-p name) (sb-int:quasiquote (quote #S(sb-impl::comma :expr name :kind 0))) (e name)) :kind 0)))) (setf (gethash (quote function) *form-handler*) (quote hander-function)))


Instruction:
Generate a defmacro form that transforms code like this:
(def-iter iterator-zip (iterator-vec n) (zip-from-itl (itl-of-itls) (let* ((itl-of-itls (iter-to-vec itl-of-itls)) (n (length itl-of-itls))) (loop for i below n do (setf (aref itl-of-itls i) (make-iterator (aref itl-of-itls i)))) (if (zerop n) (empty-iterator) (init-state (iterator-vec itl-of-itls) n)))) (loop with alive = t for i below n with ret-vec = (make-array n) while alive do (multiple-value-bind (iter-item iter-alive) (next (aref iterator-vec i)) (setf alive iter-alive) (setf (aref ret-vec i) iter-item)) finally (return (if alive (values ret-vec t) (values nil nil)))))

Pattern to recognize: Macro call that should be transformed by def-iter

Input: (def-iter iterator-zip (iterator-vec n) (zip-from-itl (itl-of-itls) (let* ((itl-of-itls (iter-to-vec itl-of-itls)) (n (length itl-of-itls))) (loop for i below n do (setf (aref itl-of-itls i) (make-iterator (aref itl-of-itls i)))) (if (zerop n) (empty-iterator) (init-state (iterator-vec itl-of-itls) n)))) (loop with alive = t for i below n with ret-vec = (make-array n) while alive do (multiple-value-bind (iter-item iter-alive) (next (aref iterator-vec i)) (setf alive iter-alive) (setf (aref ret-vec i) iter-item)) finally (return (if alive (values ret-vec t) (values nil nil)))))

Output:
(defmacro def-iter (name state-vars (constructor-name constructor-params &body constructor-body)
                    &body next-body)
  "An anaphoric convenience macro which can be re-implemented to change how iterators are
  structured. Exposes the local `init-state` macro within `constructor-body`

  If you don't want to-use this macro (which I totally understand) just write constructors for your
  iterators returning 0-argument closures representing the `next` function and you'll be fine. This
  macro just helped me get through a lot of waffling during development

  Parameters
  ----------
  `name` is a synbol naming the iterator's backing state. However it's actually
  ignored, since PICL doesn't currently expose iterators' backing state

  `state-vars` is a list of symbols naming the iterator's state variables.

  The `constructor-name/params/body` will be `defun`'d to create the user-facing constructor
  function. In `constructor-body`, the return value should be an iterator or a call to local
  `init-state` macro

  `next-body` The definition of the `next` function for this iterator, which will be run in a
   lexical environment consisting of the state vars

  Both `constructor-body` and `next-body` are defined in the lexical environment of the `def-iter`
  form, and as such can access any lexical bindings not shadowed by the `constructor-params` and
  `state-vars` respectively

  The local `init-state` macro.
  ----------------------------
  The arguments to `init-state` should be of the form `(statevar-symbol value-form)`or
  `statevar-symbol`. In the first case, the value of `value-form` will be used to initialize the
  state variable named by `symbol`. In the second case, `statevar-symbol` is also used as the
  corresponding `value-form`

  Example
  -------
  What follows is a sample implementation of the `count` iterator using this macro
  ```
  (def-iter ignored-backing-name (curr-val step)
    (count (start step)
      (init-state (curr-val start) step))
    (prog1 curr-val (incf curr-val step))))
  ````"

  (declare (ignore name))
  (alexandria:with-gensyms (next-fname)
    (let ((docstring "Function had no docstring, so this one was inserted"))
      (when (and (cdr constructor-body) (stringp (car constructor-body)))
        (setf docstring (car constructor-body)
              constructor-body (cdr constructor-body)))
      `(labels ((,next-fname (&key ,@state-vars)
                  (labels ((self () ,@next-body)) #'self)))
         (defun ,constructor-name ,constructor-params
           ,docstring
           (macrolet
               ((init-state (&rest argspecs)
                  (list 'apply '#',next-fname
                        (apply #'append
                               '(list )
                               (mapcar (lambda (aspec)
                                         (if (symbolp aspec)
                                             (list (alx:make-keyword aspec) aspec)
                                             (destructuring-bind (aname adef) aspec
                                               (list (alx:make-keyword aname) adef))))
                                       argspecs)))))
             ,@constructor-body))))))

(labels ((#:next-fname136 (&key iterator-vec n) (labels ((self nil (loop with alive = t for i below n with ret-vec = (make-array n) while alive do (multiple-value-bind (iter-item iter-alive) (next (aref iterator-vec i)) (setf alive iter-alive) (setf (aref ret-vec i) iter-item)) finally (return (if alive (values ret-vec t) (values nil nil)))))) (function self)))) (defun zip-from-itl (itl-of-itls) "Function had no docstring, so this one was inserted" (macrolet ((init-state (&rest argspecs) (list (quote apply) (quote (function #:next-fname136)) (apply (function append) (quote (list)) (mapcar (lambda (aspec) (if (symbolp aspec) (list (alx:make-keyword aspec) aspec) (destructuring-bind (aname adef) aspec (list (alx:make-keyword aname) adef)))) argspecs))))) (let* ((itl-of-itls (iter-to-vec itl-of-itls)) (n (length itl-of-itls))) (loop for i below n do (setf (aref itl-of-itls i) (make-iterator (aref itl-of-itls i)))) (if (zerop n) (empty-iterator) (init-state (iterator-vec itl-of-itls) n))))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(with-active-layers nil
  :key
  nil)

Write a macro that addresses: Macro call that should be transformed by WITH-ACTIVE-LAYERS

Input:
(with-active-layers nil
  :key
  nil)

Output: (defmacro WITH-ACTIVE-LAYERS ...)


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(define-element-maker :linear-gradient "linearGradient" '(:id :x1 :y1 :x2 :y2))

Write a macro that addresses: Macro call that should be transformed by define-element-maker

Input: (define-element-maker :linear-gradient "linearGradient" '(:id :x1 :y1 :x2 :y2))

Output:
(defmacro define-element-maker (element name required-attributes)
  `(progn
     (defmethod assert-required-attributes ((element (eql ,element)) attributes)
       (declare (ignore element))
       (unless (evenp (length attributes))
         (warn "attribute list may be missing data: ~A" attributes))
       (let ((missing (set-difference ,required-attributes attributes)))
	 (when missing
	   (error 'missing-attributes :message (format nil "~A missing attributes: ~{~A~^ ~}" ,element missing)))))
     (defmethod make-svg-element ((element (eql ,element)) attributes)
       (when *check-required-attributes*
         (assert-required-attributes element attributes))
       (make-instance 'svg-element :name ,name :attributes attributes))))

(progn (defmethod assert-required-attributes ((element (eql :linear-gradient)) attributes) (declare (ignore element)) (unless (evenp (length attributes)) (warn "attribute list may be missing data: ~A" attributes)) (let ((missing (set-difference (quote (:id :x1 :y1 :x2 :y2)) attributes))) (when missing (error (quote missing-attributes) :message (format nil "~A missing attributes: ~{~A~^ ~}" :linear-gradient missing))))) (defmethod make-svg-element ((element (eql :linear-gradient)) attributes) (when *check-required-attributes* (assert-required-attributes element attributes)) (make-instance (quote svg-element) :name "linearGradient" :attributes attributes)))


Instruction:
Generate a defmacro form that transforms code like this:
(enable-string-quote-syntax)

Pattern to recognize: Macro call that should be transformed by ENABLE-STRING-QUOTE-SYNTAX

Input: (enable-string-quote-syntax)

Output: (defmacro ENABLE-STRING-QUOTE-SYNTAX ...)

(eval-when (:compile-toplevel :execute)
  (setf *readtable* (copy-readtable *readtable*))
  (set-string-quote-syntax-in-readtable :start-character
                                        #\HALFWIDTH_LEFT_CORNER_BRACKET
                                        :end-character
                                        #\HALFWIDTH_RIGHT_CORNER_BRACKET
                                        :transformer #'identity)
  (values))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(deferror "XX" internal-error)

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

Input: (deferror "XX" internal-error)

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

(progn (define-condition internal-error (database-error) nil) (setf (gethash "XX" *error-table*) (quote internal-error)))


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

Problem: Macro call that should be transformed by DRELET*

Input:
(drelet* nil
  nil)

Output: (defmacro DRELET* ...)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(-<>> (diamond-wand init (cddr exp) t))

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

Input: (-<>> (diamond-wand init (cddr exp) t))

Output: (defmacro -<> (init &body exps) (diamond-wand init exps))


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

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

Input:
(f_n
  'some-name)

Output: (defmacro F_N ...)


Instruction:
Define a macro that eliminates this repetitive pattern:
(is-error (error "Raising an error") 'simple-error)

Issue: Macro call that should be transformed by is

Input: (is-error (error "Raising an error") 'simple-error)

Output:
(defmacro is (got expected &rest args)
  (with-gensyms (duration result new-args desc)
    (once-only (expected)
      `(let* ((,new-args (list ,@args))
              (,desc (parse-description-and-test ,new-args)))
         (with-catching-errors (:description ,desc :expected ,expected)
           (with-duration ((,duration ,result) ,got)
             (test ,result ,expected ,new-args
                   :duration ,duration)))))))

(with-duration ((#:duration182 #:error181) (handler-case (error "Raising an error") (condition (#:error181) #:error181))) (test #:error181 (quote simple-error) nil :duration #:duration182 :got-form (quote (error "Raising an error")) :test-fn (function typep) :report-expected-label "raise a condition"))


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-temp (input-file :tmpdir d :template "XXXXXX.prolog" :debug (<= 1 *debug-prolog*)) (with-open-file (s input-file :direction :output :if-does-not-exist :error) (dolist (r rules) (print-rule s r))) (run-command-with-debug-print `(,*yap* "-l" ,input-file ,@args) :input input :output output :error error))

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

Input: (with-temp (input-file :tmpdir d :template "XXXXXX.prolog" :debug (<= 1 *debug-prolog*)) (with-open-file (s input-file :direction :output :if-does-not-exist :error) (dolist (r rules) (print-rule s r))) (run-command-with-debug-print `(,*yap* "-l" ,input-file ,@args) :input input :output output :error error))

Output:
(defmacro with-temp ((var &key directory template (tmpdir "/tmp/") debug) &body body)
  "Create a temporary file, then remove the file by unwind-protect.
Most arguments are analogous to mktemp.
When DIRECTORY is non-nil, creates a directory instead.
DEBUG is a form.
When evaluated to non-nil, it does not remove the directory so that you can investigate what happened inside the directory.
It may be evaluated multiple times."
  (with-gensyms (command)
    `(let ((,var (uiop:run-program
                  (let ((,command (format nil "mktemp --tmpdir='~a' ~@[-d~*~] ~@[~a~]"
                                          ,tmpdir ,directory ,template)))
                    (when ,debug
                      (format *error-output* "~&; ~a~%" ,command))
                    ,command)
                  :output '(:string :stripped t))))
       (unwind-protect
            (progn ,@body)
         (if ,debug
             (format *error-output* "~&; not removing ~a for debugging~%" ,var)
             (uiop:run-program (format nil "rm -rf ~a" (namestring ,var)) :ignore-error-status t))))))

(let ((input-file (uiop/run-program:run-program (let ((#:command180 (format nil "mktemp --tmpdir='~a' ~@[-d~*~] ~@[~a~]" d nil "XXXXXX.prolog"))) (when (<= 1 *debug-prolog*) (format *error-output* "~&; ~a~%" #:command180)) #:command180) :output (quote (:string :stripped t))))) (unwind-protect (progn (with-open-file (s input-file :direction :output :if-does-not-exist :error) (dolist (r rules) (print-rule s r))) (run-command-with-debug-print (sb-int:quasiquote (#S(sb-impl::comma :expr *yap* :kind 0) "-l" #S(sb-impl::comma :expr input-file :kind 0) #S(sb-impl::comma :expr args :kind 2))) :input input :output output :error error)) (if (<= 1 *debug-prolog*) (format *error-output* "~&; not removing ~a for debugging~%" input-file) (uiop/run-program:run-program (format nil "rm -rf ~a" (namestring input-file)) :ignore-error-status t))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-lock (lru-pool-lock pool) (get-from-lru-pool pool host-port))

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

Input: (with-lock (lru-pool-lock pool) (get-from-lru-pool pool host-port))

Output:
(defmacro with-lock (lock &body body)
  (declare (ignorable lock))
  #+thread-support `(bt2:with-lock-held (,lock)
                      ,@body)
  #-thread-support `(progn ,@body))

(bt2:with-lock-held ((lru-pool-lock pool)) (get-from-lru-pool pool host-port))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(with-ps-gensyms nil)

What needs to change: Macro call that should be transformed by WITH-PS-GENSYMS

Input: (with-ps-gensyms nil)

Output: (defmacro WITH-PS-GENSYMS ...)


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(aetypecase 1.0 (fixnum (* 2 it)) (float (+ 2.0 it)) (symbol :oops))

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

Input: (aetypecase 1.0 (fixnum (* 2 it)) (float (+ 2.0 it)) (symbol :oops))

Output:
(defmacro aetypecase (keyform &body cases)
  "Like ETYPECASE, except binds the result of the keyform to IT (via LET) for
the scope of the cases."
  `(anaphoric etypecase ,keyform ,@cases))

(anaphoric etypecase 1.0 (fixnum (* 2 it)) (float (+ 2.0 it)) (symbol :oops))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(defun-compile-time walk-lambda-list-reducing (map-function reduce-function screamer? partial? nested? lambda-list environment &optional mode) (cond ((null lambda-list) (funcall reduce-function)) ((member (first lambda-list) *ordered-lambda-list-keywords* :test #'eq) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment (first lambda-list))) (t (ecase mode ((nil &rest &allow-other-keys &aux) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) ((&optional &key) (if (and (consp (first lambda-list)) (consp (rest (first lambda-list)))) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second (first lambda-list)) environment) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)))))))

Write a macro that addresses: Macro call that should be transformed by defun-compile-time

Input: (defun-compile-time walk-lambda-list-reducing (map-function reduce-function screamer? partial? nested? lambda-list environment &optional mode) (cond ((null lambda-list) (funcall reduce-function)) ((member (first lambda-list) *ordered-lambda-list-keywords* :test #'eq) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment (first lambda-list))) (t (ecase mode ((nil &rest &allow-other-keys &aux) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) ((&optional &key) (if (and (consp (first lambda-list)) (consp (rest (first lambda-list)))) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second (first lambda-list)) environment) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)))))))

Output:
(defmacro defun-compile-time (function-name lambda-list &body body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (cl:defun ,function-name ,lambda-list ,@body)
     (eval-when (:compile-toplevel) (compile ',function-name))))

(eval-when (:compile-toplevel :load-toplevel :execute) (common-lisp:defun walk-lambda-list-reducing (map-function reduce-function screamer? partial? nested? lambda-list environment &optional mode) (cond ((null lambda-list) (funcall reduce-function)) ((member (first lambda-list) *ordered-lambda-list-keywords* :test (function eq)) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment (first lambda-list))) (t (ecase mode ((nil &rest &allow-other-keys &aux) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) ((&optional &key) (if (and (consp (first lambda-list)) (consp (rest (first lambda-list)))) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second (first lambda-list)) environment) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode))))))) (eval-when (:compile-toplevel) (compile (quote walk-lambda-list-reducing))))


Instruction:
Generate a defmacro form that transforms code like this:
(defsynonym sum :sum)

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

Input: (defsynonym sum :sum)

Output:
(defmacro defsynonym (symbol synonym)
  "Set SYNONYM for a SYMBOL. "
  `(eval-always
     (setf (get ',symbol 'synonym) ',synonym)))

(eval-always (setf (get (quote sum) (quote synonym)) (quote :sum)))


Instruction:
Define a macro that eliminates this repetitive pattern:
(with-special-initargs nil
  (progn))

Issue: Macro call that should be transformed by WITH-SPECIAL-INITARGS

Input:
(with-special-initargs nil
  (progn))

Output: (defmacro WITH-SPECIAL-INITARGS ...)

(funcall-with-special-initargs (list) (lambda () (progn)))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(with-html-string (:div (:p "Text " (:a "link text") " more text")))

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

Input: (with-html-string (:div (:p "Text " (:a "link text") " more text")))

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 (:div (:p "Text " (:a "link text") " more text"))))


Instruction:
Generate a defmacro form that transforms code like this:
(ematch0 patterns ((list) nil) ((list* first rest) (let ((first* (correct-pattern (pattern-expand-all/lift first)))) (cons first* (let ((*lexvars* (variables first*))) (expand-multipatterns rest))))))

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

Input: (ematch0 patterns ((list) nil) ((list* first rest) (let ((first* (correct-pattern (pattern-expand-all/lift first)))) (cons first* (let ((*lexvars* (variables first*))) (expand-multipatterns rest))))))

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

(match0 patterns ((list) nil) ((list* first rest) (let ((first* (correct-pattern (pattern-expand-all/lift first)))) (cons first* (let ((*lexvars* (variables first*))) (expand-multipatterns rest))))) (_ (error "level0 match error!")))


Instruction:
Generate a defmacro form that transforms code like this:
(define-class some-class (some super classes) ((slot1 42 :documentation "zork") (slot2 :unbound :accessor slot2-custom) (slot3 :unbound :accessor nil :export :accessor)) (:export-accessor-names-p t) (:export-class-name-p t) (:export-slot-names-p t))

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

Input: (define-class some-class (some super classes) ((slot1 42 :documentation "zork") (slot2 :unbound :accessor slot2-custom) (slot3 :unbound :accessor nil :export :accessor)) (:export-accessor-names-p t) (:export-class-name-p t) (:export-slot-names-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 some-class (some super classes) ((slot1 :initform 42 :accessor slot1 :initarg :slot1 :documentation "zork") (slot2 :accessor slot2-custom :initarg :slot2) (slot3 :initarg :slot3))) (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)))) (eval-when (:compile-toplevel :load-toplevel :execute) (export (quote (some-class slot2 slot2-custom slot1 slot1)) #A((8) base-char . "NCLASSES"))) (setf (documentation (quote slot2-custom) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot SLOT2.")) (ignore-errors (setf (documentation (fdefinition (quote slot2-custom)) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot SLOT2."))) (ignore-errors (setf (documentation (fdefinition (quote (setf slot2-custom))) (quote function)) #A((48) base-char . "Auto-generated accessor function for slot SLOT2."))) (setf (documentation (quote slot1) (quote function)) #A((53) base-char . "Auto-generated accessor function for slot SLOT1.
zork")) (ignore-errors (setf (documentation (fdefinition (quote slot1)) (quote function)) #A((53) base-char . "Auto-generated accessor function for slot SLOT1.
zork"))) (ignore-errors (setf (documentation (fdefinition (quote (setf slot1))) (quote function)) #A((53) base-char . "Auto-generated accessor function for slot SLOT1.
zork"))) (find-class (quote some-class) nil))


Instruction:
Create a Common Lisp macro for the following transformation. Before code:
(is something 'a 'a)

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

Input: (is something 'a 'a)

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

(eval-in-context *context* (make-instance (quote comparison-result) :expression (quote (is something (quote a) (quote a))) :value-form (quote (quote a)) :body (lambda nil (quote a)) :expected (quote a) :comparison (quote something)))


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

Write a macro that addresses: Macro call that should be transformed by DEFINE-ALIAS

Input:
(define-alias nil
    nil)

Output: (defmacro DEFINE-ALIAS ...)

(progn
 (macrolet ((thunk ()
              (let ())))
   (defun nil () nil (thunk)))
 (define-compiler-macro nil
     nil
   nil
   `(let ,(list)
      ,(let ()))))


Instruction:
You are a Common Lisp macro expert. Given this code pattern:
(yield-for-union-ops "UNION ALL")

Write a macro that addresses: Macro call that should be transformed by yield-for-union-ops

Input: (yield-for-union-ops "UNION ALL")

Output:
(defmacro yield-for-union-ops (keyword)
  `(multiple-value-bind (statements others)
      (loop for obj in (conjunctive-op-expressions op)
            if (sql-statement-p obj)
              collecting obj into statements
            else
              collecting obj into others
            finally (return (values statements others)))
     (with-yield-binds
       (format nil (if *inside-select*
                       "(~{~A~^ ~})"
                       "~{~A~^ ~}")
               (append (list (format nil ,(format nil "~~{~~A~~^ ~a ~~}" keyword)
                                     (mapcar #'yield statements)))
                       (when others
                         (list (format nil "~{~A~^ ~}"
                                       (mapcar #'yield others)))))))))

(multiple-value-bind (statements others) (loop for obj in (conjunctive-op-expressions op) if (sql-statement-p obj) collecting obj into statements else collecting obj into others finally (return (values statements others))) (with-yield-binds (format nil (if *inside-select* "(~{~A~^ ~})" "~{~A~^ ~}") (append (list (format nil #A((19) base-char . "~{~A~^ UNION ALL ~}") (mapcar (function yield) statements))) (when others (list (format nil "~{~A~^ ~}" (mapcar (function yield) others))))))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(*> (string "Mālum") #'eof)

Issue: Macro call that should be transformed by *>

Input: (*> (string "Mālum") #'eof)

Output:
(defmacro *> (parser &rest parsers)
  "Combination of parsers yielding the result of the rightmost one."
  (let ((offset (gensym "*>-OFFSET")))
    `(lambda (,offset)
       ,(reduce (lambda (i p)
                  (let ((res  (gensym "*>-RES"))
                        (next (gensym "*>-NEXT")))
                    `(multiple-value-bind (,res ,next) ,i
                       (if (ok? ,res)
                           (funcall ,p ,next)
                           (fail ,next)))))
                parsers
                :initial-value `(funcall ,parser ,offset)))))

(lambda (#:*>-offset200) (multiple-value-bind (#:*>-res201 #:*>-next202) (funcall (string "Mālum") #:*>-offset200) (if (ok? #:*>-res201) (funcall (function eof) #:*>-next202) (fail #:*>-next202))))


Instruction:
Define a macro that eliminates this repetitive pattern:
(signals error (error "an error"))

Issue: Macro call that should be transformed by signals

Input: (signals error (error "an error"))

Output:
(defmacro signals (condition-spec
                   &body body)
  "Generates a pass if BODY signals a condition of type
CONDITION. BODY is evaluated in a block named NIL, CONDITION is
not evaluated."
  (let ((block-name (gensym)))
    (destructuring-bind (condition &optional reason-control &rest reason-args)
        (ensure-list condition-spec)
      `(block ,block-name
         (handler-bind ((,condition (lambda (c)
                                      (declare (ignore c))
                                      ;; ok, body threw condition
                                      (add-result 'test-passed
                                                  :test-expr ',condition)
                                      (return-from ,block-name t))))
           (block nil
             ,@body))
         (process-failure
           ',condition
           ,@(if reason-control
                 `(,reason-control ,@reason-args)
                 `("Failed to signal a ~S" ',condition)))
         (return-from ,block-name nil)))))

(block #:g285 (handler-bind ((error (lambda (c) (declare (ignore c)) (add-result (quote test-passed) :test-expr (quote error)) (return-from #:g285 t)))) (block nil (error "an error"))) (process-failure (quote error) "Failed to signal a ~S" (quote error)) (return-from #:g285 nil))


Instruction:
Generate a defmacro form that transforms code like this:
(define-error cannot-not-shadow-core () () "You cannot shadow or replace core macros or special functions.")

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

Input: (define-error cannot-not-shadow-core () () "You cannot shadow or replace core macros or special functions.")

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 cannot-not-shadow-core (:error-type varjo-error :prefix "Varjo") nil "You cannot shadow or replace core macros or special functions.")


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

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

Input: (with-form-field-values (name) form (print name))

Output:
(defmacro with-form-field-values (fields form &body body)
  "Bind the value of FIELDS in FORM.

Example:

@lisp
(with-form-field-values (name) form
   (print name))
@end lisp"
  `(let ,(loop for field in fields
               collect `(,field (field-value (get-field ,form ',field))))
     ,@body))

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


Instruction:
Generate a defmacro form that transforms code like this:
(is (= 1 b))

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

Input: (is (= 1 b))

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 ((#:e268 1) (#:a269 b)) (if (progn (= #:e268 #:a269)) (add-result (quote test-passed) :test-expr (quote (= 1 b))) (process-failure (quote (= 1 b)) "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%" (quote b) #:a269 (quote =) #:e268)))


Instruction:
Write a Common Lisp macro to handle this code pattern:
(c-assert (null (c-callers old)))

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

Input: (c-assert (null (c-callers old)))

Output:
(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
  (declare (ignorable assertion places fmt$ fmt-args))
   #+(or)`(progn)
  `(unless *stop*
     (unless ,assertion
       ,(if fmt$
            `(c-break ,fmt$ ,@fmt-args)
          `(c-break "failed assertion: ~a" ',assertion)))))

(unless *stop* (unless (null (c-callers old)) (c-break "failed assertion: ~a" (quote (null (c-callers old))))))