Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10793
Modified Files: eval.lisp Log Message: For make-destructuring-env, throw program-error when too few or too many values are provided.
--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/08 21:39:52 1.29 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/13 20:12:37 1.30 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.29 2008/04/08 21:39:52 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.30 2008/04/13 20:12:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -279,17 +279,17 @@ (setf env-var (cadr pattern) pattern (cddr pattern))) (loop with next-states = '(&optional &rest &key &aux) - with state = 'requireds - for pp on pattern as p = (car pp) - if (member p next-states) - do (setf next-states (member p next-states) - state p) - else do (cond + with state = 'requireds + for pp on pattern as p = (car pp) + if (member p next-states) + do (setf next-states (member p next-states) + state p) + else do (cond ((and (eq state 'requireds) recursive-p (consp p)) (unless (listp (car values)) - (error "Pattern mismatch.")) + (simple-program-error "Lambda-list pattern mismatch.")) (setf env (make-destructuring-env p (pop values) env :recursive-p nil :environment-p nil))) @@ -302,7 +302,8 @@ (case state (requireds (when (null values) - (error "Too few values provided. [~S:~S:~S]" state next-states env)) + (simple-program-error "Too few values provided. [~S:~S:~S]" + state next-states env)) (push (cons p (pop values)) env)) (&optional @@ -314,7 +315,7 @@ env)) (push (cons var (if values (pop values) - (eval-form init-form env))) + (eval-form init-form env))) env))) (&rest (push (cons p values) @@ -326,7 +327,7 @@ (present-p (not (null x))) (value (if present-p (cadr x) - (eval-form init-form env)))) + (eval-form init-form env)))) (when supplied-p-parameter (push (cons supplied-p-parameter present-p) @@ -341,9 +342,12 @@ (push (cons var (eval-form init-form env)) env))))) (t (error "Illegal destructuring pattern: ~S" pattern))) - (when (not (listp (cdr pp))) - (push (cons (cdr pp) values) - env))) + (when (not (listp (cdr pp))) + (push (cons (cdr pp) values) + env)) + finally + (when (and values (member state '(requireds optionals))) + (simple-program-error "Too many arguments."))) (if (and environment-p env-var) (cons (cons env-var env) env)