guile-prescheme/prescheme/bcomp/usual.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
;;;
;;;   scheme48-1.9.2/scheme/bcomp/usual.scm
;;;
;;; This is file usual.scm.

(define-module (prescheme bcomp usual)
  #:use-module (prescheme scheme48)
  #:use-module (prescheme bcomp name)
  #:export (usual-transform))

;;;; Macro expanders for the standard macros

(define the-usual-transforms (make-table))

(define (define-usual-macro name proc aux-names)
  (table-set! the-usual-transforms
              name
              (cons proc aux-names)))

(define (usual-transform name)
  (or (table-ref the-usual-transforms name)
      (assertion-violation 'usual-transform  "no such transform" name)))

;; Ordinarily we would write #f instead of ,#f below.  However, it is
;; useful (although decreasingly so) to be able compile Scheme 48
;; images using a Scheme system that does not distinguish #f from ().
;; In this case, the cross-compiler treats the expression #f (= ()) as
;; boolean false, and any () (= #f) in a quoted constant as the empty
;; list.  If we were to write `(if ... #f) then this would be seen in
;; the *target* system as `(if ... ()), which would be a syntax error.

(define-usual-macro 'and
  (lambda (exp r c)
    (let ((conjuncts (cdr exp)))
      (cond ((null? conjuncts) `#t)
            ((null? (cdr conjuncts)) (car conjuncts))
            (else `(,(r 'if) ,(car conjuncts)
                       (,(r 'and) ,@(cdr conjuncts))
                       ,#f)))))
  '(if and))

;; Tortuously crafted so as to avoid the need for an (unspecific)
;; procedure.  Unspecific values come from IF forms.

(define-usual-macro 'cond
  (lambda (exp r c)
    (let ((clauses (cdr exp)))
      (if (or (null? clauses)
              (not (every list? clauses)))
          exp
          (car (let recur ((clauses clauses))
                 (if (null? clauses)
                     '()
                     (list
                      (let ((clause (car clauses))
                            (more (recur (cdr clauses))))
                        (cond ((c (car clause) (r 'else))
                               ;; (if (not (null? more)) ...error...)
                               `(,(r 'begin) ,@(cdr clause)))
                              ((null? (cdr clause))
                               `(,(r 'or) ,(car clause)
                                          ,@more))
                              ((c (cadr clause) (r '=>))
                               (let ((temp (r 'temp)))
                                 (if (null? (cddr clause))
                                     exp
                                     `(,(r 'let)
                                       ((,temp ,(car clause)))
                                       (,(r 'if) ,temp
                                                 (,(caddr clause) ,temp)
                                                 ,@more)))))
                              (else
                               `(,(r 'if) ,(car clause)
                                          (,(r 'begin) ,@(cdr clause))
                                          ,@more)))))))))))
  '(or cond begin let if begin))

(define-usual-macro 'do
  (lambda (exp r c)
    (if (and (pair? (cdr exp))
             (pair? (cddr exp)))
        (let ((specs (cadr exp))
              (end (caddr exp))
              (body (cdddr exp))
              (%loop (r 'loop))
              (%letrec (r 'letrec))
              (%lambda (r 'lambda))
              (%cond (r 'cond)))
          (if (and (list? specs)
                   (every do-spec? specs)
                   (list? end))
              `(,%letrec ((,%loop
                           (,%lambda ,(map car specs)
                                     (,%cond ,end
                                             (else ,@body
                                                   (,%loop
                                                    ,@(map (lambda (spec)
                                                             (if (null? (cddr spec))
                                                                 (car spec)
                                                                 (caddr spec)))
                                                           specs)))))))
                         (,%loop ,@(map cadr specs)))
              exp))
        exp))
  '(letrec lambda cond))

(define (do-spec? s)
  (and (pair? s)
       (name? (car s))
       (pair? (cdr s))
       (let ((rest (cddr s)))
         (or (null? rest)
             (and (pair? rest)
                  (null? (cdr rest)))))))

(define-usual-macro 'let
  (lambda (exp r c)
    (if (pair? (cdr exp))
        (let ((specs (cadr exp))
              (body (cddr exp))
              (%lambda (r 'lambda)))
          (if (name? specs)
              (let ((tag specs)
                    (specs (car body))
                    (body (cdr body))
                    (%letrec (r 'letrec)))
                (if (specs? specs)
                    `((,%letrec ((,tag (,%lambda ,(map car specs) ,@body)))
                                ,tag)
                      ,@(map cadr specs))
                    exp))
              (if (specs? specs)
                  `((,%lambda ,(map car specs) ,@body)
                    ,@(map cadr specs))
                  exp)))
        exp))
  '(lambda letrec))

(define-usual-macro 'let*
  (lambda (exp r c)
    (if (pair? (cdr exp))
        (let ((specs (cadr exp))
              (body (cddr exp)))
          (if (specs? specs)
              (if (or (null? specs)
                      (null? (cdr specs)))
                  `(,(r 'let) ,specs ,@body)
                  `(,(r 'let) (,(car specs))
                              (,(r 'let*) ,(cdr specs) ,@body)))
              exp))
        exp))
  '(let let*))

(define (specs? x)
  (or (null? x)
      (and (pair? x)
           (let ((s (car x)))
             (and (pair? s)
                  (name? (car s))
                  (pair? (cdr s))
                  (null? (cddr s))))
           (specs? (cdr x)))))

(define-usual-macro 'or
  (lambda (exp r c)
    (let ((disjuncts (cdr exp)))
      (cond ((null? disjuncts)
             #f)  ;;not '#f
            ((not (pair? disjuncts))
             exp)
            ((null? (cdr disjuncts))
             (car disjuncts))
            (else
             (let ((temp (r 'temp)))
               `(,(r 'let) ((,temp ,(car disjuncts)))
                  (,(r 'if) ,temp
                            ,temp
                            (,(r 'or) ,@(cdr disjuncts)))))))))
  '(let if or))

;; CASE needs auxiliary MEMV.

(define-usual-macro 'case
  (lambda (exp r c)
    (if (and (list? (cdr exp))
             (every (lambda (clause)
                      (case-clause? clause c (r 'else)))
                    (cddr exp)))
        (let ((key (cadr exp))
              (clauses (cddr exp))
              (temp (r 'temp))
              (%eqv? (r 'eqv?))
              (%eq? (r 'eq?))     ;;+++ hack for symbols
              (%memv (r 'memv))
              (%quote (r 'quote))
              (%else (r 'else)))
          `(,(r 'let)
            ((,temp ,key))
            (,(r 'cond)
             ,@(map (lambda (clause)
                      `(,(cond ((c (car clause) %else)
                                (car clause))
                               ((null? (car clause))
                                #f)
                               ((null? (cdar clause)) ;;+++
                                `(,(if (symbol? (caar clauses)) %eq? %eqv?)
                                    ,temp
                                    (,%quote ,(caar clause))))
                               (else
                                `(,%memv ,temp (,%quote ,(car clause)))))
                        ,@(cdr clause)))
                    clauses))))
        exp))
  '(let cond eqv? eq? memv quote))

(define (case-clause? c compare %else)
  (and (list? c)
       (let ((head (car c)))
         (or (null? head)
             (compare head %else)
             (list? head)))))

;; Quasiquote

(define-usual-macro 'quasiquote
  (lambda (exp r c)

    (define %quote (r 'quote))
    (define %quasiquote (r 'quasiquote))
    (define %unquote (r 'unquote))
    (define %unquote-splicing (r 'unquote-splicing))
    (define %append (r 'append))
    (define %cons (r 'cons))
    (define %list (r 'list))
    (define %list->vector (r 'list->vector))

    (define (expand-quasiquote x level)
      (descend-quasiquote x level finalize-quasiquote))

    (define (finalize-quasiquote mode arg)
      (cond ((eq? mode 'quote) `(,%quote ,arg))
            ((eq? mode 'unquote)
             (if (and (pair? arg)
                      (null? (cdr arg)))
                 (car arg)
                 (syntax-violation 'quasiquote ", in invalid context" arg)))
            ((eq? mode 'unquote-splicing)
             (syntax-violation 'quasiquote ",@ in invalid context" arg))
            (else `(,mode ,@arg))))

    (define (descend-quasiquote x level return)
      (cond ((vector? x)
             (descend-quasiquote-vector x level return))
            ((not (pair? x))
             (return 'quote x))
            ((interesting-to-quasiquote? x %quasiquote)
             (descend-quasiquote-pair x (+ level 1) return))
            ((interesting-to-quasiquote? x %unquote)
             (cond ((= level 0)
                    (return 'unquote (cdr x)))
                   (else
                    (descend-quasiquote-pair x (- level 1) return))))
            ((interesting-to-quasiquote? x %unquote-splicing)
             (cond ((= level 0)
                    (return 'unquote-splicing (cdr x)))
                   (else
                    (descend-quasiquote-pair x (- level 1) return))))
            (else
             (descend-quasiquote-pair x level return))))

    ;; RETURN gets called with two arguments: an operator and an "arg":
    ;; If the operator is UNQUOTE or UNQUOTE-SPLICING, the "arg"
    ;; is the list of operands of the UNQUOTE resp. UNQUOTE-SPLICING form.
    (define (descend-quasiquote-pair x level return)
      (descend-quasiquote (car x) level
        (lambda (car-mode car-arg)
          (descend-quasiquote (cdr x) level
            (lambda (cdr-mode cdr-arg)
              (cond ((and (eq? car-mode 'quote)
                          (eq? cdr-mode 'quote))
                     (return 'quote x))
                    ((eq? car-mode 'unquote)
                     (if (and (pair? car-arg)
                              (null? (cdr car-arg)))
                         (return %cons  ;; +++
                                 (list (car car-arg)
                                       (finalize-quasiquote cdr-mode cdr-arg)))
                         (return %append
                                 (list (cons %list car-arg)
                                       (finalize-quasiquote cdr-mode cdr-arg)))))

                    ((eq? car-mode 'unquote-splicing)
                     ;; (,@mumble ...)
                     (if (and (eq? cdr-mode 'quote) (null? cdr-arg) ;; +++
                              (pair? car-arg) (null? (cdr car-arg)))
                         (return 'unquote car-arg)
                         (return %append
                                 (append car-arg
                                         (list (finalize-quasiquote
                                                cdr-mode cdr-arg))))))
                    (else
                     (return %cons
                             (list (finalize-quasiquote car-mode car-arg)
                                   (finalize-quasiquote cdr-mode cdr-arg))))))))))

    (define (descend-quasiquote-vector x level return)
      (descend-quasiquote (vector->list x) level
        (lambda (mode arg)
          (case mode
            ((quote) (return 'quote x))
            (else (return %list->vector
                          (list (finalize-quasiquote mode arg))))))))

    (define (interesting-to-quasiquote? x marker)
      (and (pair? x)
           (c (car x) marker)))

    (if (and (pair? (cdr exp))
             (null? (cddr exp)))
        (expand-quasiquote (cadr exp) 0)
        exp))
  '(append cons list->vector quasiquote unquote unquote-splicing))


;;(define (tst e)
;;  (let ((probe (usual-transform (car e))))
;;    ((car probe) e (lambda (x) x) eq?)))