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