[Cl-irc-cvs] CVS update: cl-irc/protocol.lisp

[Kevin Rosenberg]

Update of /project/cl-irc/cvsroot/cl-irc
In directory common-lisp.net:/tmp/cvs-serv21472

Modified Files:
	protocol.lisp 
Log Message:
intern based on symbol-name to support case sensitive lisps
Date: Thu Jan  8 18:11:47 2004
Author: krosenberg

Index: cl-irc/protocol.lisp
diff -u cl-irc/protocol.lisp:1.1.1.1 cl-irc/protocol.lisp:1.2
--- cl-irc/protocol.lisp:1.1.1.1	Mon Jan  5 09:13:04 2004
+++ cl-irc/protocol.lisp	Thu Jan  8 18:11:47 2004
@@ -1,4 +1,4 @@
-;;;; $Id: protocol.lisp,v 1.1.1.1 2004/01/05 14:13:04 eenge Exp $
+;;;; $Id: protocol.lisp,v 1.2 2004/01/08 23:11:47 krosenberg Exp $
 ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $
 
 ;;;; See LICENSE for licensing information.
@@ -520,14 +520,23 @@
 
 (defclass irc-error-reply (irc-message) ())
 
+(defun intern-message-symbol (prefix name)
+  "Intern based on symbol-name to support case-sensitive mlisp"
+  (intern
+   (concatenate 'string
+		(symbol-name prefix)
+		"-"
+		(symbol-name name)
+		"-"
+		(symbol-name '#:message))))
+  
 (defmacro define-irc-message (command)
-  (let ((*print-case* :upcase))
-    (let ((name (intern (format nil "IRC-~A-MESSAGE" command))))
-      `(progn
-         (defmethod find-irc-message-class ((type (eql ,command)))
-           (find-class ',name))
-         (export ',name)
-         (defclass ,name (irc-message) ())))))
+  (let ((name (intern-message-symbol :irc command)))
+    `(progn
+      (defmethod find-irc-message-class ((type (eql ,command)))
+	(find-class ',name))
+      (export ',name)
+      (defclass ,name (irc-message) ()))))
 
 (defun create-irc-message-classes (class-list)
   (dolist (class class-list)
@@ -570,13 +579,12 @@
 (defclass standard-ctcp-message (ctcp-mixin message) ())
 
 (defmacro define-ctcp-message (ctcp-command)
-  (let ((*print-case* :upcase))
-    (let ((name (intern (format nil "CTCP-~A-MESSAGE" ctcp-command))))
-      `(progn
-         (defmethod find-ctcp-message-class ((type (eql ,ctcp-command)))
-           (find-class ',name))
-         (export ',name)
-         (defclass ,name (ctcp-mixin irc-message) ())))))
+  (let ((name (intern-message-symbol :ctcp ctcp-command)))
+    `(progn
+      (defmethod find-ctcp-message-class ((type (eql ,ctcp-command)))
+	(find-class ',name))
+      (export ',name)
+      (defclass ,name (ctcp-mixin irc-message) ()))))
 
 (defun create-ctcp-message-classes (class-list)
   (dolist (class class-list)