From: szymon
Subject: Useful (I hope) trick.
Date: 
Message-ID: <87lli7w5qr.fsf@darkstar.example.net>
Hi. I just discover nice trick. (I'm (now) learning about
lexical-scope/closures, thus I'm trying to write some examples
myslef).

CL-USER> (my-defun foo-1 (a b c d) (list a b c d))

FOO-1


CL-USER> (my-defun foo-2 (a b c) (concatenate 'string a b c))

FOO-2


CL-USER> ~

#:S3

CL-USER> (foo-1 'A 'B 'C 'D)

(A B C D)


CL-USER> (foo-2 "foo" "-" "bar")

"foo-bar"

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- nice, eh? :]
;; no more unwanted lambdas...

CL-USER> (mapcar (foo-2 ~ "-" ~) '("foo" "1" "A") '("bar" "2" "B"))

("foo-bar" "1-2" "A-B")


CL-USER> (mapcar (foo-1 'A 'B 'C ~) '(D E F G))

((A B C D) (A B C E) (A B C F) (A B C G))


CL-USER> (setq foo-1-two-args-jammed (foo-1 'A ~ ~ 'D))

#<Interpreted Function "MY-DEFUN FOO-1" {48A6D359}>


CL-USER> (funcall foo-1-two-args-jammed "fro" "boz")

(A "fro" "boz" D)


CL-USER> (funcall (foo-2 "X" ~ "Y") " * ")

"X * Y"


CL-USER> (foo-2 "X" " * " "Y") 

"X * Y"

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

;; CAUTION: cannot call f.e. `(foo ~ ~ ~)' - (imo) no point in it.
;; For example with 3-arg function only `(foo ~ x x)', `(foo ~ ~ x)',
;; `(foo x ~ x)', `(foo ~ x ~)', `(foo x x ~)', `(foo x ~ ~)' are
;; valid patterns.

;; CODE:

;; This is one of my first (semi) useful macros...  Please
;; improve/critique it as you will.  I think it's good example (maybe
;; after rewrite by experieced lispnik) for "newbies" (Imho, closures
;; examples like "make adder" are boring).

(defmacro my-defun (name (&rest args) &body body)
  ((lambda (FN c z SPEC GENSYM-LL)
     `(let ((SPEC (if (and (boundp '~) (symbolp ~) (eq ~ (symbol-value ~)))
		      ~
		    (prog1 ,SPEC (defconstant ~ ,SPEC)))))
	(flet ((,FN ,args ,@body))
	  (defun ,name ,args
	    (if (member SPEC (list ,@args) :test #'eq)
		(case (count SPEC (list ,@args) :test #'eq)
		  ,@(loop
		     for i in GENSYM-LL count t into j
		     collect `(,j #'(lambda ,i
				      (apply #',FN
					     (loop
					      with ,c = (list ,@i)
					      for ,z in (list ,@args)
					      collect (if (eq ,z SPEC)
							  (pop ,c)
							,z)))))))
	      (,FN ,@args))))))
   (gensym) (gensym) (gensym) (let ((g (gensym "S"))) (set g g))
   (loop for i from 1 to (1- (length args))
	 collect (mapcar #'gensym (make-list i :initial-element "H")))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

Regards, Szymon.

From: Barry Margolin
Subject: Re: Useful (I hope) trick.
Date: 
Message-ID: <barmar-19C4AB.22240428062004@comcast.dca.giganews.com>
In article <··············@darkstar.example.net>, szymon <···@bar.baz> 
wrote:

> ;; This is one of my first (semi) useful macros...  Please
> ;; improve/critique it as you will.  I think it's good example (maybe
> ;; after rewrite by experieced lispnik) for "newbies" (Imho, closures
> ;; examples like "make adder" are boring).
> 
> (defmacro my-defun (name (&rest args) &body body)
>   ((lambda (FN c z SPEC GENSYM-LL)

Don't use LAMBDA like this -- it puts too much distance between the 
variables and their initial bindings, and makes it difficult to match 
them up.  Use LET:

(defmacro my-defun (name (&rest args) &body body)
  (let ((FN (gensym))
        (c (gensym))
        (z (gensym))
        (SPEC (let ((g (gensym "S"))) (set g g)))
        (GENSYM-LL (loop for i from 1 to (1- (length args))
                         collect (mapcar #'gensym
                                         (make-list i :initial-element 
"H")))))

-- 
Barry Margolin, ······@alum.mit.edu
Arlington, MA
*** PLEASE post questions in newsgroups, not directly to me ***
From: Carl Shapiro
Subject: Re: Useful (I hope) trick.
Date: 
Message-ID: <ouyn02m6esc.fsf@panix3.panix.com>
Barry Margolin <······@alum.mit.edu> writes:

> (defmacro my-defun (name (&rest args) &body body)
>   (let ((FN (gensym))
>         (c (gensym))
>         (z (gensym))
>         (SPEC (let ((g (gensym "S"))) (set g g)))
>         (GENSYM-LL (loop for i from 1 to (1- (length args))
>                          collect (mapcar #'gensym
>                                          (make-list i :initial-element 
> "H")))))

While we are on the subject of style, one should never say

  (loop for var from start to (1- finish) ...)

Consider expressing such a loop in the following form  

  (loop for var from start below finish ...)

This more clearly states the termination condition.
From: szymon
Subject: Re: Useful (I hope) trick.
Date: 
Message-ID: <87d63i2u8v.fsf@darkstar.example.net>
Carl Shapiro <·············@panix.com> writes:

> Barry Margolin <······@alum.mit.edu> writes:
>
>> (defmacro my-defun (name (&rest args) &body body)
>>   (let ((FN (gensym))
>>         (c (gensym))
>>         (z (gensym))
>>         (SPEC (let ((g (gensym "S"))) (set g g)))
>>         (GENSYM-LL (loop for i from 1 to (1- (length args))
>>                          collect (mapcar #'gensym
>>                                          (make-list i :initial-element 
>> "H")))))
>
> While we are on the subject of style, one should never say
>
>   (loop for var from start to (1- finish) ...)
>
> Consider expressing such a loop in the following form  
>
>   (loop for var from start below finish ...)
>
> This more clearly states the termination condition.


Thanks. I rewrite `my-defun' (but it's still prototype - no keyword args,
etc...). I hope it's better now.


;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

;; Now, `(foo ~ ~ ~)' is valid

(defmacro my-defun (name (&rest args) &body body)
  (let ((FN-1 (gensym (symbol-name name)))
	(FN-2 (gensym "MERGE-LAMDA-LISTS"))
	(I (gensym "I"))
	(SPEC (let ((g (gensym "S"))) (set g g))))
    `(progn
       (unless (and (boundp '~) (symbolp ~) (eq ~ (symbol-value ~)))
	 (defconstant ~ ,SPEC))
       (defun ,name ,args
	 (labels ((,FN-1 ,args ,@body)
		  (,FN-2 (l-1 l-2)
			 (loop for ,I in l-2
                               collect (if (eq ,I ~) (pop l-1) ,I))))
	   (case (count ~ (list ,@args) :test #'eq)
	     ,@(mapcar (lambda (i)
			 (list (length i)
			       `(lambda ,i
				  (apply #',FN-1
					 (,FN-2 (list ,@i) (list ,@args))))))
		       (loop for i from 1 upto (length args)
                             collect (mapcar #'gensym
                                             (make-list i :initial-element "H"))))
	     (T (,FN-1 ,@args))))))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

(defun my-defun-test ()
  (flet
      ((xxx ()
	    (my-defun foo-1 (a b c d) (list a b c d))
	    (my-defun foo-2 (a b c) (concatenate 'string a b c))
	    (values (mapcar (foo-1 'A 'B 'C ~) '(D E F G))
		    (mapcar (foo-2 ~ "-" ~) '("foo" "1" "A") '("bar" "2" "B"))
		    (funcall (foo-2 ~ ~ ~) "a" "b" "c")
		    (foo-2 "A" "B" "C"))))
    (multiple-value-bind (a b c d) (xxx)
      (values (function-lambda-expression #'xxx)
	      '----------------------------------------------------------
	      a b c d))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --


; SLIME 2004-05-06
;;;; (defmacro my-defun (name (&rest args) &body body)   (let ((F ...
;;;; (defun my-defun-test ()   (flet       ((xxx () 	    (my-defu ...
CL-USER> (my-defun-test)
; Converted FOO-1.
; Converted FOO-2.
; 

; Warning: These variables are undefined:
;   #:S22 #:S3 ~
; 
(LAMBDA ()
  (BLOCK XXX
    (MY-DEFUN FOO-1 (A B C D) (LIST A B C D))
    (MY-DEFUN FOO-2 (A B C) (CONCATENATE 'STRING A B C))
    (VALUES (MAPCAR (FOO-1 'A 'B 'C ~) '(D E F G))
            (MAPCAR (FOO-2 ~ "-" ~) '("foo" "1" "A") '("bar" "2" "B"))
            (FUNCALL (FOO-2 ~ ~ ~) "a" "b" "c")
            (FOO-2 "A" "B" "C"))))
----------------------------------------------------------
((A B C D) (A B C E) (A B C F) (A B C G))
("foo-bar" "1-2" "A-B")
"abc"
"ABC"
CL-USER> ~
#:S3
CL-USER> 

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

Regards, Szymon.
From: szymon
Subject: Re: Useful (I hope) trick.
Date: 
Message-ID: <87isd90zw3.fsf@darkstar.example.net>
szymon <···@bar.baz> writes:

> [...] I hope it's better now.

Second rewrite. It is faster (VECTOR of closures instead of CASE). 

Any ideas for further improvments/optimizations?

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

(defmacro my-defun (name (&rest args) &body body)
  (let ((FN-1 (gensym (symbol-name name)))
	(FN-2 (gensym "MERGE-LAMDA-LISTS"))
	(I (gensym "I"))
	(MEMQ (gensym "MEMQ"))
	(SPEC (let ((g (gensym "S"))) (set g g))))
    `(progn
       (unless (and (boundp '~) (symbolp ~) (eq ~ (symbol-value ~)))
	 (defconstant ~ ,SPEC))
       (flet ((,FN-1 ,args ,@body)
	      (,FN-2 (l-1 l-2)
		     (loop for ,I in l-2 collect (if (eq ,I ~) (pop l-1) ,I))))
	 (defun ,name ,args
	   (let ((,MEMQ (memq ~ (list ,@args))))
	     (if ,MEMQ
		 (svref
		  (vector
		   ,@(mapcar (lambda (i)
			       `#'(lambda ,i
				    (apply #',FN-1
					   (,FN-2 (list ,@i)
						  (list ,@args)))))
			     (loop
			      for i from 1 upto (length args)
			      collect (mapcar
				       #'gensym
				       (make-list i :initial-element "H")))))
		  (1- (count ~ ,MEMQ :test #'eq)))
	       (,FN-1 ,@args))))))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

macroexpansion example:

CL-USER> (macroexpand '(my-defun foo-1 (a b c d) (list a b c d)))

(PROGN
 (UNLESS (AND (BOUNDP '~) (SYMBOLP ~) (EQ ~ (SYMBOL-VALUE ~))) (DEFCONSTANT ~ #:S1852))
 (FLET ((#:FOO-11848 (A B C D) (LIST A B C D))
        (#:MERGE-LAMDA-LISTS1849 (L-1 L-2)
          (LOOP FOR #:I1850 IN L-2 COLLECT (IF (EQ #:I1850 ~) (POP L-1) #:I1850))))
   (DEFUN FOO-1 (A B C D)
     (LET ((#:MEMQ1851 (MEMQ ~ (LIST A B C D))))
       (IF #:MEMQ1851
           (SVREF
            (VECTOR
             #'(LAMBDA (#:H1853)
                 (APPLY #'#:FOO-11848
                        (#:MERGE-LAMDA-LISTS1849 (LIST #:H1853)
                         (LIST A B C D))))
             #'(LAMBDA (#:H1854 #:H1855)
                 (APPLY #'#:FOO-11848
                        (#:MERGE-LAMDA-LISTS1849 (LIST #:H1854 #:H1855)
                         (LIST A B C D))))
             #'(LAMBDA (#:H1856 #:H1857 #:H1858)
                 (APPLY #'#:FOO-11848
                        (#:MERGE-LAMDA-LISTS1849 (LIST #:H1856 #:H1857 #:H1858)
                         (LIST A B C D))))
             #'(LAMBDA (#:H1859 #:H1860 #:H1861 #:H1862)
                 (APPLY #'#:FOO-11848
                        (#:MERGE-LAMDA-LISTS1849
                         (LIST #:H1859 #:H1860 #:H1861 #:H1862)
                         (LIST A B C D)))))
            (1- (COUNT ~ #:MEMQ1851 :TEST #'EQ)))
           (#:FOO-11848 A B C D))))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

Regards, Szymon.
From: Alan Crowe
Subject: Re: Useful (I hope) trick.
Date: 
Message-ID: <864qosojqz.fsf@cawtech.freeserve.co.uk>
In Szymon's macro

(defmacro my-defun (name (&rest args) &body body)
  (let ((FN-1 (gensym (symbol-name name)))
	(FN-2 (gensym "MERGE-LAMDA-LISTS"))
	(I (gensym "I"))
	(SPEC (let ((g (gensym "S"))) (set g g))))
    `(progn
       (unless (and (boundp '~) (symbolp ~) (eq ~ (symbol-value ~)))
	 (defconstant ~ ,SPEC))
       (defun ,name ,args
	 (labels ((,FN-1 ,args ,@body)
		  (,FN-2 (l-1 l-2)
			 (loop for ,I in l-2
                               collect (if (eq ,I ~) (pop l-1) ,I))))
	   (case (count ~ (list ,@args) :test #'eq)
	     ,@(mapcar (lambda (i)
			 (list (length i)
			       `(lambda ,i
				  (apply #',FN-1
					 (,FN-2 (list ,@i) (list ,@args))))))
		       (loop for i from 1 upto (length args)
                             collect (mapcar #'gensym
                                             (make-list i :initial-element "H"))))
	     (T (,FN-1 ,@args))))))))

I don't think the counting and the case clause are actually
needed. I might be making a fool of myself here, because
I've got a head cold and I'm giving up and going to bed
shortly.

I've been trying to work my way into this very interesting
code by writing a simpler functional version.

(defconstant ~ (gensym))

; I didn't realise what
; (loop for ,I in l-2
;       collect (if (eq ,I ~) (pop l-1) ,I)
; was doing until after I came up with my own
; version in the style that I am more familiar with
(defun splice (gaps filler)
  "(splice (list 1 ~ 2 ~ 3) '(b d)) => (1 B 2 D 3)"
  (when gaps
    (if (eq (car gaps) ~)
	(cons (car filler)
	      (splice (cdr gaps)
		     (cdr filler)))
      (cons (car gaps)
	    (splice (cdr gaps) filler)))))

(defun fix (func &rest arg-list)
  (lambda (&rest args)
    (apply func (splice arg-list args))))

Example

(mapcar (fix #'list 1 ~ 2 ~ 3) '(a b c) '("a" "b" "c"))
=> ((1 A 2 "a" 3) (1 B 2 "b" 3) (1 C 2 "c" 3))

My FIX works without counting and casing ~'s.
I don't think that the counting and casing is helping with
efficiency because FN-2 gets called at run time.

If you want to merge the lambda lists at compile time, don't
you hit an exponential explosion? That is to say you need

(f ~ a b) --> (lambda(x)(funcall f x a b))
(f a ~ b) --> (lambda(x)(funcall f a x b))
(f a b ~) --> (lambda(x)(funcall f a b x))

with all 2^n patterns being needed.

Tricky stuff, my head hurts, good night.

Alan Crowe
Edinburgh
Scotland
From: szymon
Subject: Re: Useful (I hope) trick.
Date: 
Message-ID: <87isd7ab8r.fsf@darkstar.example.net>
Alan Crowe <····@cawtech.freeserve.co.uk> writes:

> [.....]

Thanks for the response.

> I don't think the counting and the case clause are actually
> needed.

Counting, why not? (I need it). CASE was not the best idea and I
replaced it with SVREF/VECTOR. I have optimized the whole (the code
appears below) so that the lambda list is "used" as many times as
necessary - i.e.  I combined counting with caching of the places that
include the special symbol indicated by "~".

> I might be making a fool of myself here, because I've got a head
> cold and I'm giving up and going to bed shortly.

I hope that 'having a head cold' is nothing serious and that you
recover soon.

> I've been trying to work my way into this very interesting
> code by writing a simpler functional version.

> [...] a little of a nice code  [...]
  
> Example

> (mapcar (fix #'list 1 ~ 2 ~ 3) '(a b c) '("a" "b" "c"))
> => ((1 A 2 "a" 3) (1 B 2 "b" 3) (1 C 2 "c" 3))

> My FIX works without counting and casing ~'s.

Sure. However, what I meant was that the function should in some cases
(that is, where there is/are a 'special' uninterned symbol/symbols in
the lambda list) return 'itself' with 'jammed' arguments.

> I don't think that the counting and casing is helping with
> efficiency because FN-2 gets called at run time.

I did this for better clarity (i.e. I isolated the counting from
splicing).  FN-2 may be 'distributed' across the code so that it might
help to avoid unncessary operations.

> If you want to merge the lambda lists at compile time, don't
> you hit an exponential explosion? That is to say you need

> (f ~ a b) --> (lambda(x)(funcall f x a b))
> (f a ~ b) --> (lambda(x)(funcall f a x b))
> (f a b ~) --> (lambda(x)(funcall f a b x))

[imho]  NO. Only one (see macroexpansion below).

> with all 2^n patterns being needed.

[imho]  NO. See the code below (I believe that complexity is polynominal one).

> Tricky stuff, [...], good night.

Thank you.

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
;; _SAMPLE MACROEXPANSION:_ (macroexpand '(my-defun FOO (a b c d) (list a b c d)))
;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

(PROGN

 (UNLESS (AND (BOUNDP '~) (SYMBOLP ~) (EQ ~ (SYMBOL-VALUE ~))) (DEFCONSTANT ~ #:S1690))

 (LET ((#:CACHE-VECTOR1686 (MAKE-ARRAY 4 :ELEMENT-TYPE 'LIST :INITIAL-ELEMENT NIL))
       #:LAMBDA-LIST1685
       #:MEMQ1689
       #:VECTOR-INDEX1687)

;; initialization of variables - there is no need to use LET each time.

   (FLET ((#:FOO1684 (A B C D) (LIST A B C D)))

     (DEFUN FOO (A B C D)

       (SETQ #:LAMBDA-LIST1685 (LIST A B C D)
             #:MEMQ1689 (MEMQ ~ #:LAMBDA-LIST1685))

;; I have 'walked through'/created the list for the first time. It's
;; silly I cannot directly reach the lambda list in Common Lisp.

;; MEMQ runs through a part of the list repeatedly, but I discard this
;; now and will take it into consideration when the second run is over
;; (as I remember what MEMQ has done).

       (IF #:MEMQ1689
           (SVREF
            (VECTOR

;; SVREF + VECTOR gives me a constant input into the time of the
;; operation (in contradistinction to CASE which I used the last
;; time).

             #'(LAMBDA (#:H1691)

;; I cannot see any 2 - raised to the the n-th power. There is only
;; one LAMBDA for n-cases (those with one "~").

                 (RPLACA (SVREF #:CACHE-VECTOR1686 0) #:H1691)

;; destructively modifies the (variable, not 'true' ll) lambda list in
;; the places where I previously found "~" (when discussing the "~"
;; counting, I must say I need it to apply its result in SVREF as an
;; index).

                 (APPLY #'#:FOO1684 #:LAMBDA-LIST1685))

             #'(LAMBDA (#:H1692 #:H1693)         ; this is the case for _two_ "~"

                 (RPLACA (SVREF #:CACHE-VECTOR1686 0) #:H1692)
                 (RPLACA (SVREF #:CACHE-VECTOR1686 1) #:H1693)

                 (APPLY #'#:FOO1684 #:LAMBDA-LIST1685))


             #'(LAMBDA (#:H1694 #:H1695 #:H1696) ; this is the case for _three_ "~"

                 (RPLACA (SVREF #:CACHE-VECTOR1686 0) #:H1694)
                 (RPLACA (SVREF #:CACHE-VECTOR1686 1) #:H1695)
                 (RPLACA (SVREF #:CACHE-VECTOR1686 2) #:H1696)

                 (APPLY #'#:FOO1684 #:LAMBDA-LIST1685))

             #'(LAMBDA (#:H1697 #:H1698 #:H1699 #:H1700) ; this is the case for _four_ "~"

                 (RPLACA (SVREF #:CACHE-VECTOR1686 0) #:H1697)
                 (RPLACA (SVREF #:CACHE-VECTOR1686 1) #:H1698)
                 (RPLACA (SVREF #:CACHE-VECTOR1686 2) #:H1699)
                 (RPLACA (SVREF #:CACHE-VECTOR1686 3) #:H1700)

                 (APPLY #'#:FOO1684 #:LAMBDA-LIST1685)))

;; in the LOOP below I used the counting from a part of the operations
;; earlier performed by the "splice"/"merge" (subsequent sublists of
;; tails of the lambda list) beginning with "~"s 'cached' in the
;; vector.  There is no consing as the elements of the vector are
;; shared by the data of the lambda list.

;; here I end the second run of the lambda list started by MEMO.

;; as for each "~" there is performed one operation of attribution
;; (later lambda list is modified by the RPLACA), then, in the most
;; pessimistic case, the computing complexity, as far as the
;; access/modifications of the lambda list are concerned, will be
;; _linear_ with the coefficient of about 4.

            (LOOP INITIALLY (SETQ #:VECTOR-INDEX1687 -1)
                  FOR #:_CDR_1688 ON #:MEMQ1689
                  IF (EQ (CAR #:_CDR_1688) ~)
                  DO (SETF (SVREF #:CACHE-VECTOR1686 (INCF #:VECTOR-INDEX1687)) #:_CDR_1688)
                  FINALLY (RETURN #:VECTOR-INDEX1687)))

           (#:FOO1684 A B C D))))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
;; CODE:
;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

(defmacro my-defun (name (&rest args) &body body)
  (let ((FN-1 (gensym (symbol-name name)))
	(LAMBDA-LIST (gensym "LAMBDA-LIST"))
	(CVECT (gensym "CACHE-VECTOR"))
	(VECTOR-INDEX (gensym "VECTOR-INDEX"))
	(_cdr_ (gensym "_CDR_"))
	(MEMQ (gensym "MEMQ"))
	(SPEC (let ((g (gensym "S"))) (set g g))))
    `(progn
       (unless (and (boundp '~) (symbolp ~) (eq ~ (symbol-value ~)))
	 (defconstant ~ ,SPEC))
       (let ((,CVECT (make-array ,(length args) :element-type 'list :initial-element nil))
	     ,LAMBDA-LIST ,MEMQ ,VECTOR-INDEX)
	 (flet ((,FN-1 ,args ,@body))
	   (defun ,name ,args
	     (setq ,LAMBDA-LIST (list ,@args)
		   ,MEMQ (memq ~ ,LAMBDA-LIST))
	     (if ,MEMQ
		 (svref
		  (vector
		   ,@(mapcar (lambda (i)
			       `#'(lambda ,i
				    ,@(loop for j below (length i)
					    collect `(rplaca (svref ,CVECT ,j) ,(nth j i)))
				    (apply #',FN-1 ,LAMBDA-LIST)))
			     (loop for i from 1 upto (length args)
				   collect (mapcar
					    #'gensym
					    (make-list i :initial-element "H")))))
		  (loop initially (setq ,VECTOR-INDEX -1)
			for ,_cdr_ on ,MEMQ
			if (eq (car ,_cdr_) ~)
			do (setf (svref ,CVECT (incf ,VECTOR-INDEX)) ,_cdr_)
			finally (return ,VECTOR-INDEX)))
	       (,FN-1 ,@args))))))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
;; END "MY-DEFUN".
;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

(defun my-defun-test ()
  (flet
      ((xxx ()

	    (my-defun foo-1 (a b c d e) (list a b c d e))

	    (my-defun foo-2 (a b c) (concatenate 'string a b c))


	    (values (mapcar (foo-1 1 2 3 4 ~) '(D E F G))

		    (mapcar (foo-1 1 ~ 2 ~ 3) '(a c) '(b d))

		    (mapcar (foo-2 ~ "-" ~) '("foo" "1" "A") '("bar" "2" "B"))

		    (funcall (foo-2 ~ ~ ~) "a" "b" "c")

		    (foo-2 "A" "B" "C"))))


    (multiple-value-bind (a b c d e) (xxx)
      (values (function-lambda-expression #'xxx)
	      '----------------------------------------------------------
	      a b c d e))))

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

CL-USER> (my-defun-test)
(LAMBDA ()
  (BLOCK XXX
    (MY-DEFUN FOO-1 (A B C D E) (LIST A B C D E))
    (MY-DEFUN FOO-2 (A B C) (CONCATENATE 'STRING A B C))
    (VALUES (MAPCAR (FOO-1 1 2 3 4 ~) '(D E F G))
            (MAPCAR (FOO-1 1 ~ 2 ~ 3) '(A C) '(B D))
            (MAPCAR (FOO-2 ~ "-" ~) '("foo" "1" "A") '("bar" "2" "B"))
            (FUNCALL (FOO-2 ~ ~ ~) "a" "b" "c")
            (FOO-2 "A" "B" "C"))))
----------------------------------------------------------
((1 2 3 4 D) (1 2 3 4 E) (1 2 3 4 F) (1 2 3 4 G))
((1 A 2 B 3) (1 C 2 D 3))
("foo-bar" "1-2" "A-B")
"abc"
"ABC"
CL-USER> 

;; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

Regards, Szymon.
From: Joerg Hoehle
Subject: Re: Useful (I hope) trick.
Date: 
Message-ID: <uu0wc83pv.fsf@users.sourceforge.net>
szymon <···@bar.baz> writes:

> Hi. I just discover nice trick. (I'm (now) learning about
> lexical-scope/closures, thus I'm trying to write some examples
> myslef).

> (defmacro my-defun (name (&rest args) &body body)
>   ((lambda (FN c z SPEC GENSYM-LL)
>      `(let ((SPEC (if (and (boundp '~) (symbolp ~) (eq ~ (symbol-value ~)))
> 		      ~
> 		    (prog1 ,SPEC (defconstant ~ ,SPEC)))))

1. The test to second-quess whether ~ is already a constant may not work
across all implementations and compilers.

You don't need that overhead. Just use

(defconstant ~ 'xxx)	; do you ever need that value?

(defmacro my-defun ...)

2. Learn about LOOP WITH, i.e. vector-index could be local to loop

3. In the ~ case, you build N closures, and immediately discard all
   but one.  Your CASE-base version did not do this. Rely on your CL
   compiler to optimize (CASE (1 ..) (2 ..) (T ..)) to good code.
  Are your sure VECTOR is faster than CASE -- Did you compile?

4. Why do you keep LAMBDA-LIST and MEMQ (and VECTOR-CACHE) outside the
   defun and what implications does this have on repeated uses of the
   function?   I guess you better use local variables!
[71]> (setq f1 (foo-1 ~ ~ 3 4))
[72]> (setq f2 (foo-1 ~ 2 ~ 4))
[73]> (funcall f1 'a 'b)
(A 2 B 4) -- Oops!

5. What happens when used recursively?
   The given name is not visible inside the FLET, thus probably
   generating a compiler note the first time it's encountered.

Remembers me of Scheme's SRFI about CUT and CUTE.
http://srfi.schemers.org/srfi-26/

Regards,
	Jorg Hohle
Telekom/T-Systems Technology Center