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 227;; Define user-exposed functions that are written in Lisp. 228;; 229;; If the function name NAME starts with #\$ we check the number of 230;; arguments. In this case, two functions are created: NAME and 231;; NAME-IMPL (without the leading $). NAME is the user function that 232;; checks for the argument count and NAME-IMPL is the actual 233;; implementation.. 234;; 235;; If the function name doesn't start with $, we still allow it, but 236;; these should be replaced with plain defun eventually. 237;; 238;; The lambda-list supports &optional and &rest args. Keyword args 239;; are an error. 240(defmacro defmfun (name lambda-list &body body) 241 (let ((maclisp-narg-p (and (symbolp lambda-list) (not (null lambda-list))))) 242 (cond 243 ((or (char/= #\$ (aref (string name) 0)) 244 maclisp-narg-p) 245 ;; If NAME doesn't start with $, it's an internal function not 246 ;; directly exposed to the user. Basically define the function 247 ;; as is, taking care to support the Maclisp narg syntax. 248 (cond (maclisp-narg-p 249 ;; Support MacLisp narg syntax: (defun foo a ...) 250 `(progn 251 (defprop ,name t translated) 252 (defun ,name (&rest narg-rest-argument 253 &aux (,lambda-list (length narg-rest-argument))) 254 ,@body))) 255 (t 256 `(progn 257 (defprop ,name t translated) 258 (defun ,name ,lambda-list ,@body))))) 259 (t 260 ;; Function name begins with $, so it's exposed to the user; 261 ;; carefully check the number of arguments and print a nice 262 ;; message if the number doesn't match the expected number. 263 #+nil 264 (unless (char= #\$ (aref (string name) 0)) 265 (warn "First character of function name must start with $: ~S~%" name)) 266 (multiple-value-bind (required-args 267 optional-args 268 restp 269 rest-arg 270 keywords-present-p) 271 (parse-lambda-list lambda-list) 272 273 (when keywords-present-p 274 (error "Keyword arguments are not supported")) 275 276 (let* ((required-len (length required-args)) 277 (optional-len (length optional-args)) 278 (impl-name (intern (concatenate 'string 279 (string name) 280 "-IMPL"))) 281 (impl-doc (format nil "Implementation for ~S" name)) 282 (nargs (gensym "NARGS-")) 283 (args (gensym "REST-ARG-")) 284 (rest-name (gensym "REST-ARGS")) 285 (pretty-fname 286 (cond (optional-args 287 ;; Can't do much with optional args, so just use the function name. 288 name) 289 (restp 290 ;; Use maxima syntax for rest args: foo(a,b,[c]); 291 `((,name) ,@required-args ((mlist) ,rest-arg))) 292 (t 293 ;; Just have required args: foo(a,b) 294 `((,name) ,@required-args))))) 295 296 (multiple-value-bind (forms decls doc-string) 297 (parse-body body nil t) 298 (setf doc-string (if doc-string (list doc-string))) 299 `(progn 300 (defun ,impl-name ,lambda-list 301 ,impl-doc 302 ,@decls 303 (block ,name 304 ,@forms)) 305 (defprop ,name t translated) 306 (defun ,name (&rest ,args) 307 ,@doc-string 308 (let ((,nargs (length ,args))) 309 (declare (ignorable ,nargs)) 310 ,@(cond 311 (restp 312 ;; When a rest arg is given, there's no upper 313 ;; limit to the number of args. Just check that 314 ;; we have enough args to satisfy the required 315 ;; args. 316 (unless (null required-args) 317 `((when (< ,nargs ,required-len) 318 (merror (intl:gettext "~M: expected at least ~M arguments but got ~M: ~M") 319 ',pretty-fname 320 ,required-len 321 ,nargs 322 (list* '(mlist) ,args)))))) 323 (optional-args 324 ;; There are optional args (but no rest 325 ;; arg). Verify that we don't have too many args, 326 ;; and that we still have all the required args. 327 `( 328 (when (> ,nargs ,(+ required-len optional-len)) 329 (merror (intl:gettext "~M: expected at most ~M arguments but got ~M: ~M") 330 ',pretty-fname 331 ,(+ required-len optional-len) 332 ,nargs 333 (list* '(mlist) ,args))) 334 (when (< ,nargs ,required-len) 335 (merror (intl:gettext "~M: expected at least ~M arguments but got ~M: ~M") 336 ',pretty-fname 337 ,required-len 338 ,nargs 339 (list* '(mlist) ,args))))) 340 (t 341 ;; We only have required args. 342 `((unless (= ,nargs ,required-len) 343 (merror (intl:gettext "~M: expected exactly ~M arguments but got ~M: ~M") 344 ',pretty-fname 345 ,required-len 346 ,nargs 347 (list* '(mlist) ,args)))))) 348 (apply #',impl-name ,args))) 349 (define-compiler-macro ,name (&rest ,rest-name) 350 `(,',impl-name ,@,rest-name)))))))))) 351 352;; Examples: 353;; (defmfun $foobar (a b) (list '(mlist) a b)) 354;; (defmfun $foobar1 (a b &optional c) (list '(mlist) a b c)) 355;; (defmfun $foobar1a (a b &optional (c 99)) (list '(mlist) a b c)) 356;; (defmfun $foobar2 (a b &rest c) (list '(mlist) a b (list* '(mlist) c))) 357;; (defmfun $foobar3 (a b &optional c &rest d) "foobar3 function" (list '(mlist) a b c (list* '(mlist) d))) 358;; 359;; This works by accident, kind of: 360;; (defmfun $baz (a &aux (b (1+ a))) (list '(mlist) a b)) 361 362;; This should produce compile errors 363;; (defmfun $zot (a &key b) (list '(mlist) a b)) 364