guile-prescheme/ps-compiler/prescheme/ps-syntax.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey
;;;
;;;   scheme48-1.9.2/ps-compiler/prescheme/ps-syntax.scm
;;;
;;; Redefine CASE so that it doesn't call MEMV

(define-module (ps-compiler prescheme ps-syntax))

;; TODO: port prescheme macros to syntax-case

#|
(define-syntax case
  (lambda (e r c)
    (let ((x (r 'x))
          (xlet (r 'let))
          (xcond (r 'cond))
          (xif (r 'if))
          (xeq? (r 'eq?))
          (xquote (r 'quote)))
      (let ((test (lambda (y)
                    `(,xeq? ,x (,xquote ,y)))))
        `(,xlet ((,x ,(cadr e)))
                (,xcond . ,(map (lambda (clause)
                                  (if (c (car clause) 'else)
                                      clause
                                      `(,(let label ((xs (car clause)))
                                           (cond ((null? xs) #f)
                                                 ((null? (cdr xs))
                                                  (test (car xs)))
                                                 (else
                                                  `(,xif ,(test (car xs))
                                                         #t
                                                         ,(label (cdr xs))))))
                                        . ,(cdr clause))))
                                (cddr e))))))))

;; RECEIVE (from big-scheme)

(define-syntax receive
  (syntax-rules ()
    ((receive ?vars ?producer . ?body)
     (call-with-values (lambda () ?producer)
                       (lambda ?vars . ?body)))))


(define-syntax external
  (lambda (e r c)
    (let ((l (length e)))
      (if (and (or (= l 3) (= l 4))
               (string? (cadr e)))
          `(,(r 'real-external) ,(cadr e) ',(caddr e))
          e))))

;; DEFINE-EXTERNAL-ENUMERATION (from prescheme)

(define-syntax define-external-enumeration
  (lambda (form rename compare)
    (let* ((name (cadr form))
           (symbol->upcase-string
            (lambda (s)
              (list->string (map (lambda (c)
                                   (if (char=? c #\-)
                                       #\_
                                       (char-upcase c)))
                                 (string->list (symbol->string s))))))
           (constant
            (lambda (sym string)
              `(,(rename 'make-external-constant) ',name ',sym ,string)))
           (conc (lambda things
                   (string->symbol (apply string-append
                                          (map (lambda (thing)
                                                 (if (symbol? thing)
                                                     (symbol->string thing)
                                                     thing))
                                               things)))))
           (var-name
            (lambda (sym)
              (conc name "/" sym)))
           (components
            (list->vector
             (map (lambda (stuff)
                    (if (pair? stuff)
                        (cons (car stuff)
                              (var-name (car stuff)))
                        (cons stuff
                              (var-name stuff))))
                  (caddr form))))
           (%define (rename 'define))
           (%define-syntax (rename 'define-syntax))
           (%begin (rename 'begin))
           (%quote (rename 'quote))
           (%make-external-constant (rename 'make-external-constant))
           (e-name (conc name '- 'enumeration))
           (count (vector-length components)))
      `(,%begin
        (,%define-syntax ,name
            (let ((components ',components))
              (lambda (e r c)
                (let ((key (cadr e)))
                  (cond ((c key 'enum)
                         (let ((which (caddr e)))
                           (let loop ((i 0)) ;;vector-posq
                             (if (< i ,count)
                                 (if (c which (car (vector-ref components i)))
                                     (r (cdr (vector-ref components i)))
                                     (loop (+ i 1)))
                                 ;; (syntax-error "unknown enumerand name"
                                 ;;               `(,(cadr e) ,(car e) ,(caddr e)))
                                 e))))
                        (else e))))))
        (,%define ,(conc name '- 'count) ,count)
        . ,(map (lambda (stuff)
                  (if (pair? stuff)
                      `(,%define ,(var-name (car stuff))
                           (,%make-external-constant ',name
                                                     ',(car stuff)
                                                     ,(cadr stuff)))
                      `(,%define ,(var-name stuff)
                           (,%make-external-constant ',name
                                                     ',stuff
                                                     ,(symbol->upcase-string stuff)))))
                (caddr form)))))
    (begin define define-syntax quote external make-external-constant))
|#