I am new to LISP programming and it is the end of semester and our teacher asked us to do this project and I have been trying to make it but I am stuck so any help would be appreciated. the Project is to write an eval (expr) function in Lisp to overwrite the already existing function. here is the details:
Project Description: Items in an arithmetic expression separated by spaces;
; Input:
; 1. The form of arithmetic expression given in prefix notation like LISP
; Assumptions:
; 1. binary operations for +, -, *, and /
; 2. integer division, no reals
; 3. an arithmetic expression occupies only one line
; 4. nested arithmetic expressions permitted
; 5. all given inputs are syntax correct
; 6. no need for error handling
I wrote a code that can do eval of the simple arithmetic expressions and it works!! but I COULD NOT get it to work on nested arithmetic operations. I think I have an issue with the recursion part i am doing something wrong but what is it exactly idk :(
here is my code :
; Assign a character string to a global variable input-prompt
; treat input-prompt as a constant global variable
(setf input-prompt "Please input an arithmetic expression: ")
(setf output-prompt "The value is: ")
(defun prompt-for-input (msg)
(format t msg)
(format t "~%")) ; ~% new line
(defun prompt-for-output (msg)
(format t msg))
(defun output-msg (result)
(format t "~S" result) ; ~S takes the result into the print message
(format t "~%"))
(defun eval (expr)
(print "My EVAL Function is Working *_*")
(if (numberp expr) expr)
(cond
((eq (car expr) '+)
(if (and (numberp (cadr expr))
(numberp (caddr expr))) ;to check if we have simple expression
(+ (cadr expr) (caddr expr)) ;in case both are numbers we add normally
(if (not (numberp (cadr expr)))
;in case the second argument is not number
;we need to call eval again to check the expression
((eval (cadr exp)))
(if (not (numberp (caddr expr)))
;in case the third argument is not a number
;we need to call eval again to check the expression
((eval (caddr exp)))
(0)))))
((eq (car expr) '-)
(if (and (numberp (cadr expr))
(numberp (caddr expr))) ;to check if we have simple expression
(- (cadr expr) (caddr expr)) ;in case both are numbers we add normally
(if (not (numberp (cadr expr)))
;in case the second argument is not number
;we need to call eval again to check the expression
((eval (cadr exp)))
(if (not (numberp (caddr expr)))
;in case the third argument is not a number
;we need to call eval again to check the expression
((eval (caddr exp)))
(0)))))
((eq (car expr) '*)
(if (and (numberp (cadr expr))
(numberp (caddr expr))) ;to check if we have simple expression
(* (cadr expr) (caddr expr)) ;in case both are numbers we add normally
(if (not (numberp (cadr expr)))
;in case the second argument is not number
;we need to call eval again to check the expression
((eval (cadr exp)))
(if (not (numberp (caddr expr)))
;in case the third argument is not a number
;we need to call eval again to check the expression
((eval (caddr exp)))
(0)))))
((eq (car expr) '/)
(if (and (numberp (cadr expr))
(numberp (caddr expr))) ;to check if we have simple expression
(/ (cadr expr) (caddr expr)) ;in case both are numbers we add normally
(if (not (numberp (cadr expr)))
;in case the second argument is not number
;we need to call eval again to check the expression
((eval (cadr exp)))
(if (not (numberp (caddr expr)))
;in case the third argument is not a number
;we need to call eval again to check the expression
((eval (caddr exp)))
(0)))))))
; it should have eval(expr) function which returns the value of the
; arithmetic expression
; for instance,
; (+ 2 3) outputs 5
; (+ (* 3 2) (/ 4 2))) outputs 8
; (* (- 2 3) 5) outputs -5
; driver accepts the input arithmetic expression
; evaluate the arithmetic expression
; output the reulst of the evaluation of the arithmetic expression
; execution is in the loop; to exit the loop; type cntrl-c
(defun driver ()
(prompt-for-input input-prompt)
;to print "Please input an arithmetic expression
(let ((expression (read)))
(output-msg expression)
(let ((result (eval expression)))
(prompt-for-output output-prompt)
(output-msg result)))
(driver))
First of all, the basic call that does the trick is ... drum roll ... -
(apply (symbol-function (car expr)) (cdr expr))
this assuming - for a moment - that all the arguments in the expression are already numbers.
This one line replaces all four cases in your code which are all exact copies of one another, up to the operation to be performed.
Now, to make sure we have numbers, we just need to call same eval on each of them. If they were numbers, they will stay as is, and if not - they'll get evaluated.
Let's just call our new function calc, for "calculate", instead:
(defun calc (expr) ; our "eval"
(cond
((numberp expr) expr)
(T (call (car expr)
(mapcar #'calc (cdr expr))))))
(defun call (op args) ; our "apply"
(apply (symbol-function op)
args))
That's all. If you consider this cheating, you can call the operation by hand, but still you don't need to copy the same block of code four times for that. :)
If you indeed write the call yourself to call the operation by hand, do note that the default value for (*) is 1, not 0; and that there's no default value for (-) and (/) in Common Lisp (as tested in CLisp). Also, (/ 2) should return 1/2.
a few hints:
Expressions like (0) are not meaningful. 0 is not a function. Similar ((foo)) also makes no sense.
you should properly format and indent Lisp code. The editor helps.
Avoid functions like CAR, CDR, CADR, ... - use FIRST, REST, SECOND, ...
don't call the function EVAL. That's a built-in function in Common Lisp.
Related
I'm trying to write an epsilon-nfa compiler for regular expression in lisp for a course project. Given this input prompt
CL prompt> (defparameter nfa-name (nfa-regexp-comp 'reg-exp))
should return the automata. The best i've came up to is this function:
;ALL THE CREATE-NFA FUNCTIONS ARE ALREADY DEFINED LATER IN THE CODE
(defun nfa-regex-comp (RE)
(cond
((is-regexp RE) ; working function returning true if the input is a regexp
(cond
((atom RE) (create-nfa-atom RE)) ; if atom
((equal (car RE) 'star)
(create-nfa-star (nfa-regex-comp (cadr RE)))) ; if <RE>*
((equal (car RE) 'plus)
(create-nfa-plus (nfa-regex-comp (cadr RE)))) ; if <RE>+
((equal (car RE) 'seq)
(create-nfa-seq (map 'list #'nfa-regex-comp (cdr RE)))) ; if <RE1>...<REn>
((equal (car RE) 'or)
(create-nfa-or (map 'list #'nfa-regex-comp (cdr RE)))))) ; if <RE1>|...|<REn>
(t nil)))
when i load it and try it, input being
(defparameter basic-nfa-1 (nfa-regexp-comp ’a)) (teacher example)
LispWorks returns this error
Undefined operator NFA-REGEXP-COMP in form (NFA-REGEXP-COMP (QUOTE A))
and i can't understand why is it.
Thanks for the attention.
IF you use apropos you can search for a symbol with a substring:
CL-USER 25 > (apropos "NFA")
TYPE::DNFA
NFA-REGEX-COMP (defined)
CREATE-NFA-ATOM
CREATE-NFA-SEQ
CREATE-NFA-PLUS
CREATE-NFA-STAR
CREATE-NFA-OR
Above shows that NFA-REGEX-COMP is a defined function. I would then look at what you have typed and what the system says exists:
CL-USER 26 > (equal 'NFA-REGEX-COMP 'NFA-REGEXP-COMP)
NIL
So there must be a difference...
Let's look for the mismatch:
CL-USER 27 > (mismatch (symbol-name 'NFA-REGEX-COMP)
(symbol-name 'NFA-REGEXP-COMP))
9
The mismatch is at character 9:
CL-USER 28 > (aref (symbol-name 'NFA-REGEX-COMP) 9)
#\-
CL-USER 29 > (aref (symbol-name 'NFA-REGEXP-COMP) 9)
#\P
While we are at it: a few style improvements:
car, cdr, cadr can be replaced by first, rest, second --> slight readability improvements
cond with many comparisons can be replaced by case. ecase additionally checks that the item is actually matching in some clause.
Example:
(defun nfa-regex-comp (RE)
(when (is-regexp RE) ; working function returning true if the input is a regexp
(if (atom RE)
(create-nfa-atom RE) ; if atom
(ecase (first RE)
(star (create-nfa-star (nfa-regex-comp (second RE)))) ; if <RE>*
(plus (create-nfa-plus (nfa-regex-comp (second RE)))) ; if <RE>+
(seq (create-nfa-seq (map 'list #'nfa-regex-comp (rest RE)))) ; if <RE1>...<REn>
(or (create-nfa-or (map 'list #'nfa-regex-comp (rest RE))))))))
I'm currently experimenting with macro's in Lisp and I would like to write a macro which can handle syntax as follows:
(my-macro (args1) (args2))
The macro should take two lists which would then be available within my macro to do further processing. The catch, however, is that the lists are unquoted to mimic the syntax of some real Lisp/CLOS functions. Is this possible?
Currently I get the following error when attempting to do something like this:
Undefined function ARGS1 called with arguments ().
Thanks in advance!
I think you need to show what you have tried to do. Here is an example of a (silly) macro which has an argument pattern pretty much what yours is:
(defmacro stupid-let ((&rest vars) (&rest values) &body forms)
;; Like LET but with a terrible syntax
(unless (= (length vars) (length values))
(error "need exactly one value for each variable"))
(unless (every #'symbolp vars)
(error "not every variable is a symbol"))
`(let ,(mapcar #'list vars values) ,#forms))
Then
> (macroexpand '(stupid-let (a b c) (1 2 3) (+ a b c)))
(let ((a 1) (b 2) (c 3)) (+ a b c))
The above macro depends on defmacro's arglist-destructuring, but you don't have to do that:
(defun proper-list-p (l)
;; elaborate version with an occurs check, quadratic.
(labels ((plp (tail tails)
(if (member tail tails)
nil
(typecase tail
(null t)
(cons (plp (rest tail) (cons tail tails)))
(t nil)))))
(plp l '())))
(defmacro stupid-let (vars values &body forms)
;; Like LET but with a terrible syntax
(unless (and (proper-list-p vars) (proper-list-p values))
(error "need lists of variables and values"))
(unless (= (length vars) (length values))
(error "need exactly one value for each variable"))
(unless (every #'symbolp vars)
(error "not every variable is a symbol"))
`(let ,(mapcar #'list vars values) ,#forms))
As a slightly more useful example, here is a macro which is a bit like the CLOS with-slots / with-accessors macros:
(defmacro with-mindless-accessors ((&rest accessor-specifications) thing
&body forms)
"Use SYMBOL-MACROLET to define mindless accessors for THING.
Each accessor specification is either a symbol which names the symbol
macro and the accessor, or a list (macroname accessorname) which binds
macroname to a symbol macro which calls accessornam. THING is
evaluated once only."
(multiple-value-bind (accessors functions)
(loop for accessor-specification in accessor-specifications
if (symbolp accessor-specification)
collect accessor-specification into acs
and collect accessor-specification into fns
else if (and (proper-list-p accessor-specification)
(= (length accessor-specification) 2)
(every #'symbolp accessor-specification))
collect (first accessor-specification) into acs
and collect (second accessor-specification) into fns
else do (error "bad accessor specification ~A" accessor-specification)
end
finally (return (values acs fns)))
(let ((thingn (make-symbol "THING")))
`(let ((,thingn ,thing))
(symbol-macrolet ,(loop for accessor in accessors
for function in functions
collect `(,accessor (,function ,thingn)))
,#forms)))))
So now we can write this somewhat useless code:
> (with-mindless-accessors (car cdr) (cons 1 2)
(setf cdr 3)
(+ car cdr))
4
And this:
> (let ((l (list 1 2)))
(with-mindless-accessors (second) l
(setf second 4)
l))
(1 4)
I am having the following trouble: when trying to use APPLY function with a MAPCAR call, the lambda function passed to APPLY, which contains only one parameter, the list returned by MAPCAR, gives the following error :
*** - EVAL/APPLY: too many arguments given to :LAMBDA
The following code identifies if a heterogenous list has the last atom at any level a numerical atom.
(DEFUN hasLastNumeric (L)
(COND
((NUMBERP L) T)
((ATOM L) NIL)
((LISTP L)
(APPLY #'(LAMBDA (Lst)
(COND ((EQ (LAST Lst) T) T)
(T NIL)))
(MAPCAR 'hasLastNumeric L)))))
(WRITE (hasLastNumeric '(1 2 5)))
You don't need APPLY. Why would you use it? Remember: APPLY calls a function and uses the provided list as the list of arguments.
MAPCAR returns a list.
(let ((foo (mapcar #'1+ '(1 2 3 4))))
(cond ((eql (last foo) ...) ...)
...))
Check also what last actually returns...
If you call a function eg. (#'(lambda (a b) (+ a b)) 2 3) there is a requirement that the number of arguments fits the number of provided arguments. When using apply the requirements are the same so (apply #'(lambda (one) ...) lst) require that lst is only one element list like '(a), but it cannot be '() or '(a b). The only way to support variable number of arguments you need to use &rest arguments eg. (apply #'(lambda (&rest lst) ...) '(a b))
Looking at the logic I don't understand it. You want to return t when you have encountered a list with the last element as a number but also searched list elements on the way and returned early had you found them. It should be possible without the use of last at each step. eg.
(defun has-a-last-numeric (lst)
(labels ((helper (lst)
(loop :for (e . rest) :on lst
:if (and (null rest) (numberp e))
:do (return-from has-a-last-numeric t)
:if (listp e)
:do (helper e))))
(helper lst)))
I want to solve a lisp function that returns a NUMBER(count) of numbers which are greater than the first number in the list.The list is a linear list of numbers.
(defun foo (lst)
(cond ((null lst) 0)
(car = k)
((> (car lst) k)
(1+ (foo (cdr lst))))
(T (foo (cdr lst)))))
My problem is that I cannot keep the first element and compare it with the others.
Let's take apart your problem:
You have a set of numbers. Really, you have a “special” first number, and then the rest of them. Specifically, you probably want only real numbers, because “less than” does not make sense in terms of complex (imaginary) numbers.
You can use first to get the first number from the list, and rest for the others.
Of these, you want to count any that are not greater than the first.
So let's start with sort of pseudocode
(defun count-numbers-greater-than-first (list)
;; split out first and rest
;; call the real count function
)
Well, we know now that we can use first and rest (also, as you used, historically car and cdr), so:
(defun count-numbers-greater-than-first (list)
(count-numbers-greater-than (first list) (rest list))
You already probably know that > is used to test whether real numbers are greater than one another.
A quick look at the CLHS reveals a nice function called count-if
(defun count-numbers-not-greater-than (reference other-numbers)
(count-if ??? other-numbers))
The ??? needs to be an object of function type, or the name of a function. We need to “curry” the reference (first number) into that function. This means we want to create a new function, that is only used for one run through the count-if, that already has “closed over” the value of reference.
If we knew that number would always be, say, 100, that function would look like this:
(defun greater-than-100 (number)
(> number 100))
That function could then get used in the count-if:
(defun count-numbers-greater-than (reference other-numbers)
(count-if (function greater-than-100)
other-numbers))
(defun count-numbers-greater-than (reference other-numbers)
(count-if #'greater-than-100 other-numbers))
But that doesn't solve the problem of getting the reference number “curried” into the function.
Without reaching for Alexandria (I'll explain in a moment), you can use a lambda form to create a new, anonymous function right here. Since reference is available within count-numbers-not-greater-than, you can use its value within that lambda. Let's convert for 100 first:
(defun count-numbers-greater-than (reference other-numbers)
(count-if (lambda (number) (> number 100))
other-numbers))
Now we can use reference:
(defun count-numbers-greater-than (reference other-numbers)
(count-if (lambda (number) (> number reference))
other-numbers))
And, in fact, you could even merge this back into the other function, if you wanted:
(defun count-numbers-greater-than-first (list)
(count-if (lambda (number) (> number (first list)))
(rest list)))
That Alexandria thing
But, what about Alexandria? Alexandria is a collection of super-useful utility functions that's available in Quicklisp or elsewhere.
(ql:quickload "alexandria")
(use-package #:alexandria)
Of course, you'd normally use it in your own defpackage
(defpackage my-cool-program
(:use :common-lisp :alexandria))
Two of the things it provides are curry and rcurry functions. It turns out, that lambda function in there is a really common case. You have an existing function — here, > — that you want to call with the same value over and over, and also some unknown value that you want to pass in each time.
These end up looking a lot like this:
(lambda (x) (foo known x))
You can use curry to write the same thing more concisely:
(curry #'foo known)
It also work with any number of arguments. RCurry does the same, but it puts the unknown values “x” at the left, and your known values at the right.
(lambda (x) (foo x known)) = (rcurry #'foo known)
So another way to write the count-if is:
(defun count-numbers-greater-than-first (list)
(count-if (rcurry #'> (first list))
(rest list)))
* (count-numbers-greater-than-first '(10 9 8 7 11 12))
2
Your function indented correctly looks like this:
(defun foo (lst)
(cond ((null lst) 0)
(car = k) ; strange cond term
((> (car lst) k)
(1+ (foo (cdr lst))))
(T (foo (cdr lst)))))
I have commented the second term in your cond. It is quite strange. It first evaluates the variable car (not the function #'car). If car is not nil it first evaluates the variable = (not the function #'=) and since it is not the last consequent expression in the cond term it throws that away and returns the last which is k.
Secondly you write that you say you use the first element as comparison, however you call it k in your function but it is not defined anywhere. You need to do something before you do the recursion and thus you cannot let the actual function do the recursion since it will take the first element each time. Here is where labels can be used:
;; didn't call it foo since it's not very descriptive
(defun count-larger-than-first (list)
(let ((first (car list)))
(labels ((helper (list)
(cond ((null list) 0)
((> (car list) first)
(1+ (helper (cdr list))))
(t (helper (cdr list))))))
(helper (cdr list)))))
Of course. Since you now have the possibility to add more arguments I would have added an accumulator:
(defun count-larger-than-first (list)
(let ((first (car list)))
(labels ((helper (list acc)
(cond ((null list) acc)
((> (car list) first)
(helper (cdr list) (1+ acc)))
(t (helper (cdr list) acc)))))
(helper (cdr list) 0))))
And of course recursion might blow the stack so you should really write it without in Common Lisp:
(defun count-larger-than-first (list)
(let ((first (car list)))
(loop :for element :in (cdr list)
:counting (> element first))))
There are higher order functions that count too which might be more suitable:
(defun count-larger-than-first (list)
(let ((first (car list)))
(count-if (lambda (element) (> element first))
(cdr list))))
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))))))
This is kind of tricky:
Problem: you assume that backquote/comma expressions are plain lists.
You need to ask yourself this question:
What is the representation of a backquote/comma expression?
Is it a list?
Actually the full representation is unspecified. See here: CLHS: Section 2.4.6.1 Notes about Backquote
We are using SBCL. See this:
* (setf *print-pretty* nil)
NIL
* '`(a ,b)
(SB-INT:QUASIQUOTE (A #S(SB-IMPL::COMMA :EXPR B :KIND 0)))
So a comma expression is represented by a structure of type SB-IMPL::COMMA. The SBCL developers thought that this representation helps when such backquote lists need to be printed by the pretty printer.
Since your flatten treats structures as atoms, it won't look inside...
But this is the specific representation of SBCL. Clozure CL does something else and LispWorks again does something else.
Clozure CL:
? '`(a ,b)
(LIST* 'A (LIST B))
LispWorks:
CL-USER 87 > '`(a ,b)
(SYSTEM::BQ-LIST (QUOTE A) B)
Debugging
Since you found out that somehow flatten was involved, the next debugging steps are:
First: trace the function flatten and see with which data it is called and what it returns.
Since we are not sure what the data actually is, one can INSPECT it.
A debugging example using SBCL:
* (defun flatten (x)
(inspect 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)))
STYLE-WARNING: redefining COMMON-LISP-USER::FLATTEN in DEFUN
FLATTEN
Above calls INSPECT on the argument data. In Common Lisp, the Inspector usually is something where one can interactively inspect data structures.
As an example we are calling flatten with a backquote expression:
* (flatten '`(a ,b))
The object is a proper list of length 2.
0. 0: SB-INT:QUASIQUOTE
1. 1: (A ,B)
We are in the interactive Inspector. The commands now available:
> help
help for INSPECT:
Q, E - Quit the inspector.
<integer> - Inspect the numbered slot.
R - Redisplay current inspected object.
U - Move upward/backward to previous inspected object.
?, H, Help - Show this help.
<other> - Evaluate the input as an expression.
Within the inspector, the special variable SB-EXT:*INSPECTED* is bound
to the current inspected object, so that it can be referred to in
evaluated expressions.
So the command 1 walks into the data structure, here a list.
> 1
The object is a proper list of length 2.
0. 0: A
1. 1: ,B
Walk in further:
> 1
The object is a STRUCTURE-OBJECT of type SB-IMPL::COMMA.
0. EXPR: B
1. KIND: 0
Here the Inspector tells us that the object is a structure of a certain type. That's what we wanted to know.
We now leave the Inspector using the command q and the flatten function continues and returns a value:
> q
(SB-INT:QUASIQUOTE A ,B)
For anyone else who is trying to get defmacro! to work on SBCL, a temporary solution to this problem is to grope inside the unquote structure during the flatten procedure recursively flatten its contents:
(defun flatten (x)
(labels ((flatten-recursively (x flattening-list)
(cond ((null x) flattening-list)
((eq (type-of x) 'SB-IMPL::COMMA) (flatten-recursively (sb-impl::comma-expr x) flattening-list))
((atom x) (cons x flattening-list))
(t (flatten-recursively (car x) (flatten-recursively (cdr x) flattening-list))))))
(flatten-recursively x nil)))
But this is horribly platform dependant. If I find a better way, I'll post it.
In case anyone's still interested in this one, here are my three cents. My objection to the above modification of flatten is that it might be more naturally useful as it were originally, while the problem with representations of unquote is rather endemic to defmacro/g!. I came up with a not-too-pretty modification of defmacro/g! using features to decide what to do. Namely, when dealing with non-SBCL implementations (#-sbcl) we proceed as before, while in the case of SBCL (#+sbcl) we dig into the sb-impl::comma structure, use its expr attribute when necessary and use equalp in remove-duplicates, as we are now dealing with structures, not symbols. Here's the code:
(defmacro defmacro/g! (name args &rest body)
(let ((syms (remove-duplicates
(remove-if-not #-sbcl #'g!-symbol-p
#+sbcl #'(lambda (s)
(and (sb-impl::comma-p s)
(g!-symbol-p (sb-impl::comma-expr s))))
(flatten body))
:test #-sbcl #'eql #+sbcl #'equalp)))
`(defmacro ,name ,args
(let ,(mapcar
(lambda (s)
`(#-sbcl ,s #+sbcl ,(sb-impl::comma-expr s)
(gensym ,(subseq
#-sbcl
(symbol-name s)
#+sbcl
(symbol-name (sb-impl::comma-expr s))
2))))
syms)
,#body))))
It works with SBCL. I have yet to test it thoroughly on other implementations.