r9199: fold clsql-base and clsql-base-sys into clsql-base

[clsql.git] / base / pool.lisp

diff --git a/base/pool.lisp b/base/pool.lisp
index 2a9f91bf94e49be7002ef12b1a0d7ae9163ce009..0564eb0e33f9651c2bc9af616e6c815d99111677 100644 (file)
--- a/base/pool.lisp
+++ b/base/pool.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg, Marc Battyani
 ;;;; Date Started:  Apr 2002
 ;;;;
-;;;; $Id: pool.lisp 7061 2003-09-07 06:34:45Z kevin $
+;;;; $Id$
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
 ;;;;
@@ -16,33 +16,14 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package #:clsql-base-sys)
-
-(defun make-process-lock (name) 
-  #+allegro (mp:make-process-lock :name name)
-  #+scl (thread:make-lock name)
-  #+lispworks (mp:make-lock :name name)
-  #-(or allegro scl lispworks) (declare (ignore name))
-  #-(or allegro scl lispworks) nil)
-
-(defmacro with-process-lock ((lock desc) &body body)
-  #+scl `(thread:with-lock-held (,lock ,desc) ,@body)
-  #+(or allegro lispworks)
-  (declare (ignore desc))
-  #+(or allegro lispworks)
-  (let ((l (gensym)))
-    `(let ((,l ,lock))
-       #+allegro (mp:with-process-lock (,l) ,@body)
-       #+lispworks (mp:with-lock (,l) ,@body)))
-  #-(or scl allegro lispworks) (declare (ignore lock desc))
-  #-(or scl allegro lispworks) `(progn ,@body))
+(in-package #:clsql-base)
 
 (defvar *db-pool* (make-hash-table :test #'equal))
 (defvar *db-pool-lock* (make-process-lock "DB Pool lock"))
 
 (defclass conn-pool ()
   ((connection-spec :accessor connection-spec :initarg :connection-spec)
-   (database-type :accessor database-type :initarg :database-type)
+   (database-type :accessor pool-database-type :initarg :pool-database-type)
    (free-connections :accessor free-connections
                     :initform (make-array 5 :fill-pointer 0 :adjustable t))
    (all-connections :accessor all-connections
@@ -55,7 +36,7 @@
        (and (plusp (length (free-connections pool)))
             (vector-pop (free-connections pool))))
       (let ((conn (connect (connection-spec pool)
-                          :database-type (database-type pool)
+                          :database-type (pool-database-type pool)
                           :if-exists :new)))
        (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
          (vector-push-extend conn (all-connections pool))
@@ -85,7 +66,7 @@ if not found"
       (unless conn-pool
        (setq conn-pool (make-instance 'conn-pool
                                       :connection-spec connection-spec
-                                      :database-type database-type))
+                                      :pool-database-type database-type))
        (setf (gethash key *db-pool*) conn-pool))
       conn-pool)))