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