;;; 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/>.
+(/debug "loading lambda-list.lisp!")
+
+
(defvar !lambda-list-keywords
'(&optional &rest &key &aux &allow-other-keys &body &optional))
(def!struct auxvar
variable initform)
-(def!struct d-lambda-list
+(def!struct lambda-list
wholevar
reqvars
optvars
(defun parse-destructuring-lambda-list (lambda-list)
(let (;; Destructured lambda list structure where we accumulate the
;; results of the parsing.
- (d-ll (make-d-lambda-list))
+ (ll (make-lambda-list))
;; List of lambda list keywords which we have already seen.
(lambda-keywords nil))
- (flet ( ;; Check if we are in the beginning of the section NAME in
+ (flet (;; Check if we are in the beginning of the section NAME in
;; the lambda list. It checks also if the section is in the
;; proper place and it is new.
(lambda-section (name)
;; &whole var
(when (lambda-section '&whole)
(let ((wholevar (pop lambda-list)))
- (setf (d-lambda-list-wholevar d-ll) (var-or-pattern wholevar))))
+ (setf (lambda-list-wholevar ll) (var-or-pattern wholevar))))
;; required vars
(while (in-section-p)
(let ((var (pop lambda-list)))
- (push (var-or-pattern var) (d-lambda-list-reqvars d-ll))))
- (setf (d-lambda-list-reqvars d-ll)
- (reverse (d-lambda-list-reqvars d-ll)))
+ (push (var-or-pattern var) (lambda-list-reqvars ll))))
+ (setf (lambda-list-reqvars ll)
+ (reverse (lambda-list-reqvars ll)))
;; optional vars
(when (lambda-section '&optional)
(while (in-section-p)
(push (parse-optvar (pop lambda-list))
- (d-lambda-list-optvars d-ll)))
- (setf (d-lambda-list-optvars d-ll)
- (reverse (d-lambda-list-optvars d-ll))))
+ (lambda-list-optvars ll)))
+ (setf (lambda-list-optvars ll)
+ (reverse (lambda-list-optvars ll))))
;; Dotted lambda-list and &rest/&body vars. If the lambda-list
;; is dotted. Convert it the tail to a &rest and finish.
(when (and lambda-list (atom lambda-list))
- (push lambda-list (d-lambda-list-restvar d-ll))
+ (push lambda-list (lambda-list-restvar ll))
(setq lambda-list nil))
(when (find (car lambda-list) '(&body &rest))
(pop lambda-list)
- (setf (d-lambda-list-restvar d-ll)
+ (setf (lambda-list-restvar ll)
(var-or-pattern (pop lambda-list))))
;; Keyword arguments
(when (lambda-section '&key)
(while (in-section-p)
(push (parse-keyvar (pop lambda-list))
- (d-lambda-list-keyvars d-ll)))
- (setf (d-lambda-list-keyvars d-ll)
- (reverse (d-lambda-list-keyvars d-ll))))
+ (lambda-list-keyvars ll)))
+ (setf (lambda-list-keyvars ll)
+ (reverse (lambda-list-keyvars ll))))
(when (lambda-section '&allow-other-keys)
- (setf (d-lambda-list-allow-other-keys d-ll) t))
+ (setf (lambda-list-allow-other-keys ll) t))
;; Aux variables
(when (lambda-section '&aux)
(while (in-section-p)
(push (parse-auxvar (pop lambda-list))
- (d-lambda-list-auxvars d-ll)))
- (setf (d-lambda-list-auxvars d-ll)
- (reverse (d-lambda-list-auxvars d-ll))))
- d-ll)))
+ (lambda-list-auxvars ll)))
+ (setf (lambda-list-auxvars ll)
+ (reverse (lambda-list-auxvars ll))))
+ ll)))
;;;; Destructuring
(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.")))))
-(defun !destructuring-bind-macro-function (lambda-list expression &rest body)
- (multiple-value-bind (d-ll)
+
+(defun !expand-destructuring-bind (lambda-list expression &rest body)
+ (multiple-value-bind (ll)
(parse-destructuring-lambda-list lambda-list)
(let ((bindings '()))
(labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
(compute-pbindings (pattern form)
(cond
((null pattern))
- ;; Bind the symbol to FORM.
((symbolp pattern)
(push `(,pattern ,form) bindings)
- (values 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)))))
+ pattern)
+ ((lambda-list-p pattern)
+ (compute-bindings pattern form))))
- ;; Compute the bindings for the full D-LAMBDA-LIST d-ll
+ ;; Compute the bindings for the full LAMBDA-LIST ll
;; against FORM.
- (compute-bindings (d-ll form)
- (compute-pbindings (d-lambda-list-wholevar d-ll) form)
- (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
- (optvar-count (length (d-lambda-list-optvars d-ll)))
- (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))
-
- ;; Rest-variable and keywords
- (when (or (d-lambda-list-restvar d-ll)
- (d-lambda-list-keyvars d-ll))
+ (compute-bindings (ll form)
+ (let ((reqvar-count (length (lambda-list-reqvars ll)))
+ (optvar-count (length (lambda-list-optvars ll)))
+ (whole (or (lambda-list-wholevar ll) (gensym))))
+ ;; Create a binding for the whole expression
+ ;; FORM. It will match to 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 (lambda-list-reqvars ll))
+ (compute-pbindings reqvar (nth-chain whole count))
+ (incf count))
+ ;; Optional vars
+ (dolist (optvar (lambda-list-optvars 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
+
;; 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 (lambda-list-restvar ll))
+ (pattern (or restvar (gensym)))
+ (keywords (mapcar #'keyvar-keyword-name (lambda-list-keyvars 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 ,(lambda-list-allow-other-keys ll))))
+ (restvar (compute-pbindings pattern chain))
+ (t (compute-pbindings pattern `(validate-max-args ,chain))))))
+ (when (lambda-list-keyvars ll)
+ ;; Keywords
+ (dolist (keyvar (lambda-list-keyvars 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 (lambda-list-auxvars 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 ll expression)
+ `(let* ,(reverse bindings)
+ ,@body)))))
;;; Because DEFMACRO uses destructuring-bind to parse the arguments of
;;; defmacro to avoid a circularity. So just define the macro function
;;; explicitly.
-#+common-lisp
+#-jscl
(defmacro !destructuring-bind (lambda-list expression &body body)
- (apply #'!destructuring-bind-macro-function lambda-list expression body))
+ (apply #'!expand-destructuring-bind lambda-list expression body))
#+jscl
-(eval-when-compile
+(eval-when (:compile-toplevel)
(let ((macroexpander
'#'(lambda (form &optional environment)
(declare (ignore environment))
- (apply #'!destructuring-bind-macro-function form))))
+ (apply #'!expand-destructuring-bind form))))
(%compile-defmacro '!destructuring-bind macroexpander)
(%compile-defmacro 'destructuring-bind macroexpander)))
projects / jscl.git / blobdiff