From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Wed, 15 May 2002 17:10:47 +0000 (+0000)
Subject: r2049: moved cmucl-compat files
X-Git-Tag: v3.8.6~1061
X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=27635f61adae5a49f9986762acf13daa0437826b

r2049: moved cmucl-compat files
---

diff --git a/Makefile b/Makefile
index 1b2e4fb..5e29581 100644
--- a/Makefile
+++ b/Makefile
@@ -5,7 +5,7 @@
 #  Programer:    Kevin M. Rosenberg
 #  Date Started: Mar 2002
 #
-#  CVS Id:   $Id: Makefile,v 1.18 2002/05/13 03:24:41 kevin Exp $
+#  CVS Id:   $Id: Makefile,v 1.19 2002/05/15 17:10:28 kevin Exp $
 #
 # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 #
@@ -15,7 +15,7 @@
 
 PKG:=clsql
 DEBPKG=cl-sql
-SUBDIRS:=interfaces sql cmucl-compat
+SUBDIRS:=interfaces sql base
 DOCSUBDIRS:=doc
 
 include Makefile.common
diff --git a/base/Makefile b/base/Makefile
new file mode 100644
index 0000000..31dc910
--- /dev/null
+++ b/base/Makefile
@@ -0,0 +1,6 @@
+SUBDIRS		:= 
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
diff --git a/base/cmucl-compat.cl b/base/cmucl-compat.cl
new file mode 100644
index 0000000..85cc280
--- /dev/null
+++ b/base/cmucl-compat.cl
@@ -0,0 +1,115 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cmucl-compat.sql
+;;;; Purpose:       Compatiblity library for CMUCL functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: cmucl-compat.cl,v 1.1 2002/05/15 17:10:28 kevin Exp $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+
+(defpackage :cmucl-compat
+  (:export
+   #:shrink-vector
+   #:make-sequence-of-type
+   #:result-type-or-lose
+   #:required-argument
+   ))
+(in-package :cmucl-compat)
+
+#+cmu
+(defmacro required-argument ()
+  `(ext:required-argument))
+
+#-cmu
+(defun required-argument ()
+  (error "~&A required keyword argument was not supplied"))
+
+#+cmu
+(defmacro shrink-vector (vec len)
+  `(lisp::shrink-vector ,vec ,len))
+
+#-cmu
+(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."
+  (let ((new-vec (gensym)))
+    `(cond
+      ((adjustable-array-p ,vec)
+       (adjust-array ,vec ,len))
+      ((typep ,vec 'simple-array)
+       (let ((,new-vec (make-array ,len :element-type
+				   (array-element-type ,vec))))
+	 (dotimes (i ,len)
+	   (declare (fixnum i))
+	   (setf (aref ,new-vec i) (aref ,vec i)))
+	 (setq ,vec ,new-vec)))
+      ((typep ,vec 'vector)
+	(setf (fill-pointer ,vec) ,len)
+	,vec)
+      (t
+       (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) 
+       )))
+
+
+
+#-cmu
+(defun make-sequence-of-type (type length)
+  "Returns a sequence of the given TYPE and LENGTH."
+  (declare (fixnum length))
+  (case type
+    (list 
+     (make-list length))
+    ((bit-vector simple-bit-vector) 
+     (make-array length :element-type '(mod 2)))
+    ((string simple-string base-string simple-base-string)
+     (make-string length))
+    (simple-vector 
+     (make-array length))
+    ((array simple-array vector)
+     (if (listp type)
+	 (make-array length :element-type (cadr type))
+       (make-array length)))
+    (t
+     (make-sequence-of-type (result-type-or-lose type t) length))))
+
+
+#+cmu
+(if (fboundp 'lisp::make-sequence-of-type)
+    (defun make-sequence-of-type (type len)
+      (lisp::make-sequence-of-type type len))
+  (defun make-sequence-of-type (type len)
+    (system::make-sequence-of-type type len)))
+  
+
+#-cmu
+(defun result-type-or-lose (type nil-ok)
+  (unless (or type nil-ok)
+    (error "NIL output type invalid for this sequence function"))
+  (case type
+    ((list cons)
+     'list)
+    ((string simple-string base-string simple-base-string)
+     'string)
+    (simple-vector
+     'simple-vector)
+    (vector
+     'vector)
+    (t
+     (error "~S is a bad type specifier for sequence functions." type))
+    ))
+
+#+cmu
+(defun result-type-or-lose (type nil-ok)
+  (lisp::result-type-or-lose type nil-ok))
diff --git a/clsql-base.system b/clsql-base.system
index 8a13152..51b0c58 100644
--- a/clsql-base.system
+++ b/clsql-base.system
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: clsql-base.system,v 1.4 2002/05/14 16:23:37 kevin Exp $
+;;;; $Id: clsql-base.system,v 1.5 2002/05/15 17:10:28 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -31,7 +31,8 @@
     :source-pathname "CL-LIBRARY:clsql;base;"
     :source-extension "cl"
     :binary-pathname "CL-LIBRARY:clsql;base;bin;"
-    :components ((:file "package")
+    :components ((:file "cmucl-compat")
+		 (:file "package")
 		 (:file "classes" :depends-on ("package"))
 		 (:file "conditions" :depends-on ("classes"))
 		 (:file "db-interface" :depends-on ("conditions"))
diff --git a/clsql.system b/clsql.system
index 9b3fa34..aa63476 100644
--- a/clsql.system
+++ b/clsql.system
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: clsql.system,v 1.12 2002/05/13 05:24:57 kevin Exp $
+;;;; $Id: clsql.system,v 1.13 2002/05/15 17:10:28 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -27,24 +27,18 @@
 
 ;;; System definitions
 
-(mk:defsystem :cmucl-compat
-    :source-pathname "CL-LIBRARY:clsql;cmucl-compat;"
-    :source-extension "cl"
-    :binary-pathname "CL-LIBRARY:clsql;cmucl-compat;bin;"
-    :components ((:file "cmucl-compat")
-		 (:file "loop-extension")))
-
 (mk:defsystem :clsql
     :source-pathname "CL-LIBRARY:clsql;sql;"
     :source-extension "cl"
     :binary-pathname "CL-LIBRARY:clsql;sql;bin;"
     :components ((:file "pool")
+		 (:file "loop-extension")
 		 (:file "sql" :depends-on ("pool"))
 		 (:file "transactions" :depends-on ("sql"))
 		 (:file "utils")
 		 (:file "functional" :depends-on ("sql"))
 		 (:file "usql" :depends-on ("sql")))
-    :depends-on (:clsql-base :cmucl-compat)
+    :depends-on (:clsql-base)
     :finally-do
     (pushnew :clsql cl:*features*)
     )
diff --git a/cmucl-compat/.cvsignore b/cmucl-compat/.cvsignore
deleted file mode 100755
index ca8d09f..0000000
--- a/cmucl-compat/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-.bin
diff --git a/cmucl-compat/Makefile b/cmucl-compat/Makefile
deleted file mode 100644
index 31dc910..0000000
--- a/cmucl-compat/Makefile
+++ /dev/null
@@ -1,6 +0,0 @@
-SUBDIRS		:= 
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
diff --git a/cmucl-compat/cmucl-compat.cl b/cmucl-compat/cmucl-compat.cl
deleted file mode 100644
index f2dde00..0000000
--- a/cmucl-compat/cmucl-compat.cl
+++ /dev/null
@@ -1,115 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          cmucl-compat.sql
-;;;; Purpose:       Compatiblity library for CMUCL functions
-;;;; Programmer:    Kevin M. Rosenberg
-;;;; Date Started:  Feb 2002
-;;;;
-;;;; $Id: cmucl-compat.cl,v 1.1 2002/03/23 14:04:49 kevin Exp $
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-(defpackage :cmucl-compat
-  (:export
-   #:shrink-vector
-   #:make-sequence-of-type
-   #:result-type-or-lose
-   #:required-argument
-   ))
-(in-package :cmucl-compat)
-
-#+cmu
-(defmacro required-argument ()
-  `(ext:required-argument))
-
-#-cmu
-(defun required-argument ()
-  (error "~&A required keyword argument was not supplied"))
-
-#+cmu
-(defmacro shrink-vector (vec len)
-  `(lisp::shrink-vector ,vec ,len))
-
-#-cmu
-(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."
-  (let ((new-vec (gensym)))
-    `(cond
-      ((adjustable-array-p ,vec)
-       (adjust-array ,vec ,len))
-      ((typep ,vec 'simple-array)
-       (let ((,new-vec (make-array ,len :element-type
-				   (array-element-type ,vec))))
-	 (dotimes (i ,len)
-	   (declare (fixnum i))
-	   (setf (aref ,new-vec i) (aref ,vec i)))
-	 (setq ,vec ,new-vec)))
-      ((typep ,vec 'vector)
-	(setf (fill-pointer ,vec) ,len)
-	,vec)
-      (t
-       (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) 
-       )))
-
-
-
-#-cmu
-(defun make-sequence-of-type (type length)
-  "Returns a sequence of the given TYPE and LENGTH."
-  (declare (fixnum length))
-  (case type
-    (list 
-     (make-list length))
-    ((bit-vector simple-bit-vector) 
-     (make-array length :element-type '(mod 2)))
-    ((string simple-string base-string simple-base-string)
-     (make-string length))
-    (simple-vector 
-     (make-array length))
-    ((array simple-array vector)
-     (if (listp type)
-	 (make-array length :element-type (cadr type))
-       (make-array length)))
-    (t
-     (make-sequence-of-type (result-type-or-lose type t) length))))
-
-
-#+cmu
-(if (fboundp 'lisp::make-sequence-of-type)
-    (defun make-sequence-of-type (type len)
-      (lisp::make-sequence-of-type type len))
-  (defun make-sequence-of-type (type len)
-    (system::make-sequence-of-type type len)))
-  
-
-#-cmu
-(defun result-type-or-lose (type nil-ok)
-  (unless (or type nil-ok)
-    (error "NIL output type invalid for this sequence function"))
-  (case type
-    ((list cons)
-     'list)
-    ((string simple-string base-string simple-base-string)
-     'string)
-    (simple-vector
-     'simple-vector)
-    (vector
-     'vector)
-    (t
-     (error "~S is a bad type specifier for sequence functions." type))
-    ))
-
-#+cmu
-(defun result-type-or-lose (type nil-ok)
-  (lisp::result-type-or-lose type nil-ok))
diff --git a/cmucl-compat/loop-extension.cl b/cmucl-compat/loop-extension.cl
deleted file mode 100644
index 4eec894..0000000
--- a/cmucl-compat/loop-extension.cl
+++ /dev/null
@@ -1,98 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          loop-extension.cl
-;;;; Purpose:       Extensions to the Loop macro for CMUCL
-;;;; Programmer:    Pierre R. Mai
-;;;;
-;;;; Copyright (c) 1999-2001 Pierre R. Mai
-;;;;
-;;;; $Id: loop-extension.cl,v 1.1 2002/03/23 14:04:49 kevin Exp $
-;;;;
-;;;; The functions in this file were orignally distributed in the
-;;;; MaiSQL package in the file sql/sql.cl
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-;;;; MIT-LOOP extension
-
-#+cmu
-(defun loop-record-iteration-path (variable data-type prep-phrases)
-  (let ((in-phrase nil)
-	(from-phrase nil))
-    (loop for (prep . rest) in prep-phrases
-	  do
-	  (case prep
-	    ((:in :of)
-	     (when in-phrase
-	       (ansi-loop::loop-error
-		"Duplicate OF or IN iteration path: ~S." (cons prep rest)))
-	     (setq in-phrase rest))
-	    ((:from)
-	     (when from-phrase
-	       (ansi-loop::loop-error
-		"Duplicate FROM iteration path: ~S." (cons prep rest)))
-	     (setq from-phrase rest))
-	    (t
-	     (ansi-loop::loop-error
-	      "Unknown preposition: ~S." prep))))
-    (unless in-phrase
-      (ansi-loop::loop-error "Missing OF or IN iteration path."))
-    (unless from-phrase
-      (setq from-phrase '(*default-database*)))
-    (cond
-      ((consp variable)
-       (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
-	     (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
-	     (result-set-var (ansi-loop::loop-gentemp
-			      'loop-record-result-set-))
-	     (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
-	 (push `(when ,result-set-var
-		 (database-dump-result-set ,result-set-var ,db-var))
-	       ansi-loop::*loop-epilogue*)
-	 `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
-	    (,db-var ,(first from-phrase))
-	    (,result-set-var nil)
-	    (,step-var nil))
-	   ((multiple-value-bind (%rs %cols)
-		(database-query-result-set ,query-var ,db-var)
-	      (setq ,result-set-var %rs ,step-var (make-list %cols))))
-	   ()
-	   ()
-	   (not (database-store-next-row ,result-set-var ,db-var ,step-var))
-	   (,variable ,step-var)
-	   (not ,result-set-var)
-	   ()
-	   (not (database-store-next-row ,result-set-var ,db-var ,step-var))
-	   (,variable ,step-var))))
-      (t
-       (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
-	     (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
-	     (result-set-var (ansi-loop::loop-gentemp
-			      'loop-record-result-set-)))
-	 (push `(when ,result-set-var
-		 (database-dump-result-set ,result-set-var ,db-var))
-	       ansi-loop::*loop-epilogue*)
-	 `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
-	    (,db-var ,(first from-phrase))
-	    (,result-set-var nil))
-	   ((multiple-value-bind (%rs %cols)
-		(database-query-result-set ,query-var ,db-var)
-	      (setq ,result-set-var %rs ,variable (make-list %cols))))
-	   ()
-	   ()
-	   (not (database-store-next-row ,result-set-var ,db-var ,variable))
-	   ()
-	   (not ,result-set-var)
-	   ()
-	   (not (database-store-next-row ,result-set-var ,db-var ,variable))
-	   ()))))))
-
-#+cmu
-(ansi-loop::add-loop-path '(record records tuple tuples)
-			  'loop-record-iteration-path
-			  ansi-loop::*loop-ansi-universe*
-			  :preposition-groups '((:of :in) (:from))
-			  :inclusive-permitted nil)
diff --git a/interfaces/postgresql/postgresql-usql.cl b/interfaces/postgresql/postgresql-usql.cl
index eeee53b..4633f39 100644
--- a/interfaces/postgresql/postgresql-usql.cl
+++ b/interfaces/postgresql/postgresql-usql.cl
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg and onShore Development Inc
 ;;;; Date Started:  Mar 2002
 ;;;;
-;;;; $Id: postgresql-usql.cl,v 1.3 2002/05/15 17:03:43 kevin Exp $
+;;;; $Id: postgresql-usql.cl,v 1.4 2002/05/15 17:10:28 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and by onShore Development Inc.
@@ -39,7 +39,7 @@
 	  (mapcar #'car
 		  (database-query
 		   (format nil
-			   "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'" relname)
+			   "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'" table)
 		   database nil))))
     (if result
 	(reverse
diff --git a/sql/loop-extension.cl b/sql/loop-extension.cl
new file mode 100644
index 0000000..a36e1cc
--- /dev/null
+++ b/sql/loop-extension.cl
@@ -0,0 +1,98 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          loop-extension.cl
+;;;; Purpose:       Extensions to the Loop macro for CMUCL
+;;;; Programmer:    Pierre R. Mai
+;;;;
+;;;; Copyright (c) 1999-2001 Pierre R. Mai
+;;;;
+;;;; $Id: loop-extension.cl,v 1.1 2002/05/15 17:10:28 kevin Exp $
+;;;;
+;;;; The functions in this file were orignally distributed in the
+;;;; MaiSQL package in the file sql/sql.cl
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+;;;; MIT-LOOP extension
+
+#+cmu
+(defun loop-record-iteration-path (variable data-type prep-phrases)
+  (let ((in-phrase nil)
+	(from-phrase nil))
+    (loop for (prep . rest) in prep-phrases
+	  do
+	  (case prep
+	    ((:in :of)
+	     (when in-phrase
+	       (ansi-loop::loop-error
+		"Duplicate OF or IN iteration path: ~S." (cons prep rest)))
+	     (setq in-phrase rest))
+	    ((:from)
+	     (when from-phrase
+	       (ansi-loop::loop-error
+		"Duplicate FROM iteration path: ~S." (cons prep rest)))
+	     (setq from-phrase rest))
+	    (t
+	     (ansi-loop::loop-error
+	      "Unknown preposition: ~S." prep))))
+    (unless in-phrase
+      (ansi-loop::loop-error "Missing OF or IN iteration path."))
+    (unless from-phrase
+      (setq from-phrase '(*default-database*)))
+    (cond
+      ((consp variable)
+       (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
+	     (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
+	     (result-set-var (ansi-loop::loop-gentemp
+			      'loop-record-result-set-))
+	     (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
+	 (push `(when ,result-set-var
+		 (database-dump-result-set ,result-set-var ,db-var))
+	       ansi-loop::*loop-epilogue*)
+	 `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
+	    (,db-var ,(first from-phrase))
+	    (,result-set-var nil)
+	    (,step-var nil))
+	   ((multiple-value-bind (%rs %cols)
+		(database-query-result-set ,query-var ,db-var)
+	      (setq ,result-set-var %rs ,step-var (make-list %cols))))
+	   ()
+	   ()
+	   (not (database-store-next-row ,result-set-var ,db-var ,step-var))
+	   (,variable ,step-var)
+	   (not ,result-set-var)
+	   ()
+	   (not (database-store-next-row ,result-set-var ,db-var ,step-var))
+	   (,variable ,step-var))))
+      (t
+       (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
+	     (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
+	     (result-set-var (ansi-loop::loop-gentemp
+			      'loop-record-result-set-)))
+	 (push `(when ,result-set-var
+		 (database-dump-result-set ,result-set-var ,db-var))
+	       ansi-loop::*loop-epilogue*)
+	 `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
+	    (,db-var ,(first from-phrase))
+	    (,result-set-var nil))
+	   ((multiple-value-bind (%rs %cols)
+		(database-query-result-set ,query-var ,db-var)
+	      (setq ,result-set-var %rs ,variable (make-list %cols))))
+	   ()
+	   ()
+	   (not (database-store-next-row ,result-set-var ,db-var ,variable))
+	   ()
+	   (not ,result-set-var)
+	   ()
+	   (not (database-store-next-row ,result-set-var ,db-var ,variable))
+	   ()))))))
+
+#+cmu
+(ansi-loop::add-loop-path '(record records tuple tuples)
+			  'loop-record-iteration-path
+			  ansi-loop::*loop-ansi-universe*
+			  :preposition-groups '((:of :in) (:from))
+			  :inclusive-permitted nil)