src/parse-lambda-list.lisp

   1 ;;;; -*- encoding:utf-8 -*-
   2
   3 ;;; Copyright 2007 Red Daly
   4
   5 ;;; SPDX-License-Identifier: BSD-3-Clause
   6
   7 ;;; Redistribution and use in source and binary forms, with or
   8 ;;; without modification, are permitted provided that the following
   9 ;;; conditions are met:
  10
  11 ;;; 1. Redistributions of source code must retain the above copyright
  12 ;;; notice, this list of conditions and the following disclaimer.
  13
  14 ;;; 2. Redistributions in binary form must reproduce the above
  15 ;;; copyright notice, this list of conditions and the following
  16 ;;; disclaimer in the documentation and/or other materials provided
  17 ;;; with the distribution.
  18
  19 ;;; 3. Neither the name of the copyright holder nor the names of its
  20 ;;; contributors may be used to endorse or promote products derived
  21 ;;; from this software without specific prior written permission.
  22
  23 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  24 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  25 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  26 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  28 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  29 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  30 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  31 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  32 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  33 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  34 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  35 ;;; POSSIBILITY OF SUCH DAMAGE.
  36
  37 (in-package #:parenscript)
  38
  39 ;;;; This software was taken from the SBCL system, mostly verbatim.
  40
  41 ;;; if you have found this on google, THIS IS NOT AN SBCL SOURCE FILE
  42
  43 ;;; Break something like a lambda list (but not necessarily actually a
  44 ;;; lambda list, e.g. the representation of argument types which is
  45 ;;; used within an FTYPE specification) into its component parts. We
  46 ;;; return twelve values:
  47 ;;;  1. a list of the required args;
  48 ;;;  2. a list of the &OPTIONAL arg specs;
  49 ;;;  3. true if a &REST arg was specified;
  50 ;;;  4. the &REST arg;
  51 ;;;  5. true if &KEY args are present;
  52 ;;;  6. a list of the &KEY arg specs;
  53 ;;;  7. true if &ALLOW-OTHER-KEYS was specified.;
  54 ;;;  8. true if any &AUX is present (new in SBCL vs. CMU CL);
  55 ;;;  9. a list of the &AUX specifiers;
  56 ;;; 10. true if a &MORE arg was specified;
  57 ;;; 11. the &MORE context var;
  58 ;;; 12. the &MORE count var;
  59 ;;; 13. true if any lambda list keyword is present (only for
  60 ;;;     PARSE-LAMBDA-LIST-LIKE-THING).
  61 ;;; 14. the &KEY-OBJECT var
  62 ;;;
  63 ;;; The top level lambda list syntax is checked for validity, but the
  64 ;;; arg specifiers are just passed through untouched.
  65
  66 (eval-when (:compile-toplevel :load-toplevel :execute)
  67   (defun collect-list-expander (n-value n-tail forms)
  68     (let ((n-res (gensym)))
  69       `(progn
  70         ,@(mapcar (lambda (form)
  71                     `(let ((,n-res (cons ,form nil)))
  72                       (cond (,n-tail
  73                              (setf (cdr ,n-tail) ,n-res)
  74                              (setq ,n-tail ,n-res))
  75                             (t
  76                              (setq ,n-tail ,n-res  ,n-value ,n-res)))))
  77                   forms)
  78         ,n-value))))
  79
  80 (defmacro collect (collections &body body)
  81   (let ((macros ())
  82         (binds ()))
  83     (dolist (spec collections)
  84       ;;(unless (proper-list-of-length-p spec 1 3)
  85       ;;  (error "malformed collection specifier: ~S" spec))
  86       (let* ((name (first spec))
  87              (default (second spec))
  88              (kind (or (third spec) 'collect))
  89              (n-value (gensym (concatenate 'string
  90                                            (symbol-name name)
  91                                            "-N-VALUE-"))))
  92         (push `(,n-value ,default) binds)
  93         (if (eq kind 'collect)
  94             (let ((n-tail (gensym (concatenate 'string
  95                                                (symbol-name name)
  96                                                "-N-TAIL-"))))
  97               (if default
  98                   (push `(,n-tail (last ,n-value)) binds)
  99                   (push n-tail binds))
 100                 (push `(,name (&rest args)
 101                         (collect-list-expander ',n-value ',n-tail args))
 102                       macros))
 103             (push `(,name (&rest args)
 104                     (collect-normal-expander ',n-value ',kind args))
 105                   macros))))
 106     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
 107
 108 (defparameter *lambda-list-keywords*
 109  '(&allow-other-keys &aux &body &environment &key &key-object &optional &rest &whole))
 110
 111 (defun style-warn (&rest args) (apply #'format t args))
 112
 113 (defun parse-lambda-list-like-thing (list)
 114  (collect ((required)
 115             (optional)
 116             (keys)
 117             (aux))
 118     (let ((restp nil)
 119           (rest nil)
 120           (morep nil)
 121           (more-context nil)
 122           (more-count nil)
 123           (keyp nil)
 124           (auxp nil)
 125           (allowp nil)
 126           (key-object nil)
 127           (state :required))
 128       (declare (type (member :allow-other-keys :aux
 129                              :key
 130                              :more-context :more-count
 131                              :optional
 132                              :post-more :post-rest
 133                              :required :rest
 134                              :key-object :post-key)
 135                      state))
 136       (dolist (arg list)
 137         (if (member arg *lambda-list-keywords*)
 138             (case arg
 139               (&optional
 140                (unless (eq state :required)
 141                  (format t "misplaced &OPTIONAL in lambda list: ~S"
 142                          list))
 143                (setq state :optional))
 144               (&rest
 145                (unless (member state '(:required :optional))
 146                  (format t "misplaced &REST in lambda list: ~S" list))
 147                (setq state :rest))
 148               (&more
 149                (unless (member state '(:required :optional))
 150                  (format t "misplaced &MORE in lambda list: ~S" list))
 151                (setq morep t
 152                      state :more-context))
 153               (&key
 154                (unless (member state
 155                                '(:required :optional :post-rest :post-more))
 156                  (format t "misplaced &KEY in lambda list: ~S" list))
 157                (when (optional)
 158                  (format t "&OPTIONAL and &KEY found in the same lambda list: ~S" list))
 159                (setq keyp t
 160                      state :key))
 161               (&allow-other-keys
 162                (unless (member state '(:key :post-key))
 163                  (format t "misplaced &ALLOW-OTHER-KEYS in ~
 164                                   lambda list: ~S"
 165                                  list))
 166                (setq allowp t
 167                      state :allow-other-keys))
 168               (&aux
 169                (when (member state '(:rest :more-context :more-count))
 170                  (format t "misplaced &AUX in lambda list: ~S" list))
 171                (when auxp
 172                  (format t "multiple &AUX in lambda list: ~S" list))
 173                (setq auxp t
 174                      state :aux))
 175               (&key-object
 176                (unless (member state '(:key :allow-other-keys))
 177                  (format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list))
 178                (setf state :key-object))
 179               (t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
 180             (progn
 181               (when (symbolp arg)
 182                 (let ((name (symbol-name arg)))
 183                   (when (and (plusp (length name))
 184                              (char= (char name 0) #\&))
 185                     (style-warn
 186                      "suspicious variable in lambda list: ~S." arg))))
 187               (case state
 188                 (:required (required arg))
 189                 (:optional (optional arg))
 190                 (:rest
 191                  (setq restp t
 192                        rest arg
 193                        state :post-rest))
 194                 (:more-context
 195                  (setq more-context arg
 196                        state :more-count))
 197                 (:more-count
 198                  (setq more-count arg
 199                        state :post-more))
 200                 (:key (keys arg))
 201                 (:key-object (setf key-object arg) (setf state :post-key))
 202                 (:aux (aux arg))
 203                 (t
 204                  (format t "found garbage in lambda list when expecting ~
 205                                   a keyword: ~S"
 206                                  arg))))))
 207       (when (eq state :rest)
 208         (format t "&REST without rest variable"))
 209
 210       (values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
 211               morep more-context more-count
 212               (not (eq state :required))
 213               key-object))))
 214
 215 ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
 216 ;;; really *is* a lambda list, not just a "lambda-list-like thing", so
 217 ;;; can barf on things which're illegal as arguments in lambda lists
 218 ;;; even if they could conceivably be legal in not-quite-a-lambda-list
 219 ;;; weirdosities
 220 (defun parse-lambda-list (lambda-list)
 221   ;; Classify parameters without checking their validity individually.
 222   (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
 223                         morep more-context more-count beyond-requireds? key-object)
 224       (parse-lambda-list-like-thing lambda-list)
 225     (declare (ignore beyond-requireds?))
 226     ;; Check validity of parameters.
 227     (flet ((need-symbol (x why)
 228              (unless (symbolp x)
 229                (format t "~A is not a symbol: ~S" why x))))
 230       (dolist (i required)
 231         (need-symbol i "Required argument"))
 232       (dolist (i optional)
 233         (typecase i
 234           (symbol)
 235           (cons
 236            (destructuring-bind (var &optional init-form supplied-p) i
 237              (declare (ignore init-form supplied-p))
 238              (need-symbol var "&OPTIONAL parameter name")))
 239           (t
 240            (format t "&OPTIONAL parameter is not a symbol or cons: ~S"
 241                            i))))
 242       (when restp
 243         (need-symbol rest "&REST argument"))
 244       (when keyp
 245         (dolist (i keys)
 246           (typecase i
 247             (symbol)
 248             (cons
 249              (destructuring-bind (var-or-kv &optional init-form supplied-p) i
 250                (declare (ignore init-form supplied-p))
 251                (if (consp var-or-kv)
 252                    (destructuring-bind (keyword-name var) var-or-kv
 253                      (declare (ignore keyword-name))
 254                      (need-symbol var "&KEY parameter name"))
 255                    (need-symbol var-or-kv "&KEY parameter name"))))
 256             (t
 257              (format t "&KEY parameter is not a symbol or cons: ~S"
 258                              i))))))
 259     ;; Voila.
 260     (values required optional restp rest keyp keys allowp auxp aux
 261             morep more-context more-count key-object)))