From 7371ab0cc2e40d392982b8a9e2299ef7e54a7fb7 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 17 Aug 2015 14:07:32 -0600
Subject: [PATCH] remove accidentally added file

---
 racket/collects/racket/private/qar.rkt | 501 -------------------------
 1 file changed, 501 deletions(-)
 delete mode 100644 racket/collects/racket/private/qar.rkt

diff --git a/racket/collects/racket/private/qar.rkt b/racket/collects/racket/private/qar.rkt
deleted file mode 100644
index 0a0bcc5da5..0000000000
--- a/racket/collects/racket/private/qar.rkt
+++ /dev/null
@@ -1,501 +0,0 @@
-
-;;----------------------------------------------------------------------
-;; quasiquote, and, or
-
-(module qq-and-or '#%kernel
-  (#%require (for-syntax "stx.rkt" '#%kernel))
-  
-  (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)
-               (if (null? bindings)
-                   (list* (quote-syntax let-values) '() (cddr l))
-                   (list (quote-syntax let-values) (list (car bindings)) (gen (cdr bindings))))))
-           (datum->syntax #f (gen bindings) 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)))))))
-
-  (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)))
-                                              (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)
-                                                                  (quote-syntax make-immutable-hash)))
-                                                          l)))))
-                                          x)))))))))
-	      (qq form 0))
-	    form)
-	   in-form)))))
-
-  (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))))))))
-
-  (#%provide let*-values
-             let let* letrec
-             quasiquote and or))