--- /dev/null
+;;; lambda-list.lisp --- Lambda list parsing and destructuring
+
+;; 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
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; 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)
+
+;;;; Lambda list parsing
+
+(defstruct optvar
+ variable initform supplied-p-parameter)
+
+(defstruct keyvar
+ variable keyword-name initform supplied-p-parameter)
+
+(defstruct auxvar
+ variable initform)
+
+(defstruct d-lambda-list
+ wholevar
+ reqvars
+ optvars
+ restvar
+ allow-other-keys
+ keyvars
+ auxvars)
+
+(defun var-or-pattern (x)
+ (etypecase x
+ (symbol x)
+ (cons (parse-destructuring-lambda-list x))))
+
+(defun parse-optvar (desc)
+ (etypecase desc
+ (symbol
+ (make-optvar :variable desc))
+ (cons
+ (let ((variable (first desc))
+ (initform (second desc))
+ (supplied-p-parameter (third desc)))
+ (unless (null (cdddr desc))
+ (error "Bad optional parameter specification `~S'" desc))
+ (unless (symbolp supplied-p-parameter)
+ (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
+ (make-optvar :variable (var-or-pattern variable)
+ :initform initform
+ :supplied-p-parameter supplied-p-parameter)))))
+
+(defun parse-keyvar (desc)
+ (etypecase desc
+ (symbol
+ (make-keyvar :variable desc :keyword-name (intern (string desc) "KEYWORD")))
+ (cons
+ (let (variable
+ keyword-name
+ (initform (second desc))
+ (supplied-p-parameter (third desc)))
+ (unless (null (cdddr desc))
+ (error "Bad keyword parameter specification `~S'" desc))
+ (unless (symbolp supplied-p-parameter)
+ (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
+ (let ((name (first desc)))
+ (etypecase name
+ (symbol
+ (setq keyword-name (intern (string name) "KEYWORD"))
+ (setq variable name))
+ (cons
+ (unless (null (cddr name))
+ (error "Bad keyword argument name description `~S'" name))
+ (setq keyword-name (first name))
+ (setq variable (second name)))))
+ (unless (symbolp keyword-name)
+ (error "~S is not a valid keyword-name." keyword-name))
+ (make-keyvar :variable (var-or-pattern variable)
+ :keyword-name keyword-name
+ :initform initform
+ :supplied-p-parameter supplied-p-parameter)))))
+
+(defun parse-auxvar (desc)
+ (etypecase desc
+ (symbol
+ (make-auxvar :variable desc))
+ (cons
+ (let ((variable (first desc))
+ (initform (second desc)))
+ (unless (null (cdddr desc))
+ (error "Bad aux variable specification `~S'" desc))
+ (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))
+ ;; 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
+ ;; the lambda list. It checks also if the section is in the
+ ;; proper place and it is new.
+ (lambda-section (name)
+ (let ((section (first lambda-list)))
+ (when (find section lambda-keywords)
+ (error "Bad placed ~a in the lambda-list ~S." section lambda-list))
+ (when (eq name section)
+ (push name lambda-keywords)
+ (pop lambda-list)
+ t)))
+ ;; Check if we are in the middle of a lambda list section,
+ ;; looking for a lambda list keyword in the current
+ ;; position of the lambda list.
+ (in-section-p ()
+ (and (consp lambda-list)
+ (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))))
+
+ ;; 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)))
+
+ ;; 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))))
+
+ ;; 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))
+ (setq lambda-list nil))
+ (when (find (car lambda-list) '(&body &rest))
+ (pop lambda-list)
+ (setf (d-lambda-list-restvar d-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))))
+ (when (lambda-section '&allow-other-keys)
+ (setf (d-lambda-list-allow-other-keys d-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)))
+
+
+;;;; Destructuring
+
+;;; 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)))
+
+;;; 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)))
+
+;;; 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
+ ;; arguments in the list to signal an error in that case.
+ (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."))))
+
+(defmacro !destructuring-bind (lambda-list expression &body 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))), 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)))
+ `(car ,(nth-chain x n t))))
+ ;; Compute the bindings for a pattern against FORM. If
+ ;; PATTERN is a lambda-list the pattern is bound to an
+ ;; auxiliary variable, otherwise PATTERN must be a
+ ;; 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
+ (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)))))
+
+ ;; 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))
+
+ ;; Rest-variable and keywords
+ (when (or (d-lambda-list-restvar d-ll)
+ (d-lambda-list-keyvars d-ll))
+ ;; 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))))))))))
+
+ ;; 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)))))))
+
+
+#+jscl
+(defmacro destructuring-bind (lambda-list expression &body body)
+ `(!destructuring-bind ,lambda-list ,expression ,@body))
+
+
+
+
+
+
+
projects / jscl.git / commitdiff