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

[Brian Mastenbrook]

Update of /project/cl-irc/cvsroot/cl-irc
In directory common-lisp.net:/home/bmastenbrook/cl-irc

Modified Files:
	protocol.lisp 
Log Message:
speedup from Maddas

Date: Fri Aug  6 06:08:10 2004
Author: bmastenbrook

Index: cl-irc/protocol.lisp
diff -u cl-irc/protocol.lisp:1.10 cl-irc/protocol.lisp:1.11
--- cl-irc/protocol.lisp:1.10	Fri Aug  6 06:00:52 2004
+++ cl-irc/protocol.lisp	Fri Aug  6 06:08:09 2004
@@ -1,4 +1,4 @@
-;;;; $Id: protocol.lisp,v 1.10 2004/08/06 13:00:52 bmastenbrook Exp $
+;;;; $Id: protocol.lisp,v 1.11 2004/08/06 13:08:09 bmastenbrook Exp $
 ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $
 
 ;;;; See LICENSE for licensing information.
@@ -592,34 +592,32 @@
 
 (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 ((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)
-    (eval (list 'define-irc-message class)))) ; argh.  eval.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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))))
+
+  (defun define-irc-message (command)
+    (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) ())))))
+
+(defmacro create-irc-message-classes (class-list)
+  `(progn ,@(mapcar #'define-irc-message class-list)))
 
 ;; should perhaps wrap this in an eval-when?
-(create-irc-message-classes (remove-duplicates
-                             (mapcar #'second *reply-names*)))
-(create-irc-message-classes '(:privmsg :notice :kick :topic :error
-                              :mode :ping :nick :join :part :quit :kill
-			      :pong :invite))
+(create-irc-message-classes #.(remove-duplicates (mapcar #'second *reply-names*)))
+(create-irc-message-classes (:privmsg :notice :kick :topic :error :mode :ping
+			     :nick :join :part :quit :kill :pong :invite))
 
 (defmethod find-irc-message-class (type)
   (declare (ignore type))
@@ -654,20 +652,20 @@
 
 (defgeneric find-ctcp-message-class (type))
 
-(defmacro define-ctcp-message (ctcp-command)
-  (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)
-    (eval (list 'define-ctcp-message class)))) ; argh.  eval.  must go away.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun define-ctcp-message (ctcp-command)
+    (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) ())))))
+  
+(defmacro create-ctcp-message-classes (class-list)
+  `(progn ,@(mapcar #'define-ctcp-message class-list)))
 
 ;; should perhaps wrap this in an eval-when?
-(create-ctcp-message-classes '(:action :source :finger :ping
+(create-ctcp-message-classes (:action :source :finger :ping
                                :version :userinfo :time :dcc-chat-request
                                :dcc-send-request))