;;; 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)
+(/debug "loading lambda-list.lisp!")
+
+
+(defvar !lambda-list-keywords
+ '(&optional &rest &key &aux &allow-other-keys &body &optional))
;;;; Lambda list parsing
-(defstruct optvar
+(def!struct optvar
variable initform supplied-p-parameter)
-(defstruct keyvar
+(def!struct keyvar
variable keyword-name initform supplied-p-parameter)
-(defstruct auxvar
+(def!struct auxvar
variable initform)
-(defstruct d-lambda-list
+(def!struct lambda-list
wholevar
reqvars
optvars
(make-auxvar :variable (var-or-pattern variable)
:initform initform)))))
-
(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
;; 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)
(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
- (loop while (in-section-p)
- do (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)))
+ (while (in-section-p)
+ (let ((var (pop lambda-list)))
+ (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)
- (loop while (in-section-p)
- do (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))))
+ (while (in-section-p)
+ (push (parse-optvar (pop lambda-list))
+ (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)
- (loop while (in-section-p)
- do (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))))
+ (while (in-section-p)
+ (push (parse-keyvar (pop lambda-list))
+ (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)
- (loop while (in-section-p)
- do (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)))
+ (while (in-section-p)
+ (push (parse-auxvar (pop lambda-list))
+ (lambda-list-auxvars ll)))
+ (setf (lambda-list-auxvars ll)
+ (reverse (lambda-list-auxvars ll))))
+ ll)))
;;;; Destructuring
+(defmacro do-keywords (var value list &body body)
+ (let ((g!list (gensym)))
+ `(let ((,g!list ,list))
+ (while ,g!list
+ (let ((,var (car ,g!list))
+ (,value (cadr ,g!list)))
+ ,@body)
+ (setq ,g!list (cddr ,g!list))))))
+
;;; Return T if KEYWORD is supplied in the list of arguments LIST.
(defun keyword-supplied-p (keyword list)
- (loop
- for (key value) on list by #'cddr
- thereis (eq key keyword)))
+ (do-keywords key value list
+ (declare (ignore value))
+ (when (eq key keyword) (return t))
+ (setq list (cddr list))))
;;; Return the value of KEYWORD in the list of arguments LIST or NIL
;;; if it is not supplied.
(defun keyword-lookup (keyword list)
- (loop
- for (key value) on list by #'cddr
- when (eq key keyword) do (return value)))
+ (do-keywords key value list
+ (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)
(allow-other-keys
(or allow-other-keys (keyword-lookup :allow-other-keys list))))
(unless allow-other-keys
- (or (loop
- for (key value) on list by #'cddr
- unless (find key keyword-list)
- do (error "Unknown keyword argument `~S'." key))))
- (loop
- for (key . tail) on list by #'cddr
- unless (symbolp key) do
- (error "Keyword argument `~S' is not a symbol." key)
- unless (consp tail) do
- (error "Odd number of keyword arguments."))))
+ (do-keywords key value list
+ (declare (ignore value))
+ (unless (find key keyword-list)
+ (error "Unknown keyword argument `~S'." key))))
+ (do* ((tail list (cddr tail))
+ (key (car tail) (car tail)))
+ ((null tail) list)
+ (unless (symbolp key)
+ (error "Keyword argument `~S' is not a symbol." key))
+ (unless (consp (cdr tail))
+ (error "Odd number of keyword arguments.")))))
-(defmacro !destructuring-bind (lambda-list expression &body 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 ((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))), such that
- ;; there are N calls to CDR.
+ (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
(if (zerop n) x `(cdr ,(nth-chain x (1- n) t)))
;; symbol it will be bound to the form. The variable
;; where the form is bound is returned.
(compute-pbindings (pattern form)
- (etypecase pattern
- (null)
- ;; Bind the symbol to FORM.
- (symbol
+ (cond
+ ((null pattern))
+ ((symbolp pattern)
(push `(,pattern ,form) bindings)
- (values pattern))
- ;; Bind FORM to a auxiliar variable and bind
- ;; pattern agains it recursively.
- (d-lambda-list
- (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 ((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
+;;; 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)))