[Chicken-users] Solved: Re: need help with hygienic macros

[Jörg F . Wittenberger]

Eventually I learned that the technique I've been looking for is 
known singe 2001 by the name "Petrofsky Extraction".

Thanks to everyone who bothered trying to understand my needs.
FYI find the solution below.  I should not be able "hygienize"
the questionable code.

/Jörg

On May 16 2013, Jörg F. Wittenberger wrote:

> I need some syntax to define a set of procedures, which all have the
> same list of formal arguments.  However those arguments are about to
> change and therefore MUST NOT appear at the definition side.  Access
> to those formals shall be available within the procedure body by means
> of some special syntax.
>
> Like this: (`deftig` would be the syntax to define the procedure.)
> I want to write:
>
> (deftig f1 (+ (get-x) (get-y)))


;; # Petrofsky Extraction
;;
;; Extract several colored identifiers from a form
;;    extract* SYMB-L BODY CONT
;; where SYMB-L is the list of symbols to extract, and BODY and CONT
;; has the same meaning as in extract, see above.
;; 
;; The extract* macro expands into
;;   (K-HEAD (extr-id-l . K-IDL) . K-ARGS)
;; where extr-id-l is the list of extracted colored identifiers. The
;; extraction itself is performed by the macro extract.

(define-syntax extract*
 (syntax-rules ()
   ;; How to write dirty R5RS macros
   ;; 
http://groups.google.com/groups?selm=87oflzcdwt.fsf%40radish.petrofsky.org
   ;; How to write seemingly unhygienic macros using syntax-rules
   ;; Date: 2001-11-19 01:23:33 PST

   ;; Extract a colored identifier from a form
   ;;    extract SYMB BODY CONT
   ;; BODY is a form that may contain an occurence of an identifier
   ;; that refers to the same binding occurrence as SYMB, perhaps
   ;; with a different color.
   ;; CONT is a form of the shape (K-HEAD K-IDL . K-ARGS)
   ;; where K-IDL are K-ARGS are S-expressions representing lists or
   ;; the empty list.
   ;; The extract macro expands into
   ;;   (K-HEAD (extr-id . K-IDL) . K-ARGS)
   ;; where extr-id is the extracted colored identifier. If symbol
   ;; SYMB does not occur in BODY at all, extr-id is identical to
   ;; SYMB.
   ((_ "extract" symb body _cont)
     (letrec-syntax
        ((tr
          (syntax-rules (symb)
              ((_ x symb tail (cont-head symb-l . cont-args))
               (cont-head (x . symb-l) . cont-args)) ; symb has occurred
              ((_ d (x . y) tail cont)   ; if body is a composite form,
               (tr x x (y . tail) cont)) ; look inside
              ((_ d1 d2 () (cont-head  symb-l . cont-args))
               (cont-head (symb . symb-l) . cont-args)) ; symb does not occur
              ((_ d1 d2 (x . y) cont)
               (tr x x y cont)))))
        (tr body body () _cont)))
   ((_ (symb) body cont)      ; only one symbol: use extract to do the job
    (extract* "extract" symb body cont))
   ((_ _symbs _body _cont)
    (letrec-syntax
         ((ex-aux               ; extract symbol-by-symbol
           (syntax-rules ()
             ((_ found-symbs () body cont)
              (reverse () found-symbs cont))
             ((_ found-symbs (symb . symb-others) body cont)
              (extract* "extract" symb body
                       (ex-aux found-symbs symb-others body cont)))
             ))
          (reverse              ; reverse the list of extracted symbols
           (syntax-rules ()     ; to match the order of SYMB-L
             ((_ res () (cont-head () . cont-args))
              (cont-head res . cont-args))
             ((_ res (x . tail) cont)
              (reverse (x . res) tail cont)))))
      (ex-aux () _symbs _body _cont)))))

;; Surprise: `deftig1` does not work under chicken, but expands
;; perfectly under alexpander.

(define-syntax deftig1
 (syntax-rules ()
   ((_ name body)
    (let-syntax
         ((deftag (syntax-rules ()
                    ((_ (*foo *bar) body_)
                     (define (name x y)
                       (let-syntax
                           ((*foo (syntax-rules () ((_) (x y))))
                            (*bar (syntax-rules () ((_) y))))
                         body_))))))
      (extract* (foo bar) body (deftag () body))))))

(define-syntax deftig
 (syntax-rules ()
   ((_ name body)
    (define (name x y)
      (let-syntax
           ((deftag (syntax-rules ()
                      ((_ (foo bar) body_)
                       (let-syntax
                           ((foo (syntax-rules () ((_) (x y))))
                            (bar (syntax-rules () ((_) y))))
                         body_)))))
         (extract* (foo bar) body (deftag () body)))))))

(deftig f1 (let ((r (+ (foo) (bar) 2.0))) r))

(f1 (lambda (x) (/ x 3.0)) 7) ;; => 11.33~

..........