Thu Apr  9 14:03:30 CEST 2009  asf@boinkor.net
  * Support natural joins, fix cross joins, add a using keyword
diff -rN -u old-postmodern/s-sql/s-sql.lisp new-postmodern/s-sql/s-sql.lisp
--- old-postmodern/s-sql/s-sql.lisp	2009-04-09 14:06:40.000000000 +0200
+++ new-postmodern/s-sql/s-sql.lisp	2009-04-09 14:06:40.000000000 +0200
@@ -504,30 +504,69 @@
 
 ;; Selecting and manipulating
 
+(defun destructure-join-keyword (keyword &optional (error-p t))
+  (declare (optimize debug))
+  (labels
+      ((pop-from-end (expected &optional (error-p t))
+         (let ((met-expectation
+                (unless (zerop (length keyword))
+                  (member keyword expected
+                          :test (lambda (kw ex)
+                                  (and
+                                   (>= (length kw) (length (string ex)))
+                                   (string= ex kw :start2 (- (length kw) (length (string ex))))))))))
+           (cond
+             ((and error-p (null met-expectation))
+              (sql-error ":~A is not a valid join keyword." keyword))
+             (met-expectation 
+              (prog1
+                (subseq keyword (- (length keyword) (length (string (first met-expectation)))))
+                (setf keyword (subseq keyword 0 (- (length keyword)
+                                                   (length (string (first met-expectation))))))))
+             (t nil)))))
+    (handler-bind ((sql-error (lambda (c)
+                                (if error-p
+                                    (invoke-debugger c)
+                                    (return-from destructure-join-keyword nil)))))
+      (if (symbolp keyword)
+          (setf keyword (string keyword))
+          (sql-error "~S is not a valid join keyword" keyword))
+      (pop-from-end '(:-join))
+      (let ((join-keyword (intern (pop-from-end '(:left :right :outer :cross :inner)) :keyword)))
+        (values (if (eql join-keyword :outer) :full join-keyword)
+                (when (pop-from-end '(:natural-) nil)
+                  :natural))))))
+
 (defun expand-joins (args)
   "Helper for the select operator. Turns the part following :from into
 the proper SQL syntax for joining tables."
-  (labels ((is-join (x) (member x '(:left-join :right-join :inner-join :outer-join :cross-join))))
-    (when (null args)
-      (sql-error "Empty :from clause in select"))
-    (when (is-join (car args))
-      (sql-error ":from clause starts with a join: ~A" args))
-    (let ((rest args))
-      (loop :while rest
-            :for first = t :then nil
-            :append (cond ((is-join (car rest))
-                           (destructuring-bind (join name on clause &rest left) rest
-                              (setf rest left)
-                              (unless (and (eq on :on) clause)
-                                (sql-error "Incorrect join form in select."))
-                              `(" " ,(ecase join
-                                        (:left-join "LEFT") (:right-join "RIGHT")
-                                        (:inner-join "INNER") (:outer-join "FULL OUTER")
-                                        (:cross-join "CROSS"))
-                                " JOIN " ,@(sql-expand name)
-                                " ON " ,@(sql-expand clause))))
-                          (t (prog1 `(,@(if first () '(", ")) ,@(sql-expand (car rest)))
-                               (setf rest (cdr rest)))))))))
+  (when (null args)
+    (sql-error "Empty :from clause in select"))
+  (when (destructure-join-keyword (car args) nil)
+    (sql-error ":from clause starts with a join: ~A" args))
+  (let ((rest args))
+    (loop :while rest
+          :for first = t :then nil
+          :append
+          (multiple-value-bind (join naturalp) (destructure-join-keyword (car rest) nil)
+            (cond (join
+                   (destructuring-bind (join-keyword name &rest clause) rest
+                     (declare (ignore join-keyword))
+                     (let ((on-keyword (case (first clause)
+                                         ((:using :on) (pop clause)))))
+                       (setf rest (rest clause)
+                             clause (first clause))
+                       `(" " ,@(when naturalp
+                                 '("NATURAL "))
+                             ,(string join)
+                             " JOIN " ,@(sql-expand name)
+                             ,@(case on-keyword
+                                 (:on `(" ON " ,@(sql-expand clause)))
+                                 (:using `(" USING (" ,@(sql-expand-list clause) ") "))
+                                 (nil (unless (or naturalp (eql join :cross))
+                                        (sql-error "Empty :on or :using clauses in ~A" join))))))))
+                  (t (prog1 `(,@(if first () '(", ")) ,@(sql-expand (car rest)))
+                            (setf rest (cdr rest)))))))))
 
 (def-sql-op :select (&rest args)
   (split-on-keywords ((vars *) (distinct - ?) (distinct-on * ?) (from * ?) (where ?) (group-by * ?)