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))