macros.lisp (22114B)
1 ;;; cl-2sql Copyright (c) 2011 Tomas Hlavaty 2 3 (defpackage :2sql-macros 4 (:use) 5 (:nicknames :q) ;; TODO really? 6 (:import-from :cl :&optional :&rest :&body :nil :t)) 7 8 (in-package :2sql-macros) 9 10 (cl:defmacro defsyntax (name args &body body) 11 `(cl:progn 12 (cl:export ',name) 13 (cl:defmacro ,name ,args ,@body))) 14 15 (defsyntax lst (sep &body body) 16 `(:lst ,sep ,@(cl:mapcar 17 (cl:lambda (x) (cl:if (cl:atom x) x (cl:macroexpand x))) 18 body))) 19 20 (defsyntax clist (&body body) 21 `(lst ", " ,@body)) 22 23 (defsyntax prefix (name &body args) 24 `(lst nil ,name ,@args)) 25 26 (defsyntax infix (name &body args) 27 `(lst ,name ,@args)) 28 29 (defsyntax postfix (name &body args) 30 `(prefix ,@args ,name)) 31 32 (cl:macrolet 33 ((defop (name ecase) 34 `(defsyntax ,name (&rest form) 35 (cl:block here 36 (cl:dolist (x form) 37 (cl:when (cl:let ((backend (cl:car x))) 38 (cl:or (cl:eq t backend) 39 (cl:if (cl:atom backend) 40 (cl:eq backend 2sql:*backend*) 41 (cl:member 2sql:*backend* backend)))) 42 (cl:return-from here (cl:cadr x)))) ;; cadr or cdr? 43 (cl:when ,ecase 44 (cl:error "Backend ~s fell through BACKEND-CASE ~s" 45 2sql:*backend* form)))))) 46 (defop backend-case nil) 47 (defop backend-ecase t)) 48 49 (cl:macrolet ;; prefix unary operators 50 ((defop (name &rest rest) 51 `(defsyntax ,name (exp) 52 `(prefix ,,@rest ,exp)))) 53 ;;(defop not :not) 54 (defop @ :@) 55 (defop \|/ :\|/) 56 (defop ~ :~) 57 (defop ~* :~*) 58 (defop exists :exists) 59 (defop distinct :distinct)) 60 61 (cl:macrolet ;; postfix unary operators 62 ((defop (name &rest rest) 63 `(defsyntax ,name (exp) 64 `(prefix ,exp ,,@rest)))) 65 (defop is-null :is :null) 66 (defop is-not-null :is :not :null)) 67 68 (cl:macrolet ;; binary operators 69 ((defop (name sep) 70 `(defsyntax ,name (lexp rexp) 71 `(infix ,,sep ,lexp ,rexp)))) 72 (defop = " = ") 73 (defop < " < ") 74 (defop > " > ") 75 (defop <= " <= ") 76 (defop >= " >= ") 77 (defop <> " <> ") 78 (defop in " IN ") 79 (defop / " / ") 80 (defop % " % ") 81 (defop ^ " ^ ") 82 (defop ** " ** ") 83 (defop & " & ") 84 (defop \| " | ") 85 (defop \# " # ") 86 (defop << " << ") 87 (defop >> " >> ") 88 (defop like " LIKE ") 89 (defop ilike " ILIKE ")) 90 91 (cl:macrolet ;; polyadic operators 92 ((defop (name sep) 93 `(defsyntax ,name (&body args) 94 `(infix ,,sep ,@args)))) 95 (defop + " + ") 96 (defop - " - ") 97 (defop * " * ") 98 (defop and " AND ") 99 (defop or " OR ") 100 (defop \|\| " || ")) 101 102 (defsyntax like* (lexp rexp) 103 `(like (upper ,lexp) (upper ,rexp))) 104 105 (defsyntax between (what lexp rexp) 106 `(prefix ,what :between ,lexp :and ,rexp)) 107 108 (defsyntax select (cols &body body) 109 `(prefix :select ,(cl:if (cl:or (cl:atom cols) (cl:atom (cl:car cols))) 110 cols 111 `(clist ,@cols)) ,@body)) 112 113 (defsyntax from (&body body) `(prefix :from (clist ,@body))) 114 (defsyntax where (exp) `(prefix :where ,exp)) 115 (defsyntax order-by (&body clist) `(prefix :order :by (clist ,@clist))) 116 (defsyntax group-by (&body clist) `(prefix :group :by (clist ,@clist))) 117 (defsyntax having (exp) `(prefix :having ,exp)) 118 (defsyntax limit (exp) `(prefix :limit ,exp)) 119 (defsyntax offset (exp) `(prefix :offset ,exp)) 120 121 (defsyntax for (what &optional wait) 122 `(prefix :for ,@ (cl:ecase what 123 (:update '(:update)) 124 (:share '(:share))) 125 ,@(cl:unless wait '(:nowait)))) 126 127 (defsyntax delete-from (tab &body where) 128 `(prefix :delete :from ,tab ,@where)) 129 130 (cl:macrolet ;; join 131 ((defop (name &rest rest) 132 `(defsyntax ,name (left right on &optional using) 133 `(prefix ,left ,,@rest :join ,right 134 ,@(cl:when on `(:on ,on)) 135 ,@(cl:when using `(:using (par ,using))))))) 136 (defop inner-join :inner) 137 (defop natural-join :natural) 138 (defop cross-join :cross) 139 (defop left-join :left) 140 (defop right-join :right) 141 (defop full-join :full :outer)) 142 143 (cl:macrolet ;; set operations 144 ((defop (name sep) 145 `(defsyntax ,name (order-by limit offset &body subqueries) 146 `(prefix (lst ,,sep ,@subqueries) 147 ,@(cl:when order-by `(,@order-by)) 148 ,@(cl:when limit `(,@limit)) 149 ,@(cl:when offset `(,@offset)))))) 150 (defop union " UNION ") 151 (defop union-all " UNION ALL ") 152 (defop intersect " INTERSECT ") 153 (defop intersect-all " INTERSECT ALL ") 154 (defop except " EXCEPT ") 155 (defop except-all " EXCEPT ALL ")) 156 157 (defsyntax drop-if-exists (name kind if-exists &body body) 158 `(backend-ecase 159 (:oracle 160 ,(cl:if if-exists 161 `(prefix :declare :begin :execute :immediate 162 (\|\| "DROP " 163 , (cl:ecase kind 164 (:table " TABLE ") 165 (:view " VIEW ") 166 (:index " INDEX ") 167 (:sequence "SEQUENCE ")) 168 ,name #+nil(2sql:pure-form-to-string name)) 169 :\; :exception :when :others :then :null :\; :end :\;) 170 `(prefix :drop ,kind))) 171 (:postgresql 172 (prefix :drop ,kind ,@(cl:when if-exists '(:if :exists)) ,name ,@body)))) 173 174 (defsyntax drop-table (name &optional if-exists cascade) 175 `(drop-if-exists ,name :table ,if-exists ,@(cl:when cascade '(:cascade)))) 176 177 (defsyntax drop-view (name &optional if-exists) 178 `(drop-if-exists ,name :view ,if-exists)) 179 180 (defsyntax drop-index (name &optional if-exists) 181 `(drop-if-exists ,name :index ,if-exists)) 182 183 (defsyntax drop-sequence (name &optional if-exists) 184 `(backend-ecase 185 (:postgresql (drop-if-exists ,name :sequence ,if-exists)) 186 (:sqlite (drop-table ,name ,if-exists)))) 187 188 ;;(2sql:query () '(drop-sequence seq t)) 189 190 (defsyntax create-index (name unique tab using cols properties triggers &body where) 191 #+nil ;; -> cols 192 (lambda (node db) 193 (typecase node 194 (sql-column (funcall 'format-sql-identifier node db)) 195 (t (funcall 'format-sql-syntax-node (%shorten-columns node) db)))) 196 ;; Oracle doesn't permit table_name.column_name in index expressions, 197 ;; and the table_name is redundant anyway, so let's strip it 198 ;; unconditionally: 199 #+nil 200 (defun %shorten-columns (node) 201 (etypecase node 202 (sql-literal) 203 (sql-fragment) ;; allow sexp2sql 204 (sql-unary-operator 205 (setf (expression-of node) 206 (%shorten-columns (expression-of node)))) 207 (sql-function-call 208 (setf (arguments-of node) 209 (mapcar #'%shorten-columns (arguments-of node)))) 210 (sql-index-operation 211 (setf (value-of node) (%shorten-columns (value-of node)))) 212 (sql-column-alias 213 (setf (table-of node) nil))) 214 node) 215 ;; where e.g. http://www.postgresql.org/docs/8.4/static/indexes-partial.html 216 ;; e.g. [USING method] for postgresql 217 ;; http://www.postgresql.org/docs/8.2/static/sql-createindex.html 218 ;; index properties for oracle 219 ;; http://download.oracle.com/docs/cd/B13789_01/server.101/b10759/statements_5010.htm#i2138869 220 ;; triggers list of strings 221 `(prefix :create ,@(cl:when unique '(:unique)) :index ,name 222 :on ,tab ,@(cl:when using `(:using ,@using)) (par ,@cols) 223 ,@(cl:when where `(:where ,@where)) 224 ,@(cl:when properties properties))) 225 226 ;; http://developer.postgresql.org/pgdocs/postgres/indexes-opclass.html 227 (defsyntax operator-class (value operation) 228 `(prefix ,value ,operation)) 229 230 (defsyntax values (&body values) 231 (cl:when values `(prefix :values (par (clist ,@values))))) 232 233 (defsyntax insert-into (tab cols &body body) 234 ;; body (values...) | (select...) 235 `(prefix :insert :into ,tab 236 ,@(cl:when cols `((par (clist ,@cols)))) 237 ,@(cl:loop 238 :for x :in body 239 :when (cl:macroexpand x) 240 :collect x))) 241 242 (defsyntax returning (cols &optional vars) ;; oracle; better (k1 v1) (k2 v2)... 243 `(backend-ecase 244 (:oracle (prefix :returning (clist ,@cols) :into (clist ,@vars))) 245 (:postgresql ,@(cl:when cols `((prefix :returning (clist ,@cols))))))) 246 247 (defsyntax column (name type &optional nullable default other) 248 `(prefix ,name ,type 249 (nullable ,nullable) 250 ,@(cl:when default `(:default ,default)) 251 ,@(cl:when other (cl:list (cl:macroexpand other))))) 252 253 (defsyntax columns (&body cols) 254 `(clist ,@cols)) 255 256 (defsyntax create-sequence (name &optional temp) 257 `(backend-ecase 258 (:postgresql 259 (prefix :create ,@(cl:when temp '(:temporary)) :sequence ,name)) 260 (:sqlite 261 (create-table ,name 262 (columns (column seq (integer-type) nil nil 263 (prefix :primary :key #+nil :autoincrement))))))) 264 265 (defsyntax curval (seq) 266 `(function :curval ,seq)) 267 268 (defsyntax nextval (seq) 269 `(backend-case 270 (:oracle ,(cl:intern (cl:format nil "~:@(~a.nextval~)" seq))) ;; TODO dont intern, polutes this package 271 (:postgresql (function :nextval ,(2sql:print-symbol seq))))) 272 273 (defsyntax setval (seq val &optional current) 274 `(function :curval ,seq ,val ,@(cl:unless current '(:false)))) 275 276 ;; Need to distinguish between boolean type, value and expression. 277 ;; Oracle does not have a boolean type and value. Expressions 278 ;; evaluate to true|false but these are not first class values so 279 ;; manual conversion to the chosen boolean value of the chosen boolean 280 ;; type is always necessary. 281 282 (defsyntax boolean () 283 `(backend-ecase 284 (:oracle (function :char 1)) 285 (:postgresql :boolean) 286 (:sqlite :boolean))) 287 288 (defsyntax true-value () 289 `(backend-ecase 290 (:oracle "Y") 291 (:postgresql t #+nil :true) 292 (:sqlite 1))) 293 294 (defsyntax false-value () 295 `(backend-ecase 296 (:oracle "N") 297 (:postgresql nil #+nil :false) 298 (:sqlite 0))) 299 300 (defsyntax true-exp () 301 `(backend-case 302 (:oracle (= 1 1)) 303 (t (true-value)))) 304 305 (defsyntax false-exp () 306 `(backend-case 307 (:oracle (= 1 2)) 308 (t (false-value)))) 309 310 (defsyntax to-boolean (exp) 311 `(backend-case 312 (:oracle ,(cl:cond 313 ((cl:not exp) `(false-value)) 314 ((cl:eq t exp) `(true-value)) 315 ((cl:atom exp) (cl:error "not a boolean value ~s" exp)) 316 (t `(prefix :case :when ,exp (true-value) :else (false-value))))) 317 (t (= (true-value) ,exp)))) 318 319 ;;(cl:macroexpand '(to-boolean (= 1 2))) 320 321 (defsyntax cond (&body cases) 322 `(backend-case 323 (:oracle 324 (= (true-value) 325 (par 326 (prefix :case 327 ,@(cl:loop 328 :for (c b) :in cases 329 :appending (cl:if (cl:eq cl:t c) `(:else ,b) `(:when ,c :then ,b))) 330 :end)))) 331 (t (prefix :case 332 ,@(cl:loop 333 :for (c b) :in cases 334 :appending (cl:if (cl:eq cl:t c) `(:else ,b) `(:when ,c :then ,b))) 335 :end)))) 336 337 (defsyntax if (test then else) 338 `(cond (,test ,then) (t ,else))) 339 340 ;;(cl:macroexpand '(if 1 (false-value) (true-value))) ;; TODO forbid cl:nil and cl:t? 341 ;;(cl:macroexpand '(if 1 2 3)) 342 ;;(cl:macroexpand '(cond (1 1) (2 2) (t 3))) 343 344 #+nil ;; when and unless dont make sense for sql because of return value type clash 345 (defsyntax when (test &body body) 346 `(if ,test ,body (false-value))) 347 348 #+nil 349 (defsyntax unless (test &body body) 350 `(if ,test (false-value) ,body)) 351 352 (defsyntax gt0 (exp) `(< 0 ,exp)) 353 (defsyntax ge0 (exp) `(<= 0 ,exp)) 354 (defsyntax lt0 (exp) `(< ,exp 0)) 355 (defsyntax le0 (exp) `(<= ,exp 0)) 356 357 (defsyntax zerop (exp) `(= 0 ,exp)) 358 (defsyntax plusp (exp) `(gt0 ,exp)) 359 (defsyntax minusp (exp) `(lt ,exp)) 360 361 ;;(plusp (+ 1 2 3)) 362 363 (defsyntax par (&body body) 364 `(prefix :|(| ,@body :|)|)) 365 366 (defsyntax function (name &body clist) 367 `(prefix ,name (par (clist ,@clist)))) 368 369 (defsyntax count (x) `(function :count ,x)) 370 ;;(defsyntax distinct (x) `(function :distinct ,x)) 371 (defsyntax upper (x) `(function :upper ,x)) 372 373 (cl:macrolet 374 ((defop (name &rest rest) 375 `(defsyntax ,name (exp) 376 `(function ,,@rest ,exp)))) 377 (defop min :min) 378 (defop max :max) 379 (defop avg :avg) 380 (defop sum :sum)) 381 382 (defsyntax asc (exp) `(prefix ,exp :asc)) 383 (defsyntax desc (exp) `(prefix ,exp :desc)) 384 385 (defsyntax as (tab alias) `(prefix ,tab ,alias)) 386 387 (defsyntax qvar (name &optional type) 388 `(:qvar ,name ,type)) 389 390 (defsyntax qchunk (qchunk) 391 `(:qchunk ,qchunk)) 392 393 (defsyntax alter-table (tab &body clist) 394 `(prefix :alter :table ,tab (clist ,@clist))) 395 396 (defsyntax alter-sequence (seq &body body) 397 `(prefix :alter :sequence ,seq ,@body)) 398 399 (defsyntax nullable (nullable) 400 (cl:if nullable '(prefix :null) '(prefix :not :null))) 401 402 ;;; We need to distinguish between constraints which can be set up 403 ;;; during CREATE TABLE and those which require a second ALTER TABLE 404 ;;; step: 405 ;;; 406 ;;; While foreign key constraints are nominally part of the column 407 ;;; definition, it is not possible to define both together in the case 408 ;;; where the target table has not been defined yet, meaning that 409 ;;; ordering matterns and circular references need to be dealt with. 410 ;;; 411 ;;; An similar issue would arise for table contents: We need to be able 412 ;;; to separate out table and constraint definition for data import files, 413 ;;; where the order must be: 414 ;;; 1. create table 415 ;;; 2. insert into / copy 416 ;;; 3. alter table add foreign key 417 (defsyntax add-column (name type nullable default &body constraints) 418 `(prefix :add ,name ,type 419 (nullable ,nullable) 420 ,@(cl:when default `(:default ,default)) 421 #+nil 422 (mapc (lambda (constraint) 423 (unless (delay-constraint-until-alter-table-p constraint) 424 (format-sql-syntax-node constraint))) 425 constraints))) 426 427 (defsyntax drop-column (name cascade) 428 `(prefix :drop :column ,name 429 ,@(cl:when cascade `(:cascade 430 ,@(backend-case (:oracle '(:constraints))))))) 431 432 (defsyntax alter-column-type (name type nullable) ;; TODO nullable 433 `(backend-ecase 434 (:oracle (prefix :modify ,name ,type)) 435 (:postgresql (prefix :alter :column ,name :type ,type)))) 436 437 (defsyntax add-unique-constraint (name &body columns) 438 `(prefix :add :constraint ,name :unique (par (clist ,@columns)))) 439 440 (defsyntax add-primary-key-constraint (name &body columns) 441 `(prefix :add :constraint ,name :primary :key (par (clist ,@columns)))) 442 443 (cl:defmacro foreign-key-action (action) 444 (cl:ecase action 445 (:no-action '(:no :action)) 446 (:restrict '(:restrict)) 447 (:set-null '(:set :null)) 448 (:set-default '(:set :default)) 449 (:cascade '(:cascade)))) 450 451 (defsyntax on-delete (action) 452 `(prefix :on :delete (foreign-key-action ,action))) 453 454 (defsyntax on-update (action) 455 `(prefix :on :update (foreign-key-action ,action))) 456 457 (defsyntax add-foreign-key-constraint (name source-columns target-columns 458 target-table 459 on-delete on-update) 460 `(prefix :add :constraint ,name 461 :foreign :key (par (clist ,@source-columns)) 462 :references ,target-table (par (clist ,@target-columns)) 463 ,on-delete ,on-update 464 :deferrable :initially :immediate)) 465 466 (defsyntax drop-constraint (name tab) 467 `(alter-table ,tab :drop :constraint ,name)) 468 469 (defsyntax update (tab alist &optional where) 470 `(prefix :update ,tab :set 471 (clist ,@(cl:loop :for (k v) :in alist :collect `(lst " = " ,k ,v))) 472 ,where)) 473 474 (defsyntax create-table (name cols &optional temp as using) 475 `(prefix :create 476 ,@(cl:when temp '(:global :temporary)) 477 ,@(cl:when using '(:virtual)) 478 :table ,name 479 ,@(cl:when using `(:using ,using)) 480 (par ,cols) 481 ,@ (cl:when (cl:and temp (cl:not (cl:eq t temp)) (cl:not as)) 482 `((:on :commit ,@ (cl:ecase temp 483 (:drop '(:drop)) 484 (:preserve-rows '(:preserve :rows)) 485 (:delete-rows '(:delete-rows)))))) 486 ,@(cl:when as `(,@as)))) 487 488 (defsyntax create-view (replace name temp cols &optional as) 489 `(prefix :create ,@(cl:when replace '(:or :replace)) 490 ,@(cl:when temp '(:temporary)) :view ,name 491 (par ,@cols) ,@(cl:when as `(,@as)))) 492 493 (defsyntax lock-table (tab mode wait) 494 `(prefix :lock :table ,tab 495 :in ,@ (cl:ecase mode 496 (:row-share '(:row :share)) 497 (:row-exclusive '(:row :exclusive)) 498 (:share-update '(:share :update)) 499 (:share '(:share)) 500 (:share-row-exclusive '(:share :row :exclusive)) 501 (:exclusive '(:exclusive))) 502 :mode 503 ,@(cl:unless wait '(:nowait)))) 504 505 (defsyntax regexp-like (string pattern case-sensitive) 506 `(backend-ecase 507 (:oracle (function :regexp_like ,string ,pattern ,(cl:if case-sensitive "c" "i"))) 508 (:postgresql ??))) 509 510 (defsyntax not (exp) 511 `(backend-ecase 512 (:oracle (function :not ,(cl:if (cl:atom exp) `(= (true-value) ,exp) exp))) 513 (:postgresql (prefix :not ,exp)))) 514 515 (defsyntax abs (exp) 516 `(backend-ecase 517 (:oracle (function :abs ,exp)) 518 (:postgresql (@ ,exp)))) 519 520 (defsyntax sqrt (exp) 521 `(backend-ecase 522 ((:oracle :mysql) (function :sqrt ,exp)) 523 (:postgresql (\|/ ,exp)))) 524 525 (defsyntax bitand(lexp rexp) 526 `(backend-ecase 527 (:oracle (function :bitand ,lexp ,rexp)) 528 (:postgresql (& ,lexp ,rexp)))) 529 530 (defsyntax suppress-qvar (exp) ;; make qchunk from qvar 531 `(:suppress-qvar ,(cl:macroexpand exp))) 532 533 (defsyntax postgresql/to-tsvector (what &optional regconfig) 534 `(function :to_tsvector 535 ,@(cl:when regconfig `((suppress-qvar ,regconfig))) 536 ,what)) 537 538 (defsyntax postgresql/to-tsquery (query &optional regconfig) 539 `(function :to_tsquery 540 ,@(cl:when regconfig `((suppress-qvar ,regconfig))) 541 ,query)) 542 543 (defsyntax postgresql/@@ (tsvector tsquery) 544 `(infix " @@ " ,tsvector ,tsquery)) 545 546 (defsyntax oracle/contains (what query &optional number) 547 `(function :contains ,what (suppress-qvar ,query) 548 ,@(cl:when number `((suppress-qvar ,number))))) 549 550 #+nil 551 (define-query-macro full-text-search (class what query &optional regconfig) 552 `(backend-ecase 553 (:postgresql (full-text-search-query-outer-function 554 (postgresql/@@ 555 ,(or (let ((x (related-tsvector-accessor class (car what)))) 556 (when x 557 (cons x (cdr what)))) 558 `(postgresql/to-tsvector ,what ,regconfig)) 559 (postgresql/to-tsquery 560 (full-text-search-query-inner-function ,query) 561 ,regconfig)) 562 ,what 563 ,query)) 564 (:oracle (plusp (oracle/contains ,what ,query))))) 565 566 (defsyntax empty-clob () 567 `(function :empty_clob)) 568 569 (defsyntax empty-blob () 570 `(function :empty_blob)) 571 572 (defsyntax boolean-type () 573 `(backend-ecase 574 (:oracle (function :char 1)) 575 (:postgresql :bool) 576 (:sqlite :boolean))) 577 578 (defsyntax numeric-type () 579 `(backend-ecase 580 ;; NUMBER => oracle assumes NUMBER(*.0) :-{ 581 (:oracle ,(cl:error "use more specific type with oracle backend")) 582 (t (:numeric)))) 583 584 (defsyntax tsvector-type () 585 '(:tsvector)) 586 587 (defsyntax clob-type () 588 `(backend-ecase 589 (:oracle :clob) 590 (:postgresql (prefix :character :large :object)))) 591 592 (defsyntax blob-type () 593 `(backend-ecase 594 (:oracle :blob) 595 (:postgresql :bytea))) 596 597 (defsyntax date-type () 598 :date) 599 600 (defsyntax time-type () 601 :time) 602 603 (defsyntax timestamp-type () 604 :timestamp) 605 606 (defsyntax timestamp-with-timezone-type () 607 '(prefix :timestamp :with :time :zone)) 608 609 (defsyntax interval-type () 610 `(backend-ecase 611 (:oracle ,(cl:error "sql-interval-type not yet supported")) 612 (:postgresql '(:interval)))) 613 614 (defsyntax char-sized-type (type &optional size) 615 `(backend-ecase 616 (:oracle (prefix ,type ,@(cl:when size `(par (prefix ,size :char))))) 617 (:postgresql (prefix ,type ,@(cl:when size `(#+nil :size (par ,size))))))) 618 619 (defsyntax char-type (&optional size) 620 `(backend-ecase 621 (:oracle ,(cl:if (cl:eql 1 size) 622 (cl:error "CHAR(1) is reserved for boolean type") 623 `(char-sized-type :char ,size))) 624 (:postgresql (char-sized-type :char ,size)))) 625 626 (defsyntax varchar-type (&optional size) 627 `(backend-ecase 628 (:oracle (char-sized-type :varchar2 ,size)) 629 (t ,(cl:if size `(char-sized-type :varchar ,size) :text)))) 630 631 (defsyntax varchar-without-size-if-possible () 632 `(varchar-type (backend-case 633 ;; max 4000 bytes? 634 (:oracle (varchar-type 256))))) 635 636 (defsyntax float-type (bit-size) 637 (cl:progn 638 (cl:assert (cl:and bit-size (cl:<= 32 bit-size 64))) 639 (cl:cond 640 ((cl:<= bit-size 32) 641 `(backend-ecase 642 (:oracle :binary_float) 643 (:postgresql :real))) 644 ((cl:<= bit-size 64) 645 `(backend-ecase 646 (:oracle :binary_double) 647 (:postgresql '(prefix :double :precision))))))) 648 649 (defsyntax integer-type (&optional bit-size) 650 (cl:cond 651 ((cl:null bit-size) 652 `(backend-ecase 653 (:oracle '(function :number :* 0)) 654 (:postgresql :numeric) 655 (:sqlite :integer))) 656 ((cl:<= bit-size 16) 657 `(backend-ecase 658 (:oracle '(function :number 5 0)) 659 (:postgresql :smallint) 660 (:sqlite :integer))) 661 ((cl:<= bit-size 32) 662 `(backend-ecase 663 (:oracle '(function :number 10 0)) 664 (:postgresql :int) 665 (:sqlite :integer))) 666 ((cl:<= bit-size 64) 667 `(backend-ecase 668 (:oracle '(function :number 19 0)) 669 (:postgresql :bigint) 670 (:sqlite :integer))) 671 (cl:t 672 `(backend-ecase 673 (:oracle '(function :number :* 0)) 674 (:postgresql :numeric) 675 (:sqlite :integer))))) 676 677 (defsyntax bit-sized-type (type &optional bit-size) 678 (cl:cond 679 ((cl:null bit-size) type) 680 ;; TODO why not ,bit-size 681 ((cl:<= bit-size 16) `(prefix ,type :bit :bit-size 16)) 682 ((cl:<= bit-size 32) `(prefix ,type :bit :bit-size 32)) 683 ((cl:<= bit-size 64) `(prefix ,type :bit :bit-size 64)) 684 (cl:t type))) 685 686 (defsyntax set (&body values) 687 `(par (clist ,@values))) 688 689 (defsyntax power (lexp rexp) 690 `(function :power ,lexp ,rexp))