-port

               read
               read-char
               peek-char
               eof-object?
               char-ready?

               write
               display
               newline
               write-char

               ;;transcript-on
               ;;transcript-off
               )

  #:export (null-environment
            syntax-rules cond case))

;;; These definitions of `cond', `case', and `syntax-rules' differ from
;;; the ones in Guile in that they expect their auxiliary syntax (`_',
;;; `...', `else', and `=>') to be unbound.  They also don't support
;;; some extensions from Guile (e.g. `=>' in `case'.).

(define-syntax syntax-rules
  (lambda (x)
    (define (replace-underscores pattern)
      (syntax-case pattern (_)
        (_ #'^_)
        ((x . y)
         (with-syntax ((x (replace-underscores #'x))
                       (y (replace-underscores #'y)))
           #'(x . y)))
        ((x . y)
         (with-syntax ((x (replace-underscores #'x))
                       (y (replace-underscores #'y)))
           #'(x . y)))
        (#(x ^...)
         (with-syntax (((x ^...) (map replace-underscores #'(x ^...))))
           #'#(x ^...)))
        (x #'x)))
    (syntax-case x ()
      ((^_ dots (k ^...) . clauses)
       (identifier? #'dots)
       #'(with-ellipsis dots (syntax-rules (k ^...) . clauses)))
      ((^_ (k ^...) ((keyword . pattern) template) ^...)
       (with-syntax (((pattern ^...) (replace-underscores #'(pattern ^...))))
         #`(lambda (x)
             (syntax-case x (k ^...)
               ((dummy . pattern) #'template)
               ^...)))))))

(define-syntax case
  (lambda (stx)
    (let lp ((stx stx))
      (syntax-case stx (else)
        (("case" x)
         #'(if #f #f))
        (("case" x ((y ^...) expr ^...) clause ^...)
         #`(if (memv x '(y ^...))
               (begin expr ^...)
               #,(lp #'("case" x clause ^...))))
        (("case" x (else expr ^...))
         #'(begin expr ^...))
        (("case" x clause . ^_)
         (syntax-violation 'case "bad 'case' clause" #'clause))
        ((^_ x clause clause* ^...)
         #`(let ((t x))
             #,(lp #'("case" t clause clause* ^...))))))))

(define-syntax cond
  (lambda (stx)
    (let lp ((stx stx))
      (syntax-case stx (else =>)
        (("cond")
         #'(if #f #f))
        (("cond" (else expr ^...))
         #'(begin expr ^...))
        (("cond" (test => expr) clause ^...)
         #`(let ((t test))
             (if t
                 (expr t)
                 #,(lp #'("cond" clause ^...)))))
        (("cond" (test) clause ^...)
         #`(or test #,(lp #'("cond" clause ^...))))
        (("cond" (test expr ^...) clause ^...)
         #`(if test
               (begin expr ^...)
               #,(lp #'("cond" clause ^...))))
        (("cond" clause . ^_)
         (syntax-violation 'cond "bad 'cond' clause" #'clause))
        ((^_ clause clause* ^...)
         (lp #'("cond" clause clause* ^...)))))))

(define (null-environment n)
  (unless (eqv? n 5)
    (scm-error 'misc-error 'null-environment
               "~A is not a valid version" (list n) '()))
  ;; Note that we need to create a *fresh* interface
  (let ((interface (make-module)))
    (set-module-kind! interface 'interface)
    (define bindings
      '(define quote lambda if set! cond case and or let let* letrec
	 begin do delay quasiquote unquote
         define-syntax let-syntax letrec-syntax syntax-rules))
    (module-use! interface
                 (resolve-interface '(ice-9 safe-r5rs) #:select bindings))
    interface))