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 ;;; 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
 103 (defun parse-destructuring-lambda-list (lambda-list)
 104   (let (;; Destructured lambda list structure where we accumulate the
 105         ;; results of the parsing.
 106         (d-ll (make-d-lambda-list))
 107         ;; List of lambda list keywords which we have already seen.
 108         (lambda-keywords nil))
 109     (flet (;; Check if we are in the beginning of the section NAME in
 110            ;; the lambda list. It checks also if the section is in the
 111            ;; proper place and it is new.
 112            (lambda-section (name)
 113              (let ((section (first lambda-list)))
 114                (when (find section lambda-keywords)
 115                  (error "Bad placed ~a in the lambda-list ~S." section lambda-list))
 116                (when (eq name section)
 117                  (push name lambda-keywords)
 118                  (pop lambda-list)
 119                  t)))
 120            ;; Check if we are in the middle of a lambda list section,
 121            ;; looking for a lambda list keyword in the current
 122            ;; position of the lambda list.
 123            (in-section-p ()
 124              (and (consp lambda-list)
 125                   (not (find (first lambda-list) lambda-list-keywords)))))
 126
 127       ;; &whole var
 128       (when (lambda-section '&whole)
 129         (let ((wholevar (pop lambda-list)))
 130           (setf (d-lambda-list-wholevar d-ll) (var-or-pattern wholevar))))
 131
 132       ;; required vars
 133       (loop while (in-section-p)
 134          do (let ((var (pop lambda-list)))
 135               (push (var-or-pattern var) (d-lambda-list-reqvars d-ll))))
 136       (setf (d-lambda-list-reqvars d-ll)
 137             (reverse (d-lambda-list-reqvars d-ll)))
 138
 139       ;; optional vars
 140       (when (lambda-section '&optional)
 141         (loop while (in-section-p)
 142            do (push (parse-optvar (pop lambda-list))
 143                     (d-lambda-list-optvars d-ll)))
 144         (setf (d-lambda-list-optvars d-ll)
 145               (reverse (d-lambda-list-optvars d-ll))))
 146
 147       ;; Dotted lambda-list and &rest/&body vars. If the lambda-list
 148       ;; is dotted. Convert it the tail to a &rest and finish.
 149       (when (and lambda-list (atom lambda-list))
 150         (push lambda-list (d-lambda-list-restvar d-ll))
 151         (setq lambda-list nil))
 152       (when (find (car lambda-list) '(&body &rest))
 153         (pop lambda-list)
 154         (setf (d-lambda-list-restvar d-ll)
 155               (var-or-pattern (pop lambda-list))))
 156
 157       ;; Keyword arguments
 158       (when (lambda-section '&key)
 159         (loop while (in-section-p)
 160            do (push (parse-keyvar (pop lambda-list))
 161                     (d-lambda-list-keyvars d-ll)))
 162         (setf (d-lambda-list-keyvars d-ll)
 163               (reverse (d-lambda-list-keyvars d-ll))))
 164       (when (lambda-section '&allow-other-keys)
 165         (setf (d-lambda-list-allow-other-keys d-ll) t))
 166
 167       ;; Aux variables
 168       (when (lambda-section '&aux)
 169         (loop while (in-section-p)
 170            do (push (parse-auxvar (pop lambda-list))
 171                     (d-lambda-list-auxvars d-ll)))
 172         (setf (d-lambda-list-auxvars d-ll)
 173               (reverse (d-lambda-list-auxvars d-ll))))
 174       d-ll)))
 175
 176
 177 ;;;; Destructuring
 178
 179 ;;; Return T if KEYWORD is supplied in the list of arguments LIST.
 180 (defun keyword-supplied-p (keyword list)
 181   (loop
 182      for (key value) on list by #'cddr
 183      thereis (eq key keyword)))
 184
 185 ;;; Return the value of KEYWORD in the list of arguments LIST or NIL
 186 ;;; if it is not supplied.
 187 (defun keyword-lookup (keyword list)
 188   (loop
 189      for (key value) on list by #'cddr
 190      when (eq key keyword) do (return value)))
 191
 192 ;;; Validate a list of keyword arguments.
 193 (defun validate-keyvars (list keyword-list &optional allow-other-keys)
 194   (let (;; If it is non-NIL, we have to check for unknown keyword
 195         ;; arguments in the list to signal an error in that case.
 196         (allow-other-keys
 197          (or allow-other-keys (keyword-lookup :allow-other-keys list))))
 198     (unless allow-other-keys
 199       (or (loop
 200              for (key value) on list by #'cddr
 201              unless (find key keyword-list)
 202              do (error "Unknown keyword argument `~S'." key))))
 203     (loop
 204        for (key . tail) on list by #'cddr
 205        unless (symbolp key) do
 206          (error "Keyword argument `~S' is not a symbol." key)
 207        unless (consp tail) do
 208          (error "Odd number of keyword arguments."))))
 209
 210 (defmacro !destructuring-bind (lambda-list expression &body body)
 211   (multiple-value-bind (d-ll)
 212       (parse-destructuring-lambda-list lambda-list)
 213     (let ((reqvar-count (length (d-lambda-list-reqvars d-ll)))
 214           (optvar-count (length (d-lambda-list-optvars d-ll)))
 215           (bindings '()))
 216       (labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))), such that
 217                ;; there are N calls to CDR.
 218                (nth-chain (x n &optional tail)
 219                  (if tail
 220                      (if (zerop n) x `(cdr ,(nth-chain x (1- n) t)))
 221                      `(car ,(nth-chain x n t))))
 222                ;; Compute the bindings for a pattern against FORM. If
 223                ;; PATTERN is a lambda-list the pattern is bound to an
 224                ;; auxiliary variable, otherwise PATTERN must be a
 225                ;; symbol it will be bound to the form. The variable
 226                ;; where the form is bound is returned.
 227                (compute-pbindings (pattern form)
 228                  (etypecase pattern
 229                    (null)
 230                    ;; Bind the symbol to FORM.
 231                    (symbol
 232                     (push `(,pattern ,form) bindings)
 233                     (values pattern))
 234                    ;; Bind FORM to a auxiliar variable and bind
 235                    ;; pattern agains it recursively.
 236                    (d-lambda-list
 237                     (let ((subpart (gensym)))
 238                       (push `(,subpart
 239                               (progn
 240                                 ,form))
 241                             bindings)
 242                       (compute-bindings pattern subpart)
 243                       (values subpart)))))
 244
 245                ;; Compute the bindings for the full D-LAMBDA-LIST d-ll
 246                ;; against FORM.
 247                (compute-bindings (d-ll form)
 248                  (compute-pbindings (d-lambda-list-wholevar d-ll) form)
 249                  (let ((count 0))
 250                    ;; Required vars
 251                    (dolist (reqvar (d-lambda-list-reqvars d-ll))
 252                      (compute-pbindings reqvar (nth-chain form count))
 253                      (incf count))
 254                    ;; Optional vars
 255                    (dolist (optvar (d-lambda-list-optvars d-ll))
 256                      (when (optvar-supplied-p-parameter optvar)
 257                        (compute-pbindings (optvar-supplied-p-parameter optvar)
 258                                           `(not (null ,(nth-chain form count t)))))
 259                      (compute-pbindings (optvar-variable optvar)
 260                                         `(if (null ,(nth-chain form count t))
 261                                              ,(optvar-initform optvar)
 262                                              ,(nth-chain form count)))
 263                      (incf count))
 264
 265                    ;; Rest-variable and keywords
 266                    (when (or (d-lambda-list-restvar d-ll)
 267                              (d-lambda-list-keyvars d-ll))
 268                      ;; If there is a rest or keyword variable, we
 269                      ;; will add a binding for the rest or an
 270                      ;; auxiliary variable. The computations in of the
 271                      ;; keyword start in this variable, so we avoid
 272                      ;; the long tail of nested CAR/CDR operations
 273                      ;; each time.
 274                      (let* ((chain (nth-chain form (+ reqvar-count optvar-count) t))
 275                             (pattern (or (d-lambda-list-restvar d-ll) (gensym)))
 276                             (rest (compute-pbindings pattern chain)))
 277                        (dolist (keyvar (d-lambda-list-keyvars d-ll))
 278                          (let ((variable (keyvar-variable keyvar))
 279                                (keyword (keyvar-keyword-name keyvar))
 280                                (supplied (or (keyvar-supplied-p-parameter keyvar)
 281                                              (gensym))))
 282                            (when supplied
 283                              (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest)))
 284                            (compute-pbindings variable `(if ,supplied
 285                                                             (keyword-lookup ,keyword ,rest)
 286                                                             ,(keyvar-initform keyvar)))))))
 287
 288                    ;; Aux variables
 289                    (dolist (auxvar (d-lambda-list-auxvars d-ll))
 290                      (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))))
 291
 292         ;; Macroexpansion. Compute bindings and generate code for them
 293         ;; and some necessary checking.
 294         (let ((whole (gensym)))
 295           (compute-bindings d-ll whole)
 296           `(let ((,whole ,expression))
 297              (let* ,(reverse bindings)
 298                ,@body)))))))
 299
 300
 301 #+jscl
 302 (defmacro destructuring-bind (lambda-list expression &body body)
 303   `(!destructuring-bind ,lambda-list ,expression ,@body))