[postmodern-devel] Binary and unary operators

[Ivan Boldyrev]

On 10077 day of my life Marijn Haverbeke wrote:
> ... a patch?

Comment string may require full rewriting.

diff -rN -u old-postmodern/postmodern/package.lisp new-postmodern/postmodern/package.lisp
--- old-postmodern/postmodern/package.lisp      2008-01-07 20:38:27.000000000 +0600
+++ new-postmodern/postmodern/package.lisp      2008-01-07 20:38:27.000000000 +0600
@@ -25,6 +25,7 @@
    #:smallint #:bigint #:numeric #:real #:double-precision
    #:bytea #:text #:varchar
    #:*escape-sql-names-p* #:sql-escape-string
+   #:def-infix-ops
 
    ;; Condition type from cl-postgres
    #:database-error #:database-error-message #:database-error-code
diff -rN -u old-postmodern/s-sql/s-sql.lisp new-postmodern/s-sql/s-sql.lisp
--- old-postmodern/s-sql/s-sql.lisp     2008-01-07 20:38:27.000000000 +0600
+++ new-postmodern/s-sql/s-sql.lisp     2008-01-07 20:38:27.000000000 +0600
@@ -16,6 +16,7 @@
            #:to-sql-name
            #:sql-ize
            #:*escape-sql-names-p*
+           #:def-infix-ops
            #:sql
            #:sql-compile
            #:enable-s-sql-syntax))
@@ -373,21 +374,58 @@
       (destructuring-bind ,arglist ,args-name
         , at body))))
 
-(defun expand-infix-op (operator allow-unary args)
-  (if (cdr args)
-      `("(" ,@(sql-expand-list args (strcat " " operator " ")) ")")
-      (if allow-unary
-          (sql-expand (first args))
-          (error "SQL operator ~A takes at least two arguments." operator))))
-
-(defmacro def-infix-ops (allow-unary &rest ops)
+(defun expand-infix-op (operator class args)
+  (declare (type (member t :both nil) class))
+  (cond
+    ((cdr args)
+     `("(" ,@(sql-expand-list args (strcat " " operator " ")) ")"))
+    ((eq class t)
+     (sql-expand (first args)))
+    ((eq class :both)
+     `(,operator "(" ,@(sql-expand (first args)) ")"))
+    (t
+       (error "SQL operator ~A takes at least two arguments." operator))))
+
+(defmacro def-infix-ops (class &rest ops)
+  (declare (type (member t :both nil) class))
+  "Define infix operators.
+CLASS may be either T, :BOTH or NIL.
+
+  1. T.  S-SQL operators may be both binary and unary, but unary form
+     is equivalent to the only argument itself (e.g.
+     (:AND condition) => \"condition\").
+
+  2. :BOTH.  S-SQL operators may be both binary and unary, but unlike
+     T, operator is kept before the argument in unary form.  Example
+     is PosgreSQL's ?| operator:
+     (def-infix-ops :both :?\\|)
+     (:?\\| a)    => \"?|(a)\"
+     (:?\\| a b)  => \"a ?| b\".
+
+  3. NIL.  Operator is binary only.
+
+OPS is a list of operator designators.  There are two kinds of
+operator designators:
+
+  1. A keyword.  Downcased symbol value of the keword is used as SQL
+     name of operator.
+
+  2. Two-element list: (KEYWORD STRING).  String is used as SQL name
+     of operator, and KEYWORD is S-SQL name of operator.
+     Example: (:concat \"||\")."
   `(progn
     ,@(mapcar (lambda (op)
-                `(defmethod expand-sql-op ((op (eql ,op)) args)
-                  (expand-infix-op ,(string-downcase (symbol-name op)) ,allow-unary args)))
+                (when (keywordp op)
+                  (setf op (list op (string-downcase (symbol-name op)))))
+                (let ((kwd (first op))
+                      (txt (second op)))
+                  `(defmethod expand-sql-op ((op (eql ,kwd)) args)
+                     (expand-infix-op ,txt ,class args))))
               ops)))
-(def-infix-ops t :+ :* :& :|\|| :and :or :union)
-(def-infix-ops nil := :/ :!= :< :> :<= :>= :^ :intersect :except :~* :!~ :!~* :like :ilike)
+
+(def-infix-ops t :+ :* :& :|\|| :and :or :union :\|\| (:concat "||"))
+(def-infix-ops nil := :/ :!= :< :> :<= :>= :^ :intersect :except :~* :!~ :!~*
+                   :like :ilike :&& :% :\# :<< :>>)
 
 (def-sql-op :- (first &rest rest)
   (if rest


-- 
Ivan Boldyrev

                                      Life!  Don't talk to me about life.