mes/syntax.mes

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

(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 defines that get closured-in
     ;; mes still has a bug here; 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)
        (display "segment-pattern?: ")
        (display pattern)
        (newline)
        (display "segment-template?: ")
        (display (segment-template? pattern))
        (newline)
        (and (segment-template? pattern)
             (or (null? (cddr pattern))
                 (syntax-error "segment matching not implemented" pattern))))
       
      (define indicators-for-zero-or-more (list (string->symbol "...") '---))

      (define (segment-template? pattern)
        (and (pair? pattern)
             (display "pair?: ")
             (display (pair? pattern))
             (newline)
             (pair? (cdr pattern))
             (display "pair? cdr: ")
             (display (pair? (cdr pattern)))
             (newline)
             ;; (display "indicators: ")
             ;; (display indicators-for-zero-or-more)
             ;; (newline)
             (display "cadr pattern: ")
             (display (cadr pattern))
             (newline)
             (display "memq?: ")
             ;;(memq (cadr pattern) indicators-for-zero-or-more)
             (memq (cadr pattern) (list (string->symbol "...") '---))
             ;;(member (cadr pattern) indicators-for-zero-or-more)
             ))
       
      ;; 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)
        (display "make-transformer") (newline)
        `(lambda (,%input ,%rename ,%compare)
           (let ((,%tail (cdr ,%input)))
             (display "TEEL:") (display ,%tail) (newline)
             (cond ,@(map process-rule rules)
                   (#t ;;else
                    (syntax-error
                     "use of macro doesn't match definition"
                     ,%input))))))

      (define (process-rule rule)
        (display "process-rule") (newline)
        (cond ((and (pair? rule)
                    (pair? (cdr rule))
                    (null? (cddr rule)))
               (let ((pattern (cdar rule))
                     (template (cadr rule)))
                 (let ((xx `,(process-pattern pattern
                                              %tail
                                              (lambda (x) x)))
                       (tt `,%tail)
                       (yy (process-match %tail pattern)))
                   (display "METS>>>") (newline)
                   (display yy)
                   (newline)
                   (display "TEEL>>>") (newline)
                   (display tt)
                   (newline)
                   (display "<<<METS") (newline)
                   (display "PETTERN>>>") (newline)
                   (display xx)
                   (newline)
                   (display "<<<PETTERN") (newline)
                   )
                 
                 `((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)
        (display "process-match") (newline)
        (cond ((name? pattern)
               (cond ((member pattern subkeywords)
                      `((,%compare ,input (,%rename ',pattern))))
                     (#t `())))
              ((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)
        (display "process-segment-match") (newline)
        (let ((conjuncts (process-match '(car l) pattern)))
          (cond ((null? conjuncts)
                 `((list? ,input)))     ;+++
                (#t `((let loop ((l ,input))
                        (display "loop") (newline)
                        (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)
        (display "process-pattern pattern=") (display pattern) (newline)
        (cond ((name? pattern)
               (display "name!") (newline)
               (display "subkeywords: ") (display subkeywords) (newline)
               (cond ((memq pattern subkeywords)
;;;;(member pattern subkeywords)
                      '())
                     (#t
                      (display "hiero mapit=") (display mapit)
                      (display " path=") (display path)
                      (newline)
                      (list (list pattern (mapit path))))))
              ((segment-pattern? pattern)
               (display "segment!") (newline)
               (process-pattern (car pattern)
                                %temp
                                (lambda (x) ;temp is free in x
                                  (display "mapit x=") (display x) (newline)
                                  (mapit (cond ((eq? %temp x)
                                                ;; guile: x=%temp ==> mapit==> (cdr %tail)
                                                ;; mes:   x=%temp ==> mapit==> %temp
                                                (display " x=%temp ==> mapit==> ") (display path) (newline)
                                                path) ;+++
                                               (#t
                                                (display "not!")
                                                `(map (lambda (,%temp) ,x)
                                                      ,path)))))))
              ((pair? pattern)
               (display "pair!") (newline)
               (append (process-pattern (car pattern) `(car ,path) mapit)
                       (process-pattern (cdr pattern) `(cdr ,path) mapit)))
              (#t ;;else
               (display "else!") (newline)
               '())))

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

      (define (process-template template rank env)
        (display "process-template") (newline)
        (cond ((name? template)
               (let ((probe (assq template env)))
                 (cond (probe
                        (cond ((<= (cdr probe) rank)
                               template)
                              (#t (syntax-error "template rank error (too few ...'s?)"
                                                template))))
                       (#t `(,%rename ',template)))))
              ((segment-template? template)
               (let ((vars
                      (free-meta-variables (car template) (+ rank 1) env '())))
                 (cond ((null? vars)
                        (syntax-error "too many ...'s" template))
                       (#t (let* ((x (process-template (car template)
                                                       (+ rank 1)
                                                       env))
                                  (gen (cond ((equal? (list x) vars)
                                              x) ;+++
                                             (#t `(map (lambda ,vars ,x)
                                                       ,@vars)))))
                             (cond ((null? (cddr template))
                                    gen) ;+++
                                   (#t `(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)
        (display "meta-variables") (newline)
        (cond ((name? pattern)
               (cond ((memq pattern subkeywords)
                      vars)
                     (#t (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)
        (display "free-meta-variables") (newline)
        (cond ((name? template)
               (cond ((and (not (memq template free))
                           (let ((probe (assq template env)))
                             (and probe (>= (cdr probe) rank))))
                      (cons template free))
                     (#t 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))
                         (cond (temp temp) (#t (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