;;; lambda-list.lisp --- Lambda list parsing and destructuring
+;;; Copyright (C) 2013 David Vazquez
+
;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; You should have received a copy of the GNU General Public License
;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
-;;; lambda-list-keywords
-;; '(&optional &rest &key &aux &allow-other-keys &body &optional)
+(defvar !lambda-list-keywords
+ '(&optional &rest &key &aux &allow-other-keys &body &optional))
;;;; Lambda list parsing
;; position of the lambda list.
(in-section-p ()
(and (consp lambda-list)
- (not (find (first lambda-list) lambda-list-keywords)))))
+ (not (find (first lambda-list) !lambda-list-keywords)))))
;; &whole var
(when (lambda-section '&whole)
(when (eq key keyword) (return value))
(setq list (cddr list))))
+(defun validate-reqvars (list n)
+ (unless (listp list)
+ (error "`~S' is not a list." list))
+ (unless (<= n (length list))
+ (error "Invalid number of elements in `~S'" list))
+ list)
+
+(defun validate-max-args (list)
+ (unless (null list)
+ (error "Too many elements `~S' in the lambda-list" list))
+ list)
+
;;; Validate a list of keyword arguments.
(defun validate-keyvars (list keyword-list &optional allow-other-keys)
(let (;; If it is non-NIL, we have to check for unknown keyword
(error "Unknown keyword argument `~S'." key))))
(do* ((tail list (cddr tail))
(key (car tail) (car tail)))
- ((null list))
+ ((null tail) list)
(unless (symbolp key)
(error "Keyword argument `~S' is not a symbol." key))
- (unless (consp tail)
+ (unless (consp (cdr tail))
(error "Odd number of keyword arguments.")))))
-(defmacro !destructuring-bind (lambda-list expression &body body)
+
+(defun !expand-destructuring-bind (lambda-list expression &rest body)
(multiple-value-bind (d-ll)
(parse-destructuring-lambda-list lambda-list)
- (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
- (optvar-count (length (d-lambda-list-optvars d-ll)))
- (bindings '()))
- (labels (;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
+ (let ((bindings '()))
+ (labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
;; such that there are N calls to CDR.
(nth-chain (x n &optional tail)
(if tail
(compute-pbindings (pattern form)
(cond
((null pattern))
- ;; Bind the symbol to FORM.
((symbolp pattern)
(push `(,pattern ,form) bindings)
- (values pattern))
+ pattern)
((d-lambda-list-p pattern)
- ;; Bind FORM to a auxiliar variable and bind
- ;; pattern agains it recursively.
- (let ((subpart (gensym)))
- (push `(,subpart
- (progn
- ,form))
- bindings)
- (compute-bindings pattern subpart)
- (values subpart)))))
+ (compute-bindings pattern form))))
;; Compute the bindings for the full D-LAMBDA-LIST d-ll
;; against FORM.
(compute-bindings (d-ll form)
- (compute-pbindings (d-lambda-list-wholevar d-ll) form)
- (let ((count 0))
- ;; Required vars
- (dolist (reqvar (d-lambda-list-reqvars d-ll))
- (compute-pbindings reqvar (nth-chain form count))
- (incf count))
- ;; Optional vars
- (dolist (optvar (d-lambda-list-optvars d-ll))
- (when (optvar-supplied-p-parameter optvar)
- (compute-pbindings (optvar-supplied-p-parameter optvar)
- `(not (null ,(nth-chain form count t)))))
- (compute-pbindings (optvar-variable optvar)
- `(if (null ,(nth-chain form count t))
- ,(optvar-initform optvar)
- ,(nth-chain form count)))
- (incf count))
+ (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
+ (optvar-count (length (d-lambda-list-optvars d-ll)))
+ (whole (or (d-lambda-list-wholevar d-ll) (gensym))))
+ ;; Create a binding for the whole expression
+ ;; FORM. It will match to D-LL, so we validate the
+ ;; number of elements on the result of FORM.
+ (compute-pbindings whole `(validate-reqvars ,form ,reqvar-count))
+
+ (let ((count 0))
+ ;; Required vars
+ (dolist (reqvar (d-lambda-list-reqvars d-ll))
+ (compute-pbindings reqvar (nth-chain whole count))
+ (incf count))
+ ;; Optional vars
+ (dolist (optvar (d-lambda-list-optvars d-ll))
+ (when (optvar-supplied-p-parameter optvar)
+ (compute-pbindings (optvar-supplied-p-parameter optvar)
+ `(not (null ,(nth-chain whole count t)))))
+ (compute-pbindings (optvar-variable optvar)
+ `(if (null ,(nth-chain whole count t))
+ ,(optvar-initform optvar)
+ ,(nth-chain whole count)))
+ (incf count))
- ;; Rest-variable and keywords
- (when (or (d-lambda-list-restvar d-ll)
- (d-lambda-list-keyvars d-ll))
+ ;; Rest-variable and keywords
+
;; If there is a rest or keyword variable, we
;; will add a binding for the rest or an
;; auxiliary variable. The computations in of the
;; keyword start in this variable, so we avoid
;; the long tail of nested CAR/CDR operations
- ;; each time.
- (let* ((chain (nth-chain form (+ reqvar-count optvar-count) t))
- (pattern (or (d-lambda-list-restvar d-ll) (gensym)))
- (rest (compute-pbindings pattern chain)))
- (dolist (keyvar (d-lambda-list-keyvars d-ll))
- (let ((variable (keyvar-variable keyvar))
- (keyword (keyvar-keyword-name keyvar))
- (supplied (or (keyvar-supplied-p-parameter keyvar)
- (gensym))))
- (when supplied
- (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
- (compute-pbindings variable `(if ,supplied
- (keyword-lookup ,keyword ,rest)
- ,(keyvar-initform keyvar)))))))
-
- ;; Aux variables
- (dolist (auxvar (d-lambda-list-auxvars d-ll))
- (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))))
+ ;; each time. We also include validation of
+ ;; keywords if there is any.
+ (let* ((chain (nth-chain whole (+ reqvar-count optvar-count) t))
+ (restvar (d-lambda-list-restvar d-ll))
+ (pattern (or restvar (gensym)))
+ (keywords (mapcar #'keyvar-keyword-name (d-lambda-list-keyvars d-ll)))
+ (rest
+ ;; Create a binding for the rest of the
+ ;; arguments. If there is keywords, then
+ ;; validate this list. If there is no
+ ;; keywords and no &rest variable, then
+ ;; validate that the rest is empty, it is
+ ;; to say, there is no more arguments
+ ;; that we expect.
+ (cond
+ (keywords (compute-pbindings pattern `(validate-keyvars ,chain ',keywords ,(d-lambda-list-allow-other-keys d-ll))))
+ (restvar (compute-pbindings pattern chain))
+ (t (compute-pbindings pattern `(validate-max-args ,chain))))))
+ (when (d-lambda-list-keyvars d-ll)
+ ;; Keywords
+ (dolist (keyvar (d-lambda-list-keyvars d-ll))
+ (let ((variable (keyvar-variable keyvar))
+ (keyword (keyvar-keyword-name keyvar))
+ (supplied (or (keyvar-supplied-p-parameter keyvar)
+ (gensym))))
+ (when supplied
+ (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
+ (compute-pbindings variable `(if ,supplied
+ (keyword-lookup ,keyword ,rest)
+ ,(keyvar-initform keyvar)))))))
+ ;; Aux variables
+ (dolist (auxvar (d-lambda-list-auxvars d-ll))
+ (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))
+
+ whole)))
;; Macroexpansion. Compute bindings and generate code for them
;; and some necessary checking.
- (let ((whole (gensym)))
- (compute-bindings d-ll whole)
- `(let ((,whole ,expression))
- (let* ,(reverse bindings)
- ,@body)))))))
+ (compute-bindings d-ll expression)
+ `(let* ,(reverse bindings)
+ ,@body)))))
+
+;;; Because DEFMACRO uses destructuring-bind to parse the arguments of
+;;; the macro-function, we can't define DESTRUCTURING-BIND with
+;;; defmacro to avoid a circularity. So just define the macro function
+;;; explicitly.
+
+#-jscl
+(defmacro !destructuring-bind (lambda-list expression &body body)
+ (apply #'!expand-destructuring-bind lambda-list expression body))
#+jscl
-(defmacro destructuring-bind (lambda-list expression &body body)
- `(!destructuring-bind ,lambda-list ,expression ,@body))
+(eval-when-compile
+ (let ((macroexpander
+ '#'(lambda (form &optional environment)
+ (declare (ignore environment))
+ (apply #'!expand-destructuring-bind form))))
+ (%compile-defmacro '!destructuring-bind macroexpander)
+ (%compile-defmacro 'destructuring-bind macroexpander)))
projects / jscl.git / blobdiff