Lisp Enum Macro, Common Lisp

Lisp Enum Macro

Language: Layout:

(defmacro defenum (name-and-members &body body)
  (let ((enumname (car name-and-members))
        (members (cdr name-and-members)))
  `(progn
    ,@(concatenate 'list
       (loop for itemdef in body
         append (loop for name in members
                 for val in (cdr itemdef)
                     collect `(DEFCONSTANT
                               ,(intern (format nil "~A->~A->~A" enumname name (car itemdef)))
                               ,val)))
       `(,@(loop for name in members
            for i from 1 to (list-length members) collect
                `(let ((,(intern (format nil "~A->~A" enumname name))
                       '(,@(loop for itemdef in body collect
                                 `(,(nth (- i 1) (cdr itemdef)) . ,(car itemdef))))))
                      (defun 
                       ,(intern (format nil "~A->~A" enumname name))
                       (,name)
                       (cdr (assoc ,name ,(intern (format nil "~A->~A" enumname name))))))))))))

(print (macroexpand '(defenum (day number)
                       (Sunday 0) 
                       (Monday 1)
                       (Tuesday 2)
                       (Wednesday 3)
                       (Thursday 4)
                       (Friday 5) 
                       (Saturday 6))))

(format t "~C~C~C" #\linefeed #\linefeed #\linefeed)

(print (macroexpand '(defenum (planet mass radius)
                       (MERCURY 3.303e+23 2.4397e6)
                       (VENUS   4.869e+24 6.0518e6)
                       (EARTH   5.976e+24 6.37814e6)
                       (MARS    6.421e+23 3.3972e6)
                       (JUPITER 1.9e+27 7.1492e7)
                       (SATURN  5.688e+26 6.0268e7)
                       (URANUS  8.686e+25 2.5559e7)
                       (NEPTUNE 1.024e+26 2.4746e7))))

; `(do ((,var (next-prime ,start) (next-prime (1+ ,var))))
;      ((> ,var ,end))
;    ,@body)

[ + ] Show input
Absolute running time: 0.13 sec, cpu time: 0.08 sec, memory peak: 6 Mb, absolute service time: 0,14 sec

(PROGN (DEFCONSTANT DAY->NUMBER->SUNDAY 0) (DEFCONSTANT DAY->NUMBER->MONDAY 1) (DEFCONSTANT DAY->NUMBER->TUESDAY 2) (DEFCONSTANT DAY->NUMBER->WEDNESDAY 3) (DEFCONSTANT DAY->NUMBER->THURSDAY 4) (DEFCONSTANT DAY->NUMBER->FRIDAY 5) (DEFCONSTANT DAY->NUMBER->SATURDAY 6) (LET ((DAY->NUMBER '((0 . SUNDAY) (1 . MONDAY) (2 . TUESDAY) (3 . WEDNESDAY) (4 . THURSDAY) (5 . FRIDAY) (6 . SATURDAY)))) (DEFUN DAY->NUMBER (NUMBER) (CDR (ASSOC NUMBER DAY->NUMBER))))) (PROGN (DEFCONSTANT PLANET->MASS->MERCURY 3.303E23) (DEFCONSTANT PLANET->RADIUS->MERCURY 2439700.0) (DEFCONSTANT PLANET->MASS->VENUS 4.869E24) (DEFCONSTANT PLANET->RADIUS->VENUS 6051800.0) (DEFCONSTANT PLANET->MASS->EARTH 5.976E24) (DEFCONSTANT PLANET->RADIUS->EARTH 6378140.0) (DEFCONSTANT PLANET->MASS->MARS 6.421E23) (DEFCONSTANT PLANET->RADIUS->MARS 3397200.0) (DEFCONSTANT PLANET->MASS->JUPITER 1.9E27) (DEFCONSTANT PLANET->RADIUS->JUPITER 7.1492E7) (DEFCONSTANT PLANET->MASS->SATURN 5.688E26) (DEFCONSTANT PLANET->RADIUS->SATURN 6.0268E7) (DEFCONSTANT PLANET->MASS->URANUS 8.686E25) (DEFCONSTANT PLANET->RADIUS->URANUS 2.5559E7) (DEFCONSTANT PLANET->MASS->NEPTUNE 1.024E26) (DEFCONSTANT PLANET->RADIUS->NEPTUNE 2.4746E7) (LET ((PLANET->MASS '((3.303E23 . MERCURY) (4.869E24 . VENUS) (5.976E24 . EARTH) (6.421E23 . MARS) (1.9E27 . JUPITER) (5.688E26 . SATURN) (8.686E25 . URANUS) (1.024E26 . NEPTUNE)))) (DEFUN PLANET->MASS (MASS) (CDR (ASSOC MASS PLANET->MASS)))) (LET ((PLANET->RADIUS '((2439700.0 . MERCURY) (6051800.0 . VENUS) (6378140.0 . EARTH) (3397200.0 . MARS) (7.1492E7 . JUPITER) (6.0268E7 . SATURN) (2.5559E7 . URANUS) (2.4746E7 . NEPTUNE)))) (DEFUN PLANET->RADIUS (RADIUS) (CDR (ASSOC RADIUS PLANET->RADIUS)))))