From fa071351835a2c754895cb917db9c63303e7b5c1 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Mon, 21 Oct 2002 07:45:50 +0000
Subject: [PATCH] r3129: dtc patches

---
 base/cmucl-compat.lisp                        |  18 +-
 base/conditions.lisp                          |   4 +-
 base/utils.lisp                               |  10 +-
 .../postgresql-socket-api.lisp                | 279 +++++++++---------
 .../postgresql-socket-package.lisp            |   4 +-
 debian/changelog                              |   8 +
 sql/loop-extension.lisp                       |   6 +-
 sql/package.lisp                              |   3 +-
 sql/pool.lisp                                 |  79 +++--
 sql/sql.lisp                                  |   4 +-
 10 files changed, 233 insertions(+), 182 deletions(-)

diff --git a/base/cmucl-compat.lisp b/base/cmucl-compat.lisp
index 3da7694..8b2b5a5 100644
--- a/base/cmucl-compat.lisp
+++ b/base/cmucl-compat.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: cmucl-compat.lisp,v 1.2 2002/10/14 04:09:02 kevin Exp $
+;;;; $Id: cmucl-compat.lisp,v 1.3 2002/10/21 07:45:49 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -29,15 +29,15 @@
    ))
 (in-package :cmucl-compat)
 
-#+cmu
+#+(or cmu scl)
 (defmacro required-argument ()
   `(ext:required-argument))
 
-#-cmu
+#-(or cmu scl)
 (defun required-argument ()
   (error "~&A required keyword argument was not supplied"))
 
-#+cmu
+#+(or cmu scl)
 (defmacro shrink-vector (vec len)
   `(lisp::shrink-vector ,vec ,len))
 
