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)