Сгенерировать TYPECASE с помощью макроса в Common Lisp

Question

У меня есть список из двух подсписок элементов, которые будут изменяться и увеличиваться в процессе работы программы. Я хочу написать макрос, который принимает ключ и генерируетcase динамически как:

;; This is the List for saving CASE clauses
(setf l '((number 2) (symbol 3)))

;; and i want to have the following expansion
(typecase 'y
  (number 2)
  (symbol 3)) 

Я мог бы иметь макрос, который относится только к глобальному l:

(defmacro m (x)
  `(typecase ,x ,@l))

который будет правильно расширяться

(m 'y)  ;expands to (TYPECASE 'Y (number 2) (symbol 3))

Но как мне написать макрос с параметром для списка l чтобы он работал и с другими списками?

;; A macro which should generate the case based on the above list
(defmacro m (x l)
  `(typecase ,x ,@l))

Это не работает, так как l в списке аргументов ia символ и вызов (m 'y l) расширится до (TYPECASE 'Y . L).

Желая придерживаться typecase Механизм мой обходной путь был следующим:

(setf types-x '(((integer 0 *) 38)
                ((eql neli) "Neli in X")
                (symbol 39))
            )
(setf types-y '(((eql neli) "Neli in Y")
                ((array bit *) "A Bit Vector")))

(defmacro m (x types-id)
  (case types-id
    (:x `(typecase ,x ,@types-x))
    (:y `(etypecase ,x ,@types-y))))

(m 'neli :x)                ;"Neli in X"
(m 'neli :y)                ;"Neli in Y"
(m 'foo :x)             ;39

Любые подсказки и комментарии приветствуются.

Answer 1

Вам не нужен макрос для того, что вы пытаетесь сделать: используйте функцию.

Например, учитывая

(defvar *type-matches*
  '((float 0)
    (number 1)
    (t 3)))

затем

(defun type-match (thing &optional (against *type-matches*))
  (loop for (type val) in against
        when (typep thing type)
        return (values val type)
        finally (return (values nil nil))))

Сопоставит вещь с типом:

> (type-match 1.0)
0
float

> (type-match 1)
1
number

Вы хотите, чтобы переменные были отсортированы по типу, что вы можете сделать, например:

(setf *type-matches* (sort *type-matches* #'subtypep :key #'car))

Вы, конечно, хотите, чтобы совпадения были отсортированы.

Если вы хотите отложить выполнение форм, вы можете сделать что-то вроде этого (это также касается сортировки типов):

(defvar *type-matches*
  '())

(defmacro define-type-match (type/spec &body forms)
  ;; define a type match, optionally in a specified list
  (multiple-value-bind (type var)
      (etypecase type/spec
        (symbol (values type/spec '*type-matches*))
        (cons (values (first type/spec) (second type/spec))))
    (let ((foundn (gensym "FOUND")))
      `(let ((,foundn (assoc ',type ,var :test #'equal)))
         (if ,foundn
             (setf (cdr ,foundn) (lambda () ,@forms))
           (setf ,var (sort (acons ',type (lambda () ,@forms) ,var)
                            #'subtypep :key #'car)))
         ',type/spec))))

(defun type-match (thing &optional (against *type-matches*))
  (loop for (type . f) in against
        when (typep thing type)
        return (values (funcall f) type)
        finally (return (values nil nil))))

Answer 2

Настоящая проблема, с которой вы сталкиваетесь, заключается в том, что если вы

(setf l '((number 2) (symbol 3)))

уже на верхнем уровне, если вы оцените l, ты не заходишь дальше, чем

((number 2) (symbol 3))

Итак, если вы используете lв макросе в качестве аргумента вы не можете пойти дальше этого. Но вам нужно оценить эту форму (измененную после добавленияtypecase и оцененный x upfront) еще раз в макросе.

Вот почему @tfb предложил написать функцию, которая фактически оценивает соответствие типов, указанных в l. Итак, мы могли рассматривать егоtype-match функционировать как мини-интерпретатор для спецификаций типов, указанных в l.

Если вы сделаете простой (defmacro m (x l) `(typecase ,x ,@l))вы сталкиваетесь именно с этой проблемой:

(macroexpand-1 '(m 1 l)) 
;; (typecase 1 . l)

но нам нужно это l еще раз оценили.

(defmacro m (x l)
  `(typecase ,x ,@(eval l)))

Что даст желаемый результат:

(macroexpand-1 '(m 1 l))
;; (TYPECASE 1 (NUMBER 2) (SYMBOL 3)) ;
;; T

;; and thus:
(m 1 l) ;; 2

Пока вроде работает. Но где-то в затылке начинает чесаться, потому что мы знаем из книг и сообщества: "Не используйтеeval!! Eval в коде evil!"

Попробовав, вы очень скоро узнаете, когда он вас укусит:

# try this in a new session:

(defmacro m (x l) `(typecase ,x ,@(eval l)))
;; m

;; define `l` after definition of the macro works:
(setf l '((number 2) (symbol 3)))
;; ((NUMBER 2) (SYMBOL 3))

(m 1 l)
;; 2  ;; so our `eval` can handle definitions of `l` after macro was stated

(m '(1 2) l)
;; NIL

;; even redefining `l` works!
(setf l '((number 2) (symbol 3) (list 4)))
;; ((NUMBER 2) (SYMBOL 3) (LIST 4))

(m 1 l)
;; 2

(m '(1 2) l)
;; 4 ;; and it can handle re-definitions of `l` correctly.

;; however:
(let ((l '((number 2) (symbol 3)))) (m '(1 2) l))
;; 4 !!! this is clearly wrong! Expected is NIL!
;; so our `eval` in the macro cannot handle scoping correctly
;; which is a no-go for usage!

;; but after re-defining `l` globally to:
(setf l '((number 2) (symbol 3)))
;; ((NUMBER 2) (SYMBOL 3))

(m '(1 2) l)
;; NIL ;; it behaves correctly

(let ((lst '((number 2) (symbol 3) (list 4)))) (m '(1 2) lst))

;; *** - EVAL: variable LST has no value
;; so it becomes clear: `m` is looking in the scoping
;; where it was defined - the global scope (the parent scope of `m` when `m` was defined or within the scope of `m`).

Итак, вывод такой:

Данный макрос с evalНЕ работает правильно!! Поскольку он не может обрабатывать локальную область видимости.

Итак, ответ @tfb - написание мини-функции-оценщика для l это, вероятно, единственный способ справиться с этим правильным, безопасным и правильным способом.

Answer 3

Расширение макроса происходит во время компиляции, а не во время выполнения, поэтому, если список предложений case изменяется в ходе программы, раскрытие макроса не изменится, чтобы отразить это. Если вы хотите динамически выбирать неоцененное, но изменяемое значение, вы можете использоватьassoc в расширении вместо case:

(defmacro m (x l)
  `(second (assoc ,x ,l)))

Расширение образца:

(m x l)
->
(SECOND (ASSOC X L))

Выход (assoc x l) со значением l в вашем вопросе и x знак равно 'x:

(let ((x 'x))
  (m x l))
->
2

Однако, если вы все же решили сделать это таким образом, вы можете упростить ситуацию и заменить макрос функцией:

(defun m (x l)
  (second (assoc x l)))

ОБНОВЛЕНИЕ ДЛЯ РЕДАКТИРОВАНИЯ ВОПРОСА:

Замените assoc следующим образом:

(defun m (x l)
  (second (assoc-if (lambda (type)
                     (typep x type))
                    l)))