(module main scheme/base
  (require scheme/mpair
           (for-syntax scheme/base syntax/kerncase
                       "private/r5rs-trans.ss")
           (only-in mzscheme transcript-on transcript-off))

  (provide (for-syntax syntax-rules ...
                       (rename-out [syntax-rules-only #%top]
                                   [syntax-rules-only #%app]
                                   [syntax-rules-only #%datum]))
           (rename-out
            [mcons cons]
            [mcar car]
            [mcdr cdr]
            [set-mcar! set-car!]
            [set-mcdr! set-cdr!]
            [mpair? pair?]
            [mmap map]
            [mfor-each for-each])
           = < > <= >= max min + - * / 
           abs gcd lcm exp log sin cos tan not eq?
           call-with-current-continuation make-string
           symbol->string string->symbol make-rectangular 
           exact->inexact inexact->exact number->string string->number 
           rationalize output-port? current-input-port current-output-port current-error-port 
           open-input-file open-output-file close-input-port close-output-port
           with-output-to-file transcript-on transcript-off flush-output
           string-length string-ci<=? string-ci>=? string-append 
           string-fill!
           (rename-out [string->mlist string->list]
                       [mlist->string list->string])
           vector-length vector-fill!
           (rename-out [vector->mlist vector->list]
                       [mlist->vector list->vector])
           char-alphabetic? char-numeric? char-whitespace? 
           char-upper-case? char-lower-case? char->integer integer->char char-downcase
           call-with-output-file call-with-input-file with-input-from-file
           (rename-out [mapply apply]) symbol?
           null?
           (rename-out [mlist? list?]
                       [mlist list]
                       [mlength length]
                       [mappend append]
                       [mreverse reverse]
                       [mlist-tail list-tail]
                       [mlist-ref list-ref]
                       [mmemq memq]
                       [mmemv memv]
                       [mmember member]
                       [massq assq]
                       [massv assv]
                       [massoc assoc])
           procedure?
           number? complex? real? rational? integer? exact? inexact? zero?
           positive? negative? odd? even? 
           quotient remainder modulo floor ceiling truncate round 
           numerator denominator asin acos atan sqrt
           expt make-polar real-part imag-part angle magnitude input-port?
           (rename-out [mread read])
           read-char peek-char eof-object?
           char-ready? 
           (rename-out [mwrite write]
                       [mdisplay display])
           newline write-char load 
           string? string string-ref string-set! string=? substring string-copy
           string-ci=? string<? string>? string<=? string>=? string-ci<? string-ci>?
           vector? make-vector vector vector-ref vector-set! 
           char? char=? char<? char>? char<=? char>=? 
           char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? 
           char-upcase boolean? eqv? equal? 
           (rename-out [r5rs:force force])
           call-with-values values dynamic-wind
           (rename-out [meval eval])
           scheme-report-environment null-environment interaction-environment)

  ;; Because mcar and mcdr are inlined by the JIT
  (define-syntax provide-inlined-combo
    (syntax-rules ()
      [(_ id orig mc1r mc2r)
       (begin
         (define-syntax id
           (syntax-id-rules (set!)
             [(_ x) (mc1r (mc2r x))]
             [(set! _ v) (set! orig v)]
             [_ (lambda (x) (mc1r (mc2r x)))]))
         (provide (rename-out [id orig])))]))

  (provide-inlined-combo mcaar caar mcar mcar)
  (provide-inlined-combo mcadr cadr mcar mcdr)
  (provide-inlined-combo mcdar cdar mcdr mcar)
  (provide-inlined-combo mcddr cddr mcdr mcdr)

  (define-syntax (provide-combination stx)
    (syntax-case stx ()
      [(_ id)
       (with-syntax ([body
                      (let loop ([ops (let ([s (symbol->string (syntax-e #'id))])
                                        (string->list (substring s 1 (sub1 (string-length s)))))])
                        (if (null? ops)
                            'x
                            `(,(if (equal? (car ops) #\a) 'mcar 'mcdr)
                              ,(loop (cdr ops)))))]
                     [mid (datum->syntax #'id
                                         (string->symbol (format "m~a" (syntax-e #'id)))
                                         #'id)])
         #'(begin
             (define mid (lambda (x) body))
             (provide (rename-out [mid id]))))]
      [(_ id ...) #'(begin (provide-combination id) ...)]))

  (provide-combination caaar caadr cadar caddr cdaar cdadr cddar cdddr
                       caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
                       cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)


  (define (string->mlist s) (list->mlist (string->list s)))
  (define (mlist->string s) (list->string (mlist->list s)))

  (define (vector->mlist s) (list->mlist (vector->list s)))
  (define (mlist->vector s) (list->vector (mlist->list s)))

  (define mapply
    (case-lambda
     [(f l) (apply f (mlist->list l))]
     [(f l0 . l)
      (apply f (let loop ([l (cons l0 l)])
                 (if (null? (cdr l))
                     (mlist->list (car l))
                     (cons (car l) (loop (cdr l))))))]))

  ;; --------------------------------------------------

  (define mread
    (case-lambda
     [() (mread (current-input-port))]
     [(port) (let loop ([v (read port)])
               (cond
                [(pair? v) (mcons (loop (car v)) (loop (cdr v)))]
                [(vector? v) (list->vector
                              (map loop (vector->list v)))]
                [else v]))]))

  (define mwrite
    (case-lambda
     [(v) (mwrite v (current-output-port))]
     [(v port) (parameterize ([print-mpair-curly-braces #f])
                 (write v port))]))

  (define mdisplay
    (case-lambda
     [(v) (mdisplay v (current-output-port))]
     [(v port) (parameterize ([print-mpair-curly-braces #f])
                 (display v port))]))

  ;; --------------------------------------------------

  (define (to-mutable v)
    (cond
     [(pair? v) (mcons (to-mutable (car v))
                       (to-mutable (cdr v)))]
     [(vector? v) (list->vector
                   (map to-mutable (vector->list v)))]
     [else v]))

  (define-syntax (r5rs:quote stx)
    (syntax-case stx ()
      [(_ form)
       ;; Look for quoted pairs:
       (if (let loop ([form #'form])
             (syntax-case form ()
               [(a . b) #t]
               [#(a ...)
                (ormap loop (syntax->list #'(a ...)))]
               [_ #f]))
           ;; quote has to create mpairs:
           (syntax-local-lift-expression #'(to-mutable 'form))
           ;; no pairs to worry about:
           #'(quote form))]))

   (define-syntax (r5rs:quasiquote stx)
     (syntax-case stx ()
       [(_ form)
        ;; Look for unquote or unquote-splicing.
        ;; This should be improved to discount unquote[-splicing]
        ;; under a nested quasiquote.
        (if (let loop ([form #'form])
              (syntax-case form (unquote unquote-splicing)
                [unquote #t]
                [unquote-splicing #t]
                [(a . b) (or (loop #'a) (loop #'b))]
                [#(a ...)
                 (ormap loop (syntax->list #'(a ...)))]
                [_ #f]))
            ;; Found an unquote[-splicing], so convert:
            (let loop ([form #'form][depth 0])
              (syntax-case form (unquote unquote-splicing r5rs:quasiquote)
                [(unquote e) 
                 (if (zero? depth)
                     #'e
                     #`(mcons 'unquote
                              #,(loop (cdr (syntax-e form)) (sub1 depth))))]
                [unquote
                 (zero? depth)
                 (raise-syntax-error
                  'unquote
                  "invalid context within quasiquote"
                  stx
                  form)]
                [((unquote-splicing e) . rest)
                 (if (zero? depth)
                     (if (null? (syntax-e #'rest))
                         #'e ;; Note: we're not check for a list
                         #`(mappend e #,(loop #'rest depth)))
                     #`(mcons (mcons 'unquote-splicing
                                     #,(loop #'(e) (sub1 depth)))
                              #,(loop #'rest depth)))]
                [unquote-splicing 
                 (zero? depth)
                 (raise-syntax-error
                  'unquote-splicing 
                  "invalid context within quasiquote"
                  stx
                  form)]
                [(r5rs:quasiquote . e)
                 #`(mcons 'quasiquote #,(loop #'e (add1 depth)))]
                [(a . b)
                 #`(mcons #,(loop #'a depth) #,(loop #'b depth))]
                [#(unquote a ...)
                 (raise-syntax-error
                  'unquote
                  "invalid context within quasiquote"
                  stx
                  form)]
                [#(a ...)
                 #`(mlist->vector #,(loop (syntax->list #'(a ...)) depth))]
                [other #'(r5rs:quote other)]))
            ;; None, so just use R5RS quote:
            #'(r5rs:quote form))]))

  ;; Copied from R5rS, but with an added `let' around body,
  ;; and with optimization for precedure letrecs
  (define undefined (letrec ([u u]) u))
  (define-for-syntax (immediate-value? stx)
    (let ([v (syntax-e stx)])
      (or (number? v)
          (boolean? v)
          (string? v)
          (syntax-case stx (r5rs:lambda quote r5rs:quote #%datum)
            [(r5rs:lambda . _rest) #t]
            [(quote . _) #t]
            [(r5rs:quote . _) #t]
            [(#%datum . _) #t]
            [_ #f]))))
  (define-syntax (r5rs:letrec stx)
    (syntax-case stx (r5rs:lambda)
      ((r5rs:letrec ((var1 rhs) ...) body ...)
       (andmap immediate-value? (syntax->list #'(rhs ...)))
       (syntax/loc stx (letrec ((var1 rhs) ...) (r5rs:body body ...))))
      ((r5rs:letrec ((var1 init1) ...) body ...)
       (syntax/loc stx
         (r5rs:letrec "generate_temp_names"
                      (var1 ...)
                      ()
                      ((var1 init1) ...)
                      body ...)))
      ((r5rs:letrec "generate_temp_names"
                    ()
                    (temp1 ...)
                    ((var1 init1) ...)
                    body ...)
       (syntax/loc stx
         (let ((var1 undefined) ...)
           (let ((temp1 init1) ...)
             (set! var1 temp1)
             ...
             (let ()
               (r5rs:body
                body ...))))))
      ((r5rs:letrec "generate_temp_names"
                    (x y ...)
                    (temp ...)
                    ((var1 init1) ...)
                    body ...)
       (syntax/loc stx
         (r5rs:letrec "generate_temp_names"
                      (y ...)
                      (newtemp temp ...)
                      ((var1 init1) ...)
                      body ...)))))

  (define-syntax (r5rs:lambda stx)
    ;; Convert rest-arg list to mlist, and use r5rs:body:
    (syntax-case stx ()
      [(_ (id ...) . body)
       (syntax/loc stx (#%plain-lambda (id ...) (r5rs:body . body)))]
      [(_ (id ... . rest) . body)
       (syntax/loc stx
         (#%plain-lambda (id ... . rest)
                         (let ([rest (list->mlist rest)])
                           (r5rs:body . body))))]))

  (define-syntax (r5rs:define stx)
    ;; Use r5rs:lambda
    (syntax-case stx ()
      [(_ (id . args) . body)
       (with-syntax ([proc
                      (syntax/loc stx
                        (r5rs:lambda args . body))])
         (syntax/loc stx
           (define id proc)))]
      [(_ . rest)
       (syntax/loc stx
         (define . rest))]))

  (define-syntax (r5rs:define-syntax stx)
    ;; Disallow in internal-definition contexts:
    (when (pair? (syntax-local-context))
      (raise-syntax-error
       #f
       "disallowed as an internal definition"
       stx))
    (syntax-case stx ()
      [(_ id expr)
       (identifier? #'id)
       (syntax/loc stx
         (define-syntax id expr))]))

  (define-syntax r5rs:if
    (syntax-rules ()
      [(_ test then)
       (if test then (void))]
      [(_ test then else)
       (if test then else)]))

  ;; Essentially from Dybvig:
  (define-syntax r5rs:delay
    (lambda (x)
      (syntax-case x ()
	((delay exp)
	 (syntax/loc x (make-promise (lambda () exp)))))))
  
  (define-struct promise (p) #:mutable)
  
  (define (r5rs:force p)
    (unless (promise? p)
      (raise-type-error 'force "promise" p))
    (let ([v (promise-p p)])
      (if (procedure? v)
	  (let ([v (call-with-values v list)])
	    (when (procedure? (promise-p p))
	      (set-promise-p! p v))
	    (apply values (promise-p p)))
	  (apply values v))))

  (define-syntax r5rs:let
    (syntax-rules ()
      [(_ (binding ...) . body)
       (let (binding ...) (r5rs:body . body))]
      [(_ id (binding ...) . body)
       (let id (binding ...) (r5rs:body . body))]))
  (define-syntax-rule (r5rs:let* bindings . body)
    (let* bindings (r5rs:body . body)))
  (define-syntax-rule (r5rs:let-syntax bindings . body)
    (let-syntax bindings (r5rs:body . body)))
  (define-syntax-rule (r5rs:letrec-syntax bindings . body)
    (letrec-syntax bindings (r5rs:body . body)))

  (define-syntax (r5rs:body stx)
    (syntax-case stx (let)
      [(_ (let () . body))
       #'(let () . body)]
      [_
       ;; Convert internal definitions to `r5rs:letrec', as opposed
       ;; to `letrec'.
       (let ([def-ctx (syntax-local-make-definition-context)]
             [ctx (list (gensym 'intdef))]
             [kernel-forms (kernel-form-identifier-list)]
             [init-exprs (let ([v (syntax->list stx)])
                           (unless v
                             (raise-syntax-error #f "bad syntax" stx))
                           (cdr v))])
         (with-syntax ([(exprs ((id ...) ...) (rhs ...) (stx-ids ...) (stx-rhs ...))
                        (let loop ([exprs init-exprs]
                                   [idss null][rhss null]
                                   [stx-idss null][stx-rhss null])
                          (if (null? exprs)
                              (raise-syntax-error
                               #f
                               "no expression in body"
                               stx)
                              (let ([expr (local-expand (car exprs) ctx kernel-forms def-ctx)])
                                (syntax-case expr (begin define-syntaxes define-values)
                                  [(begin . rest)
                                   (let ([l (syntax->list #'rest)])
                                     (if l
                                         (loop (append l (cdr exprs)) idss rhss stx-idss stx-rhss)
                                         (raise-syntax-error #f expr "bad syntax")))]
                                  [(define-syntaxes (id ...) rhs)
                                   (andmap identifier? (syntax->list #'(id ...)))
                                   (with-syntax ([rhs (local-transformer-expand
                                                       #'rhs
                                                       'expression
                                                       null)])
                                     (syntax-local-bind-syntaxes
                                      (syntax->list #'(id ...))
                                      #'rhs def-ctx)
                                     (loop (cdr exprs)
                                           idss rhss
                                           (cons #'(id ...) stx-idss)
                                           (cons #'rhs stx-rhss)))]
                                  [(define-values (id ...) rhs)
                                   (andmap identifier? (syntax->list #'(id ...)))
                                   (let ([ids (syntax->list #'(id ...))])
                                     (syntax-local-bind-syntaxes ids #f def-ctx)
                                     (loop (cdr exprs)
                                           (cons #'(id ...) idss)
                                           (cons #'rhs rhss)
                                           stx-idss stx-rhss))]
                                  [else 
                                   (list (cons expr
                                               (map (lambda (expr)
                                                      (local-expand expr ctx kernel-forms def-ctx))
                                                    (cdr exprs)))
                                         (reverse idss) (reverse rhss)
                                         (reverse stx-idss) (reverse stx-rhss))]))))])
           (internal-definition-context-seal def-ctx)
           (if (and (null? (syntax-e #'(stx-rhs ...)))
                    (andmap (lambda (ids)
                              (= 1 (length (syntax->list ids))))
                            (syntax->list #'((id ...) ...))))
               ;; This is the normal case: use `r5rs:letrec':
               #`(r5rs:letrec ([id ... rhs] ...)
                              (let () . exprs))
               ;; Unusual case: need to expand to `set!' manually:
               (with-syntax ([((tmp-id ...) ...)
                              (map (lambda (ids)
                                     (generate-temporaries ids))
                                   (syntax->list #'((id ...) ...)))])
                 #`(letrec-syntaxes+values 
                       ([stx-ids stx-rhs] ...)
                       ([(id ...) (values (mk-undefined id) ...)] ...)
                     (let-values ([(tmp-id ...) rhs] ...)
                       (begin (set! id tmp-id) ...) ...
                       . exprs))))))]))

  (define-syntax-rule (mk-undefined id) undefined)
    
  (provide unquote unquote-splicing 
	   (rename-out [r5rs:quote quote]
                       [r5rs:quasiquote quasiquote]
                       [r5rs:if if]
                       [r5rs:lambda lambda]
                       [r5rs:letrec letrec]
                       [r5rs:define define]
                       [r5rs:define-syntax define-syntax]
                       [r5rs:delay delay]
                       [r5rs:let let]
                       [r5rs:let* let*]
                       [r5rs:let-syntax let-syntax]
                       [r5rs:letrec-syntax letrec-syntax])
           and or cond case do
	   begin set!
           => else

	   ;; We have to include the following Racket-isms to do anything,
	   ;; but they're not legal R5RS names, anyway.
           (rename-out [#%plain-module-begin #%module-begin])
	   #%app #%datum #%top #%top-interaction 
           #%require #%provide #%expression)
  
  ;; --------------------------------------------------

  (define-namespace-anchor here)

  (define (scheme-report-environment n)
    (unless (= n 5)
      (raise-type-error 'scheme-report-environment "5" n))
    (mk-r5rs #f))

  (define (null-environment n)
    (unless (= n 5)
      (raise-type-error 'null-environment "5" n))
    (mk-r5rs #t))

  (define (mk-r5rs stx-only?)
    (let ([n (namespace-anchor->empty-namespace here)])
      (parameterize ([current-namespace n])
        (if stx-only?
            (namespace-require '(only r5rs
                                      quote quasiquote
                                      if lambda letrec
                                      let and or cond case define delay do
                                      let* begin set!
                                      define-syntax let-syntax letrec-syntax
                                      => else
                                      #%app #%datum #%top #%top-interaction
                                      #%require #%provide #%expression))
            (begin
              (namespace-require 'r5rs) ; for syntax
              (namespace-require/copy 'r5rs))))
      n))

  (define (interaction-environment)
    (current-namespace))

  (define (meval expr env)
    (eval (let loop ([expr expr])
            (cond
             [(mpair? expr)
              (cons (loop (mcar expr))
                    (loop (mcdr expr)))]
             [(vector? expr)
              (list->vector (map loop (vector->list expr)))]
             [else expr]))
          env)))