src/lambda-list.lisp

   1 ;;; lambda-list.lisp --- Lambda list parsing and destructuring
   2
   3 ;;; Copyright (C) 2013 David Vazquez
   4
   5 ;; JSCL is free software: you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation, either version 3 of the
   8 ;; License, or (at your option) any later version.
   9 ;;
  10 ;; JSCL is distributed in the hope that it will be useful, but
  11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (defvar !lambda-list-keywords
  19   '(&optional &rest &key &aux &allow-other-keys &body &optional))
  20
  21 ;;;; Lambda list parsing
  22
  23 (def!struct optvar
  24   variable initform supplied-p-parameter)
  25
  26 (def!struct keyvar
  27   variable keyword-name initform supplied-p-parameter)
  28
  29 (def!struct auxvar
  30   variable initform)
  31
  32 (def!struct d-lambda-list
  33   wholevar
  34   reqvars
  35   optvars
  36   restvar
  37   allow-other-keys
  38   keyvars
  39   auxvars)
  40
  41 (defun var-or-pattern (x)
  42   (etypecase x
  43     (symbol x)
  44     (cons (parse-destructuring-lambda-list x))))
  45
  46 (defun parse-optvar (desc)
  47   (etypecase desc
  48     (symbol
  49      (make-optvar :variable desc))
  50     (cons
  51      (let ((variable (first desc))
  52            (initform (second desc))
  53            (supplied-p-parameter (third desc)))
  54        (unless (null (cdddr desc))
  55          (error "Bad optional parameter specification `~S'" desc))
  56        (unless (symbolp supplied-p-parameter)
  57          (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
  58        (make-optvar :variable (var-or-pattern variable)
  59                     :initform initform
  60                     :supplied-p-parameter supplied-p-parameter)))))
  61
  62 (defun parse-keyvar (desc)
  63   (etypecase desc
  64     (symbol
  65      (make-keyvar :variable desc :keyword-name (intern (string desc) "KEYWORD")))
  66     (cons
  67      (let (variable
  68            keyword-name
  69            (initform (second desc))
  70            (supplied-p-parameter (third desc)))
  71        (unless (null (cdddr desc))
  72          (error "Bad keyword parameter specification `~S'" desc))
  73        (unless (symbolp supplied-p-parameter)
  74          (error "`~S' is not a valid supplied optional parameter." supplied-p-parameter))
  75        (let ((name (first desc)))
  76          (etypecase name
  77            (symbol
  78             (setq keyword-name (intern (string name) "KEYWORD"))
  79             (setq variable name))
  80            (cons
  81             (unless (null (cddr name))
  82               (error "Bad keyword argument name description `~S'" name))
  83             (setq keyword-name (first name))
  84             (setq variable (second name)))))
  85        (unless (symbolp keyword-name)
  86          (error "~S is not a valid keyword-name." keyword-name))
  87        (make-keyvar :variable (var-or-pattern variable)
  88                     :keyword-name keyword-name
  89                     :initform initform
  90                     :supplied-p-parameter supplied-p-parameter)))))
  91
  92 (defun parse-auxvar (desc)
  93   (etypecase desc
  94     (symbol
  95      (make-auxvar :variable desc))
  96     (cons
  97      (let ((variable (first desc))
  98            (initform (second desc)))
  99        (unless (null (cdddr desc))
 100          (error "Bad aux variable specification `~S'" desc))
 101        (make-auxvar :variable (var-or-pattern variable)
 102                     :initform initform)))))
 103
 104 (defun parse-destructuring-lambda-list (lambda-list)
 105   (let (;; Destructured lambda list structure where we accumulate the
 106         ;; results of the parsing.
 107         (d-ll (make-d-lambda-list))
 108         ;; List of lambda list keywords which we have already seen.
 109         (lambda-keywords nil))
 110     (flet ( ;; Check if we are in the beginning of the section NAME in
 111            ;; the lambda list. It checks also if the section is in the
 112            ;; proper place and it is new.
 113            (lambda-section (name)
 114              (let ((section (first lambda-list)))
 115                (when (find section lambda-keywords)
 116                  (error "Bad placed ~a in the lambda-list ~S." section lambda-list))
 117                (when (eq name section)
 118                  (push name lambda-keywords)
 119                  (pop lambda-list)
 120                  t)))
 121            ;; Check if we are in the middle of a lambda list section,
 122            ;; looking for a lambda list keyword in the current
 123            ;; position of the lambda list.
 124            (in-section-p ()
 125              (and (consp lambda-list)
 126                   (not (find (first lambda-list) !lambda-list-keywords)))))
 127
 128       ;; &whole var
 129       (when (lambda-section '&whole)
 130         (let ((wholevar (pop lambda-list)))
 131           (setf (d-lambda-list-wholevar d-ll) (var-or-pattern wholevar))))
 132
 133       ;; required vars
 134       (while (in-section-p)
 135         (let ((var (pop lambda-list)))
 136           (push (var-or-pattern var) (d-lambda-list-reqvars d-ll))))
 137       (setf (d-lambda-list-reqvars d-ll)
 138             (reverse (d-lambda-list-reqvars d-ll)))
 139
 140       ;; optional vars
 141       (when (lambda-section '&optional)
 142         (while (in-section-p)
 143           (push (parse-optvar (pop lambda-list))
 144                 (d-lambda-list-optvars d-ll)))
 145         (setf (d-lambda-list-optvars d-ll)
 146               (reverse (d-lambda-list-optvars d-ll))))
 147
 148       ;; Dotted lambda-list and &rest/&body vars. If the lambda-list
 149       ;; is dotted. Convert it the tail to a &rest and finish.
 150       (when (and lambda-list (atom lambda-list))
 151         (push lambda-list (d-lambda-list-restvar d-ll))
 152         (setq lambda-list nil))
 153       (when (find (car lambda-list) '(&body &rest))
 154         (pop lambda-list)
 155         (setf (d-lambda-list-restvar d-ll)
 156               (var-or-pattern (pop lambda-list))))
 157
 158       ;; Keyword arguments
 159       (when (lambda-section '&key)
 160         (while (in-section-p)
 161           (push (parse-keyvar (pop lambda-list))
 162                 (d-lambda-list-keyvars d-ll)))
 163         (setf (d-lambda-list-keyvars d-ll)
 164               (reverse (d-lambda-list-keyvars d-ll))))
 165       (when (lambda-section '&allow-other-keys)
 166         (setf (d-lambda-list-allow-other-keys d-ll) t))
 167
 168       ;; Aux variables
 169       (when (lambda-section '&aux)
 170         (while (in-section-p)
 171           (push (parse-auxvar (pop lambda-list))
 172                 (d-lambda-list-auxvars d-ll)))
 173         (setf (d-lambda-list-auxvars d-ll)
 174               (reverse (d-lambda-list-auxvars d-ll))))
 175       d-ll)))
 176
 177
 178 ;;;; Destructuring
 179
 180 (defmacro do-keywords (var value list &body body)
 181   (let ((g!list (gensym)))
 182     `(let ((,g!list ,list))
 183        (while ,g!list
 184          (let ((,var (car ,g!list))
 185                (,value (cadr ,g!list)))
 186            ,@body)
 187          (setq ,g!list (cddr ,g!list))))))
 188
 189 ;;; Return T if KEYWORD is supplied in the list of arguments LIST.
 190 (defun keyword-supplied-p (keyword list)
 191   (do-keywords key value list
 192     (declare (ignore value))
 193     (when (eq key keyword) (return t))
 194     (setq list (cddr list))))
 195
 196 ;;; Return the value of KEYWORD in the list of arguments LIST or NIL
 197 ;;; if it is not supplied.
 198 (defun keyword-lookup (keyword list)
 199   (do-keywords key value list
 200     (when (eq key keyword) (return value))
 201     (setq list (cddr list))))
 202
 203 (defun validate-reqvars (list n)
 204   (unless (listp list)
 205     (error "`~S' is not a list." list))
 206   (unless (<= n (length list))
 207     (error "Invalid number of elements in `~S'" list))
 208   list)
 209
 210 (defun validate-max-args (list)
 211   (unless (null list)
 212     (error "Too many elements `~S' in the lambda-list" list))
 213   list)
 214
 215 ;;; Validate a list of keyword arguments.
 216 (defun validate-keyvars (list keyword-list &optional allow-other-keys)
 217   (let (;; If it is non-NIL, we have to check for unknown keyword
 218         ;; arguments in the list to signal an error in that case.
 219         (allow-other-keys
 220          (or allow-other-keys (keyword-lookup :allow-other-keys list))))
 221     (unless allow-other-keys
 222       (do-keywords key value list
 223         (declare (ignore value))
 224         (unless (find key keyword-list)
 225           (error "Unknown keyword argument `~S'." key))))
 226     (do* ((tail list (cddr tail))
 227           (key (car tail) (car tail)))
 228          ((null tail) list)
 229       (unless (symbolp key)
 230         (error "Keyword argument `~S' is not a symbol." key))
 231       (unless (consp (cdr tail))
 232         (error "Odd number of keyword arguments.")))))
 233
 234
 235 (defun !expand-destructuring-bind (lambda-list expression &rest body)
 236   (multiple-value-bind (d-ll)
 237       (parse-destructuring-lambda-list lambda-list)
 238     (let ((bindings '()))
 239       (labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
 240                ;; such that there are N calls to CDR.
 241                (nth-chain (x n &optional tail)
 242                  (if tail
 243                      (if (zerop n) x `(cdr ,(nth-chain x (1- n) t)))
 244                      `(car ,(nth-chain x n t))))
 245                ;; Compute the bindings for a pattern against FORM. If
 246                ;; PATTERN is a lambda-list the pattern is bound to an
 247                ;; auxiliary variable, otherwise PATTERN must be a
 248                ;; symbol it will be bound to the form. The variable
 249                ;; where the form is bound is returned.
 250                (compute-pbindings (pattern form)
 251                  (cond
 252                    ((null pattern))
 253                    ((symbolp pattern)
 254                     (push `(,pattern ,form) bindings)
 255                     pattern)
 256                    ((d-lambda-list-p pattern)
 257                     (compute-bindings pattern form))))
 258
 259                ;; Compute the bindings for the full D-LAMBDA-LIST d-ll
 260                ;; against FORM.
 261                (compute-bindings (d-ll form)
 262                  (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
 263                        (optvar-count (length (d-lambda-list-optvars d-ll)))
 264                        (whole (or (d-lambda-list-wholevar d-ll) (gensym))))
 265                    ;; Create a binding for the whole expression
 266                    ;; FORM. It will match to D-LL, so we validate the
 267                    ;; number of elements on the result of FORM.
 268                    (compute-pbindings whole `(validate-reqvars ,form ,reqvar-count))
 269
 270                    (let ((count 0))
 271                      ;; Required vars
 272                      (dolist (reqvar (d-lambda-list-reqvars d-ll))
 273                        (compute-pbindings reqvar (nth-chain whole count))
 274                        (incf count))
 275                      ;; Optional vars
 276                      (dolist (optvar (d-lambda-list-optvars d-ll))
 277                        (when (optvar-supplied-p-parameter optvar)
 278                          (compute-pbindings (optvar-supplied-p-parameter optvar)
 279                                             `(not (null ,(nth-chain whole count t)))))
 280                        (compute-pbindings (optvar-variable optvar)
 281                                           `(if (null ,(nth-chain whole count t))
 282                                                ,(optvar-initform optvar)
 283                                                ,(nth-chain whole count)))
 284                        (incf count))
 285
 286                      ;; Rest-variable and keywords
 287
 288                      ;; If there is a rest or keyword variable, we
 289                      ;; will add a binding for the rest or an
 290                      ;; auxiliary variable. The computations in of the
 291                      ;; keyword start in this variable, so we avoid
 292                      ;; the long tail of nested CAR/CDR operations
 293                      ;; each time. We also include validation of
 294                      ;; keywords if there is any.
 295                      (let* ((chain (nth-chain whole (+ reqvar-count optvar-count) t))
 296                             (restvar (d-lambda-list-restvar d-ll))
 297                             (pattern (or restvar (gensym)))
 298                             (keywords (mapcar #'keyvar-keyword-name (d-lambda-list-keyvars d-ll)))
 299                             (rest
 300                              ;; Create a binding for the rest of the
 301                              ;; arguments. If there is keywords, then
 302                              ;; validate this list. If there is no
 303                              ;; keywords and no &rest variable, then
 304                              ;; validate that the rest is empty, it is
 305                              ;; to say, there is no more arguments
 306                              ;; that we expect.
 307                              (cond
 308                                (keywords (compute-pbindings pattern `(validate-keyvars ,chain ',keywords ,(d-lambda-list-allow-other-keys d-ll))))
 309                                (restvar  (compute-pbindings pattern chain))
 310                                (t        (compute-pbindings pattern `(validate-max-args ,chain))))))
 311                        (when (d-lambda-list-keyvars d-ll)
 312                          ;; Keywords
 313                          (dolist (keyvar (d-lambda-list-keyvars d-ll))
 314                            (let ((variable (keyvar-variable keyvar))
 315                                  (keyword (keyvar-keyword-name keyvar))
 316                                  (supplied (or (keyvar-supplied-p-parameter keyvar)
 317                                                (gensym))))
 318                              (when supplied
 319                                (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
 320                              (compute-pbindings variable `(if ,supplied
 321                                                               (keyword-lookup ,keyword ,rest)
 322                                                               ,(keyvar-initform keyvar)))))))
 323                      ;; Aux variables
 324                      (dolist (auxvar (d-lambda-list-auxvars d-ll))
 325                        (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))
 326
 327                    whole)))
 328
 329         ;; Macroexpansion. Compute bindings and generate code for them
 330         ;; and some necessary checking.
 331         (compute-bindings d-ll expression)
 332         `(let* ,(reverse bindings)
 333            ,@body)))))
 334
 335
 336 ;;; Because DEFMACRO uses destructuring-bind to parse the arguments of
 337 ;;; the macro-function, we can't define DESTRUCTURING-BIND with
 338 ;;; defmacro to avoid a circularity. So just define the macro function
 339 ;;; explicitly.
 340
 341 #+common-lisp
 342 (defmacro !destructuring-bind (lambda-list expression &body body)
 343   (apply #'!expand-destructuring-bind lambda-list expression body))
 344
 345 #+jscl
 346 (eval-when-compile
 347   (let ((macroexpander
 348          '#'(lambda (form &optional environment)
 349               (declare (ignore environment))
 350               (apply #'!expand-destructuring-bind form))))
 351     (%compile-defmacro '!destructuring-bind macroexpander)
 352     (%compile-defmacro  'destructuring-bind macroexpander)))