;;; File: ir-macros.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Jun 20, 2011
;;;;       Jun 22, 2011
;;;;       Jul 11, 2011
;;;;       Jul 22, 2011
;;;;       Aug 02, 2011
;;;;       Aug 15, 2011
;;;;       Aug 28, 2011


;This module does to implicit renaming macros, which are new to
;chicken-4.7.0, what the er-macros module did to explicit renaming ones.
;
(require 'contracts)

(module ir-macros
  ;; ir-macro-rules is passed through from contract-helpers
  (ir-macros ir-macro-rules ir-macro-define ir-macro-let ir-macro-letrec)
(import scheme contracts)
(import-for-syntax (only contracts ir-macro-rules))

;;; initialize documentation
(doclist
  '((ir-macro-rules
      "implicit-renaming version of syntax-rules"
      (ir-macro-rules (sym ...) (pat0 xpr0) (pat1 xpr1) ...)
      "where sym ... are injected symbols, xpr0 ... evaluate to
templates, which are usually backquoted expressions and the one
corresponding to the first matching pattern is evaluated")))

;As an application of the ir-macro-rules macro from the contracts module
;we'll implement some further macros which will make the writing of
;implicit-renaming macros easier. For example, ir-macro-define will have
;the same syntax as define-macro from earlier Chicken implementations,
;so that an implementation of an or macro would look as follows:

;  (ir-macro-define (my-or . args)
;    (if (null? args)
;      #f
;      (let ((tmp (car args)))
;        `(if ,tmp ,tmp (my-or ,@(cdr args))))))

;;; (ir-macro-define code xpr . xprs) 
;;; ---------------------------------
;;; where code is the complete macro-code (name . args), i.e. the
;;; pattern of a macro call, and xpr . xprs expressions which generate
;;; the macro-expansion. In case the body xpr . xprs is of the form
;;; (with (sym ...) xpr . xprs) the local namespace is polluted by 
;;; unhygienic injected symbols sym ...
(define-syntax-with-contract ir-macro-define
  "implicit reanaming variant of syntax-rules"
  (syntax-rules (with-injected)
    ((_ (name . args) (with-injected (sym ...) xpr . xprs))
    ;; sym ... are unhygienic injected symbols
     (define-syntax name
       (ir-macro-rules (sym ...)
         ((_ . args) (begin xpr . xprs)))))
    ;; hygienic
    ((_ (name . args) xpr . xprs)
     (ir-macro-define (name . args) (with-injected () xpr . xprs)))))

;ir-macro-let and ir-macro-letrec are local versions of ir-macro-define,
;where the local macros are evaluated in parallel or recursively. For
;example

;  (let ((f (lambda (n) (+ n 10))))
;    (ir-macro-let (
;      ((f n) n)
;      ((g n) `(f ,n))
;      )
;      (display (list (f 1) (g 1))) (newline)))
;
;will result in (1 11) while  
;
;  (let ((f (lambda (n) (+ n 10))))
;    (ir-macro-letrec (
;      ((f n)  n)
;      ((g n) `(f ,n))
;      )
;      (display (list (f 1) (g 1))) (newline)))
;
;returns (1 1).
;
;;; (helper op pairs . body)
;;; ------------------------
;;; Since ir-macro-let and ir-macro-letrec have the same code except
;;; that the former evaluates to a let-syntax and the latter to a
;;; letrec-syntax, this helper starts with the op argument, which is to
;;; be replaced by either let-syntax or letrec-syntax.
(define-syntax helper
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((op (cadr form)) (pairs (caddr form)) (body (cdddr form)))
        (let (
          (pats (map car pairs))
          (bodies (map cdr pairs))
          (with? (lambda (lst)
                 (and (null? (cdr lst))
                      (list? (car lst))
                      (compare? (caar lst) 'with-injected))))
          )
          (let (
            (syms (map (lambda (b)
                         (if (with? b)
                           (cadar b)
                           '()))
                       bodies))
            (xprs (map (lambda (b)
                         (if (with? b)
                           (cddar b)
                           b))
                       bodies))
            )
            `(,op (
               ,@(map (lambda (p s x)
                        `(,(car p)
                           (ir-macro-rules ,s ((_ ,@(cdr p))
                             (begin ,@x)))))
                      pats syms xprs)
               )
               ,@body)))))))

;;; (ir-macro-let ((code xpr . xprs) ...) . body)
;;; ---------------------------------------------
;;; where code and xpr . xprs are as in ir-macro-define. This is
;;; a local version of ir-macro-define, allowing a list of
;;; (code xpr . xprs) lists to be processed in body in parallel.
(define-syntax-with-contract ir-macro-let
  "implicit-renaming macro-let, pairing macro-code with macro-body
in the declaration part"
  (syntax-rules ()
    ((_ ((code xpr . xprs) ...) . body)
     (helper let-syntax ((code xpr . xprs) ...) . body))))

;;; (ir-macro-letrec ((code xpr . xprs) ...) . body)
;;; ------------------------------------------------
;;; where code and xpr . xprs are as in ir-macro-define.
;;; Local version of ir-macro-define, allowing a list of
;;; (code xpr . xprs) lists to be processed in body recursively.

(define-syntax-with-contract ir-macro-letrec
  "implicit-renaming macro-letrec, pairing macro-code with macro-body
in the declaration part"
  (syntax-rules ()
    ((_ ((code xpr . xprs) ...) . body)
     (helper letrec-syntax ((code xpr . xprs) ...) . body))))

;;; save documentation
(define ir-macros (doclist->dispatcher (doclist)))

) ; module ir-macros