(module core-syntax '#%kernel

  ; ======================================================================
  ; Many of the base syntactic forms of Racket-- things like `and`, `let`,
  ; and `cond`. These are written together in a single module for startup
  ; time reasons, and this module forms a nice base for defining the rest
  ; of `#lang racket/base`.
  ; ======================================================================
  ;

  (#%require (for-syntax "stx.rkt" '#%kernel))

  (#%provide define define-syntax define-for-syntax
             define-values-for-syntax
             when unless
             call/ec let/ec
             cond else =>
             let*-values
             let let* letrec
             quasiquote
             and or)

  (module* old-cond #f
    (#%provide old-cond))

  ; --------------------------------------------------
  ;
  ;
  ;        ;             ;;;;   ;                                        ;                                    ;                 ;
  ;        ;            ;                                               ;                                     ;                  ;
  ;        ;            ;                                              ;                                      ;                   ;
  ;     ;;;;    ;;;     ;     ;;;     ; ;;;     ;;;                    ;      ; ;;;     ;;    ; ;;;           ;   ;  ;  ;  ;      ;
  ;    ;   ;   ;   ;  ;;;;;;    ;     ;;   ;   ;   ;                  ;       ;;   ;   ;  ;   ;;   ;          ;  ;   ;  ;  ;       ;
  ;   ;    ;  ;    ;    ;       ;     ;    ;  ;    ;                  ;       ;    ;  ;    ;  ;    ;          ; ;    ; ; ; ;       ;
  ;   ;    ;  ;;;;;;    ;       ;     ;    ;  ;;;;;;                  ;       ;    ;  ;    ;  ;    ;          ;;     ; ; ; ;       ;
  ;   ;    ;  ;         ;       ;     ;    ;  ;                       ;       ;    ;  ;    ;  ;    ;          ;;     ; ; ; ;       ;
  ;   ;    ;  ;         ;       ;     ;    ;  ;                        ;      ;    ;  ;    ;  ;    ;          ; ;    ; ; ; ;      ;
  ;   ;   ;;   ;        ;       ;     ;    ;   ;                       ;      ;    ;   ;  ;   ;    ;          ;  ;    ;   ;       ;
  ;    ;;; ;    ;;;;    ;       ;;;   ;    ;    ;;;;                    ;     ;    ;    ;;    ;    ;          ;   ;   ;   ;      ;
  ;                                                  ;;;;;;;             ;                                                      ;
  ;                                                                       ;                                                    ;
  ;
  ;
  ; non-keyword define* forms
  ;


  ; define, define-syntax, and define-for-syntax
  ;
  ; These are not user-visible (they get replaced by the full versions which
  ; use the norm-define.rkt machinery and support keywords) and so we put
  ; minimal effort into having user-friendly error reporting.
  (define-syntaxes (define define-syntax define-for-syntax)
    (let-values ()
      (define-values (process-define*)
        (lambda (full-stx id-or-prototype body-list)
          (if (identifier? id-or-prototype)
              (values id-or-prototype body-list)
              (if (stx-pair? id-or-prototype)
                  (let-values ([(nested) (stx-car id-or-prototype)]
                               [(arg-spec) (stx-cdr id-or-prototype)])
                    (process-define* full-stx
                                     nested
                                     (list (datum->syntax #f
                                                          (list* (quote-syntax lambda)
                                                                 arg-spec
                                                                 body-list)
                                                          full-stx))))
                  (raise-syntax-error #f "bad syntax" full-stx id-or-prototype)))))

      (define-values (process-define)
        (lambda (head-for-output-form stx)
          (define-values (lst) (syntax->list stx))
          (raise-syntax-error-unless lst "bad syntax" stx)
          (raise-syntax-error-unless (pair? (cdr lst)) "bad syntax" stx)
          (define-values (id rhs-list)
            (process-define* stx (cadr lst) (cddr lst)))
          (datum->syntax #f
                         (list* head-for-output-form (list id) rhs-list)
                         stx)))

    (values
     (lambda (stx)
       (process-define (quote-syntax define-values) stx))
     (lambda (stx)
      (process-define (quote-syntax define-syntaxes) stx))
     (lambda (stx)
      (datum->syntax #f
                     (list (quote-syntax begin-for-syntax)
                           (process-define (quote-syntax define-values) stx))
                     stx)))))

  ; define-values-for-syntax: this one is public
  (define-syntaxes (define-values-for-syntax)
    (lambda (stx)
      (raise-syntax-error-if (identifier? stx) "bad syntax" stx)
      (define-values (lst) (syntax->list stx))
      (raise-syntax-error-unless lst "bad syntax (illegal use of `.')" stx)
      (raise-syntax-error-if (null? (cdr lst)) "bad syntax (missing names to define)" stx)
      (define-values (ids) (syntax->list (cadr lst)))
      (raise-syntax-error-unless ids
                                 "bad syntax (expected a list of identifiers)"
                                 stx
                                 (cadr lst))
      (for-each (lambda (id)
                  (raise-syntax-error-unless (identifier? id) "not an identifier" stx id))
                ids)
      ; TODO(jsailor): April 2026-ish: uncomment when raise-if-duplicate-identifiers is committed
      ;(raise-if-duplicate-identifiers "duplicate identifier" stx ids)
      (raise-syntax-error-if (null? (cddr lst)) "bad syntax (missing expression after identifiers)" stx)
      (raise-syntax-error-if (pair? (cdddr lst)) "bad syntax (multiple expressions after identifiers)" stx)
      (datum->syntax #f
                     (list (quote-syntax begin-for-syntax)
                           (datum->syntax #f
                                          (list* (quote-syntax define-values) (cdr lst))
                                          stx))
                     stx)))

  ; --------------------------------------------------
  ;
  ;
  ;           ;                            ;                  ;;;
  ;           ;                            ;                    ;
  ;           ;                           ;                     ;
  ;  ;  ;  ;  ; ;;;     ;;;   ; ;;;       ;   ;    ;  ; ;;;     ;       ;;;    ;;;;    ;;;;
  ;  ;  ;  ;  ;;   ;   ;   ;  ;;   ;     ;    ;    ;  ;;   ;    ;      ;   ;  ;    ;  ;    ;
  ;  ; ; ; ;  ;    ;  ;    ;  ;    ;    ;     ;    ;  ;    ;    ;     ;    ;  ;       ;
  ;  ; ; ; ;  ;    ;  ;;;;;;  ;    ;    ;     ;    ;  ;    ;    ;     ;;;;;;   ;;      ;;
  ;  ; ; ; ;  ;    ;  ;       ;    ;   ;      ;    ;  ;    ;    ;     ;          ;;      ;;
  ;  ; ; ; ;  ;    ;  ;       ;    ;   ;      ;    ;  ;    ;    ;     ;            ;       ;
  ;   ;   ;   ;    ;   ;      ;    ;  ;       ;   ;;  ;    ;    ;      ;      ;    ;  ;    ;
  ;   ;   ;   ;    ;    ;;;;  ;    ;  ;        ;;; ;  ;    ;    ;;;     ;;;;   ;;;;    ;;;;
  ;
  ;
  ; when and unless
  ;

  (define-syntaxes (when)
    (lambda (stx)
      (define-values (lst) (syntax->list stx))
      (raise-syntax-error-unless (pair? lst) "bad syntax" stx)
      (raise-syntax-error-if (null? (cdr lst)) "bad syntax (missing test expression and body)" stx)
      (raise-syntax-error-if (null? (cddr lst)) "bad syntax (missing body)" stx)
      (datum->syntax (quote-syntax here)
                     (list (quote-syntax if)
                           (cadr lst)
                           (list* (quote-syntax let-values)
                                  (quote-syntax ())
                                  (cddr lst))
                           (quote-syntax (void)))
                     stx)))

  (define-syntaxes (unless)
    (lambda (stx)
      (define-values (lst) (syntax->list stx))
      (raise-syntax-error-unless (pair? lst) "bad syntax" stx)
      (raise-syntax-error-if (null? (cdr lst)) "bad syntax (missing test expression and body)" stx)
      (raise-syntax-error-if (null? (cddr lst)) "bad syntax (missing body)" stx)
      (datum->syntax (quote-syntax here)
                     (list (quote-syntax if)
                           (cadr lst)
                           (quote-syntax (void))
                           (list* (quote-syntax let-values)
                                  (quote-syntax ())
                                  (cddr lst)))
                     stx)))

  ; --------------------------------------------------
  ;
  ;
  ;                   ;;;     ;;;          ;                          ;;;                          ;
  ;                     ;       ;          ;                            ;               ;          ;
  ;                     ;       ;         ;                             ;               ;         ;
  ;     ;;;;    ;;;;    ;       ;         ;     ;;;     ;;;;            ;       ;;;     ;         ;     ;;;     ;;;;
  ;    ;       ;   ;    ;       ;        ;     ;   ;   ;                ;      ;   ;  ;;;;;;     ;     ;   ;   ;
  ;   ;       ;    ;    ;       ;       ;     ;    ;  ;                 ;     ;    ;    ;       ;     ;    ;  ;
  ;   ;       ;    ;    ;       ;       ;     ;;;;;;  ;                 ;     ;;;;;;    ;       ;     ;;;;;;  ;
  ;   ;       ;    ;    ;       ;      ;      ;       ;                 ;     ;         ;      ;      ;       ;
  ;   ;       ;    ;    ;       ;      ;      ;       ;                 ;     ;         ;      ;      ;       ;
  ;    ;      ;   ;;    ;       ;     ;        ;       ;                ;      ;        ;     ;        ;       ;
  ;     ;;;;   ;;; ;    ;;;     ;;;   ;         ;;;;    ;;;;            ;;;     ;;;;     ;;;  ;         ;;;;    ;;;;
  ;
  ;
  ; call/ec and let/ec
  ;

  (define-values (call/ec) call-with-escape-continuation)

  (define-syntaxes (let/ec)
    (lambda (stx)
      (define-values (lst) (syntax->list stx))
      (raise-syntax-error-unless (pair? lst) "bad syntax" stx)
      (define-values (len) (length lst))
      (raise-syntax-error-if (= len 1) "bad syntax (missing identifier and body)" stx)
      (raise-syntax-error-if (= len 2) "bad syntax (missing body)" stx)
      (datum->syntax (quote-syntax here)
                     (list (quote-syntax call-with-escape-continuation)
                           (datum->syntax #f
                                          (list* (quote-syntax lambda)
                                                 (list (cadr lst))
                                                 (stx-cdr (stx-cdr stx)))
                                          stx))
                     stx)))

  ; --------------------------------------------------
  ;
  ;
  ;                                ;
  ;                                ;
  ;                                ;
  ;     ;;;;    ;;    ; ;;;     ;;;;
  ;    ;       ;  ;   ;;   ;   ;   ;
  ;   ;       ;    ;  ;    ;  ;    ;
  ;   ;       ;    ;  ;    ;  ;    ;
  ;   ;       ;    ;  ;    ;  ;    ;
  ;   ;       ;    ;  ;    ;  ;    ;
  ;    ;       ;  ;   ;    ;  ;   ;;
  ;     ;;;;    ;;    ;    ;   ;;; ;
  ;
  ;
  ; `cond`
  ;

  (define-syntaxes (=>)
    (lambda (stx)
      (raise-syntax-error #f "arrow not allowed as an expression" stx)))

  (define-syntaxes (else)
    (lambda (stx)
      (raise-syntax-error #f "not allowed as an expression" stx)))

  ;; old-cond is like cond, but uses unbound `=>' and `else'

  (define-syntaxes (cond old-cond)
    (let-values ([(go)
                  (let-values ([(here) (quote-syntax here)])
                    (lambda (in-form =>-stx else-stx track-disappeared-uses?)
                      (if (identifier? in-form)
                          (raise-syntax-error #f "bad syntax" in-form)
                          (void))
                      (let-values
                          ([(expansion disappeared-uses)
                            (let-values ([(form) (stx-cdr in-form)]
                                         [(serror)
                                          (lambda (msg at)
                                            (raise-syntax-error #f msg in-form at))])
                              (letrec-values ([(loop)
                                               (lambda (tests)

                                                 (if (stx-null? tests)
                                                     (values (quote-syntax (void)) '())
                                                     (if (not (stx-pair? tests))
                                                         (serror
                                                          "bad syntax (body must contain a list of pairs)"
                                                          tests)
                                                         (let-values ([(line) (stx-car tests)]
                                                                      [(rest) (stx-cdr tests)])
                                                           (if (not (stx-pair? line))
                                                               (serror
                                                                "bad syntax (clause is not a test-value pair)"
                                                                line)
                                                               (letrec-values ([(test) (stx-car line)]
                                                                               [(value) (stx-cdr line)]
                                                                               [(else?) (if (identifier? test)
                                                                                            (free-identifier=? test else-stx)
                                                                                            #f)])
                                                                 (if (if else? (stx-pair? rest) #f)
                                                                     (serror "bad syntax (`else' clause must be last)" line)
                                                                     (void))
                                                                 (if (if (not else?)
                                                                         (if (stx-pair? value)
                                                                             (if (identifier? (stx-car value))
                                                                                 (free-identifier=? (stx-car value) =>-stx)
                                                                                 #f)
                                                                             #f)
                                                                         #f)
                                                                     (if (if (stx-pair? (stx-cdr value))
                                                                             (stx-null? (stx-cdr (stx-cdr value)))
                                                                             #f)
                                                                         (let-values ([(exp d-u) (loop rest)])
                                                                           (let-values ([(gen) 'cond-val])
                                                                             (values
                                                                              (list (quote-syntax let-values)
                                                                                    (list (list (list gen) test))
                                                                                    (list (quote-syntax if)
                                                                                          gen
                                                                                          (list (stx-car (stx-cdr value)) gen)
                                                                                          exp))
                                                                              (cons (syntax-local-introduce (stx-car value))
                                                                                    d-u))))
                                                                         (serror
                                                                          "bad syntax (bad clause form with =>)"
                                                                          line))
                                                                     (if else?
                                                                         (if (stx-null? value)
                                                                             (serror
                                                                              "missing expressions in `else' clause"
                                                                              line)
                                                                             (values (list* (quote-syntax let-values)
                                                                                            (quote-syntax ())
                                                                                            value)
                                                                                     (list (syntax-local-introduce test))))
                                                                         (let-values ([(exp d-u) (loop rest)])
                                                                           (values
                                                                            (if (stx-null? value)
                                                                                (let-values ([(gen) 'cond-val])
                                                                                  (list (quote-syntax let-values)
                                                                                        (list (list (list gen) test))
                                                                                        (list (quote-syntax if)
                                                                                              gen gen exp)))
                                                                                (list
                                                                                 (quote-syntax if) test
                                                                                 (list* (quote-syntax let-values)
                                                                                        (quote-syntax ())
                                                                                        value)
                                                                                 exp))
                                                                            d-u)))))))))
                                                 )])
                                (loop form)))])
                        (let-values ([(expansion-stx) (datum->syntax here expansion in-form)])
                          (if (if (not track-disappeared-uses?) #t (null? disappeared-uses))
                              expansion-stx
                              (syntax-property expansion-stx 'disappeared-use disappeared-uses))))))])
      (values
       (lambda (stx) (go stx (quote-syntax =>) (quote-syntax else) #t))
       (lambda (stx) (go stx (datum->syntax #f '=>) (datum->syntax #f 'else) #f)))))

  ; --------------------------------------------------
  ;
  ;
  ;   ;;;                                ;;;;
  ;     ;               ;               ;
  ;     ;               ;               ;
  ;     ;       ;;;     ;               ;       ;;     ; ;;; ; ;; ;;   ;;;;
  ;     ;      ;   ;  ;;;;;;          ;;;;;;   ;  ;    ;;  ; ;; ;; ;  ;    ;
  ;     ;     ;    ;    ;               ;     ;    ;   ;   ; ;  ;  ;  ;
  ;     ;     ;;;;;;    ;               ;     ;    ;   ;     ;  ;  ;   ;;
  ;     ;     ;         ;               ;     ;    ;   ;     ;  ;  ;     ;;
  ;     ;     ;         ;               ;     ;    ;   ;     ;  ;  ;       ;
  ;     ;      ;        ;               ;      ;  ;    ;     ;  ;  ;  ;    ;
  ;     ;;;     ;;;;     ;;;            ;       ;;     ;     ;  ;  ;   ;;;;
  ;
  ;
  ; let, let*, letrec, let-values
  ;

  
  (define-syntaxes (let*-values let let* letrec)
    (let-values ([(lambda-stx) (quote-syntax lambda-stx)]
                 [(letrec-values-stx) (quote-syntax letrec-values)]
                 [(check-for-duplicates)
                  (lambda (new-bindings sel stx)
                    (define-values (id-in-list?)
                      (lambda (id l)
                        (if (null? l)
                            #f
                            (if (bound-identifier=? id (car l)) 
                                #t
                                (id-in-list? id (cdr l))))))
                    (if ((length new-bindings) . > . 5)
                        (let-values ([(ht) (make-hasheq)])
                          (letrec-values ([(check) (lambda (l)
                                                     (if (null? l)
                                                         (void)
                                                         (let-values ([(id) (sel (car l))])
                                                           (let-values ([(idl) (hash-ref ht (syntax-e id) null)])
                                                             (if (id-in-list? id idl)
                                                                 (raise-syntax-error
                                                                  #f
                                                                  "duplicate identifier"
                                                                  stx
                                                                  id)
                                                                 (begin
                                                                   (hash-set! ht (syntax-e id) (cons id idl))
                                                                   (check (cdr l))))))))])
                                         (check new-bindings)))
                        (letrec-values ([(check) (lambda (l accum)
                                                   (if (null? l)
                                                       (void)
                                                       (let-values ([(id) (sel (car l))])
                                                         (if (id-in-list? id accum)
                                                             (raise-syntax-error
                                                              #f
                                                              "duplicate identifier"
                                                              stx
                                                              id)
                                                             (check (cdr l) (cons id accum))))))])
                                       (check new-bindings null))))])
      (let-values ([(go)
                    (lambda (stx named? star? target)
                      (define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
                      (define-values (stx-2list?)
                        (lambda (x)
                          (if (stx-pair? x)
                              (if (stx-pair? (stx-cdr x))
                                  (stx-null? (stx-cdr (stx-cdr x)))
                                  #f)
                              #f)))
                      (let-values ([(maybe-msg)
                                    (if (not (stx-list? stx))
                                        ""
                                        (let-values ([(tail1) (stx-cdr stx)])
                                          (if (stx-null? tail1)
                                              (if named?
                                                  "(missing name or binding pairs)"
                                                  "(missing binding pairs)")
                                              (if (stx-null? (stx-cdr tail1))
                                                  (if named?
                                                      "(missing binding pairs or body)"
                                                      "(missing body)")
                                                  (if named?
                                                      (if (symbol? (syntax-e (stx-car tail1)))
                                                          (if (stx-null? (stx-cdr (stx-cdr tail1)))
                                                              "(missing body)"
                                                              #f)
                                                          #f)
                                                      #f)))))])
                        (if maybe-msg
                            (raise-syntax-error #f (string-append "bad syntax " maybe-msg) stx)
                            (void)))
                      (let-values ([(name) (if named?
                                               (let-values ([(n) (stx-cadr stx)])
                                                 (if (symbol? (syntax-e n))
                                                     n
                                                     #f))
                                               #f)])
                        (let-values ([(bindings) (stx->list (stx-cadr (if name
                                                                          (stx-cdr stx)
                                                                          stx)))]
                                     [(body) (stx-cdr (stx-cdr (if name
                                                                   (stx-cdr stx)
                                                                   stx)))])
                          (if (not bindings)
                              (raise-syntax-error 
                               #f 
                               "bad syntax (not a sequence of identifier--expression bindings)" 
                               stx
                               (stx-cadr stx))
                              (let-values ([(new-bindings)
                                            (letrec-values ([(loop)
                                                             (lambda (l)
                                                               (if (null? l)
                                                                   null
                                                                   (let-values ([(binding) (car l)])
                                                                     (cons
                                                                      (if (stx-2list? binding)
                                                                          (if (symbol? (syntax-e (stx-car binding)))
                                                                              (if name
                                                                                  (cons (stx-car binding)
                                                                                        (stx-cadr binding))
                                                                                  (datum->syntax
                                                                                   lambda-stx
                                                                                   (cons (cons (stx-car binding)
                                                                                               null)
                                                                                         (stx-cdr binding))
                                                                                   binding))
                                                                              (raise-syntax-error 
                                                                               #f 
                                                                               "bad syntax (not an identifier)" 
                                                                               stx
                                                                               (stx-car binding)))
                                                                          (raise-syntax-error 
                                                                           #f 
                                                                           "bad syntax (not an identifier and expression for a binding)" 
                                                                           stx
                                                                           binding))
                                                                      (loop (cdr l))))))])
                                              (loop bindings))])
                                (if star?
                                    (void)
                                    (check-for-duplicates new-bindings 
                                                          (if name
                                                              car
                                                              (lambda (v) (stx-car (stx-car v))))
                                                          stx))
                                (datum->syntax
                                 lambda-stx
                                 (if name
                                     (apply list
                                            (list 
                                             (quote-syntax letrec-values)
                                             (list
                                              (list
                                               (list name)
                                               (list* (quote-syntax lambda)
                                                      (apply list (map car new-bindings))
                                                      body)))
                                             name)
                                            (map cdr new-bindings))
                                     (list* target
                                            new-bindings
                                            body))
                                 stx))))))])
        (values
         (lambda (stx)
           (define-values (bad-syntax)
             (lambda ()
               (raise-syntax-error #f "bad syntax" stx)))
           (define-values (l) (syntax->list stx))
           (if (not l) (bad-syntax) (void))
           (if ((length l) . < . 3) (bad-syntax) (void))
           (define-values (bindings) (syntax->list (cadr l)))
           (if (not bindings) (raise-syntax-error #f "bad syntax" stx (cadr l)) (void))
           (for-each (lambda (binding)
                       (define-values (l) (syntax->list binding))
                       (if (if (not l)
                               #t
                               (not (= 2 (length l))))
                           (raise-syntax-error #f "bad syntax" stx binding)
                           (void))
                       (define-values (vars) (syntax->list (car l)))
                       (if (not vars) (raise-syntax-error #f "bad syntax" stx (car l)) (void))
                       (for-each (lambda (var)
                                   (if (not (symbol? (syntax-e var)))
                                       (raise-syntax-error 
                                        #f 
                                        "bad syntax (not an identifier)" 
                                        stx
                                        var)
                                       (void)))
                                 vars)
                       (check-for-duplicates vars values stx))
                     bindings)
           (define-values (gen)
             (lambda (bindings nested?)
               (if (null? bindings)
                   (if nested?
                       (cddr l)
                       (list* (quote-syntax let-values) '() (cddr l)))
                   ((if nested? list values)
                    (list* (quote-syntax let-values) (list (car bindings)) (gen (cdr bindings) #t))))))
           (datum->syntax #f (gen bindings #f) stx stx))
         (lambda (stx) (go stx #t #f (quote-syntax let-values)))
         (lambda (stx) (go stx #f #t (quote-syntax let*-values)))
         (lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))

  ; --------------------------------------------------
  ;
  ;
  ;     ;;;;    ;;;;
  ;    ;   ;   ;   ;
  ;   ;    ;  ;    ;
  ;   ;    ;  ;    ;
  ;   ;    ;  ;    ;
  ;   ;    ;  ;    ;
  ;   ;   ;;  ;   ;;
  ;    ;;; ;   ;;; ;
  ;        ;       ;
  ;        ;       ;
  ;        ;       ;
  ;
  ;
  ; quasiquote
  ;

  (define-values (qq-append)
    (lambda (a b)
      (if (list? a)
	  (append a b)
	  (raise-argument-error 'unquote-splicing "list?" a))))

  (define-syntaxes (quasiquote)
    (let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
                 [(unquote-stx) (quote-syntax unquote)]
                 [(unquote-splicing-stx) (quote-syntax unquote-splicing)])
      (lambda (in-form)
	(if (identifier? in-form)
	    (raise-syntax-error #f "bad syntax" in-form)
            (void))
	(let-values
	    (((form) (if (stx-pair? (stx-cdr in-form))
			 (if (stx-null? (stx-cdr (stx-cdr in-form)))
			     (stx-car (stx-cdr in-form))
			     (raise-syntax-error #f "bad syntax" in-form))
			 (raise-syntax-error #f "bad syntax" in-form)))
	     ((normal)
	      (lambda (x old)
		(if (eq? x old)
		    (if (stx-null? x) 
			(quote-syntax ())
			(list (quote-syntax quote) x))
		    x)))
	     ((apply-cons)
	      (lambda (a d)
		(if (stx-null? d)
		    (list (quote-syntax list) a)
		    (if (if (pair? d)
			    (if (free-identifier=? (quote-syntax list) (car d))
				#t
				(free-identifier=? (quote-syntax list*) (car d)))
			    #f)
			(list* (car d) a (cdr d))
			(list (quote-syntax list*) a d))))))
	  (datum->syntax
	   here
	   (normal
	    (letrec-values
		(((qq)
		  (lambda (x level)
		    (let-values
			(((qq-list)
			  (lambda (x level)
			    (let-values
				(((old-first) (stx-car x)))
			      (let-values
				  (((old-second) (stx-cdr x)))
				(let-values
				    (((first) (qq old-first level)))
				  (let-values
				      (((second) (qq old-second level)))
				    (let-values
					()
				      (if (if (eq? first old-first)
					      (eq? second old-second)
					      #f)
					  x
					  (apply-cons
					   (normal first old-first)
					   (normal second old-second)))))))))))
		      (if (stx-pair? x)
			  (let-values
			      (((first) (stx-car x)))
			    (if (if (if (identifier? first)
					(free-identifier=? first unquote-stx)
					#f)
				    (stx-list? x)
				    #f)
				(let-values
				    (((rest) (stx-cdr x)))
				  (if (let-values
					  (((g35) (not (stx-pair? rest))))
					(if g35 g35 (not (stx-null? (stx-cdr rest)))))
				      (raise-syntax-error
				       'unquote
				       "expects exactly one expression"
				       in-form
				       x)
                                      (void))
				  (if (zero? level)
				      (stx-car rest)
				      (qq-list x (sub1 level))))
				(if (if (if (identifier? first)
					    (free-identifier=? first (quote-syntax quasiquote))
					    #f)
					(stx-list? x)
					#f)
				    (qq-list x (add1 level))
				    (if (if (if (identifier? first)
						(free-identifier=? first unquote-splicing-stx)
						#f)
					    (stx-list? x)
					    #f)
					(raise-syntax-error
					 'unquote-splicing
					 "invalid context within quasiquote"
					 in-form
					 x)
					(if (if (stx-pair? first)
						(if (identifier? (stx-car first))
						    (if (free-identifier=? (stx-car first)
                                                                           unquote-splicing-stx)
							(stx-list? first)
							#F)
						    #f)
						#f)
					    (let-values
						(((rest) (stx-cdr first)))
					      (if (let-values
						      (((g34) (not (stx-pair? rest))))
						    (if g34
							g34
							(not (stx-null? (stx-cdr rest)))))
						  (raise-syntax-error
						   'unquote
						   "expects exactly one expression"
						   in-form
						   x)
                                                  (void))
					      (let-values
						  (((uqsd) (stx-car rest))
						   ((old-l) (stx-cdr x))
						   ((l) (qq (stx-cdr x) level)))
						(if (zero? level)
						    (let-values
							(((l) (normal l old-l)))
                                                      (if (stx-null? l)
                                                          uqsd
                                                          (list (quote-syntax qq-append)
                                                                uqsd l)))
						    (let-values
							(((restx) (qq-list rest (sub1 level))))
						      (let-values
							  ()
							(if (if (eq? l old-l)
								(eq? restx rest)
								#f)
							    x
							    (apply-cons
							     (apply-cons
							      (quote-syntax (quote unquote-splicing))
							      (normal restx rest))
							     (normal l old-l))))))))
					    (qq-list x level))))))
			  (if (if (syntax? x) 
				  (vector? (syntax-e x))
				  #f)
			      (let-values
				  (((l) (vector->list (syntax-e x))))
                                ;; special case: disallow #(unquote <e>)
                                (if (stx-pair? l)
                                    (let-values ([(first) (stx-car l)])
                                      (if (identifier? first)
                                          (if (free-identifier=? first unquote-stx)
                                              (raise-syntax-error
                                               'unquote
                                               "invalid context within quasiquote"
                                               in-form
                                               first)
                                              (void))
                                          (void)))
                                    (void))
				(let-values
				    (((l2) (qq l level)))
                                  (if (eq? l l2)
                                      x
                                      (list (quote-syntax list->vector) l2))))
			      (if (if (syntax? x) (box? (syntax-e x)) #f)
				  (let-values
				      (((v) (unbox (syntax-e x))))
				    (let-values
					(((qv) (qq v level)))
				      (if (eq? v qv)
                                          x
                                          (list (quote-syntax box) qv))))
                                  (if (if (syntax? x) 
                                          (if (struct? (syntax-e x)) 
                                              (prefab-struct-key (syntax-e x))
                                              #f)
                                          #f)
                                      ;; pre-fab struct
                                      (let-values
                                          (((l) (cdr (vector->list (struct->vector (syntax-e x))))))
                                        (let-values
                                            (((l2) (qq l level)))
                                          (if (eq? l l2)
                                              x
                                              (list (quote-syntax apply)
                                                    (quote-syntax make-prefab-struct)
                                                    (list (quote-syntax quote)
                                                          (prefab-struct-key (syntax-e x)))
                                                    l2))))
                                      ;; hash[eq[v]]
                                      (if (if (syntax? x)
                                              (hash? (syntax-e x))
                                              #f)
                                          (letrec-values
                                              (((qq-hash-assocs)
						(lambda (x level)
						  (if (null? x)
						      x
						      (let-values
						          (((pair) (car x)))
                                                        (let-values ([(val)
                                                                      (qq (datum->syntax here (cdr pair)) level)]
                                                                     [(rest)
                                                                      (qq-hash-assocs (cdr x) level)])
                                                          (if (if (eq? val (cdr pair))
                                                                  (eq? rest (cdr x))
                                                                  #f)
                                                              x
                                                              (apply-cons
                                                               (list (quote-syntax list*)
                                                                     (list (quote-syntax quote)
                                                                           (datum->syntax here (car pair)))
                                                                     (if (eq? val (cdr pair))
                                                                         (list (quote-syntax quote)
                                                                               val)
                                                                         val))
                                                               (if (eq? rest (cdr x))
                                                                   (list (quote-syntax quote)
                                                                         rest)
                                                                   rest)))))))))
                                            (let-values (((l0) (hash-map (syntax-e x) cons #t)))
                                              (let-values
                                                  (((l) (qq-hash-assocs l0 level)))
                                                (if (eq? l0 l)
                                                    x
                                                    (list (if (hash-eq? (syntax-e x))
                                                              (quote-syntax make-immutable-hasheq)
                                                              (if (hash-eqv? (syntax-e x))
                                                                  (quote-syntax make-immutable-hasheqv)
                                                                  (if (hash-equal-always? (syntax-e x))
                                                                      (quote-syntax make-immutable-hashalw)
                                                                      (quote-syntax make-immutable-hash))))
                                                          l)))))
                                          x)))))))))
	      (qq form 0))
	    form)
	   in-form)))))

  ; --------------------------------------------------
  ;
  ;
  ;                        ;       ;
  ;                        ;       ;
  ;                        ;      ;
  ;     ;;;;  ; ;;;     ;;;;      ;     ;;     ; ;;;
  ;    ;   ;  ;;   ;   ;   ;     ;     ;  ;    ;;  ;
  ;   ;    ;  ;    ;  ;    ;    ;     ;    ;   ;   ;
  ;   ;    ;  ;    ;  ;    ;    ;     ;    ;   ;
  ;   ;    ;  ;    ;  ;    ;   ;      ;    ;   ;
  ;   ;    ;  ;    ;  ;    ;   ;      ;    ;   ;
  ;   ;   ;;  ;    ;  ;   ;;  ;        ;  ;    ;
  ;    ;;; ;  ;    ;   ;;; ;  ;         ;;     ;
  ;
  ;
  ; `and` and `or`
  ;

  (define-syntaxes (and)
    (let-values ([(here) (quote-syntax here)])
      (lambda (x)
	(if (not (stx-list? x))
	    (raise-syntax-error #f "bad syntax" x)
            (void))
	(let-values ([(e) (stx-cdr x)])
	  (if (stx-null? e)
	      (quote-syntax #t)
	      (if (if (stx-pair? e)
		      (stx-null? (stx-cdr e))
		      #t)
                  (datum->syntax
                   here
                   (list (quote-syntax #%expression)
                         (stx-car e))
                   x)
		  (datum->syntax
		   here
		   (list (quote-syntax if)
			 (stx-car e)
			 (cons (quote-syntax and)
			       (stx-cdr e))
			 (quote-syntax #f))
		   x)))))))

  (define-syntaxes (or)
    (let-values ([(here) (quote-syntax here)])
      (lambda (x)
	(if (identifier? x)
	    (raise-syntax-error #f "bad syntax" x)
            (void))
	(let-values ([(e) (stx-cdr x)])
	  (if (stx-null? e) 
	      (quote-syntax #f)
	      (if (if (stx-pair? e)
		      (stx-null? (stx-cdr e))
		      #f)
                  (datum->syntax
                   here
                   (list (quote-syntax #%expression)
                         (stx-car e))
                   x)
		  (if (stx-list? e)
		      (let-values ([(tmp) 'or-part])
			(datum->syntax
			 here
			 (list (quote-syntax let) (list
						   (list
						    tmp
						    (stx-car e)))
			       (list (quote-syntax if)
				     tmp
				     tmp
				     (cons (quote-syntax or)
					   (stx-cdr e))))
			 x))
		      (raise-syntax-error 
		       #f
		       "bad syntax"
		       x))))))))

  ;
  ; --------------------------------------------------
  )
