;;----------------------------------------------------------------------
;; #%qqstx : quasisyntax

(module qqstx '#%kernel
  (#%require "small-scheme.ss" "stxcase-scheme.ss" "stx.ss"
             (for-syntax '#%kernel "small-scheme.ss" "stxcase-scheme.ss" "stx.ss"))

  (#%provide quasisyntax
             quasisyntax/loc
             unsyntax
             unsyntax-splicing)
  
  (define-syntaxes (unsyntax unsyntax-splicing)
    (let ([f (lambda (stx)
	       (raise-syntax-error
		#f
		"illegal outside of quasisyntax"
		stx))])
      (values f f)))

  (-define (check-splicing-list l ctx)
    (unless (stx-list? l)
      (raise-type-error
       'unsyntax-splicing
       "proper syntax list"
       l))
    (datum->syntax ctx l ctx))

  (define-syntaxes (quasisyntax quasisyntax/loc)
    (let ([qq
	   (lambda (orig-stx body mk-final)
	     (let ([here-stx #'here])
	       (let loop ([stx body]
			  [depth 0]
			  [same-k (lambda ()
				    (datum->syntax 
				     here-stx
				     (mk-final body)
				     orig-stx))]
			  [convert-k (lambda (body bindings)
				       (datum->syntax 
					here-stx
					(list
					 (quote-syntax with-syntax)
					 bindings
					 (mk-final body))
					orig-stx))])
		 (syntax-case stx (unsyntax unsyntax-splicing quasisyntax)
		   [(unsyntax x)
		    (if (zero? depth)
			(let ([temp (car (generate-temporaries '(uq)))])
			  (convert-k temp (list (list temp (syntax x)))))
			(loop (syntax x) (sub1 depth)
			      same-k
			      (lambda (v bindings)
				(convert-k (datum->syntax
					    here-stx
					    (list (stx-car stx) v)
					    stx)
					   bindings))))]
		   [unsyntax
		    (raise-syntax-error
		     #f
		     "misuse within quasisyntax"
		     orig-stx
		     stx)]
		   [((unsyntax-splicing x) . rest)
		    (if (zero? depth)
                        (if (stx-null? (syntax rest))
                            (with-syntax ([temp (car (generate-temporaries '(uqs1)))])
                              (convert-k (datum->syntax
                                          stx
                                          (syntax temp)
                                          stx)
                                         (list #'[temp x])))
                            (let ([rest-done-k
                                   (lambda (rest-v bindings)
                                     (with-syntax ([temp (car (generate-temporaries '(uqs)))]
                                                   [ctx (datum->syntax #'x 'ctx #'x)])
                                       (convert-k (datum->syntax
                                                   stx
                                                   (list* (syntax temp)
                                                          (quote-syntax ...)
                                                          rest-v)
                                                   stx)
                                                  (cons #'[(temp (... ...)) (check-splicing-list x (quote-syntax ctx))]
                                                        bindings))))])
                              (loop (syntax rest) depth
                                    (lambda ()
                                      (rest-done-k (syntax rest) null))
                                    rest-done-k)))
			(let ([mk-rest-done-k
			       (lambda (x-v x-bindings)
				 (lambda (rest-v rest-bindings)
				   (convert-k (datum->syntax
					       stx
					       (cons x-v rest-v)
					       stx)
					      (append x-bindings
						      rest-bindings))))])
			  (loop (syntax x) (sub1 depth)
				(lambda ()
				  ;; x is unchanged.
				  (loop (syntax rest) depth
					same-k
					(mk-rest-done-k (stx-car stx) null)))
				(lambda (x-v x-bindings)
				  ;; x is generated by x-v
				  (let ([rest-done-k (mk-rest-done-k 
						      (datum->syntax
						       (stx-car stx)
						       (list (stx-car (stx-car stx)) x-v)
						       (stx-car stx))
						      x-bindings)])
				    (loop (syntax rest) depth
					  (lambda ()
					    ;; rest is unchanged
					    (rest-done-k (syntax rest) null))
					  rest-done-k))))))]
		   [unsyntax-splicing
		    (raise-syntax-error
		     #f
		     "misuse within quasisyntax"
		     orig-stx
		     stx)]
		   [(quasisyntax x)
		    (loop (syntax x) (add1 depth)
			  same-k
			  (lambda (v bindings)
			    (convert-k (datum->syntax
					stx
					(list (stx-car stx) v)
					stx)
				       bindings)))]
		   [_
		    (cond
		     ;; We treat pairs specially so that we don't generate a lot
		     ;;  of syntax objects when the input syntax collapses a list
		     ;;  into a single syntax object.
		     [(pair? (syntax-e stx))
		      (let ploop ([l (syntax-e stx)]
				  [same-k same-k]
				  [convert-k (lambda (l bindings)
					       (convert-k (datum->syntax
							   stx
							   l
							   stx)
							  bindings))])
			(cond
			 [(pair? l)
			  (if (let ([a (car l)])
				(or (and (identifier? a)
					 (or (free-identifier=? a (quote-syntax unsyntax))
					     (free-identifier=? a (quote-syntax quasisyntax))))
				    (and (stx-pair? a)
					 (let ([a (stx-car a)])
					   (and (identifier? a)
						(free-identifier=? a (quote-syntax unsyntax-splicing)))))))
			      ;; Found something important, like `unsyntax'; stop the special
			      ;; handling for pairs
			      (loop (datum->syntax #f l #f) depth
				    same-k 
				    convert-k)
			      ;; Normal special pair handling
			      (ploop (cdr l)
				     (lambda ()
				       ;; rest is the same
				       (loop (car l) depth
					     same-k
					     (lambda (a a-bindings)
					       (convert-k (cons (datum->syntax
								 (car l)
								 a 
								 (car l))
								(cdr l))
							  a-bindings))))
				     (lambda (rest rest-bindings)
				       (loop (car l) depth
					     (lambda ()
					       (convert-k (cons (car l) rest)
							  rest-bindings))
					     (lambda (a a-bindings)
					       (convert-k (cons (datum->syntax
								 (car l)
								 a
								 (car l))
								rest)
							  (append a-bindings
								  rest-bindings)))))))]
			 [(null? l) (same-k)]
			 [else (loop l depth same-k convert-k)]))]
		     [(vector? (syntax-e stx))
		      (loop (datum->syntax
			     stx
			     (vector->list (syntax-e stx))
			     stx)
			    depth
			    same-k
			    (lambda (v bindings)
			      (convert-k (datum->syntax
					  stx
					  (list->vector (syntax->list v))
					  stx)
					 bindings)))]
		     [else
		      (same-k)])]))))])
      (values (lambda (orig-stx)
		(syntax-case orig-stx ()
		  [(_ stx) (qq orig-stx
			       (syntax stx) 
			       (lambda (body)
				 (list (quote-syntax syntax) body)))]))
	      (lambda (orig-stx)
		(syntax-case orig-stx ()
		  [(_ loc stx) (qq orig-stx
				   (syntax stx) 
				   (lambda (body)
				     (list (quote-syntax syntax/loc) 
					   (syntax loc)
					   body)))]))))))