X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql.lisp;h=179a452d9e3cc9dbe0d9852e36120826dc34b79d;hb=19cb24908d2ba2faec3afbdd180eed0c7d7d8515;hp=6667de0c91137dae6f4c879c8a86e7c3bc75beb7;hpb=3da54733f61bd3305fdc5abd5fc961051c59ffb8;p=hyperobject.git

diff --git a/sql.lisp b/sql.lisp
index 6667de0..179a452 100644
--- a/sql.lisp
+++ b/sql.lisp
@@ -1,22 +1,18 @@
-ld;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          sqlgen.lisp
+;;;; Name:          sql.lisp
 ;;;; Purpose:       SQL Generation functions for Hyperobject
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sql.lisp,v 1.1 2002/12/09 10:42:06 kevin Exp $
+;;;; $Id: sql.lisp,v 1.6 2003/06/06 21:59:29 kevin Exp $
 ;;;;
-;;;; This file, part of Hyperobject-SQL, is
-;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
-(in-package :hyperobject)
-(eval-when (:compile-toplevel :execute)
-  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
-
+(in-package #:hyperobject)
 
 ;;;; Metaclass initialization commands
 
@@ -36,6 +32,9 @@ ld;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
 	(define-inverse cl esd))))
   )
 
+(defgeneric sql-name (cl)
+  )
+
 (defmethod sql-name ((cl hyperobject-class))
   "Return name of SQL table for a class"
   (let* ((sql-name-slot (slot-value cl 'sql-name))
@@ -48,7 +47,6 @@ ld;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
 	 (lisp-name (if name name (slot-definition-name esd))))
       (lisp-name-to-sql-name lisp-name)))
 
-
 (defun lisp-name-to-sql-name (lisp)
   "Convert a lisp name (atom or list, string or symbol) into a canonical
 SQL name"
@@ -57,19 +55,17 @@ SQL name"
 	  (typecase lisp
 	    (symbol (symbol-name lisp))
 	    (t (write-to-string lisp)))))
-  (let ((sql (make-string (length lisp))))
-    (dotimes (i (length lisp))
-      (declare (fixnum i))
-      (setf (char sql i)
-	    (let ((c (char lisp i)))
-	      (case c
-		(#\- #\_)
-		(#\$ #\_)
-		(#\+ #\_)
-		(#\# #\_)
-		(otherwise c)))))
-    (string-upcase sql)))
-
+  (do* ((len (length lisp))
+	(sql (make-string len))
+	(i 0 (1+ i)))
+      ((= i len) (string-upcase sql))
+    (declare (fixnum i)
+	     (simple-string sql))
+    (setf (schar sql i)
+	  (let ((c (char lisp i)))
+	    (case c
+	      ((#\- #\$ #\+ #\#) #\_)
+	      (otherwise c))))))
 			
 (defun define-inverse (class esd)
   "Define an inverse function for a slot"
@@ -151,13 +147,15 @@ SQL name"
 
 ;;;; Runtime Commands
 
+(defgeneric sql-create (cl))
 (defmethod sql-create (cl)
-  (with-sql-connection (conn)
+ (with-sql-connection (conn)
     (sql-execute (slot-value cl 'create-table-cmd) conn)
     (dolist (cmd (slot-value cl 'create-indices-cmds))
       (sql-execute cmd conn))
     (values)))
 
+(defgeneric sql-drop (cl))
 (defmethod sql-drop (cl)
   (mutex-sql-execute (slot-value cl 'drop-table-cmd))
   (values))
@@ -199,8 +197,6 @@ SQL name"
 					  (slot-value self name))))))))))
     values))
 
-
-
 (defun inverse-field-string (fields)
   (let (inverse)
     (dolist (field fields)