mes/syntax.mes

;;(define else #t)
(define (syntax-error message thing)
  (display "syntax-error:")
  (display message)
  (display ":")
  ;;(display thing)
  (newline))

(define (member x lst)
  (display "MEMBER x=") (display x) (newline) (memq x lst))
(display "mes:define-syntax...")

;;(define (caddr x) (car (cdr (cdr x))))
;; (define (caddr x)
;;   (display "wanna caddr:")
;;   (display x)
;;   (newline))

;; (define-macro mes:define-syntax
;;   (lambda (form expander)
;;      (expander `(define-macro ,(cadr form)
;;                   (let ((transformer ,(caddr form)))
;;                     (lambda (form expander)
;;                       (expander (transformer form
;;                                              (lambda (x) x)
;;                                              eq?)
;;                                 expander))))
;;                expander)))

;; (define (dinges form expander)
;;   (display "dinges form:")
;;   (display form)
;;   (newline)
;;   `(define-macro BOO ;;;,(cadr form)
;;      (let ((transformer ,(caddr form)))
;;        (lambda (form expander)
;;          (expander (transformer form
;;                                 (lambda (x) x)
;;                                 eq?)
;;                    expander)))))

;; (define-macro (mes:define-syntax form expander)
;;   `(expander (dinges form expander)
;;              expander))

(define-macro (mes:define-syntax macro-name transformer . stuff)
  ;; (display "mes:define-syntax:")
  ;; (newline)
  ;; (display   `(define-macro (,macro-name . args)
  ;;    (,transformer (cons ',macro-name args)
  ;;                  (lambda (x) x)
  ;;                  eq?)))
  ;; (newline)
  `(define-macro (,macro-name . args)
     (,transformer (cons ',macro-name args)
                             (lambda (x) x)
                             eq?)
     ))

;; (define-macro (mes:define-syntax form expander)
;;   (expander `(define-macro ,(cadr form)
;;                (let ((transformer ,(caddr form)))
;;                  (lambda (form expander)
;;                    (expander (transformer form
;;                                           (lambda (x) x)
;;                                           eq?)
;;                              expander))))
;;             expander))

;; (define-macro (mes:define-syntax form expander)
;;   (expander `(define-macro ((cadr form) form expander) 
;;                (let ((transformer (caddr form)))
;;                  (expander (transformer form
;;                                         (lambda (x) x)
;;                                         eq?)
;;                            expander)))
;;             expander))

(newline)


(display "mes:define-syntax syntax-rules...")
(newline)

(mes:define-syntax syntax-rules
   (;; let () ;; syntax-rules uses (let () ...),
              ;; mes doesn't support that yet; use ((lambda () ...))
    (lambda ()

      ;; syntax-rules uses defines that get closured-in
      ;; mes doesn't support that yet; move down
      ;; (define name? symbol?)

      ;; (define (segment-pattern? pattern)
      ;;   (and (segment-template? pattern)
      ;;        (or (null? (cddr pattern))
      ;;            (syntax-error "segment matching not implemented" pattern))))
      
      ;; (define (segment-template? pattern)
      ;;   (and (pair? pattern)
      ;;        (pair? (cdr pattern))
      ;;        (memq (cadr pattern) indicators-for-zero-or-more)))
      
      ;; (define indicators-for-zero-or-more (list (string->symbol "...") '---))
    
     (display "BOOO")

     (lambda (exp r c)

       ;; FIXME: mes, moved down 
       (define name? symbol?)
       
       (define (segment-pattern? pattern)
         (and (segment-template? pattern)
              (or (null? (cddr pattern))
                  (syntax-error "segment matching not implemented" pattern))))
       
       (define (segment-template? pattern)
         (and (pair? pattern)
              (pair? (cdr pattern))
              (memq (cadr pattern) indicators-for-zero-or-more)))
       
       (define indicators-for-zero-or-more (list (string->symbol "...") '---))
       ;; end FIXME
    

       (define %input (r '%input))      ;Gensym these, if you like.
       (define %compare (r '%compare))
       (define %rename (r '%rename))
       (define %tail (r '%tail))
       (define %temp (r '%temp))

       (define rules (cddr exp))
       (define subkeywords (cadr exp))

       (define (make-transformer rules)
         `(lambda (,%input ,%rename ,%compare)
            (let ((,%tail (cdr ,%input)))
              (cond ,@(map process-rule rules)
                    (#t ;;else
                     (syntax-error
                      "use of macro doesn't match definition"
                      ,%input))))))

       (define (process-rule rule)
         (if (and (pair? rule)
                  (pair? (cdr rule))
                  (null? (cddr rule)))
             (let ((pattern (cdar rule))
                   (template (cadr rule)))
               `((and ,@(process-match %tail pattern))
                 (let* ,(process-pattern pattern
                                         %tail
                                         (lambda (x) x))
                   ,(process-template template
                                      0
                                      (meta-variables pattern 0 '())))))
             (syntax-error "ill-formed syntax rule" rule)))

       ;; Generate code to test whether input expression matches pattern

       (define (process-match input pattern)
         (cond ((name? pattern)
                (if (member pattern subkeywords)
                    `((,%compare ,input (,%rename ',pattern)))
                    `()))
               ((segment-pattern? pattern)
                (process-segment-match input (car pattern)))
               ((pair? pattern)
                `((let ((,%temp ,input))
                    (and (pair? ,%temp)
                         ,@(process-match `(car ,%temp) (car pattern))
                         ,@(process-match `(cdr ,%temp) (cdr pattern))))))
               ((or (null? pattern) (boolean? pattern) (char? pattern))
                `((eq? ,input ',pattern)))
               (#t ;;else
                `((equal? ,input ',pattern)))))

       (define (process-segment-match input pattern)
         (let ((conjuncts (process-match '(car l) pattern)))
           (if (null? conjuncts)
               `((list? ,input))        ;+++
               `((let loop ((l ,input))
                   (or (null? l)
                       (and (pair? l)
                            ,@conjuncts
                            (loop (cdr l)))))))))

       ;; Generate code to take apart the input expression
       ;; This is pretty bad, but it seems to work (can't say why).

       (define (process-pattern pattern path mapit)
         (cond ((name? pattern)
                (if (memq pattern subkeywords)
                    '()
                    (list (list pattern (mapit path)))))
               ((segment-pattern? pattern)
                (process-pattern (car pattern)
                                 %temp
                                 (lambda (x) ;temp is free in x
                                   (mapit (if (eq? %temp x)
                                              path ;+++
                                              `(map (lambda (,%temp) ,x)
                                                    ,path))))))
               ((pair? pattern)
                (append (process-pattern (car pattern) `(car ,path) mapit)
                        (process-pattern (cdr pattern) `(cdr ,path) mapit)))
               (#t ;;else
                '())))

       ;; Generate code to compose the output expression according to template

       (define (process-template template rank env)
         (cond ((name? template)
                (let ((probe (assq template env)))
                  (if probe
                      (if (<= (cdr probe) rank)
                          template
                          (syntax-error "template rank error (too few ...'s?)"
                                        template))
                      `(,%rename ',template))))
               ((segment-template? template)
                (let ((vars
                       (free-meta-variables (car template) (+ rank 1) env '())))
                  (if (null? vars)
                      (syntax-error "too many ...'s" template)
                      (let* ((x (process-template (car template)
                                                  (+ rank 1)
                                                  env))
                             (gen (if (equal? (list x) vars)
                                      x ;+++
                                      `(map (lambda ,vars ,x)
                                            ,@vars))))
                        (if (null? (cddr template))
                            gen         ;+++
                            `(append ,gen ,(process-template (cddr template)
                                                             rank env)))))))
               ((pair? template)
                `(cons ,(process-template (car template) rank env)
                       ,(process-template (cdr template) rank env)))
               (#t ;;else
                `(quote ,template))))

       ;; Return an association list of (var . rank)

       (define (meta-variables pattern rank vars)
         (cond ((name? pattern)
                (if (memq pattern subkeywords)
                    vars
                    (cons (cons pattern rank) vars)))
               ((segment-pattern? pattern)
                (meta-variables (car pattern) (+ rank 1) vars))
               ((pair? pattern)
                (meta-variables (car pattern) rank
                                (meta-variables (cdr pattern) rank vars)))
               (#t ;;else
                vars)))

       ;; Return a list of meta-variables of given higher rank

       (define (free-meta-variables template rank env free)
         (cond ((name? template)
                (if (and (not (memq template free))
                         (let ((probe (assq template env)))
                           (and probe (>= (cdr probe) rank))))
                    (cons template free)
                    free))
               ((segment-template? template)
                (free-meta-variables (car template)
                                     rank env
                                     (free-meta-variables (cddr template)
                                                          rank env free)))
               ((pair? template)
                (free-meta-variables (car template)
                                     rank env
                                     (free-meta-variables (cdr template)
                                                          rank env free)))
               (#t ;;else
                free)))

       c                                ;ignored

       (display "HELLO")
       (newline)

       ;; Kludge for Scheme48 linker.
       ;; `(cons ,(make-transformer rules)
       ;;          ',(find-free-names-in-syntax-rules subkeywords rules))

       (make-transformer rules)))))


(mes:define-syntax mes:or
  (syntax-rules ()
    ((mes:or) #f)
    ((mes:or e) e)
    ((mes:or e1 e ...) (let ((temp e1))
                      (if temp temp (or e ...))))))

(display "(mes:or #f (= 0 1) 'hello-syntax-world): ")
(display (mes:or #f (= 0 1) 'hello-syntax-world))
(display (mes:or #f '==>baaa))
(newline)

(mes:define-syntax mes:when
  (syntax-rules ()
    ((when condition exp ...)
     (if condition
         (begin exp ...)))))

(display (mes:when #t "when:hello syntax world"))

;; (define-macro (when cond exp . rest)
;;   `(if ,cond
;;        (begin ,exp . ,rest)))


;; (define-macro (when clause . rest)
;;   (list 'cond (list clause (list 'let '() rest))))
(newline)
'syntax-dun