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

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

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

(define (define-usual-transform package name)
  (let ((loc (package-define! package name syntax-type #f 'syntax)))
    (set-contents! loc
		   (make-transform/macro ((usual-transform name) 
					  (package-reference-syntax package 0))
					 package
					 syntax-type
					 name))))

(define (define-usual-transforms package)
  (for-each (lambda (name)
	      (define-usual-transform package name))
 	    (package-usual-transforms package)))

(define-usual-macro 'and
  (lambda (here)
    (lambda (x)
      (if (not (stx-list? x))
	  (syntax-violation 'and "bad syntax" x))
      (let ((e (stx-cdr x)))
	(cond
	 ((stx-null? e)
	  (datum->syntax here #t))
	 ((stx-null? (stx-cdr e))
	  (stx-car e))
	 (else
	  (datum->syntax
	   here
	   `(if ,(stx-car e)
		(and ,@(stx-cdr e))
		#f))))))))

(define-usual-macro 'or
  (lambda (here)
    (lambda (x)
      (if (not (stx-list? x))
	  (syntax-violation 'or "bad syntax" x))
      (let ((e (stx-cdr x)))
	(cond
	 ((stx-null? e) 
	  (datum->syntax here #f))
	 ((stx-null? (stx-cdr e))
	  (stx-car e))
	 (else
	  (let ((tmp 'or-part))
	    (datum->syntax
	     here
	     `(let ((,tmp ,(stx-car e)))
		(if ,tmp
		    ,tmp
		    (or ,@(stx-cdr e))))))))))))

(define-usual-macro 'let
  (lambda (here)
    (lambda (x)
      (call-with-values
	  (lambda () (scan-let-like x #t #f))
	(lambda (name bindings body)
	  (if name
	      (datum->syntax here
			     `(letrec ((,name
					(lambda ,(map car bindings)
					  ,@body)))
				(,name ,@(map cdr bindings))))
	      (datum->syntax here
			     `((lambda ,(map car bindings)
				 ,@body)
			       ,@(map cdr bindings)))))))))

(define-usual-macro 'lambda
  (lambda (here)
    (lambda (x)
      (if (not (stx-at-least-this-long? x 3))
	  (syntax-violation (stx-car x) "bad syntax" x))
      (let ((body (stx-cdr (stx-cdr x))))
	(if (not (stx-list? body))
	    (syntax-violation (stx-car x) "bad syntax" x body))
	(let ((formal-ids
	       (formals->identifiers x (stx-cadr x))))
	  (datum->syntax here
			 `(,syntax/lambda ,(stx-cadr x)	; lambda-syntax is a reference to the plain lambda
					  (body . ,body))))))))

(define-usual-macro 'body
  (lambda (here)
    (lambda (x)
      (let ((body (stx-cdr x)))
	(if (stx-null? body)
	    (syntax-violation (stx-car x) "empty body" x body))
	(let ((dctx (syntax-local-make-definition-context))
	      (kernel-ids (kernel-form-identifier-list)))

	  (let loop ((body body)
		     (defns '())
		     (ids '()))

	    (define (done d)

	      (check-duplicates x ids)
	      
	      (let ((new-body
		     (cons d
			   (map (lambda (stx)
				  ;; attach dctx
				  (let ((stx-new (local-expand (datum->syntax #f
									      `(,syntax/quote ,stx))
							       dctx
							       (list syntax/quote))))
				    (stx-cadr stx-new)))
				(stx->list (stx-cdr body))))))
		(if (pair? defns)
		    `(letrec ,(map (lambda (defn)
				     (list (stx-cadr defn)
					   (stx-cadr (stx-cdr defn))))
				   (reverse defns))
		       ,@new-body)
		    (body->expression new-body))))

	    (if (stx-null? body)
		(syntax-violation (stx-car x) "no expressions in body" x body)
		(let ((d (local-expand (stx-car body) dctx kernel-ids)))
		  (if (and (stx-pair? d)
			   (identifier? (stx-car d)))
		      (let ((op (stx-car d)))
			(cond
			 ((free-identifier=? syntax/define op)
			  (let ((id (stx-cadr d)))
			    (syntax-local-bind-syntaxes (list id) #f dctx)
			    (loop (stx-cdr body) (cons d defns) (cons id ids))))
			 ((free-identifier=? syntax/define-syntax op)
			  (let ((id (stx-cadr d)))
			    (syntax-local-bind-syntaxes (list id) (stx-cadr (stx-cdr d)) dctx)
			    (loop (stx-cdr body) defns (cons id ids))))
			 ((free-identifier=? syntax/begin op)
			  (loop (append (stx->list (stx-cdr d)) (stx-cdr body)) defns ids))
			 (else
			  (done d))))
		      (done d))))))))))

(define-usual-macro 'let*
  (lambda (here)
    (lambda (x)
      (call-with-values
	  (lambda () (scan-let-like x #f #t))
	(lambda (name bindings body)
	  (datum->syntax
	   here
	   (if (null? bindings)
	       `(let () ,@body)
	       (let recur ((bindings bindings))
		 (if (null? (cdr bindings))
		     `(let ((,(caar bindings) ,(cdar bindings)))
			,@body)
		     `(let ((,(caar bindings) ,(cdar bindings)))
			,(recur (cdr bindings))))))))))))

