src/lambda-list.lisp

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