When I compile the following code, SBCL complains that g!-unit-value and g!-unit are undefined. I'm not sure how to debug this. As far as I can tell, flatten is failing.
When flatten reaches the unquoted part of defunits, it seems like the entire part is being treated as an atom. Does that sound correct?
The following uses code from the book Let over Lambda:
Paul Graham Utilities
(defun symb (&rest args)
(values (intern (apply #'mkstr args))))
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun group (source n)
(if (zerop n) (error "zero length"))
(labels ((rec (source acc)
(let ((rest (nthcdr n source)))
(if (consp rest)
(rec rest (cons (subseq source 0 n) acc))
(nreverse (cons source acc))))))
(if source (rec source nil) nil)))
(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec (car x) (rec (cdr x) acc))))))
(rec x nil)))
Let Over Lambda Utilities - Chapter 3
(defmacro defmacro/g! (name args &rest body)
(let ((g!-symbols (remove-duplicates
(remove-if-not #'g!-symbol-p
(flatten body)))))
`(defmacro ,name ,args
(let ,(mapcar
(lambda (g!-symbol)
`(,g!-symbol (gensym ,(subseq
(symbol-name g!-symbol)
2))))
g!-symbols)
,@body))))
(defun g!-symbol-p (symbol-to-test)
(and (symbolp symbol-to-test)
(> (length (symbol-name symbol-to-test)) 2)
(string= (symbol-name symbol-to-test)
"G!"
:start1 0
:end1 2)))
(defmacro defmacro! (name args &rest body)
(let* ((o!-symbols (remove-if-not #'o!-symbol-p args))
(g!-symbols (mapcar #'o!-symbol-to-g!-symbol o!-symbols)))
`(defmacro/g! ,name ,args
`(let ,(mapcar #'list (list ,@g!-symbols) (list ,@o!-symbols))
,(progn ,@body)))))
(defun o!-symbol-p (symbol-to-test)
(and (symbolp symbol-to-test)
(> (length (symbol-name symbol-to-test)) 2)
(string= (symbol-name symbol-to-test)
"O!"
:start1 0
:end1 2)))
(defun o!-symbol-to-g!-symbol (o!-symbol)
(symb "G!" (subseq (symbol-name o!-symbol) 2)))
Let Over Lambda - Chapter 5
(defun defunits-chaining (u units prev)
(if (member u prev)
(error "~{ ~a~^ depends on~}"
(cons u prev)))
(let ((spec (find u units :key #'car)))
(if (null spec)
(error "Unknown unit ~a" u)
(let ((chain (second spec)))
(if (listp chain)
(* (car chain)
(defunits-chaining
(second chain)
units
(cons u prev)))
chain)))))
(defmacro! defunits (quantity base-unit &rest units)
`(defmacro ,(symb 'unit-of- quantity)
(,g!-unit-value ,g!-unit)
`(* ,,g!-unit-value
,(case ,g!-unit
((,base-unit) 1)
,@(mapcar (lambda (x)
`((,(car x))
,(defunits-chaining
(car x)
(cons
`(,base-unit 1)
(group units 2))
nil)))
(group units 2))))))