mes/scaffold/boot/60-let-syntax.scm

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.

(define-macro (and . x)
  (if (null? x) #t
      (if (null? (cdr x)) (car x)
          (list (quote if) (car x) (cons (quote and) (cdr x))
                #f))))

(define-macro (or . x)
  (if (null? x) #f
      (if (null? (cdr x)) (car x)
          (list (list (quote lambda) (list (quote r))
                      (list (quote if) (quote r) (quote r)
                            (cons (quote or) (cdr x))))
                (car x)))))

(define else #t)
(define-macro (cond . clauses)
  (list 'if (pair? clauses)
        (list (cons
               'lambda
               (cons
                '(test)
                (list (list 'if 'test
                            (if (pair? (cdr (car clauses)))
                                (if (eq? (car (cdr (car clauses))) '=>)
                                    (append2 (cdr (cdr (car clauses))) '(test))
                                    (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
                                (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
                            (if (pair? (cdr clauses))
                                (cons 'cond (cdr clauses)))))))
              (car (car clauses)))))

(define (memq x lst)
  (if (null? lst) #f
      (if (eq? x (car lst)) lst
          (memq x (cdr lst)))))

  (define (symbol? x)
    (eq? (core:type x) <cell:symbol>))

  (define (string? x)
    (eq? (core:type x) <cell:string>))

  (define (vector? x)
    (eq? (core:type x) <cell:vector>))

(define (cons* . rest)
  (if (null? (cdr rest)) (car rest)
      (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))

(define (apply f h . t)
  (if (null? t) (core:apply f h (current-module))
      (apply f (apply cons* (cons h t)))))

(define (append . rest)
  (if (null? rest) '()
      (if (null? (cdr rest)) (car rest)
          (append2 (car rest) (apply append (cdr rest))))))

(define-macro (quasiquote x)
  (define (loop x)
    (if (vector? x) (list 'list->vector (loop (vector->list x)))
        (if (not (pair? x)) (cons 'quote (cons x '()))
            (if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
                (if (eq? (car x) 'unquote) (cadr x)
                    (if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
                        ((lambda (d)
                           (list 'append (car (cdr (car x))) d))
                         (loop (cdr x)))
                        ((lambda (a d)
                           (if (pair? d)
                               (if (eq? (car d) 'quote)
                                   (if (and (pair? a) (eq? (car a) 'quote))
                                       (list 'quote (cons (cadr a) (cadr d)))
                                       (if (null? (cadr d))
                                           (list 'list a)
                                           (list 'cons* a d)))
                                   (if (memq (car d) '(list cons*))
                                       (cons (car d) (cons a (cdr d)))
                                       (list 'cons* a d)))
                               (list 'cons* a d)))
                         (loop (car x))
                         (loop (cdr x)))))))))
  (loop x))

(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))

(define-macro (simple-let bindings . rest)
  (cons (cons 'lambda (cons (map car bindings) rest))
        (map cadr bindings)))

(define-macro (xsimple-let bindings rest)
  `(,`(lambda ,(map car bindings) ,@rest)
    ,@(map cadr bindings)))

(define-macro (xnamed-let name bindings rest)
  `(simple-let ((,name *unspecified*))
     (set! ,name (lambda ,(map car bindings) ,@rest))
     (,name ,@(map cadr bindings))))

(define-macro (let bindings-or-name . rest)
  (if (symbol? bindings-or-name) ;; IF
      `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
      `(xsimple-let ,bindings-or-name ,rest)))

(define (expand-let* bindings body)
  (if (null? bindings)
      `((lambda () ,@body))
      `((lambda (,(caar bindings))
          ,(expand-let* (cdr bindings) body))
        ,@(cdar bindings))))

(define-macro (let* bindings . body)
  (expand-let* bindings body))

(define (equal2? a b)
  (if (and (null? a) (null? b)) #t
      (if (and (pair? a) (pair? b))
          (and (equal2? (car a) (car b))
               (equal2? (cdr a) (cdr b)))
          (if (and (string? a) (string? b))
              (eq? (string->symbol a) (string->symbol b))
              (if (and (vector? a) (vector? b))
                  (equal2? (vector->list a) (vector->list b))
                  (eq? a b))))))

(define equal? equal2?)
(define (member x lst)
  (if (null? lst) #f
      (if (equal2? x (car lst)) lst
          (member x (cdr lst)))))

(define (<= . rest)
  (or (apply < rest)
      (apply = rest)))

(define (>= . rest)
  (or (apply > rest)
      (apply = rest)))

(define (list? x)
  (or (null? x)
      (and (pair? x) (list? (cdr x)))))

;; -*-scheme-*-

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; syntax.mes is loaded after scm.mes.  It provides the R5RS hygienic
;;; macros define-syntax, syntax-rules and define-syntax-rule.
;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm

;;; Code:

;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.

;;; scheme48-1.1/COPYING

;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
;; All rights reserved.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. The name of the authors may not be used to endorse or promote products
;;    derived from this software without specific prior written permission.

;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


(cond-expand
 (guile)
 (mes
  (define-macro (define-syntax macro-name transformer . stuff)
    `(define-macro (,macro-name . args)
       (,transformer (cons ',macro-name args)
                     (lambda (x0) x0)
                     eq?)))))

;; Rewrite-rule compiler (a.k.a. "extend-syntax")

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

(cond-expand
 (guile)
 (mes
  (define-syntax syntax-rules
    (let ()
      (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 "...") '---))

      (lambda (exp r c)

        (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)
          ;;(core:display-error "make-transformer:") (core:write-error rules) (core:display-error "\n")
          `(lambda (,%input ,%rename ,%compare)
             (let ((,%tail (cdr ,%input)))
               (cond ,@(map process-rule rules)
                     (else
                      (syntax-error
                       "use of macro doesn't match definition"
                       ,%input))))))

        (define (process-rule rule)
          ;;(core:display-error "process-rule:") (core:write-error rule) (core:display-error "\n")
          (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)
          ;;(core:display-error "process-match:") (core:write-error input) (core:display-error "\n")
          ;;(core:display-error "      pattern:") (core:write-error pattern) (core:display-error "\n")
          (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)))
                (else
                 `((equal? ,input ',pattern)))))

        (define (process-segment-match input pattern)
          ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
          ;;(core:display-error "              pattern:") (core:write-error pattern) (core:display-error "\n")
          (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)
          ;;(core:display-error "process-pattern:") (core:write-error pattern) (core:display-error "\n")
          ;;(core:display-error "           path:") (core:write-error path) (core:display-error "\n")
          (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)))
                (else '())))

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

        (define (process-template template rank env)
          ;;(core:display-error "process-template:") (core:write-error template) (core:display-error "\n")
          (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)
                       (silent-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)))
                (else `(quote ,template))))

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

        (define (meta-variables pattern rank vars)
          ;;(core:display-error "meta-variables:") (core:write-error pattern) (core:display-error "\n")
          (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)))
                (else vars)))

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

        (define (free-meta-variables template rank env free)
          ;;(core:display-error "meta-variables:") (core:write-error template) (core:display-error "\n")
          (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)))
                (else free)))

        c                               ;ignored

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

        (make-transformer rules))))))

(cond-expand
 (guile)
 (mes
  (define-macro (let-syntax bindings . rest)
    `((lambda ()
        ,@(map (lambda (binding)
                 `(define-macro (,(car binding) . args)
                    (,(cadr binding) (cons ',(car binding) args)
                     (lambda (x0) x0)
                     eq?)))
               bindings)
        ,@rest)))))

(core:display
 (let-syntax ((xwhen (syntax-rules ()
                       ((xwhen condition exp ...)
                        (if (not condition)
                            (begin exp ...))))))
   (xwhen #f 42)))