(define (lambda? stx)
  (and (stx-pair? stx)
       (let ((op (stx-car stx)))
	 (and (identifier? op)
	      (free-identifier=? op syntax/lambda)))))

; letrec* and letrec intersect here
(define (try-letrec-common x fail)
  (call-with-values
      (lambda () (scan-let-like x #f #f))
    (lambda (name bindings body)
      (let ((dctx (syntax-local-make-definition-context))
	    (kernel-ids (kernel-form-identifier-list)))
	(syntax-local-bind-syntaxes (map car bindings) #f dctx)
	(let ((expanded-rhses
	       (map (lambda (binding)
		      (local-expand (cdr binding) dctx kernel-ids))
		    bindings)))
	  (if (every lambda? expanded-rhses)
	      (datum->syntax
	       #f
	       `(,syntax/letrec ,(map (lambda (binding rhs)
					(list (car binding) rhs))
				      bindings expanded-rhses)
				,(body->expression body)))
	      (fail (map (lambda (binding rhs)
			   (cons (car binding) rhs))
			 bindings expanded-rhses)
		    body)))))))

(define-usual-macro 'letrec
  (lambda (here)
    (lambda (x)
      (try-letrec-common
       x
       (lambda (bindings body)
	 (let ((temps (generate-temporaries (map car bindings))))
	   (datum->syntax
	    here
	    `(let ,(map (lambda (binding)
			  (list (car binding)
				'(unassigned)))
			bindings)
	       (let ,(map (lambda (temp binding)
			    (list temp (cdr binding)))
			  temps bindings)
		 ,@(map (lambda (temp binding)
			  `(set! ,(car binding) ,temp))
			temps bindings))
	       ,@body))))))))

(define-usual-macro 'letrec*
  (lambda (here)
    (lambda (x)
      (try-letrec-common
       x
       (lambda (bindings body)
	 (let ((temps (generate-temporaries (map car bindings))))
	   (datum->syntax
	    here
	    `(let ,(map (lambda (binding)
			  (list (car binding)
				'(unassigned)))
			bindings)
	       ,@(map (lambda (temp binding)
			`(set! ,(car binding) ,(cdr binding)))
		      temps bindings)
	       (let () ,@body)))))))))

(define-usual-macro 'cond
  (lambda (here)
    (let ((=>-stx (datum->syntax here '=>))
	  (else-stx (datum->syntax here 'else)))
      (lambda (x)
	(datum->syntax
	 here
	 (car
	  (let recur ((clauses (stx-cdr x)))
	    (if (stx-null? clauses)
		'()
		(list
		 (let ((clause (stx-car clauses)))
		   (if (not (stx-pair? clause))
		       (syntax-violation 'cond "invalid cond clause" x clause))
		   (let ((more (recur (stx-cdr clauses)))
			 (head (stx-car clause))
			 (tail (stx-cdr clause)))
		     (cond
		      ((and (identifier? head)
			    (free-identifier=? head else-stx))
		       (if (not (stx-null? more))
			   (syntax-violation 'cond "else clause must be last" x clause))
		       `(begin ,@tail))
		      ((null? tail)
		       `(or ,head ,@more))
		      ((and (stx-pair? tail)
			    (let ((op (stx-car tail)))
			      (and (identifier? op)
				   (free-identifier=? op =>-stx))))
		       (if (null? (stx-cdr tail))
			   (syntax-violation 'cond "invalid cond clause" x clause))
		       `(let ((temp ,head))
			  (if temp
			      (,(stx-cadr tail) temp)
			      ,@more)))
		      (else
		       `(if ,head
			    (begin ,@tail)
			    ,@more))))))))))))))

(define-usual-macro 'case
  (lambda (here)
    (let ((else-stx (datum->syntax here 'else))
	  (eq?-stx (datum->syntax here 'eq?))
	  (eqv?-stx (datum->syntax here 'eqv?))
	  (memv-stx (datum->syntax here 'memv)))
      (lambda (x)
	(if (not (stx-at-least-this-long? x 2))
	    (syntax-violation 'case "bad syntax" x))
	(datum->syntax
	 here
	 `(let ((temp ,(stx-cadr x)))
	    (cond
	     ,@(map (lambda (clause)
		      (if (not (stx-pair? clause))
			  (syntax-violation 'case "invalid case clause" x clause))
		      (let ((head (stx-car clause))
			    (tail (stx-cdr clause)))
			`(,(cond ((and (identifier? head)
				       (free-identifier=? head else-stx))
				  head)
				 ((not (stx-list? head))
				  (syntax-violation 'case "invalid case clause" x clause))
				 ((stx-null? head)
				  #f)
				 ((stx-null? (stx-cdr head)) ;+++
				  `(,(if (identifier? (stx-car head)) eq?-stx eqv?-stx)
				    temp
				    ',(stx-car head)))
				 (else
				  `(,memv-stx temp ',head)))
			  ,@tail)))
		    (stx-cdr (stx-cdr x))))))))))

(define-usual-macro 'do
  (lambda (here)
    (let ((loop-stx (car (generate-temporaries '(do-loop))))
	  (letrec-stx (datum->syntax here 'letrec))
	  (lambda-stx (datum->syntax here 'lambda))
	  (cond-stx (datum->syntax here 'cond)))
      (lambda (x)
	(if (not (stx-pair? (stx-cdr x)))
	    (syntax-violation 'do "bad syntax" x))
	(let ((tail (stx-cdr (stx-cdr x))))
	  (if (not (stx-pair? tail))
	      (syntax-violation 'do "bad syntax" x))
	  (let ((specs (stx->list (stx-cadr x)))
		(end (stx-car tail))
		(body (stx-cdr tail)))
	(if (not (stx-list? specs))
	    (syntax-violation 'do "bad specs" x specs))
	(for-each (lambda (spec)
		    (if (not (do-spec? spec))
			(syntax-violation 'do "bad spec" x spec)))
		  specs)
 	(if (not (stx-list? end))
	    (syntax-violation 'do "bad end clause" x end))
	(datum->syntax
	 here
	 `(,letrec-stx ((,loop-stx
			 (,lambda-stx ,(map stx-car specs)
				      (,cond-stx ,end
						 (else ,@body
						       (,loop-stx
							,@(map (lambda (spec)
								 (let ((tail (stx-cdr (stx-cdr spec))))
								   (if (stx-null? tail)
								       (stx-car spec)
								       (stx-car tail))))
							       specs)))))))
		       (,loop-stx ,@(map stx-cadr specs))))))))))

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

(define-usual-macro 'define
  (lambda (here)
    (lambda (x)
      (if (or (not (stx-list? x))
	      (not (stx-at-least-this-long? x 2)))
	  (syntax-violation 'define "bad syntax" x))
      (let ((pat (stx-cadr x))
	    (rest (stx-cdr (stx-cdr x))))
	(cond
	 ((stx-pair? pat)
	  (let ((id (stx-car pat))
		(formals (stx-cdr pat)))
	    (if (not (identifier? id))
		(syntax-violation 'define "no identifier where one should be in definition" x id))
	    (let ((body (stx-cdr (stx-cdr x))))
	      (datum->syntax here
			     `(,syntax/define ,id
			        (lambda ,formals
				  ,@body))))))
	 ((identifier? pat)
	  (let ((rhs (if (stx-null? rest)
			 '(unspecific)
			 (begin
			   (if (not (stx-null? (stx-cdr rest)))
			       (syntax-violation 'define "right-hand side has more than one form" x rest))
			   (stx-car rest)))))
	    (datum->syntax here
			   `(,syntax/define ,pat ,rhs))))
	 (else
	  (syntax-violation 'define "invalid definition" x)))))))

(define-usual-macro 'quasiquote
  (lambda (here)
    (let ((quote-stx (datum->syntax here 'quote))
	  (quasiquote-stx (datum->syntax here 'quasiquote))
	  (unquote-stx (datum->syntax here 'unquote))
	  (unquote-splicing-stx (datum->syntax here 'unquote-splicing))
	  (append-stx (datum->syntax here 'append))
	  (cons-stx (datum->syntax here 'cons))
	  (list-stx (datum->syntax here 'list))
	  (list->vector-stx (datum->syntax here 'list->vector)))
      (lambda (x)
	(define (expand-quasiquote x level)
	  (descend-quasiquote x level finalize-quasiquote))

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

	(define (descend-quasiquote x level return)
	  (cond ((stx-vector x)
		 => (lambda (vec)
		      (descend-quasiquote-vector vec level return)))
		((not (stx-pair? x))
		 (return 'quote x))
		(else
		 (let ((op (stx-car x)))
		   (cond
		    ((not (identifier? op))
		     (descend-quasiquote-pair x level return))
		    ((free-identifier=? op quasiquote-stx)
		     (descend-quasiquote-pair x (+ level 1) return))
		    ((free-identifier=? op unquote-stx)
		     (cond ((= level 0)
			    (return 'unquote (stx-cdr x)))
			   (else
			    (descend-quasiquote-pair x (- level 1) return))))
		    ((free-identifier=? op unquote-splicing-stx)
		     (cond ((= level 0)
			    (return 'unquote-splicing (stx-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
	   (stx-car x) level
	   (lambda (car-mode car-arg)
	     (descend-quasiquote 
	      (stx-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 (stx-pair? car-arg)
				(stx-null? (stx-cdr car-arg)))
			   (return cons-stx ; +++
				   (list (stx-car car-arg)
					 (finalize-quasiquote cdr-mode cdr-arg)))
			   (return append-stx
				   (list (cons list-stx car-arg)
					 (finalize-quasiquote cdr-mode cdr-arg)))))
		     
		      ((eq? car-mode 'unquote-splicing)
		       ;; (,@mumble ...)
		       (if (and (eq? cdr-mode 'quote) (stx-null? cdr-arg) ; +++
				(stx-pair? car-arg) (stx-null? (stx-cdr car-arg)))
			   (return 'unquote car-arg)
			   (return append-stx
				   (append car-arg
					   (list (finalize-quasiquote
						  cdr-mode cdr-arg))))))
		      (else
		       (return cons-stx
			       (list (finalize-quasiquote car-mode car-arg)
				     (finalize-quasiquote cdr-mode cdr-arg))))))))))

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

	(let ((rest (stx-cdr x)))
	  (if (and (stx-pair? rest)
		   (stx-null? (stx-cdr rest)))
	      (datum->syntax here
			     (expand-quasiquote (stx-car rest) 0))
	      (syntax-violation 'quasiquote "invalid syntax" x)))))))
