src/defmfun-check.lisp

   1 ;;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2
   3 (in-package :maxima)
   4
   5 ;; We got this code from cmucl, so we don't actually need all of this.
   6 #+cmucl
   7 (progn
   8 (defun parse-lambda-list (list)
   9   (kernel:parse-lambda-list list))
  10 (defun parse-body (body environment &optional (doc-string-allowed t))
  11   (system:parse-body body environment doc-string-allowed))
  12 )
  13
  14 #-cmucl
  15 (eval-when (compile load eval)
  16 ;;;; Borrowed from cmucl src/code/extensions.lisp.  Used in parsing
  17 ;;;; lambda lists.
  18
  19 ;;;; The Collect macro:
  20
  21 ;;; Collect-Normal-Expander  --  Internal
  22 ;;;
  23 ;;;    This function does the real work of macroexpansion for normal collection
  24 ;;; macros.  N-Value is the name of the variable which holds the current
  25 ;;; value.  Fun is the function which does collection.  Forms is the list of
  26 ;;; forms whose values we are supposed to collect.
  27 ;;;
  28 (defun collect-normal-expander (n-value fun forms)
  29   `(progn
  30     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
  31     ,n-value))
  32
  33 ;;; Collect-List-Expander  --  Internal
  34 ;;;
  35 ;;;    This function deals with the list collection case.  N-Tail is the pointer
  36 ;;; to the current tail of the list, which is NIL if the list is empty.
  37 ;;;
  38 (defun collect-list-expander (n-value n-tail forms)
  39   (let ((n-res (gensym)))
  40     `(progn
  41       ,@(mapcar #'(lambda (form)
  42                     `(let ((,n-res (cons ,form nil)))
  43                        (cond (,n-tail
  44                               (setf (cdr ,n-tail) ,n-res)
  45                               (setq ,n-tail ,n-res))
  46                              (t
  47                               (setq ,n-tail ,n-res  ,n-value ,n-res)))))
  48                 forms)
  49       ,n-value)))
  50
  51
  52 ;;; Collect  --  Public
  53 ;;;
  54 ;;;    The ultimate collection macro...
  55 ;;;
  56 (defmacro collect (collections &body body)
  57   "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
  58   Collect some values somehow.  Each of the collections specifies a bunch of
  59   things which collected during the evaluation of the body of the form.  The
  60   name of the collection is used to define a local macro, a la MACROLET.
  61   Within the body, this macro will evaluate each of its arguments and collect
  62   the result, returning the current value after the collection is done.  The
  63   body is evaluated as a PROGN; to get the final values when you are done, just
  64   call the collection macro with no arguments.
  65
  66   Initial-Value is the value that the collection starts out with, which
  67   defaults to NIL.  Function is the function which does the collection.  It is
  68   a function which will accept two arguments: the value to be collected and the
  69   current collection.  The result of the function is made the new value for the
  70   collection.  As a totally magical special-case, the Function may be Collect,
  71   which tells us to build a list in forward order; this is the default.  If an
  72   Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
  73   end.  Note that Function may be anything that can appear in the functional
  74   position, including macros and lambdas."
  75
  76   (let ((macros ())
  77         (binds ()))
  78     (dolist (spec collections)
  79       (unless (<= 1 (length spec) 3)
  80         (error (intl:gettext "Malformed collection specifier: ~S.") spec))
  81       (let ((n-value (gensym))
  82             (name (first spec))
  83             (default (second spec))
  84             (kind (or (third spec) 'collect)))
  85         (push `(,n-value ,default) binds)
  86         (if (eq kind 'collect)
  87             (let ((n-tail (gensym)))
  88               (if default
  89                   (push `(,n-tail (last ,n-value)) binds)
  90                   (push n-tail binds))
  91               (push `(,name (&rest args)
  92                             (collect-list-expander ',n-value ',n-tail args))
  93                     macros))
  94             (push `(,name (&rest args)
  95                           (collect-normal-expander ',n-value ',kind args))
  96                   macros))))
  97     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
  98
  99 ;;; Borrowed from cmucl src/compiler/proclaim.lisp
 100
 101 ;;; Parse-Lambda-List  --  Interface
 102 ;;;
 103 ;;;    Break a lambda-list into its component parts.  We return eleven values:
 104 ;;;  1] A list of the required args.
 105 ;;;  2] A list of the optional arg specs.
 106 ;;;  3] True if a rest arg was specified.
 107 ;;;  4] The rest arg.
 108 ;;;  5] A boolean indicating whether keywords args are present.
 109 ;;;  6] A list of the keyword arg specs.
 110 ;;;  7] True if &allow-other-keys was specified.
 111 ;;;  8] A list of the &aux specifiers.
 112 ;;;  9] True if a more arg was specified.
 113 ;;; 10] The &more context var
 114 ;;; 11] The &more count var
 115 ;;;
 116 ;;; The top-level lambda-list syntax is checked for validity, but the arg
 117 ;;; specifiers are just passed through untouched.  If something is wrong, we
 118 ;;; use Compiler-Error, aborting compilation to the last recovery point.
 119 ;;;
 120 (defun parse-lambda-list (list)
 121   (declare (list list))
 122   (collect ((required)
 123             (optional)
 124             (keys)
 125             (aux))
 126     (flet ((compiler-error (&rest args)
 127              (apply #'error args))
 128            (compiler-note (&rest args)
 129              (apply #'warn args)))
 130       (let ((restp nil)
 131             (rest nil)
 132             (morep nil)
 133             (more-context nil)
 134             (more-count nil)
 135             (keyp nil)
 136             (allowp nil)
 137             (state :required))
 138         (dolist (arg list)
 139           ;; check for arguments that have the syntactic form of a
 140           ;; keyword argument without being a recognized lambda-list keyword
 141           (when (and (symbolp arg)
 142                      (let ((name (symbol-name arg)))
 143                        (and (/= (length name) 0)
 144                             (char= (char name 0) #\&))))
 145             (unless (member arg lambda-list-keywords)
 146               (compiler-note
 147                "~S uses lambda-list keyword naming convention, but is not a recognized lambda-list keyword."
 148                arg)))
 149           (if (member arg lambda-list-keywords)
 150               (ecase arg
 151                 (&optional
 152                  (unless (eq state :required)
 153                    (compiler-error "Misplaced &optional in lambda-list: ~S." list))
 154                  (setq state '&optional))
 155                 (&rest
 156                  (unless (member state '(:required &optional))
 157                    (compiler-error "Misplaced &rest in lambda-list: ~S." list))
 158                  (setq state '&rest))
 159                 (&more
 160                  (unless (member state '(:required &optional))
 161                    (compiler-error "Misplaced &more in lambda-list: ~S." list))
 162                  (setq morep t  state '&more-context))
 163                 (&key
 164                  (unless (member state '(:required &optional :post-rest
 165                                          :post-more))
 166                    (compiler-error "Misplaced &key in lambda-list: ~S." list))
 167                  (setq keyp t)
 168                  (setq state '&key))
 169                 (&allow-other-keys
 170                  (unless (eq state '&key)
 171                    (compiler-error "Misplaced &allow-other-keys in lambda-list: ~S." list))
 172                  (setq allowp t  state '&allow-other-keys))
 173                 (&aux
 174                  (when (member state '(&rest &more-context &more-count))
 175                    (compiler-error "Misplaced &aux in lambda-list: ~S." list))
 176                  (setq state '&aux)))
 177               (case state
 178                 (:required (required arg))
 179                 (&optional (optional arg))
 180                 (&rest
 181                  (setq restp t  rest arg  state :post-rest))
 182                 (&more-context
 183                  (setq more-context arg  state '&more-count))
 184                 (&more-count
 185                  (setq more-count arg  state :post-more))
 186                 (&key (keys arg))
 187                 (&aux (aux arg))
 188                 (t
 189                  (compiler-error "Found garbage in lambda-list when expecting a keyword: ~S." arg)))))
 190
 191         (when (eq state '&rest)
 192           (compiler-error "&rest not followed by required variable."))
 193
 194         (values (required) (optional) restp rest keyp (keys) allowp (aux)
 195                 morep more-context more-count)))))
 196
 197 (defun parse-body (body environment &optional (doc-string-allowed t))
 198   "This function is to parse the declarations and doc-string out of the body of
 199   a defun-like form.  Body is the list of stuff which is to be parsed.
 200   Environment is ignored.  If Doc-String-Allowed is true, then a doc string
 201   will be parsed out of the body and returned.  If it is false then a string
 202   will terminate the search for declarations.  Three values are returned: the
 203   tail of Body after the declarations and doc strings, a list of declare forms,
 204   and the doc-string, or NIL if none."
 205   (declare (ignore environment))
 206   (let ((decls ())
 207         (doc nil))
 208     (do ((tail body (cdr tail)))
 209         ((endp tail)
 210          (values tail (nreverse decls) doc))
 211       (let ((form (car tail)))
 212         (cond ((and (stringp form) (cdr tail))
 213                (if doc-string-allowed
 214                    (setq doc form
 215                          ;; Only one doc string is allowed.
 216                          doc-string-allowed nil)
 217                    (return (values tail (nreverse decls) doc))))
 218               ((not (and (consp form) (symbolp (car form))))
 219                (return (values tail (nreverse decls) doc)))
 220               ((eq (car form) 'declare)
 221                (push form decls))
 222               (t
 223                (return (values tail (nreverse decls) doc))))))))
 224 )
 225
 226 (defun defmfun-keywords (fname options valid-keywords)
 227   ;; options looks like (((mequal) $opt1 val1) ((mequal) $opt2 val2) ...)
 228   ;;
 229   ;; Convert to a new list that looks like (:opt1 val1 :opt2 val2 ...)
 230   ;;
 231   (unless (listp options)
 232     (merror "Invalid Maxima keyword options: ~M" options))
 233   (when (every #'(lambda (o)
 234                    ;; Make sure every option has the right form.
 235                    (let ((ok (and (listp o)
 236                                   (= (length o) 3)
 237                                   (eq (caar o) 'mequal))))
 238                      (unless ok
 239                        (merror (intl:gettext "~M: Badly formed keyword option: ~M")
 240                                fname o))
 241                      ok))
 242                options)
 243     (mapcan #'(lambda (o)
 244                 (destructuring-bind (mequal opt val)
 245                     o
 246                   (declare (ignore mequal))
 247                   (if (or (null valid-keywords)
 248                           (member opt valid-keywords))
 249                       (flet ((keywordify (x)
 250                                (intern (subseq (symbol-name x) 1) :keyword)))
 251                         (list (keywordify opt) val))
 252                       (merror (intl:gettext "~M: Unrecognized keyword: ~M")
 253                               fname opt))))
 254             options)))
 255
 256 ;; Internal macro to do the heavy lifting of defining a function that
 257 ;; checks the number of arguments of a function.  This is intended to
 258 ;; give nice error messages to user-callable functions when the number
 259 ;; of arguments is incorrect.
 260 ;;
 261 ;; The function to check arguments is named NAME.  The actual
 262 ;; implementation is in a new function named IMPL, which is called by
 263 ;; NAME.  A compiler-macro is also defined so that Lisp calls of NAME
 264 ;; get automatically converted to IMPL.
 265 ;;
 266 ;; If the keyword :DEPRECATED-P is also specified, then the function
 267 ;; is deprecated which causes a warning to be printed once when the
 268 ;; function NAME is called the first time.  The value of :DEPRECATED-P
 269 ;; is a symbol naming the function that should be used instead.
 270 ;;
 271 ;; For example:
 272 ;;
 273 ;;   (defun-checked-form ($foo foo-impl :deprecated-p $bar) ...)
 274 ;;
 275 ;;
 276 ;; The lambda-list supports &optional and &rest args.  Keyword args
 277 ;; (&key) are also supported.  Maxima keyword args (a=b) are converted
 278 ;; to Lisp keywords appropriately.  Unrecognized keywords signal a
 279 ;; Maxima error.
 280 ;;
 281 ;; The variable %%PRETTY-FNAME is defined such that the body can refer
 282 ;; to this variable to get the pretty name of the defined function for
 283 ;; use in printing error messages or what not.  This allows the
 284 ;; implementation to print out the function name that would also be
 285 ;; used when printing out error messages for incorrect number of
 286 ;; arguments.
 287
 288 (defmacro defun-checked-form ((name impl-name &key deprecated-p) lambda-list &body body)
 289   ;; Carefully check the number of arguments and print a nice message
 290   ;; if the number doesn't match the expected number.
 291   (multiple-value-bind (required-args
 292                         optional-args
 293                         restp
 294                         rest-arg
 295                         keywords-present-p
 296                         keyword-args
 297                         allow-other-keys-p)
 298       (parse-lambda-list lambda-list)
 299
 300     (when (and keywords-present-p
 301                (or optional-args restp))
 302       (error "Keyword args cannot be used with optional args or rest args"))
 303
 304     (let* ((required-len (length required-args))
 305            (optional-len (length optional-args))
 306            (impl-doc (format nil "Implementation for ~S" name))
 307            (nargs (gensym "NARGS-"))
 308            (args (gensym "REST-ARG-"))
 309            (rest-name (gensym "REST-ARGS"))
 310            (pretty-fname
 311              (cond (optional-args
 312                     ;; Can't do much with optional args, so just use the function name.
 313                     name)
 314                    (restp
 315                     ;; Use maxima syntax for rest args: foo(a,b,[c]);
 316                     `((,name) ,@required-args ((mlist) ,rest-arg)))
 317                    (keywords-present-p
 318                     ;; Not exactly sure how to do this
 319                     (let* ((index 1)
 320                            (keys (mapcar
 321                                   #'(lambda (k)
 322                                       (multiple-value-bind (name val)
 323                                           (if (consp k)
 324                                               (values
 325                                                (intern (format nil "$~A" (car k)))
 326                                                (second k))
 327                                               (values
 328                                                (intern (format nil "$~A" k))
 329                                                nil))
 330                                         (incf index)
 331                                         `((mequal) ,name ,val)))
 332                                   keyword-args)))
 333                       `((,name) ,@required-args ,@keys)))
 334                    (t
 335                     ;; Just have required args: foo(a,b)
 336                     `((,name) ,@required-args))))
 337            (maxima-keywords
 338              (unless allow-other-keys-p
 339                (mapcar #'(lambda (x)
 340                            (intern (concatenate
 341                                     'string "$"
 342                                     (symbol-name
 343                                      (if (consp x)
 344                                          (car x)
 345                                          x)))))
 346                        keyword-args)))
 347            (warning-done-var (gensym "WARNING-DONE-")))
 348
 349       (multiple-value-bind (forms decls doc-string)
 350           (parse-body body nil t)
 351         (setf doc-string (if doc-string (list doc-string)))
 352         `(progn
 353            (defun ,impl-name ,lambda-list
 354              ,impl-doc
 355              ,@decls
 356              (block ,name
 357                (let ((%%pretty-fname ',pretty-fname))
 358                  (declare (ignorable %%pretty-fname))
 359                  ,@forms)))
 360
 361            (let ,(when deprecated-p `((,warning-done-var nil)))
 362              (defun ,name (&rest ,args)
 363                ,@doc-string
 364                ,@(when deprecated-p
 365                    `((unless ,warning-done-var
 366                        (setf ,warning-done-var t)
 367                        (mwarning (aformat nil (intl:gettext "~M is deprecated; use ~M.")
 368                                           ',name ',deprecated-p)))))
 369                (let ((,nargs (length ,args)))
 370                  (declare (ignorable ,nargs))
 371                  ,@(cond
 372                      ((or restp keywords-present-p)
 373                       ;; When a rest arg is given, there's no upper
 374                       ;; limit to the number of args.  Just check that
 375                       ;; we have enough args to satisfy the required
 376                       ;; args.
 377                       (unless (null required-args)
 378                         `((when (< ,nargs ,required-len)
 379                             (merror (intl:gettext "~M: expected at least ~M arguments but got ~M: ~M")
 380                                     ',pretty-fname
 381                                     ,required-len
 382                                     ,nargs
 383                                     (list* '(mlist) ,args))))))
 384                      (optional-args
 385                       ;; There are optional args (but no rest
 386                       ;; arg). Verify that we don't have too many args,
 387                       ;; and that we still have all the required args.
 388                       `(
 389                         (when (> ,nargs ,(+ required-len optional-len))
 390                           (merror (intl:gettext "~M: expected at most ~M arguments but got ~M: ~M")
 391                                   ',pretty-fname
 392                                   ,(+ required-len optional-len)
 393                                   ,nargs
 394                                   (list* '(mlist) ,args)))
 395                         (when (< ,nargs ,required-len)
 396                           (merror (intl:gettext "~M: expected at least ~M arguments but got ~M: ~M")
 397                                   ',pretty-fname
 398                                   ,required-len
 399                                   ,nargs
 400                                   (list* '(mlist) ,args)))))
 401                      (t
 402                       ;; We only have required args.
 403                       `((unless (= ,nargs ,required-len)
 404                           (merror (intl:gettext "~M: expected exactly ~M arguments but got ~M: ~M")
 405                                   ',pretty-fname
 406                                   ,required-len
 407                                   ,nargs
 408                                   (list* '(mlist) ,args))))))
 409                  ,(cond
 410                     (keywords-present-p
 411                      `(apply #',impl-name
 412                              (append
 413                               (subseq ,args 0 ,required-len)
 414                               (defmfun-keywords ',pretty-fname
 415                                   (nthcdr ,required-len ,args)
 416                                 ',maxima-keywords))))
 417                     (t
 418                      `(apply #',impl-name ,args))))))
 419            ,(cond
 420               (keywords-present-p
 421                `(define-compiler-macro ,name (&rest ,rest-name)
 422                   ,(format nil "Compiler-macro to convert calls to ~S to ~S" name impl-name)
 423                   (let ((args (append (subseq ,rest-name 0 ,required-len)
 424                                       (defmfun-keywords ',pretty-fname
 425                                           (nthcdr ,required-len ,rest-name)
 426                                         ',maxima-keywords))))
 427                     `(,',impl-name ,@args))))
 428               (t
 429                `(define-compiler-macro ,name (&rest ,rest-name)
 430                   ,(format nil "Compiler-macro to convert calls to ~S to ~S" name impl-name)
 431                   `(,',impl-name ,@,rest-name)))))))))
 432
 433 ;; Define a Lisp function that should check the number of arguments to
 434 ;; a function and print out a nice Maxima error message instead of
 435 ;; signaling a Lisp error.  In this case, the function is not
 436 ;; explicitly exposed to the user and can just have an impl name of
 437 ;; "name-impl".
 438 (defmacro defun-checked (name lambda-list &body body)
 439   ;; Defun-checked must not be used with functions that are exposed to
 440   ;; the (Maxima) user.  That is, it can't start with "$".
 441   (when (char-equal #\$ (char (string name) 0))
 442     (error "DEFUN-CHECKED functions cannot start with $: ~S~%" name))
 443   `(defun-checked-form (,name ,(intern (concatenate 'string
 444                                                     (string name)
 445                                                     "-IMPL")))
 446                        ,lambda-list ,@body))
 447
 448 ;; Define user-exposed functions that are written in Lisp.
 449 ;;
 450 ;; If the function name NAME starts with #\$ we check the number of
 451 ;; arguments.  In this case, two functions are created: NAME and
 452 ;; NAME-IMPL (without the leading $).  NAME is the user function that
 453 ;; checks for the argument count and NAME-IMPL is the actual
 454 ;; implementation..
 455 ;;
 456 ;; If the function name doesn't start with $, we still allow it, but
 457 ;; these should be replaced with plain defun eventually.
 458 ;;
 459 (defmacro defmfun (name-maybe-prop lambda-list &body body)
 460   ;; NAME-MAYBE-PROP can be either a symbol or a list.  If a symbol,
 461   ;; it's just the name of the function to be defined.  If a list, it
 462   ;; must have the form (name &keyword :properties :deprecated-p)
 463   ;; where NAME is the name of the function to be defined.  The
 464   ;; keyword args control what is generated.  The value of :PROPERTIES
 465   ;; is a list of lists denoting properties that are set for this
 466   ;; function.  Each element of the list must be of the form (PROPERTY
 467   ;; VALUE).  The value of :DEPRECATED-P is a symbol (unquoted) naming
 468   ;; the function that should be used instead of this function because
 469   ;; this function is deprecated.
 470   ;;
 471   ;;   (defmfun ($polarform :properties ((evfun t))) (xx) ...)
 472   ;;
 473   ;; is the same as (defmfun $polarform (xx) ...) but adds
 474   ;; (putprop '$polarform t 'evfun)
 475   ;;
 476   ;; For deprecated functions:
 477   ;;
 478   ;;   (defmfun ($foo :deprecated-p $bar) () ...)
 479   ;;
 480   ;; This will print a message stating that "foo" is deprecated and to
 481   ;; use "bar" instead.
 482   (destructuring-bind (name &key properties deprecated-p)
 483       (if (symbolp name-maybe-prop)
 484           (list name-maybe-prop)
 485           name-maybe-prop)
 486     (flet ((add-props ()
 487              ;; We make sure that the ARG-LIST property is added
 488              ;; first, so that it will end up last in the list.
 489              `((putprop ',name ',lambda-list 'arg-list)
 490                (defprop ,name t translated)))
 491            (func-props ()
 492              ;; If any properties were specified for the function,
 493              ;; gather them up here into corresponding putprop forms.
 494              (mapcar #'(lambda (p)
 495                          (destructuring-bind (ind val)
 496                              p
 497                            `(putprop ',name ',val ',ind)))
 498                      properties)))
 499
 500       (let ((impl-name (intern (concatenate 'string
 501                                             (subseq (string name) 1)
 502                                             "-IMPL")))
 503             (maclisp-narg-p (and (symbolp lambda-list) (not (null lambda-list)))))
 504         (cond
 505           ((or (char/= #\$ (aref (string name) 0))
 506                maclisp-narg-p)
 507            ;; If NAME doesn't start with $, it's an internal function not
 508            ;; directly exposed to the user.  Basically define the function
 509            ;; as is, taking care to support the Maclisp narg syntax.
 510            (cond (maclisp-narg-p
 511                   ;; Support MacLisp narg syntax:  (defun foo a ...)
 512                   `(progn
 513                      (defun ,name (&rest narg-rest-argument
 514                                    &aux (,lambda-list (length narg-rest-argument)))
 515                        ,@body)
 516                      ,@(add-props)))
 517                  (t
 518                   `(progn
 519                      (defun ,name ,lambda-list ,@body)
 520                      ,@(add-props)))))
 521           (t
 522            ;; Function name begins with $, so it's exposed to the user;
 523            ;; carefully check the number of arguments and print a nice
 524            ;; message if the number doesn't match the expected number.
 525            #+nil
 526            (unless (char= #\$ (aref (string name) 0))
 527              (warn "First character of function name must start with $: ~S~%" name))
 528            `(progn
 529               (defun-checked-form (,name ,impl-name :deprecated-p ,deprecated-p) ,lambda-list
 530                 ,@body)
 531               ,@(add-props)
 532               ,@(func-props)
 533               ;; We don't put this putprop in add-props because
 534               ;; add-props is for both user and internal functions
 535               ;; while the impl-name property is only for user
 536               ;; functions.
 537               (putprop ',name ',impl-name 'impl-name))))))))
 538
 539 ;; Examples:
 540 ;; (defmfun $foobar (a b) (list '(mlist) a b))
 541 ;; (defmfun $foobar1 (a b &optional c) (list '(mlist) a b c))
 542 ;; (defmfun $foobar1a (a b &optional (c 99)) (list '(mlist) a b c))
 543 ;; (defmfun $foobar2 (a b &rest c) (list '(mlist) a b (list* '(mlist) c)))
 544 ;; (defmfun $foobar3 (a b &optional c &rest d) "foobar3 function" (list '(mlist) a b c (list* '(mlist) d)))
 545 ;;
 546 ;; (defmfun $foobar4 (a b &key c) (list '(mlist) a b c))
 547 ;; (defmfun $foobar5 (a b &key (c 42)) (list '(mlist) a b c))
 548 ;; (defmfun $foobar6 (a b &key (c 42) &allow-other-keys) (list '(mlist) a b c))
 549 ;;
 550 ;; foobar5(1,2) => [1, 2, 42]
 551 ;; foobar5(1,2,c=99) => [1, 2, 99]
 552 ;; foobar5(1,2,c=99,d=4) => error: unrecognized keyword d
 553 ;; foobar6(1,2,c=42,d=99) => [1, 2, 42]
 554 ;;
 555 ;; This works by accident, kind of:
 556 ;; (defmfun $baz (a &aux (b (1+ a))) (list '(mlist) a b))
 557
 558 ;; This should produce compile errors
 559 ;; (defmfun $zot (a &optional c &key b) (list '(mlist) a b))
 560
 561 \f
 562 ;; Defines a simplifying function for Maxima whose name is BASE-NAME.
 563 ;; The noun and verb properties are set up appropriately, along with
 564 ;; setting the operator property.  The noun form is created from the
 565 ;; BASE-NAME by prepending a "%"; the verb form, by prepending "$".
 566 ;; The verb function is defined appropriately too.
 567 ;;
 568 ;; For example, let's say we want to define a Maxima function named
 569 ;; foo of two args with a corresponding simplifier to simplify special
 570 ;; cases or numerically evaluate it.  Then:
 571 ;;
 572 ;; (def-simplifier foo (x y)
 573 ;;   (cond ((float-numerical-eval-p x y)
 574 ;;          (foo-eval x y))
 575 ;;         (t
 576 ;;          (give-up))))
 577 ;;
 578 ;; This expands to
 579 ;;
 580 ;; (progn
 581 ;;   (defprop %foo simp-%foo operators)
 582 ;;   (defprop $foo %foo verb)
 583 ;;   (defprop %foo $foo noun)
 584 ;;   (defprop $foo %foo alias)
 585 ;;   (defprop %foo $foo reversealias)
 586 ;;   (defun simp-%foo (form #:unused-5230 %%simpflag)
 587 ;;     (declare (ignore #:unused-5230))
 588 ;;     (let ((x (simpcheck (nth 1 form) #:z-5229))
 589 ;;           (y (simpcheck (nth 2 form) #:z-5229)))
 590 ;;       (arg-count-check 2 form)
 591 ;;       (macrolet ((give-up ()
 592 ;;                    '(eqtest (list '(%foo) x y) form)))
 593 ;;         (cond
 594 ;;           ((float-numerical-eval-p x y)
 595 ;;            (foo-eval x y))
 596 ;;           (t
 597 ;;            (give-up))))))
 598 ;;
 599 ;; The body can reference FORM and %%SIMPFLAG.
 600 ;;
 601 ;; The base name can also be a lambda-list of the form (name &key
 602 ;; (simpcheck :default)).  The NAME is the BASE-NAME of the
 603 ;; simpiflier.  The keyword arg :SIMPCHECK supports two values:
 604 ;; :DEFAULT and :CUSTOM, with :DEFAULT as the default.  :CUSTOM means
 605 ;; the generated code does not call SIMPCHECK on the args, as shown
 606 ;; above.  It is up to the body to do the necessary work.
 607 ;;
 608 ;; Note also that the args for the simplifier only supports a fixed
 609 ;; set of required arguments.  Not optional or rest arguments are
 610 ;; supported.  No checks are made for this.  If you need this, you'll
 611 ;; have to write your own simplifier.  Use the above macro expansion
 612 ;; to see how to define the appropriate properties for the simplifer.
 613 ;;
 614 ;; Note carefully that the expansion defines a macro GIVE-UP to
 615 ;; handle the default case of the simplifier when we can't do any
 616 ;; simplification.  Call this in the default case for the COND.
 617
 618 (defmacro def-simplifier (base-name-and-options lambda-list &body body)
 619   (destructuring-bind (base-name &key (simpcheck :default))
 620       (if (symbolp base-name-and-options)
 621           (list base-name-and-options)
 622           base-name-and-options)
 623     (let* ((noun-name (intern (concatenate 'string "%" (string base-name))))
 624            (verb-name (intern (concatenate 'string "$" (string base-name))))
 625            (simp-name (intern (concatenate 'string "SIMP-" (string noun-name))))
 626            (form-arg (intern "FORM"))
 627            (z-arg (intern "%%SIMPFLAG"))
 628            (unused-arg (gensym "UNUSED-"))
 629            (arg-forms (ecase simpcheck
 630                         (:custom
 631                          (loop for arg in lambda-list
 632                                and count from 1
 633                                collect (list arg `(nth ,count ,form-arg))))
 634                         (:default
 635                          (loop for arg in lambda-list
 636                                and count from 1
 637                                collect (list arg `(simpcheck (nth ,count ,form-arg) ,z-arg)))))))
 638       `(progn
 639          ;; Define the noun function.
 640          (defmfun ,verb-name (,@lambda-list)
 641            (ftake ',noun-name ,@lambda-list))
 642
 643          ;; Set up properties
 644          (defprop ,noun-name ,simp-name operators)
 645          ;; The verb and alias properties are needed to make things like
 646          ;; quad_qags(jacobi_sn(x,.5)...) work.
 647          (defprop ,verb-name ,noun-name verb)
 648          (defprop ,verb-name ,noun-name alias)
 649          ;; The reversealias property is needed by grind to print out
 650          ;; the right thing.  Without it, grind(jacobi_sn(x,m)) prints
 651          ;; '?%jacobi_sn(x,m)".  Also needed for labels in plots which
 652          ;; would show up as %jacobi_sn instead of jacobi_sn.
 653          (defprop ,noun-name ,verb-name reversealias)
 654
 655          ;; Define the simplifier
 656          (defun ,simp-name (,form-arg ,unused-arg ,z-arg)
 657            (declare (ignore ,unused-arg)
 658                     (ignorable ,z-arg))
 659            (arg-count-check ,(length lambda-list)
 660                             ,form-arg)
 661            (let ,arg-forms
 662              ;; Allow args to give-up if the default args won't work.
 663              ;; Useful for the (rare?) case like genfact where we want
 664              ;; to give up but want different values for args.
 665              (flet ((give-up (&optional ,@(mapcar #'(lambda (a)
 666                                                       (list a a))
 667                                                   lambda-list))
 668                       ;; Should this also return from the function?
 669                       ;; That would fit in better with giving up.
 670                       (eqtest (list '(,noun-name) ,@lambda-list) ,form-arg)))
 671                ,@body)))))))