@@ -45,7 +45,7 @@
 (defmacro shrink-vector (vec len)
   `(sb-kernel::shrink-vector ,vec ,len))
 
-#-(or cmu sbcl)
+#-(or cmu sbcl scl)
 (defmacro shrink-vector (vec len)
   "Shrinks a vector. Optimized if vector has a fill pointer.
 Needs to be a macro to overwrite value of VEC."
@@ -69,7 +69,7 @@ Needs to be a macro to overwrite value of VEC."
 
 
 
-#-(or cmu sbcl)
+#-(or cmu sbcl scl)
 (defun make-sequence-of-type (type length)
   "Returns a sequence of the given TYPE and LENGTH."
   (declare (fixnum length))
@@ -90,7 +90,7 @@ Needs to be a macro to overwrite value of VEC."
      (make-sequence-of-type (result-type-or-lose type t) length))))
 
 
-#+cmu
+#+(or cmu scl)
 (if (fboundp 'lisp::make-sequence-of-type)
     (defun make-sequence-of-type (type len)
       (lisp::make-sequence-of-type type len))
@@ -101,7 +101,7 @@ Needs to be a macro to overwrite value of VEC."
 (defun make-sequence-of-type (type len)
   (sb-impl::make-sequence-of-type type len))
 
-#-(or cmu sbcl)
+#-(or cmu sbcl scl)
 (defun result-type-or-lose (type nil-ok)
   (unless (or type nil-ok)
     (error "NIL output type invalid for this sequence function"))
@@ -118,7 +118,7 @@ Needs to be a macro to overwrite value of VEC."
      (error "~S is a bad type specifier for sequence functions." type))
     ))
 
-#+cmu
+#+(or cmu scl)
 (defun result-type-or-lose (type nil-ok)
   (lisp::result-type-or-lose type nil-ok))
 
diff --git a/base/conditions.lisp b/base/conditions.lisp
index 5f0fb3a..d1280dc 100644
--- a/base/conditions.lisp
+++ b/base/conditions.lisp
@@ -8,7 +8,7 @@
 ;;;;                 Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: conditions.lisp,v 1.1 2002/09/30 10:19:01 kevin Exp $
+;;;; $Id: conditions.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -55,7 +55,7 @@
 and signal an clsql-invalid-spec-error if they don't match."
   `(handler-case
     (destructuring-bind ,template ,connection-spec 
-      (declare (ignore ,@template))
+      (declare (ignore ,@(remove '&optional template)))
       t)
     (error () (error 'clsql-invalid-spec-error
 		     :connection-spec ,connection-spec
diff --git a/base/utils.lisp b/base/utils.lisp
index 5514dc7..f0530fb 100644
--- a/base/utils.lisp
+++ b/base/utils.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:   Kevin M. Rosenberg
 ;;;; Date Started: Mar 2002
 ;;;;
-;;;; $Id: utils.lisp,v 1.1 2002/09/30 10:19:01 kevin Exp $
+;;;; $Id: utils.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -36,16 +36,22 @@
       (substitute #\e #\f str))
      ((find #\d str)
       (substitute #\e #\d str))
+     ((find #\l str)
+      (substitute #\e #\l str))
+     ((find #\s str)
+      (substitute #\e #\S str))
      ((find #\F str)
       (substitute #\e #\F str))
      ((find #\D str)
       (substitute #\e #\D str))
+     ((find #\L str)
+      (substitute #\e #\L str))
      ((find #\S str)
       (substitute #\e #\S str))
      (t
       str))))
 
-  (defun sql-escape (identifier)
+(defun sql-escape (identifier)
   "Change hyphens to underscores, ensure string"
   (let* ((unescaped (etypecase identifier
                       (symbol (symbol-name identifier))
diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp
index afd0014..4dffc99 100644
--- a/db-postgresql-socket/postgresql-socket-api.lisp
+++ b/db-postgresql-socket/postgresql-socket-api.lisp
@@ -2,14 +2,14 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          postgresql-socket.cl
+;;;; Name:          postgresql-socket-api.lisp
 ;;;; Purpose:       Low-level PostgreSQL interface using sockets
 ;;;; Programmers:   Kevin M. Rosenberg based on
 ;;;;                Original code by Pierre R. Mai 
 ;;;;                
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: postgresql-socket-api.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: postgresql-socket-api.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -83,117 +83,120 @@ socket interface"
   +ready-for-query-message+ #\Z
   +row-description-message+ #\T))
 
-(defgeneric send-socket-value (type socket value))
+#+scl
+(declaim (inline read-byte write-byte))
 
-(defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
+(defun send-socket-value-int32 (socket value)
+  (declare (type stream socket)
+	   (type (unsigned-byte 32) value))
   (write-byte (ldb (byte 8 24) value) socket)
   (write-byte (ldb (byte 8 16) value) socket)
   (write-byte (ldb (byte 8 8) value) socket)
-  (write-byte (ldb (byte 8 0) value) socket))
+  (write-byte (ldb (byte 8 0) value) socket)
+  nil)
 
-(defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
+(defun send-socket-value-int16 (socket value)
+  (declare (type stream socket)
+	   (type (unsigned-byte 16) value))
   (write-byte (ldb (byte 8 8) value) socket)
-  (write-byte (ldb (byte 8 0) value) socket))
-
-(defmethod send-socket-value ((type (eql 'int8)) socket (value integer))
-  (write-byte (ldb (byte 8 0) value) socket))
-
-(defmethod send-socket-value ((type (eql 'string)) socket (value string))
+  (write-byte (ldb (byte 8 0) value) socket)
+  nil)
+
+(defun send-socket-value-int8 (socket value)
+  (declare (type stream socket)
+	   (type (unsigned-byte 8) value))
+  (write-byte (ldb (byte 8 0) value) socket)
+  nil)
+
+(defun send-socket-value-char-code (socket value)
+  (declare (type stream socket)
+	   (type character value))
+  (write-byte (ldb (byte 8 0) (char-code value)) socket)
+  nil)
+
+(defun send-socket-value-string (socket value)
+  (declare (type stream socket)
+	   (type string value))
   (loop for char across value
 	for code = (char-code char)
 	do (write-byte code socket)
-	finally (write-byte 0 socket)))
-
-(defmethod send-socket-value ((type (eql 'limstring)) socket (value string))
-  (loop for char across value
-	for code = (char-code char)
-	do (write-byte code socket)))
-
-(defmethod send-socket-value ((type (eql 'byte)) socket (value integer))
-  (write-byte value socket))
-
-(defmethod send-socket-value ((type (eql 'byte)) socket (value character))
-  (write-byte (char-code value) socket))
-
-(defmethod send-socket-value ((type (eql 'byte)) socket value)
-  (write-sequence value socket))
-
-(defgeneric read-socket-value (type socket))
-
-(defmethod read-socket-value ((type (eql 'int32)) socket)
+	finally (write-byte 0 socket))
+  nil)
+
+(defun send-socket-value-limstring (socket value limit)
+  (declare (type stream socket)
+	   (type string value)
+	   (type fixnum limit))
+  (let ((length (length value)))
+    (dotimes (i (min length limit))
+      (let ((code (char-code (char value i))))
+	(write-byte code socket)))
+    (dotimes (i (- limit length))
+      (write-byte 0 socket)))
+  nil)
+
+
+(defun read-socket-value-int32 (socket)
+  (declare (type stream socket))
+  (declare (optimize (speed 3)))
   (let ((result 0))
+    (declare (type (unsigned-byte 32) result))
     (setf (ldb (byte 8 24) result) (read-byte socket))
     (setf (ldb (byte 8 16) result) (read-byte socket))
     (setf (ldb (byte 8 8) result) (read-byte socket))
     (setf (ldb (byte 8 0) result) (read-byte socket))
     result))
 
-(defmethod read-socket-value ((type (eql 'int16)) socket)
+(defun read-socket-value-int16 (socket)
+  (declare (type stream socket))
   (let ((result 0))
+    (declare (type (unsigned-byte 16) result))
     (setf (ldb (byte 8 8) result) (read-byte socket))
     (setf (ldb (byte 8 0) result) (read-byte socket))
     result))
 
-(defmethod read-socket-value ((type (eql 'int8)) socket)
+(defun read-socket-value-int8 (socket)
+  (declare (type stream socket))
   (read-byte socket))
 
-(defmethod read-socket-value ((type (eql 'string)) socket)
+(defun read-socket-value-string (socket)
+  (declare (type stream socket))
   (with-output-to-string (out)
     (loop for code = (read-byte socket)
 	  until (zerop code)
 	  do (write-char (code-char code) out))))
 
-(defgeneric skip-socket-value (type socket))
-
-(defmethod skip-socket-value ((type (eql 'int32)) socket)
-  (dotimes (i 4) (read-byte socket)))
-
-(defmethod skip-socket-value ((type (eql 'int16)) socket)
-  (dotimes (i 2) (read-byte socket)))
-
-(defmethod skip-socket-value ((type (eql 'int8)) socket)
-  (read-byte socket))
-
-(defmethod skip-socket-value ((type (eql 'string)) socket)
-  (loop until (zerop (read-byte socket))))
 
 (defmacro define-message-sender (name (&rest args) &rest clauses)
-  (loop with socket-var = (gensym)
-	for (type value) in clauses
-	collect
-	`(send-socket-value ',type ,socket-var ,value)
-	into body
-      finally
-	(return
-	  `(defun ,name (,socket-var ,@args)
-	     ,@body))))
-
-(defun pad-limstring (string limit)
-  (let ((result (make-string limit :initial-element #\NULL)))
-    (loop for char across string
-	  for index from 0 below limit
-	  do (setf (char result index) char))
-    result))
+  (let ((socket-var (gensym))
+	(body nil))
+    (dolist (clause clauses)
+      (let* ((type (first clause))
+	     (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-)
+				      (symbol-name type)))))
+	(push `(,fn ,socket-var ,@(rest clause)) body)))
+    `(defun ,name (,socket-var ,@args)
+       ,@(nreverse body))))
 
 (define-message-sender send-startup-message
     (database user &optional (command-line "") (backend-tty ""))
   (int32 296)                           ; Length
   (int32 #x00020000)                    ; Version 2.0
-  (limstring (pad-limstring database 64))
-  (limstring (pad-limstring user 32))
-  (limstring (pad-limstring command-line 64))
-  (limstring (pad-limstring "" 64))     ; Unused
-  (limstring (pad-limstring backend-tty 64)))
+  (limstring database 64)
+  (limstring user 32)
+  (limstring command-line 64)
+  (limstring "" 64)     ; Unused
+  (limstring backend-tty 64))
 
 (define-message-sender send-terminate-message ()
-  (byte #\X))
+  (char-code #\X))
 
 (define-message-sender send-unencrypted-password-message (password)
   (int32 (+ 5 (length password)))
   (string password))
 
 (define-message-sender send-query-message (query)
-  (byte #\Q)
+  (char-code #\Q)
   (string query))
 
 (define-message-sender send-encrypted-password-message (crypted-password)
@@ -208,9 +211,10 @@ socket interface"
 
 
 (defun read-socket-sequence (string stream)
-"KMR -- Added to support reading from binary stream into a string"
-  (declare (optimize (speed 3) (safety 0))
-	   (string string))
+  "KMR -- Added to support reading from binary stream into a string"
+  (declare (string string)
+	   (stream stream)
+	   (optimize (speed 3) (safety 0)))
   (dotimes (i (length string))
     (declare (fixnum i))
     (setf (char string i) (code-char (read-byte stream))))
@@ -219,25 +223,33 @@ socket interface"
 
 ;;; Support for encrypted password transmission
 
-(defvar *crypt-library-loaded* nil)
+#-scl
+(eval-when (compile eval load)
+  (defvar *crypt-library-loaded* nil)
 
-(defun crypt-password (password salt)
-  "Encrypt a password for transmission to a PostgreSQL server."
   (unless *crypt-library-loaded*
     (uffi:load-foreign-library 
      (uffi:find-foreign-library "libcrypt"
 			   '("/usr/lib/" "/usr/local/lib/" "/lib/"))
      :supporting-libraries '("c"))
-    (eval '(uffi:def-function "crypt" 
-	    ((key :cstring)
-	     (salt :cstring))
-	    :returning :cstring))
-    (setq *crypt-library-loaded* t))
-   (uffi:with-cstring (password-cstring password)
-     (uffi:with-cstring (salt-cstring salt)
-       (uffi:convert-from-cstring 
-	(funcall (fdefinition 'crypt) password-cstring salt-cstring)))))
-;;; Condition hierarchy
+    (setq *crypt-library-loaded* t)))
+
+(in-package :postgresql-socket)
+
+(uffi:def-function "crypt" 
+    ((key :cstring)
+     (salt :cstring))
+  :returning :cstring)
+
+(defun crypt-password (password salt)
+  "Encrypt a password for transmission to a PostgreSQL server."
+  (uffi:with-cstring (password-cstring password)
+    (uffi:with-cstring (salt-cstring salt)
+      (uffi:convert-from-cstring 
+       (crypt password-cstring salt-cstring)))))
+
+
+;;;; Condition hierarchy
 
 (define-condition postgresql-condition (condition)
   ((connection :initarg :connection :reader postgresql-condition-connection)
@@ -297,7 +309,7 @@ socket interface"
   "Timeout in seconds for reads from the PostgreSQL server.")
 
 
-#+cmu
+#+(or cmu scl)
 (defun open-postgresql-socket (host port)
   (etypecase host
     (pathname
@@ -309,7 +321,7 @@ socket interface"
     (string
      (ext:connect-to-inet-socket host port))))
 
-#+cmu
+#+(or cmu scl)
 (defun open-postgresql-socket-stream (host port)
   (system:make-fd-stream
    (open-postgresql-socket host port)
@@ -397,9 +409,9 @@ connection, if it is still open."
 				 (postgresql-connection-tty connection))
 	   (force-output socket)
 	   (loop
-	       (case (read-socket-value 'int8 socket)
+	       (case (read-socket-value-int8 socket)
 		 (#.+authentication-message+
-		  (case (read-socket-value 'int32 socket)
+		  (case (read-socket-value-int32 socket)
 		    (0 (return))
 		    ((1 2)
 		     (error 'postgresql-login-error
@@ -423,7 +435,7 @@ connection, if it is still open."
 			    :message
 			    "Postmaster expects unknown authentication method."))))
 		 (#.+error-response-message+
-		  (let ((message (read-socket-value 'string socket)))
+		  (let ((message (read-socket-value-string socket)))
 		    (error 'postgresql-login-error
 			   :connection connection :message message)))
 		 (t
@@ -434,22 +446,22 @@ connection, if it is still open."
 	   ;; Start backend communication
 	   (force-output socket)
 	   (loop
-	       (case (read-socket-value 'int8 socket)
+	       (case (read-socket-value-int8 socket)
 		 (#.+backend-key-message+
 		  (setf (postgresql-connection-pid connection)
-			(read-socket-value 'int32 socket)
+			(read-socket-value-int32 socket)
 			(postgresql-connection-key connection)
-			(read-socket-value 'int32 socket)))
+			(read-socket-value-int32 socket)))
 		 (#.+ready-for-query-message+
 		  (setq socket nil)
 		  (return connection))
 		 (#.+error-response-message+
-		  (let ((message (read-socket-value 'string socket)))
+		  (let ((message (read-socket-value-string socket)))
 		    (error 'postgresql-login-error
 			   :connection connection
 			   :message message)))
 		 (#.+notice-response-message+
-		  (let ((message (read-socket-value 'string socket)))
+		  (let ((message (read-socket-value-string socket)))
 		    (warn 'postgresql-warning :connection connection
 			  :message message)))
 		 (t
@@ -480,14 +492,14 @@ connection, if it is still open."
   (loop with socket = (postgresql-connection-socket connection)
 	while (listen socket)
 	do
-	(case (read-socket-value 'int8 socket)
+	(case (read-socket-value-int8 socket)
 	  (#.+notice-response-message+
-	   (let ((message (read-socket-value 'string socket)))
+	   (let ((message (read-socket-value-string socket)))
 	     (warn 'postgresql-warning :connection connection
 		   :message message)))
 	  (#.+notification-response-message+
-	   (let ((pid (read-socket-value 'int32 socket))
-		 (message (read-socket-value 'string socket)))
+	   (let ((pid (read-socket-value-int32 socket))
+		 (message (read-socket-value-string socket)))
 	     (when (= pid (postgresql-connection-pid connection))
 	       (signal 'postgresql-notification :connection connection
 		       :message message))))
@@ -508,21 +520,21 @@ connection, if it is still open."
 	(cursor-name nil)
 	(error nil))
     (loop
-	(case (read-socket-value 'int8 socket)
+	(case (read-socket-value-int8 socket)
 	  (#.+completed-response-message+
-	   (return (values :completed (read-socket-value 'string socket))))
+	   (return (values :completed (read-socket-value-string socket))))
 	  (#.+cursor-response-message+
-	   (setq cursor-name (read-socket-value 'string socket)))
+	   (setq cursor-name (read-socket-value-string socket)))
 	  (#.+row-description-message+
-	   (let* ((count (read-socket-value 'int16 socket))
+	   (let* ((count (read-socket-value-int16 socket))
 		  (fields
 		   (loop repeat count
 		     collect
 		     (list
-		      (read-socket-value 'string socket)
-		      (read-socket-value 'int32 socket)
-		      (read-socket-value 'int16 socket)
-		      (read-socket-value 'int32 socket)))))
+		      (read-socket-value-string socket)
+		      (read-socket-value-int32 socket)
+		      (read-socket-value-int16 socket)
+		      (read-socket-value-int32 socket)))))
 	     (return
 	       (values :cursor
 		       (make-postgresql-cursor :connection connection
@@ -537,17 +549,17 @@ connection, if it is still open."
 	     (error error))
 	   (return nil))
 	  (#.+error-response-message+
-	   (let ((message (read-socket-value 'string socket)))
+	   (let ((message (read-socket-value-string socket)))
 	     (setq error
 		   (make-condition 'postgresql-error
 				   :connection connection :message message))))
 	  (#.+notice-response-message+
-	   (let ((message (read-socket-value 'string socket)))
+	   (let ((message (read-socket-value-string socket)))
 	     (warn 'postgresql-warning
 		   :connection connection :message message)))
 	  (#.+notification-response-message+
-	   (let ((pid (read-socket-value 'int32 socket))
-		 (message (read-socket-value 'string socket)))
+	   (let ((pid (read-socket-value-int32 socket))
+		 (message (read-socket-value-string socket)))
 	     (when (= pid (postgresql-connection-pid connection))
 	       (signal 'postgresql-notification :connection connection
 		       :message message))))
@@ -567,7 +579,7 @@ connection, if it is still open."
 
 
 (defun read-field (socket type)
-  (let ((length (- (read-socket-value 'int32 socket) 4)))
+  (let ((length (- (read-socket-value-int32 socket) 4)))
     (case type
       ((:int32 :int64)
        (read-integer-from-socket socket length))
@@ -688,7 +700,7 @@ connection, if it is still open."
 	 (fields (postgresql-cursor-fields cursor)))
     (assert (postgresql-connection-open-p connection))
     (loop
-	(let ((code (read-socket-value 'int8 socket)))
+	(let ((code (read-socket-value-int8 socket)))
 	  (case code
 	    (#.+ascii-row-message+
 	     (return
@@ -706,18 +718,18 @@ connection, if it is still open."
 	    (#.+binary-row-message+
 	     (error "NYI"))
 	    (#.+completed-response-message+
-	     (return (values nil (read-socket-value 'string socket))))
+	     (return (values nil (read-socket-value-string socket))))
 	    (#.+error-response-message+
-	     (let ((message (read-socket-value 'string socket)))
+	     (let ((message (read-socket-value-string socket)))
 	       (error 'postgresql-error
 		      :connection connection :message message)))
 	    (#.+notice-response-message+
-	     (let ((message (read-socket-value 'string socket)))
+	     (let ((message (read-socket-value-string socket)))
 	       (warn 'postgresql-warning
 		     :connection connection :message message)))
 	    (#.+notification-response-message+
-	     (let ((pid (read-socket-value 'int32 socket))
-		   (message (read-socket-value 'string socket)))
+	     (let ((pid (read-socket-value-int32 socket))
+		   (message (read-socket-value-string socket)))
 	       (when (= pid (postgresql-connection-pid connection))
 		 (signal 'postgresql-notification :connection connection
 			 :message message))))
@@ -739,7 +751,7 @@ connection, if it is still open."
 	 (fields (postgresql-cursor-fields cursor)))
     (assert (= (length fields) (length sequence)))
     (loop
-	(let ((code (read-socket-value 'int8 socket)))
+	(let ((code (read-socket-value-int8 socket)))
 	  (case code
 	    (#.+ascii-row-message+
 	     (return
@@ -762,18 +774,18 @@ connection, if it is still open."
 	    (#.+binary-row-message+
 	     (error "NYI"))
 	    (#.+completed-response-message+
-	     (return (values nil (read-socket-value 'string socket))))
+	     (return (values nil (read-socket-value-string socket))))
 	    (#.+error-response-message+
-	     (let ((message (read-socket-value 'string socket)))
+	     (let ((message (read-socket-value-string socket)))
 	       (error 'postgresql-error
 		      :connection connection :message message)))
 	    (#.+notice-response-message+
-	     (let ((message (read-socket-value 'string socket)))
+	     (let ((message (read-socket-value-string socket)))
 	       (warn 'postgresql-warning
 		     :connection connection :message message)))
 	    (#.+notification-response-message+
-	     (let ((pid (read-socket-value 'int32 socket))
-		   (message (read-socket-value 'string socket)))
+	     (let ((pid (read-socket-value-int32 socket))
+		   (message (read-socket-value-string socket)))
 	       (when (= pid (postgresql-connection-pid connection))
 		 (signal 'postgresql-notification :connection connection
 			 :message message))))
@@ -787,31 +799,31 @@ connection, if it is still open."
 	 (socket (postgresql-connection-socket connection))
 	 (fields (postgresql-cursor-fields cursor)))
     (loop
-	(let ((code (read-socket-value 'int8 socket)))
+	(let ((code (read-socket-value-int8 socket)))
 	  (case code
 	    (#.+ascii-row-message+
 	     (loop for null-bit across
 		   (read-null-bit-vector socket (length fields))
 		   do
 		   (unless (zerop null-bit)
-		     (let* ((length (read-socket-value 'int32 socket)))
+		     (let* ((length (read-socket-value-int32 socket)))
 		       (loop repeat (- length 4) do (read-byte socket)))))
 	     (return t))
 	    (#.+binary-row-message+
 	     (error "NYI"))
 	    (#.+completed-response-message+
-	     (return (values nil (read-socket-value 'string socket))))
+	     (return (values nil (read-socket-value-string socket))))
 	    (#.+error-response-message+
-	     (let ((message (read-socket-value 'string socket)))
+	     (let ((message (read-socket-value-string socket)))
 	       (error 'postgresql-error
 		      :connection connection :message message)))
 	    (#.+notice-response-message+
-	     (let ((message (read-socket-value 'string socket)))
+	     (let ((message (read-socket-value-string socket)))
 	       (warn 'postgresql-warning
 		     :connection connection :message message)))
 	    (#.+notification-response-message+
-	     (let ((pid (read-socket-value 'int32 socket))
-		   (message (read-socket-value 'string socket)))
+	     (let ((pid (read-socket-value-int32 socket))
+		   (message (read-socket-value-string socket)))
 	       (when (= pid (postgresql-connection-pid connection))
 		 (signal 'postgresql-notification :connection connection
 			 :message message))))
@@ -830,3 +842,6 @@ connection, if it is still open."
 	  collect row
 	  finally
 	  (wait-for-query-results connection))))
+
+#+scl
+(declaim (ext:maybe-inline read-byte write-byte))
diff --git a/db-postgresql-socket/postgresql-socket-package.lisp b/db-postgresql-socket/postgresql-socket-package.lisp
index 7898830..23b7747 100644
--- a/db-postgresql-socket/postgresql-socket-package.lisp
+++ b/db-postgresql-socket/postgresql-socket-package.lisp
@@ -2,12 +2,12 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          postgresql-socket-package.cl
+;;;; Name:          postgresql-socket-package.lisp
 ;;;; Purpose:       Package definition for PostgreSQL interface using sockets
 ;;;; Programmers:   Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: postgresql-socket-package.lisp,v 1.2 2002/10/14 04:09:02 kevin Exp $
+;;;; $Id: postgresql-socket-package.lisp,v 1.3 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
diff --git a/debian/changelog b/debian/changelog
index 0af334c..e221714 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,11 @@
+cl-sql (1.1.3-1) unstable; urgency=low
+
+  * Add more support for SCL and performance improvements to postgresql-socket
+  (Thanks Doug Crosher)
+  * Add locks to connection pool for SCL (Doug Crosher)
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Mon, 21 Oct 2002 01:26:40 -0600
+
 cl-sql (1.1.2-1) unstable; urgency=low
 
   * Fix clsql-mysql.so search path for Debian.
diff --git a/sql/loop-extension.lisp b/sql/loop-extension.lisp
index d19dfb6..343acba 100644
--- a/sql/loop-extension.lisp
+++ b/sql/loop-extension.lisp
@@ -8,7 +8,7 @@
 ;;;;
 ;;;; Copyright (c) 1999-2001 Pierre R. Mai
 ;;;;
-;;;; $Id: loop-extension.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: loop-extension.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; The functions in this file were orignally distributed in the
 ;;;; MaiSQL package in the file sql/sql.cl
@@ -18,7 +18,7 @@
 
 ;;;; MIT-LOOP extension
 
-#+cmu
+#+(or cmu scl)
 (defun loop-record-iteration-path (variable data-type prep-phrases)
   (let ((in-phrase nil)
 	(from-phrase nil))
@@ -90,7 +90,7 @@
 	   (not (database-store-next-row ,result-set-var ,db-var ,variable))
 	   ()))))))
 
-#+cmu
+#+(or cmu scl)
 (ansi-loop::add-loop-path '(record records tuple tuples)
 			  'loop-record-iteration-path
 			  ansi-loop::*loop-ansi-universe*
diff --git a/sql/package.lisp b/sql/package.lisp
index dd3e5dd..3f8f49c 100644
--- a/sql/package.lisp
+++ b/sql/package.lisp
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: package.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: package.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -26,6 +26,7 @@
   (defpackage :clsql-sys
     (:nicknames :clsql)
     (:use :common-lisp :clsql-base-sys)
+    #+scl (:import-from :thread #:make-lock #:with-lock-held)
     (:import-from 
      :clsql-base
      .
diff --git a/sql/pool.lisp b/sql/pool.lisp
index 1a556d8..9528ac2 100644
--- a/sql/pool.lisp
+++ b/sql/pool.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg, Marc Battyani
 ;;;; Date Started:  Apr 2002
 ;;;;
-;;;; $Id: pool.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: pool.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -19,7 +19,17 @@
 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
 (in-package :clsql-sys)
 
+#-scl
+(defun make-lock (name) (declare (ignore name)) nil)
+
+#-scl
+(defmacro with-lock-held ((lock desc) &body body)
+  (declare (ignore lock desc))
+  `(progn
+     ,@body))
+
 (defvar *db-pool* (make-hash-table :test #'equal))
+(defvar *db-pool-lock* (make-lock "DB Pool lock"))
 
 (defclass conn-pool ()
   ((connection-spec :accessor connection-spec :initarg :connection-spec)
@@ -27,37 +37,47 @@
    (free-connections :accessor free-connections
 		     :initform (make-array 5 :fill-pointer 0 :adjustable t))
    (all-connections :accessor all-connections
-		    :initform (make-array 5 :fill-pointer 0 :adjustable t))))
+		    :initform (make-array 5 :fill-pointer 0 :adjustable t))
+   (lock :accessor conn-pool-lock
+	 :initform (make-lock "Connection pool"))))
 
 (defun acquire-from-conn-pool (pool)
-  (if (zerop (length (free-connections pool)))
-    (let ((conn (connect (connection-spec pool)
-			 :database-type (database-type pool) :if-exists :new)))
-      (vector-push-extend conn (all-connections pool))
-      (setf (conn-pool conn) pool)
-      conn)
-    (vector-pop (free-connections pool))))
+  (or (with-lock-held ((conn-pool-lock pool) "Acquire from pool")
+	(and (plusp (length (free-connections pool)))
+	     (vector-pop (free-connections pool))))
+      (let ((conn (connect (connection-spec pool)
+			   :database-type (database-type pool)
+			   :if-exists :new)))
+	(with-lock-held ((conn-pool-lock pool) "Acquire from pool")
+	  (vector-push-extend conn (all-connections pool))
+	  (setf (conn-pool conn) pool))
+	conn)))
 
 (defun release-to-conn-pool (conn)
-  (vector-push-extend conn (free-connections (conn-pool conn))))
+  (let ((pool (conn-pool conn)))
+    (with-lock-held ((conn-pool-lock pool) "Release to pool")
+      (vector-push-extend conn (free-connections pool)))))
 
 (defun clear-conn-pool (pool)
-  (loop for conn across (all-connections pool)
-	do (setf (conn-pool conn) nil)
-	   (disconnect :database conn))
-  (setf (fill-pointer (free-connections pool)) 0)
-  (setf (fill-pointer (all-connections pool)) 0))
+  (with-lock-held ((conn-pool-lock pool) "Clear pool")
+    (loop for conn across (all-connections pool)
+	  do (setf (conn-pool conn) nil)
+	  (disconnect :database conn))
+    (setf (fill-pointer (free-connections pool)) 0)
+    (setf (fill-pointer (all-connections pool)) 0))
+  nil)
 
 (defun find-or-create-connection-pool (connection-spec database-type)
   "Find connection pool in hash table, creates a new connection pool if not found"
-  (let* ((key (list connection-spec database-type))
-	 (conn-pool (gethash key *db-pool*)))
-    (unless conn-pool
-      (setq conn-pool (make-instance 'conn-pool
-				     :connection-spec connection-spec
-				     :database-type database-type))
-      (setf (gethash key *db-pool*) conn-pool))
-    conn-pool))
+  (with-lock-held (*db-pool-lock* "Find connection")
+    (let* ((key (list connection-spec database-type))
+	   (conn-pool (gethash key *db-pool*)))
+      (unless conn-pool
+	(setq conn-pool (make-instance 'conn-pool
+				       :connection-spec connection-spec
+				       :database-type database-type))
+	(setf (gethash key *db-pool*) conn-pool))
+      conn-pool)))
 
 (defun acquire-from-pool (connection-spec database-type &optional pool)
   (unless (typep pool 'conn-pool)
@@ -69,11 +89,12 @@
 
 (defun disconnect-pooled (&optional clear)
   "Disconnects all connections in the pool"
-  (maphash
-   #'(lambda (key conn-pool)
-       (declare (ignore key))
-       (clear-conn-pool conn-pool))
-   *db-pool*)
-  (when clear (clrhash *db-pool*))
+  (with-lock-held (*db-pool-lock* "Find connection")
+    (maphash
+     #'(lambda (key conn-pool)
+	 (declare (ignore key))
+	 (clear-conn-pool conn-pool))
+     *db-pool*)
+    (when clear (clrhash *db-pool*)))
   t)
 
diff --git a/sql/sql.lisp b/sql/sql.lisp
index b5a7f20..00d9667 100644
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -8,7 +8,7 @@
 ;;;;                 Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: sql.lisp,v 1.2 2002/10/14 15:25:15 kevin Exp $
+;;;; $Id: sql.lisp,v 1.3 2002/10/21 07:45:50 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -66,7 +66,7 @@
 		(pool nil))
   "Connects to a database of the given database-type, using the type-specific
 connection-spec.  if-exists is currently ignored.
-If pool is t the the connection will be taken from the general pool,
+If pool is t the connection will be taken from the general pool,
 if pool is a conn-pool object the connection will be taken from this pool.
 "
   (if pool
-- 
2.34.1