1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; The data in this file contains enhancments. ;;;;; 4;;; ;;;;; 5;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;; 6;;; All rights reserved ;;;;; 7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 9(in-package :maxima) 10 11;;this will make operators which declare the type and result of numerical operations 12(eval-when (:compile-toplevel :load-toplevel :execute) 13 14 (defmacro def-op (name arg-type op &optional return-type) 15 `(setf (macro-function ',name) 16 (make-operation ',arg-type ',op ',return-type))) 17 18 ;;make very sure .type .op and .return are not special!! 19 (defun make-operation (.type .op .return) 20 (or .return (setf .return .type)) 21 #'(lambda (bod env) 22 (declare (ignore env)) 23 (loop for v in (cdr bod) 24 when (eq t .type) collect v into body 25 else 26 collect `(the , .type ,v) into body 27 finally (setq body `(, .op ,@body)) 28 (return 29 (if (eq t .return) 30 body 31 `(the , .return ,body)))))) 32 33 ;; these allow running of code and they print out where the error occurred 34 #+fix-debug 35 (progn 36 (defvar *dbreak* t) 37 38 (defun chk-type (lis na typ sho) 39 (unless (every #'(lambda (v) (typep v typ)) lis) 40 (format t "~%Bad call ~a types:~a" (cons na sho) (mapcar #'type-of lis)) 41 (when *dbreak* 42 (break "hi")))) 43 44 (defmacro def-op (name arg-type old) 45 `(defmacro ,name (&rest l) 46 `(progn 47 (chk-type (list ,@l) ',',name ',',arg-type ',l) 48 (,',old ,@l))))) 49 50 (def-op f+ fixnum +) 51 (def-op f* fixnum *) 52 (def-op f- fixnum -) 53 (def-op f1- fixnum 1-) 54 (def-op f1+ fixnum 1+) 55 (def-op quotient t quot)) 56 57;;this is essentially what the quotient is supposed to do. 58 59(declaim (inline quot)) 60(defun quot (a b) 61 (if (and (integerp a) (integerp b)) 62 (truncate a b) 63 (/ a b))) 64 65(defmacro status (option &optional item) 66 (cond ((equal (symbol-name option) (symbol-name '#:feature)) 67 `(member ,(intern (string item) (find-package 'keyword)) *features*)) 68 ((equal option 'gctime) 0))) 69 70#+(or scl allegro) 71(defun string<$ (str1 str2) 72 "Compare string, but flip the case for maxima variable names to maintain 73 the same order irrespective of the lisp case mode." 74 (declare (string str1 str2)) 75 (cond (#+scl (eq ext:*case-mode* :lower) 76 #+allegro (eq excl:*current-case-mode* :case-sensitive-lower) 77 (let ((str1l (length str1)) 78 (str2l (length str2))) 79 (cond ((and (> str1l 1) (char= (aref str1 0) #\$) 80 (> str2l 1) (char= (aref str2 0) #\$)) 81 (flet ((case-flip (str) 82 (let ((some-upper nil) 83 (some-lower nil)) 84 (dotimes (i (length str)) 85 (let ((ch (schar str i))) 86 (when (lower-case-p ch) 87 (setf some-lower t)) 88 (when (upper-case-p ch) 89 (setf some-upper t)))) 90 (cond ((and some-upper some-lower) 91 nil) 92 (some-upper 93 :downcase) 94 (some-lower 95 :upcase))))) 96 (let ((flip1 (case-flip str1)) 97 (flip2 (case-flip str2))) 98 (do ((index 1 (1+ index))) 99 ((or (>= index str1l) (>= index str2l)) 100 (if (= index str1l) index nil)) 101 (let ((ch1 (aref str1 index)) 102 (ch2 (aref str2 index))) 103 (cond ((and (eq flip1 :downcase) (both-case-p ch1)) 104 (setf ch1 (char-downcase ch1))) 105 ((and (eq flip1 :upcase) (both-case-p ch1)) 106 (setf ch1 (char-upcase ch1)))) 107 (cond ((and (eq flip2 :downcase) (both-case-p ch2)) 108 (setf ch2 (char-downcase ch2))) 109 ((and (eq flip2 :upcase) (both-case-p ch2)) 110 (setf ch2 (char-upcase ch2)))) 111 (unless (char= ch1 ch2) 112 (return (if (char< ch1 ch2) 113 index 114 nil)))))))) 115 (t 116 (string< str1 str2))))) 117 (t 118 (string< str1 str2)))) 119;;; 120#-(or scl allegro) 121(defun string<$ (str1 str2) 122 (string< str1 str2)) 123 124;;numbers<strings<symbols<lists<? 125(defun alphalessp (x y) 126 (cond ((numberp x) 127 (if (numberp y) (< x y) t)) 128 ((stringp x) 129 (cond ((numberp y) nil) 130 ((stringp y) 131 (string< x y)) 132 (t t))) 133 ((symbolp x) 134 (cond ((or (numberp y) (stringp y)) nil) 135 ((symbolp y) 136 (let ((nx (print-invert-case x)) 137 (ny (print-invert-case y))) 138 (declare (string nx ny)) 139 (cond ((string<$ nx ny) 140 t) 141 ((string= nx ny) 142 (cond ((eq nx ny) nil) 143 ((null (symbol-package x)) nil) 144 ((null (symbol-package y)) nil) 145 (t (string< 146 (package-name (symbol-package x)) 147 (package-name (symbol-package y)))))) 148 (t nil)))) 149 ((consp y) t))) 150 ((listp x) 151 (cond ((or (numberp y) (stringp y)(symbolp y )) nil) 152 ((listp y) 153 (or (alphalessp (car x) (car y)) 154 (and (equal (car x) (car y)) 155 (alphalessp (cdr x) (cdr y))))) 156 (t nil))) 157 ((or (numberp y) (stringp y) (symbolp y)(consp y)) 158 nil) 159 (t ;neither is of known type: 160 (alphalessp (format nil "~s" x)(format nil "~s" y))))) 161 162(defmacro symbol-array (sym) 163 `(get ,sym 'array)) 164 165(defun arraydims (ar) 166 (when (symbolp ar) 167 (setq ar (symbol-array ar))) 168 (cons (array-element-type ar) (array-dimensions ar))) 169 170(declaim (inline fixnump bignump posint negint memq firstn)) 171(defun fixnump (n) 172 (declare (optimize (speed 3))) 173 (typep n 'fixnum)) 174 175(defun bignump (x) 176 (declare (optimize (speed 3))) 177 (typep x 'bignum)) 178 179(defun posint (x) 180 (declare (optimize (speed 3))) 181 (and (integerp x) (> x 0))) 182 183(defun negint (x) 184 (declare (optimize (speed 3))) 185 (and (integerp x) (< x 0))) 186 187;; if x is in the list, return the sublist with element, else nil. 188;; 189;; At least at the time memq was designed it was (at least in many cases) faster 190;; than the lisp's built-in function "member", see: 191;; https://people.eecs.berkeley.edu/~fateman/papers/lispoptim.pdf 192(defun memq (x lis) 193 (declare (optimize (speed 3))) 194 (member x lis :test #'eq)) 195 196(defun firstn (n lis) 197 (declare (type (integer 0 (#.most-positive-fixnum)) n) 198 (optimize (speed 3))) 199 (subseq lis 0 n)) 200 201;;actually this was for lists too. 202 203(defun putprop (sym val indic) 204 (if (consp sym) 205 (setf (getf (cdr sym) indic) val) 206 (setf (get sym indic) val))) 207 208(defmacro defprop (sym val indic) 209 (if (eq indic 'expr) 210 `(setf (symbol-function ',sym) #',val) 211 `(setf (get ',sym ',indic) ',val))) 212 213;; Find the N most significant or least significant bits of the 214;; absolute value of X. If N is positive, take the most significant; 215;; otherwise, the least significant. 216(defun haipart (x n) 217 (let ((x (abs x))) 218 (if (< n 0) 219 ;; If the desired number of bits is larger than the actual 220 ;; number, just return the number. (Prevents gratuitously 221 ;; generating a huge bignum if n is very large, as can happen 222 ;; with bigfloats.) 223 (if (< (integer-length x) (- n)) 224 x 225 (logand x (1- (ash 1 (- n))))) 226 (ash x (min (- n (integer-length x)) 0))))) 227 228;; also correct but slower. 229;;(defun haipart (integer count) 230;; (let ((x (abs integer))) 231;; (if (minusp count) 232;; (ldb (byte (- count) 0) x) 233;; (ldb (byte count (max 0 (- (integer-length x) count))) x)))) 234 235;;used in translation 236(defun fset (sym val) 237 (setf (symbol-function sym) val)) 238 239(defun zl-get (sym tag) 240 (cond ((symbolp sym) (get sym tag)) 241 ((consp sym) (getf (cdr sym) tag)))) 242 243(defun getl (plist indicator-list ) 244 (cond ((symbolp plist) 245 (setq plist (symbol-plist plist))) 246 ((consp plist) (setq plist (cdr plist))) 247 (t (return-from getl nil))) 248 (loop for tail on plist by #'cddr 249 when (member (car tail) indicator-list :test #'eq) 250 do (return tail))) 251 252(declaim (inline safe-get safe-getl)) 253(defun safe-get (sym prop) 254 (and (symbolp sym) (get sym prop))) 255 256(defun safe-getl (sym prop) 257 (and (symbolp sym) (getl sym prop))) 258 259(defmacro ncons (x) 260 `(cons ,x nil)) ;;can one optimize this?? 261 262(defvar *acursor* (make-array 11 :element-type 'fixnum :initial-element 0)) 263 264;; Format of *acursor*. 265;; 0 1 2 3 4 5 6 7 8 9 10 266;; dim i1 i2 i3 i4 i5 d1 d2 d3 d4 d5 267;; array dimension current index maximal index 268 269(defun set-up-cursor (ar) 270 (let ((lis (array-dimensions ar))) 271 (setf (aref *acursor* 0) (length lis)) 272 (loop for v in lis for i from 6 do (setf (aref *acursor* i) (1- v))) 273 (loop for i from 1 to (length lis) do (setf (aref *acursor* i) 0)))) 274 275(defun aset-by-cursor (ar val) 276 (let ((curs *acursor*)) 277 (declare (type (simple-array fixnum (11)) curs)) 278 (ecase (aref curs 0) 279 (1 (setf (aref ar (aref curs 1)) val)) 280 (2 (setf (aref ar (aref curs 1) (aref curs 2)) val)) 281 (3 (setf (aref ar (aref curs 1) (aref curs 2) (aref curs 3)) val)) 282 (4 (setf (aref ar (aref curs 1) (aref curs 2) (aref curs 3) 283 (aref curs 4)) val)) 284 (5 (setf (aref ar (aref curs 1) (aref curs 2) (aref curs 3) 285 (aref curs 4) (aref curs 5)) val))) 286 ;; set the index (`cursor') for the next call to ASET-BY-CURSOR 287 (loop for j downfrom (aref curs 0) 288 do (cond ((< (aref curs j) (aref curs (+ 5 j))) 289 (setf (aref curs j) (+ (aref curs j) 1)) 290 (return-from aset-by-cursor t)) 291 (t (setf (aref curs j) 0))) 292 (cond ((eql j 0) (return-from aset-by-cursor nil)))))) 293 294(defun fillarray (ar x) 295 (when (symbolp ar) 296 (setq ar (get ar 'array))) 297 (when (/= (array-rank ar) 1) 298 (setq ar (make-array (array-total-size ar) :displaced-to ar))) 299 (setq x (cond ((null x) 300 (ecase (array-element-type ar) 301 (fixnum '(0)) 302 (float '(0.0)) 303 ((t) '(nil)))) 304 ((arrayp x)(listarray x)) 305 ((atom x) (list x)) 306 (t x))) 307 (when (> (length ar) 0) 308 (set-up-cursor ar) 309 (loop while (aset-by-cursor ar (car x)) 310 do (and (cdr x) (setq x (cdr x)))))) 311 312(defun listarray (x) 313 (when (symbolp x) 314 (setq x (get x 'array))) 315 (if (eql (array-rank x) 1) 316 (coerce x 'list) 317 (coerce (make-array (apply '* (array-dimensions x)) :displaced-to x 318 :element-type (array-element-type x)) 319 'list))) 320 321(defmacro check-arg (place pred &rest res) 322 (when (atom pred) 323 (setq pred (list pred place))) 324 `(assert ,pred (,place) ,@res)) 325 326(defmacro deff (fun val) 327 `(setf (symbol-function ',fun) ,val)) 328 329(defmacro xcons (x y) 330 (cond ((atom x) `(cons ,y,x)) 331 (t (let ((g (gensym))) 332 `(let ((,g ,x)) 333 (cons ,y ,g)))))) 334 335(defun make-equal-hash-table (not-dim1) 336 (let ((table (make-hash-table :test 'equal))) 337 (or not-dim1 (setf (gethash 'dim1 table) t)) 338 table)) 339 340;;; Range of atan should be [0,2*pi] 341(defun atan (y x) 342 (let ((tem (cl:atan y x))) 343 (if (>= tem 0) 344 tem 345 (+ tem (* 2 pi))))) 346 347;;; Range of atan2 should be (-pi,pi] 348;;; CL manual says that's what lisp::atan is supposed to have. 349(deff atan2 #'cl:atan) 350 351;;; exp is shadowed to save trouble for other packages--its declared special 352(deff exp #'cl:exp) 353 354#+clisp 355(progn 356 ;; This used to be enabled, but 357 ;; http://clisp.cons.org/impnotes/num-dict.html seems to indicate 358 ;; that the result of float, coerce, sqrt, etc., on a rational will 359 ;; return a float of the specified type. But ANSI CL says we must 360 ;; return a single-float. I (rtoy) am commenting this out for now. 361 362 ;; (setq custom:*default-float-format* 'double-float) 363 364 ;; We currently don't want any warnings about floating-point contagion. 365 (setq custom::*warn-on-floating-point-contagion* nil) 366 367 ;; We definitely want ANSI-style floating-point contagion. 368 (setq custom:*floating-point-contagion-ansi* t) 369 370 ;; Set custom:*floating-point-rational-contagion-ansi* so that 371 ;; contagion is done as per the ANSI CL standard. Has an effect only 372 ;; in those few cases when the mathematical result is exact although 373 ;; one of the arguments is a floating-point number, such as (* 0 374 ;; 1.618), (/ 0 1.618), (atan 0 1.0), (expt 2.0 0) 375 (setq custom:*floating-point-rational-contagion-ansi* t) 376 377 ;; When building maxima using with 'flonum being a 'long-float it may be 378 ;; useful to adjust the number of bits of precision that CLISP uses for 379 ;; long-floats. 380 #+nil 381 (setf (ext:long-float-digits) 128) 382 383 ;; We want underflows not to signal errors. 384 (ext:without-package-lock () 385 (setq sys::*inhibit-floating-point-underflow* t)) 386 ) 387 388#+abcl 389(progn 390 ;; We want underflows not to signal errors 391 (when (fboundp (find-symbol "FLOAT-UNDERFLOW-MODE" "SYS")) 392 (funcall (find-symbol "FLOAT-UNDERFLOW-MODE" "SYS") nil)) 393 ) 394 395;; Make the maximum exponent larger for CMUCL. Without this, cmucl 396;; will generate a continuable error when raising an integer to a 397;; power greater than this. 398#+cmu 399(setf ext::*intexp-maximum-exponent* 100000) 400;;;; Setup the mapping from the Maxima 'flonum float type to a CL float type. 401;;;; 402;;;; Add :flonum-long to *features* if you want flonum to be a 403;;;; long-float. Or add :flonum-double-double if you want flonum to 404;;;; be a double-double (currently only for CMUCL). Otherwise, you 405;;;; get double-float as the flonum type. 406;;;; 407;;;; Default double-float flonum. 408(eval-when (:compile-toplevel :load-toplevel :execute) 409 (setq *read-default-float-format* 'double-float)) 410 411#-(or flonum-long flonum-double-double) 412(progn 413;; Tell Lisp the float type for a 'flonum. 414#-(or clisp abcl) 415(deftype flonum (&optional low high) 416 (cond (high 417 `(double-float ,low ,high)) 418 (low 419 `(double-float ,low)) 420 (t 421 'double-float))) 422 423;; Some versions of clisp and ABCL appear to be buggy: (coerce 1 'flonum) 424;; signals an error. So does (coerce 1 '(double-float 0d0)). But 425;; (coerce 1 'double-float) returns 1d0 as expected. So for now, make 426;; flonum be exactly the same as double-float, without bounds. 427#+(or clisp abcl) 428(deftype flonum (&optional low high) 429 (declare (ignorable low high)) 430 'double-float) 431 432(defconstant most-positive-flonum most-positive-double-float) 433(defconstant most-negative-flonum most-negative-double-float) 434(defconstant least-positive-flonum least-positive-double-float) 435(defconstant least-negative-flonum least-negative-double-float) 436(defconstant flonum-epsilon double-float-epsilon) 437(defconstant least-positive-normalized-flonum least-positive-normalized-double-float) 438 439(defconstant flonum-exponent-marker #\D) 440) 441 442#+flonum-long 443(progn 444;;;; The Maxima 'flonum can be a CL 'long-float on the Scieneer CL or CLISP, 445;;;; but should be the same as 'double-float on other CL implementations. 446 447 (eval-when (:compile-toplevel :load-toplevel :execute) 448 (setq *read-default-float-format* 'long-float)) 449 450;; Tell Lisp the float type for a 'flonum. 451(deftype flonum (&optional low high) 452 (cond (high 453 `(long-float ,low ,high)) 454 (low 455 `(long-float ,low)) 456 (t 457 'long-float))) 458 459(defconstant most-positive-flonum most-positive-long-float) 460(defconstant most-negative-flonum most-negative-long-float) 461(defconstant least-positive-flonum least-positive-long-float) 462(defconstant least-negative-flonum least-negative-long-float) 463(defconstant flonum-epsilon long-float-epsilon) 464(defconstant least-positive-normalized-flonum least-positive-normalized-long-float) 465 466(defconstant flonum-exponent-marker #\L) 467 468) 469 470#+flonum-double-double 471(progn 472 473;;;; The Maxima 'flonum can be a 'kernel:double-double-float on the CMU CL. 474 475 (eval-when (:compile-toplevel :load-toplevel :execute) 476 (setq *read-default-float-format* 'kernel:double-double-float)) 477 478;; Tell Lisp the float type for a 'flonum. 479(deftype flonum (&optional low high) 480 (cond (high 481 `(kernel:double-double-float ,low ,high)) 482 (low 483 `(kernel:double-double-float ,low)) 484 (t 485 'kernel:double-double-float))) 486 487;; While double-double can represent number as up to 488;; most-positive-double-float, it can't really do operations on them 489;; due to the way multiplication and division are implemented. (I 490;; don't think there's any workaround for that.) 491;; 492;; So, the largest number that can be used is the float just less than 493;; 2^1024/(1+2^27). This is the number given here. 494(defconstant most-positive-double-double-hi 495 (scale-float (cl:float (1- 9007199187632128) 1d0) 944)) 496 497(defconstant most-positive-flonum (cl:float most-positive-double-double-hi 1w0)) 498(defconstant most-negative-flonum (cl:float (- most-positive-double-double-hi 1w0))) 499(defconstant least-positive-flonum (cl:float least-positive-double-float 1w0)) 500(defconstant least-negative-flonum (cl:float least-negative-double-float 1w0)) 501;; This is an approximation to a double-double epsilon. Due to the 502;; way double-doubles are represented, epsilon is actually zero 503;; because 1+x = 1 only when x is zero. But double-doubles only have 504;; 106 bits of precision, so we use that as epsilon. 505(defconstant flonum-epsilon (scale-float 1w0 -106)) 506(defconstant least-positive-normalized-flonum (cl:float least-positive-normalized-double-float 1w0)) 507 508(defconstant flonum-exponent-marker #\W) 509 510) 511 512;;;; 513(defmacro float (x &optional (y 1e0)) 514 `(cl:float ,x ,y)) 515 516(defmacro with-collector (collector-sym &body forms) 517 (let ((acc (gensym))) 518 `(let ((,acc)) 519 (flet ((,collector-sym (x) (push x ,acc))) 520 ,@forms 521 (nreverse ,acc))))) 522 523;; DO-MERGE-ASYM moved here from nset.lisp so that it is defined before 524;; it is referenced in compar.lisp. 525(defmacro do-merge-symm (list1 list2 eqfun lessfun bothfun onefun) 526 ;; Like do-merge-asym, but calls onefun if an element appears in one but 527 ;; not the other list, regardless of which list it appears in. 528 `(do-merge-asym ,list1 ,list2 ,eqfun ,lessfun ,bothfun ,onefun ,onefun)) 529 530(defmacro do-merge-asym 531 (list1 list2 eqfun lessfun bothfun only1fun only2fun) 532 ;; Takes two lists. 533 ;; The element equality function is eqfun, and they must be sorted by lessfun. 534 ;; Calls bothfun on each element that is shared by the two lists; 535 ;; calls only1fun on each element that appears only in the first list; 536 ;; calls only2fun on each element that appears only in the second list. 537 ;; If both/only1/only2 fun are nil, treat as no-op. 538 (let ((l1var (gensym)) 539 (l2var (gensym))) 540 `(do ((,l1var ,list1) 541 (,l2var ,list2)) 542 ((cond ((null ,l1var) 543 (if ,only2fun 544 (while ,l2var 545 (funcall ,only2fun (car ,l2var)) 546 (setq ,l2var (cdr ,l2var)))) 547 t) 548 ((null ,l2var) 549 (if ,only1fun 550 (while ,l1var 551 (funcall ,only1fun (car ,l1var)) 552 (setq ,l1var (cdr ,l1var)))) 553 t) 554 ((funcall ,eqfun (car ,l1var) (car ,l2var)) 555 (if ,bothfun (funcall ,bothfun (car ,l1var))) 556 (setq ,l1var (cdr ,l1var) ,l2var (cdr ,l2var)) 557 nil) 558 ((funcall ,lessfun (car ,l1var) (car ,l2var)) 559 (if ,only1fun (funcall ,only1fun (car ,l1var))) 560 (setq ,l1var (cdr ,l1var)) 561 nil) 562 (t 563 (if ,only2fun (funcall ,only2fun (car ,l2var))) 564 (setq ,l2var (cdr ,l2var)) 565 nil)))))) 566 567;;; Test 568; (do-merge-asym '(a a a b c g h k l) 569; '(a b b c c h i j k k) 570; 'eq 571; 'string< 572; '(lambda (x) (prin0 'both x)) 573; '(lambda (x) (prin0 'one1 x)) 574; '(lambda (x) (prin0 'one2 x))) 575; both a 576; one1 a 577; one1 a 578; both b 579; one2 b 580; both c 581; one2 c 582; one1 g 583; both h 584; one2 i 585; one2 j 586; both k 587; one2 k 588; one1 l 589; nil 590 591;; Defines a function named NAME that checks that the number of 592;; arguments is correct. If the number of actual arguments is 593;; incorrect, a maxima error is signaled. 594;; 595;; The required arguments is given by REQUIRED-ARG-LIST. Allowed 596;; (maxima) keyword arguments is given by KEYWORD-ARG-LIST. 597;; 598;; The body of the function can refer to KEYLIST which is the list of 599;; maxima keyword arguments converted to lisp keyword arguments. 600 601(defmacro defun-checked (name ((&rest required-arg-list) 602 &rest keyword-arg-list) 603 &body body) 604 (let ((number-of-required-args (length required-arg-list)) 605 (number-of-keyword-args (length keyword-arg-list)) 606 (arg-list (gensym "ARG-LIST-")) 607 (helper-fun (gensym "REAL-FUN-")) 608 (options (gensym "OPTIONS-ARG-"))) 609 `(defun ,name (&rest ,arg-list) 610 ;; Check that the required number of arguments is given and 611 ;; that we don't supply too many arguments. 612 ;; 613 ;; NOTE: The check when keyword args are given is a little too 614 ;; tight. It's valid to have duplicate keyword args, but we 615 ;; disallow that if the number of arguments exceed the limit. 616 (when (or (> (length ,arg-list) ,(+ number-of-required-args number-of-keyword-args)) 617 (< (length ,arg-list) ,number-of-required-args)) 618 (merror (intl:gettext "~M arguments supplied to ~M: found ~M") 619 (if (< (length ,arg-list) ,number-of-required-args) 620 (intl:gettext "Too few") 621 (if (> (length ,arg-list) ,(+ number-of-required-args 622 number-of-keyword-args)) 623 (intl:gettext "Too many") 624 (intl:gettext "Incorrect number of"))) 625 ',(if keyword-arg-list 626 `((,name) ,@required-arg-list ((mlist simp) ,@keyword-arg-list)) 627 `((,name) ,@required-arg-list)) 628 (cons '(mlist) ,arg-list))) 629 (flet ((,helper-fun (,@required-arg-list 630 ,@(when keyword-arg-list 631 `(&rest ,options))) 632 (let ,(when keyword-arg-list 633 `((keylist (lispify-maxima-keyword-options ,options 634 ',keyword-arg-list)))) 635 ,@body))) 636 (apply #',helper-fun ,arg-list))))) 637