# 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
#
PKG:=clsql
DEBPKG=cl-sql
-SUBDIRS:=interfaces sql cmucl-compat
+SUBDIRS:=interfaces sql base
DOCSUBDIRS:=doc
include Makefile.common
--- /dev/null
+SUBDIRS :=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
--- /dev/null
+;;;; -*- 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))
;;;; 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
;;;;
: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"))
;;;; 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
;;;;
;;; 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*)
)
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- 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))
+++ /dev/null
-;;;; -*- 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)
;;;; 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.
(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
--- /dev/null
+;;;; -*- 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)