Author: ehuelsmann
Date: Tue May 23 16:40:48 2006
New Revision: 161
Added:
trunk/test/test-binding-macro.lisp (contents, props changed)
Modified:
trunk/package.lisp (contents, props changed)
trunk/test/cl-irc-test.asd (contents, props changed)
trunk/test/package.lisp
trunk/utility.lisp (contents, props changed)
Log:
Replace destructuring-arguments with a hopefully more useful version.
Including tests.
Raising specific errors has been raised as its own issue #22.
Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp (original)
+++ trunk/package.lisp Tue May 23 16:40:48 2006
@@ -1,5 +1,5 @@
;;;; $Id$
-;;;; $Source$
+;;;; $URL$
;;;; See the LICENSE file for licensing information.
@@ -16,6 +16,7 @@
:start-background-message-handler
:stop-background-message-handler
:destructuring-arguments
+ :&req
:socket-connect
:server-name
:server-port
Modified: trunk/test/cl-irc-test.asd
==============================================================================
--- trunk/test/cl-irc-test.asd (original)
+++ trunk/test/cl-irc-test.asd Tue May 23 16:40:48 2006
@@ -1,5 +1,5 @@
;;;; $Id$
-;;;; $Source$
+;;;; $URL$
;;;; See the LICENSE file for licensing information.
@@ -16,11 +16,11 @@
:version "0.1.0"
:licence "MIT"
:description "Tests for the cl-irc system"
- :depends-on
- #+sbcl (:sb-bsd-sockets :split-sequence :rt :cl-irc)
- #-sbcl (:split-sequence :rt :cl-irc)
+ :depends-on (:split-sequence :rt :cl-irc)
:components ((:file "package")
(:file "test-parse-message"
:depends-on ("package"))
(:file "test-protocol"
- :depends-on ("test-parse-message"))))
+ :depends-on ("test-parse-message"))
+ (:file "test-binding-macro"
+ :depends-on ("package"))))
Modified: trunk/test/package.lisp
==============================================================================
--- trunk/test/package.lisp (original)
+++ trunk/test/package.lisp Tue May 23 16:40:48 2006
@@ -7,6 +7,6 @@
(eval-when (:execute :load-toplevel :compile-toplevel)
(defpackage :cl-irc-test
- (:use :cl :rt)
+ (:use :cl :rt :cl-irc)
(:nicknames :cl-irc-test)
(:export :do-tests)))
Added: trunk/test/test-binding-macro.lisp
==============================================================================
--- (empty file)
+++ trunk/test/test-binding-macro.lisp Tue May 23 16:40:48 2006
@@ -0,0 +1,56 @@
+;;;; $Id$
+;;;; $URL$
+
+;;;; See the LICENSE file for licensing information.
+
+
+(in-package :cl-irc-test)
+
+(defvar *protocol-mode*
+ ":Chanserv!chanserve@services. MODE #svn +o eh")
+
+
+;; tests which should complete successfully
+
+(deftest binding.1
+ (destructuring-arguments
+ (target modes &rest arguments)
+ (cl-irc::create-irc-message *protocol-mode*)
+ (values target modes arguments))
+ "#svn" "+o" ("eh"))
+
+
+(deftest binding.2
+ (destructuring-arguments
+ (target :ignored &rest arguments)
+ (cl-irc::create-irc-message *protocol-mode*)
+ (values target arguments))
+ "#svn" ("eh"))
+
+(deftest binding.3
+ (destructuring-arguments
+ (:ignored &rest arguments &req nick)
+ (cl-irc::create-irc-message *protocol-mode*)
+ (values nick arguments))
+ "eh" ("+o"))
+
+(deftest binding.4
+ (destructuring-arguments
+ (target &optional modes &req nick)
+ (cl-irc::create-irc-message *protocol-mode*)
+ (values target modes nick))
+ "#svn" "+o" "eh")
+
+(deftest binding.5
+ (destructuring-arguments
+ (&whole all target &optional modes &req nick)
+ (cl-irc::create-irc-message *protocol-mode*)
+ (values all target modes nick))
+ ("#svn" "+o" "eh") "#svn" "+o" "eh")
+
+(deftest binding.6
+ (destructuring-arguments
+ (target &optional modes &rest args &req nick)
+ (cl-irc::create-irc-message *protocol-mode*)
+ (values target modes args nick))
+ "#svn" "+o" nil "eh")
Modified: trunk/utility.lisp
==============================================================================
--- trunk/utility.lisp (original)
+++ trunk/utility.lisp Tue May 23 16:40:48 2006
@@ -1,5 +1,5 @@
;;;; $Id$
-;;;; $Source$
+;;;; $URL$
;;;; See the LICENSE file for licensing information.
@@ -215,65 +215,115 @@
;; Message arguments binding macro
;;
-
(defmacro destructuring-arguments (lambda-list message &body body)
- "Destructures the arguments slot in MESSAGE according
-to LAMBDA-LIST and binds them in BODY.
-destructuring-irc-message-arguments's lambda list syntax is as follows:
+ "Destructures the `arguments' slot in `message' according
+to `lambda-list' and binds them in `body'.
+
+The lambda list syntax is as follows:
+wholevar::= &whole var
reqvars::= var*
-optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}*]
+optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}* ]
restvar::= [&rest var]
-wholevar::= [&whole var]
-lastvar::= [&last var]
-lambda-list::= (wholevar reqvars optvars restvar lastvar)
-
-With the exception of &last, all lambda list keywords are
-analogous to a destructuring lambda list's (see clhs 3.4.5).
-
-If &last is given, the specified variable is bound to the last
-argument in the message. Specifying &last implies that all
-arguments past the last of the required variables will be
-ignored, even if there is no &rest lambda list keyword present.
-
-If both &rest and &last are specified, the last element in the
-list is also included in the rest list."
- (let ((valid-bare-ll-keywords '(&optional &rest &whole))
- (nothing (gensym))
- (%message (gensym)))
- (labels ((keyword-ll-entry-p (entry)
- (eql (schar (symbol-name entry) 0) #\&))
- (valid-bare-ll-entry-p (entry)
- (or (not (keyword-ll-entry-p entry))
- (member entry valid-bare-ll-keywords :test 'string=)))
- (append-&rest-p (last-entries destructuring-ll)
- (not (or (null last-entries)
- (member '&rest destructuring-ll :test 'string=)))))
- (let* ((last-entries (member '&last lambda-list :test 'string=))
- (last-variable (second last-entries))
- (destructuring-ll (butlast lambda-list (length last-entries)))
- (invalid-ll-entries (remove-if #'valid-bare-ll-entry-p
- destructuring-ll)))
- (unless (or (null last-entries) (= 2 (length last-entries)))
- (error "Invalid number of &last arguments in ~S" lambda-list))
- (when (and last-variable (member last-variable destructuring-ll))
- (error "Duplicate entry ~S in lambda list ~S"
- last-variable lambda-list))
- (when invalid-ll-entries
- (error "Invalid lambda list entries ~S found in ~S"
- invalid-ll-entries lambda-list))
- `(let ((,%message ,message))
- (let (,@(when last-entries
- `((,last-variable (car (last (arguments ,%message)))))))
- (destructuring-bind ,(if (append-&rest-p last-entries
- destructuring-ll)
- (append destructuring-ll
- `(&rest ,nothing))
- destructuring-ll)
- (arguments ,%message)
- ,@(when (append-&rest-p last-entries destructuring-ll)
- `((declare (ignore ,nothing))))
- ,@body)))))))
+reqtrailingvars::= [&req var*]
+lambda-list::= (wholevar reqvars optvars restvar reqtrailingvars)
+
+With the exception of &req (which is new) and &rest, all lambda list
+keywords are analogous to a destructuring lambda list (see clhs 3.4.5).
+
+If &req is specified, these values are consumed off the end of the list
+before processing any preceeding &optional or &rest keywords.
+
+For any variable, the `:ignored' keyword can be passed instead,
+indicating the binding should be ignored in the `body'."
+ (let ((%message (gensym))
+ (%args (gensym))
+ (%arg-count (gensym))
+ (valid-keywords '(&whole &optional &rest &req)))
+ (labels ((lambda-key-p (x)
+ (member x valid-keywords))
+ (ignored-p (x)
+ (eq x :ignored))
+ (count-valid-keys (lambda-list)
+ (count-if #'lambda-key-p lambda-list))
+ (replace-ignored (lambda-list)
+ (let ((ignores))
+ (values (mapcar #'(lambda (x)
+ (if (ignored-p x)
+ (let ((y (gensym)))
+ (push y ignores)
+ y)
+ x))
+ lambda-list)
+ ignores)))
+ (bind-req-trail (req-trail args body)
+ (let ((req-syms (cdr req-trail)))
+ (if (and req-trail
+ (notevery #'ignored-p req-syms))
+ (multiple-value-bind
+ (ll ignores) (replace-ignored req-syms)
+ `(destructuring-bind
+ ,ll ,args
+ ,(if ignores
+ `(declare (ignore ,@ignores))
+ (values))
+ ,body))
+ body))))
+
+ (let* ((whole-var (when (eq (car lambda-list) '&whole)
+ (second lambda-list)))
+ (lambda-list (if whole-var (nthcdr 2 lambda-list) lambda-list))
+ (opt-entries (member '&optional lambda-list))
+ (rest-entries (member '&rest lambda-list))
+ (req-trail (member '&req lambda-list))
+ (destructuring-ll (butlast lambda-list (length req-trail)))
+ (longest-sublist (cond
+ (opt-entries opt-entries)
+ (rest-entries rest-entries)
+ (req-trail req-trail)
+ (t nil)))
+ (min-entries (+ (if req-trail (1- (length req-trail)) 0)
+ ;; required start && end
+ (- (- (length lambda-list)
+ (count-valid-keys lambda-list))
+ (- (length longest-sublist)
+ (count-valid-keys longest-sublist)))))
+ (max-entries (when (null rest-entries)
+ ;; required start && end && optionals
+ (+ min-entries
+ (if opt-entries
+ (- (1- (length opt-entries))
+ (length req-trail))
+ 0)))))
+
+ `(let* ((,%message ,message)
+ (,%args (arguments ,%message))
+ (,%arg-count (length ,%args))
+ ,@(if (and whole-var
+ (not (ignored-p whole-var)))
+ `((,whole-var ,%args))
+ (values)))
+ (when ,(if max-entries
+ `(not (and (<= ,min-entries ,%arg-count)
+ (<= ,%arg-count ,max-entries)))
+ `(> ,min-entries ,%arg-count))
+ ;; we want to raise a cl-irc condition here!
+ (error "Unexpected protocol input"))
+ ,(bind-req-trail
+ req-trail
+ `(last ,%args ,(1- (length req-trail)))
+ (multiple-value-bind
+ (ll ignores) (replace-ignored destructuring-ll)
+ `(destructuring-bind
+ ,ll
+ ,(if req-trail
+ `(butlast ,%args ,(1- (length req-trail)))
+ %args)
+ ,(if ignores
+ `(declare (ignore ,@ignores))
+ (values))
+ ,@body))))))))
+
;;
;; RPL_ISUPPORT support routines
