From: David Vázquez Date: Sun, 5 May 2013 14:49:03 +0000 (+0100) Subject: WIP: Include DESTRUCTURING-BIND operator X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a4a03827e66f1cad335199660bfe0c57cf5c37c8;p=jscl.git WIP: Include DESTRUCTURING-BIND operator --- diff --git a/src/lambda-list.lisp b/src/lambda-list.lisp new file mode 100644 index 0000000..8e4ed61 --- /dev/null +++ b/src/lambda-list.lisp @@ -0,0 +1,306 @@ +;;; 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 . + +;;; 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)) + + + + + + +