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;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; 9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 11(in-package :maxima) 12 13(macsyma-module matcom) 14 15;; This is the Match Compiler. 16 17(declare-top (special $rules $props boundlist reflist topreflist program)) 18 19(defmvar $announce_rules_firing nil) 20 21(defmspec $matchdeclare (form) 22 (let ((meta-prop-p nil)) 23 (proc-$matchdeclare (cdr form)))) 24 25(defun proc-$matchdeclare (x) 26 (if (oddp (length x)) 27 (merror (intl:gettext "matchdeclare: must be an even number of arguments."))) 28 (do ((x x (cddr x))) ((null x)) 29 (cond ((symbolp (car x)) 30 (cond ((and (not (symbolp (cadr x))) 31 (or (numberp (cadr x)) 32 (member (caaadr x) '(mand mor mnot mcond mprog) :test #'eq))) 33 (improper-arg-err (cadr x) '$matchdeclare))) 34 (meta-add2lnc (car x) '$props) 35 (meta-mputprop (car x) (ncons (cadr x)) 'matchdeclare)) 36 ((not ($listp (car x))) 37 (improper-arg-err (car x) '$matchdeclare)) 38 (t (do ((l (cdar x) (cdr l))) ((null l)) 39 (proc-$matchdeclare (list (car l) (cadr x))))))) 40 '$done) 41 42(defun compileatom (e p) 43 (prog (d) 44 (setq d (getdec p e)) 45 (return (cond ((null d) 46 (emit (list 'cond 47 (list (list 'not 48 (list 'equal 49 e 50 (list 'quote p))) 51 '(matcherr))))) 52 ((member p boundlist :test #'eq) 53 (emit (list 'cond 54 (list (list 'not (list 'equal e p)) 55 '(matcherr))))) 56 (t (setq boundlist (cons p boundlist)) (emit d)))))) 57 58(defun emit (x) (setq program (nconc program (list x)))) 59 60(defun memqargs (x) 61 (cond ((or (numberp x) (member x boundlist :test #'eq)) x) 62 ((and (symbolp x) (get x 'operators)) `(quote ,x)) 63 ;; ((NULL BOUNDLIST) (LIST 'SIMPLIFYA (LIST 'QUOTE X) NIL)) 64 (t `(meval (quote ,x))))) 65 66(defun makepreds (l gg) 67 (cond ((null l) nil) 68 (t (cons (cond ((atom (car l)) 69 (list 'lambda (list (setq gg (gensym))) 70 `(declare (special ,gg)) 71 (getdec (car l) gg))) 72 (t (defmatch1 (car l) (gensym)))) 73 (makepreds (cdr l) nil))))) 74 75(defun defmatch1 (pt e) 76 (prog (topreflist program prog-variables) 77 (setq topreflist (list e)) 78 (cond ((atom (errset (compilematch e pt))) 79 (merror (intl:gettext "defmatch: failed to compile match for pattern ~M") pt)) 80 (t 81 ;; NOTE TO TRANSLATORS: MEANING OF FOLLOWING TEXT IS UNKNOWN 82 (mtell "defmatch: ~M will be matched uniquely since sub-parts would otherwise be ambigious.~%" pt) 83 (return (list 'lambda 84 (list e) 85 `(declare (special ,e)) 86 (list 'catch ''match 87 (nconc (list 'prog) 88 (list (setq prog-variables (cdr (reverse topreflist)))) 89 `((declare (special ,@ prog-variables))) 90 program 91 (list (list 'return t)))))))))) 92 93(defun compileplus (e p) 94 (prog (reflist f g h flag leftover) 95 a (setq p (cdr p)) 96 a1 (cond ((null p) 97 (cond ((null leftover) 98 (return (emit (list 'cond 99 (list (list 'not (list 'equal e 0.)) 100 '(matcherr)))))) 101 ((null (cdr leftover)) (return (compilematch e (car leftover)))) 102 ((setq f (intersection leftover boundlist :test #'equal)) 103 (emit (list 'setq 104 e 105 (list 'meval 106 (list 'quote 107 (list '(mplus) 108 e 109 (list '(mminus) (car f))))))) 110 (setq leftover (delete (car f) leftover :test #'equal)) 111 (go a1)) 112 (t 113 ;; Almost nobody knows what this means. Just suppress the noise. 114 ;; (mtell "COMPILEPLUS: ~M partitions '+' 115 ;; expression.~%" (cons '(mplus) leftover)) 116 (setq boundlist (append boundlist (remove-if-not #'atom leftover))) 117 (return (emit (list 'cond 118 (list (list 'part+ 119 e 120 (list 'quote leftover) 121 (list 'quote 122 (makepreds leftover nil)))) 123 '(t (matcherr)))))))) 124 ((fixedmatchp (car p)) 125 (emit (list 'setq 126 e 127 (list 'meval 128 (list 'quote 129 (list '(mplus) 130 e 131 (list '(mminus) (car p)))))))) 132 ((atom (car p)) 133 (cond ((cdr p) (setq leftover (cons (car p) leftover)) (setq p (cdr p)) (go a1)) 134 (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1))) 135 (setq boundlist (cons (car p) boundlist)) 136 (emit (getdec (car p) e)) 137 (cond ((null (cdr p)) (return nil)) (t (go a)))) 138 ((eq (caaar p) 'mtimes) 139 (cond ((and (not (or (numberp (cadar p)) 140 (and (not (atom (cadar p))) 141 (eq (caar (cadar p)) 'rat)))) 142 (fixedmatchp (cadar p))) 143 (setq flag nil) 144 (emit `(setq ,(genref) 145 (ratdisrep 146 (ratcoef ,e ,(memqargs (cadar p)))))) 147 (compiletimes (car reflist) (cons '(mtimes) (cddar p))) 148 (emit `(setq ,e (meval 149 (quote 150 (($ratsimp) 151 ((mplus) ,e 152 ((mtimes) -1 ,(car reflist) 153 ,(cadar p))))))))) 154 ((null flag) 155 (setq flag t) (rplacd (car p) (reverse (cdar p))) (go a1)) 156 (t (setq leftover (cons (car p) leftover)) (go a)))) 157 ((eq (caaar p) 'mexpt) 158 (cond ((fixedmatchp (cadar p)) 159 (setq f 'findexpon) 160 (setq g (cadar p)) 161 (setq h (caddar p))) 162 ((fixedmatchp (caddar p)) 163 (setq f 'findbase) 164 (setq g (caddar p)) 165 (setq h (cadar p))) 166 (t (go functionmatch))) 167 (emit (list 'setq 168 (genref) 169 (list f e (setq g (memqargs g)) ''mplus))) 170 (emit (list 'setq 171 e 172 (list 'meval 173 (list 'quote 174 (list '(mplus) 175 e 176 (list '(mminus) 177 (cond ((eq f 'findexpon) 178 (list '(mexpt) 179 g 180 (car reflist))) 181 (t (list '(mexpt) 182 (car reflist) 183 g))))))))) 184 (compilematch (car reflist) h)) 185 ((not (fixedmatchp (caaar p))) 186 (cond ((cdr p) 187 (setq leftover (cons (car p) leftover)) 188 (setq p (cdr p)) 189 (go a1)) 190 (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1))) 191 (setq boundlist (cons (caaar p) boundlist)) 192 (emit (list 'msetq 193 (caaar p) 194 (list 'kaar e))) 195 (go functionmatch)) 196 (t (go functionmatch))) 197 (go a) 198 functionmatch 199 (emit (list 'setq 200 (genref) 201 (list 'findfun e (memqargs (caaar p)) ''mplus))) 202 (cond ((eq (caaar p) 'mplus) 203 (mtell (intl:gettext "COMPILEPLUS: warning: '+' within '+' in: ~M~%") (car p)) 204 (compileplus (car reflist) (car p))) 205 (t (emit (list 'setq (genref) (list 'kdr (cadr reflist)))) 206 (compileeach (car reflist) (cdar p)))) 207 (emit (list 'setq 208 e 209 (list 'meval 210 (list 'quote 211 (list '(mplus) e (list '(mminus) (car p))))))) 212 (go a))) 213 214(defun compiletimes (e p) 215 (prog (reflist f g h leftover) 216 a (setq p (cdr p)) 217 a1 (cond ((null p) 218 (cond ((null leftover) 219 (return (emit (list 'cond 220 (list (list 'not (list 'equal e 1.)) 221 '(matcherr)))))) 222 ((null (cdr leftover)) (return (compilematch e (car leftover)))) 223 ((setq f (intersection leftover boundlist :test #'equal)) 224 (emit (list 'setq 225 e 226 (list 'meval 227 (list 'quote 228 (list '(mquotient) e (car f)))))) 229 (setq leftover (delete (car f) leftover :test #'equal)) 230 (go a1)) 231 (t 232 ;; Almost nobody knows what this means. Just suppress the noise. 233 ;; (mtell "COMPILETIMES: ~M partitions '*' expression.~%" (cons '(mtimes) leftover)) 234 (setq boundlist (append boundlist (remove-if-not #'atom leftover))) 235 (return (emit (list 'cond 236 (list (list 'part* 237 e 238 (list 'quote leftover) 239 (list 'quote 240 (makepreds leftover nil)))) 241 '(t (matcherr)))))))) 242 ((fixedmatchp (car p)) 243 (emit (list 'setq 244 e 245 (list 'meval 246 (list 'quote (list '(mquotient) e (car p))))))) 247 ((atom (car p)) 248 (cond ((cdr p) (setq leftover (cons (car p) leftover)) (setq p (cdr p)) (go a1)) 249 (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1))) 250 (setq boundlist (cons (car p) boundlist)) 251 (emit (getdec (car p) e)) 252 (cond ((null (cdr p)) (return nil)) (t (go a)))) 253 ((eq (caaar p) 'mexpt) 254 (cond ((fixedmatchp (cadar p)) 255 (setq f 'findexpon) 256 (setq g (cadar p)) 257 (setq h (caddar p))) 258 ((fixedmatchp (caddar p)) 259 (setq f 'findbase) 260 (setq g (caddar p)) 261 (setq h (cadar p))) 262 (t (go functionmatch))) 263 (emit (list 'setq 264 (genref) 265 (list f e (setq g (memqargs g)) ''mtimes))) 266 (cond ((eq f 'findbase) 267 (emit (list 'cond 268 (list (list 'equal (car reflist) 0) 269 '(matcherr)))))) 270 (emit (list 'setq 271 e 272 (list 'meval 273 (list 'quote 274 (list '(mquotient) 275 e 276 (cond ((eq f 'findexpon) 277 (list '(mexpt) g (car reflist))) 278 (t (list '(mexpt) 279 (car reflist) 280 g)))))))) 281 (compilematch (car reflist) h)) 282 ((not (fixedmatchp (caaar p))) 283 (cond ((cdr p) 284 (setq leftover (cons (car p) leftover)) 285 (setq p (cdr p)) 286 (go a1)) 287 (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1))) 288 (setq boundlist (cons (caaar p) boundlist)) 289 (emit (list 'msetq 290 (caaar p) 291 (list 'kaar e))) 292 (go functionmatch)) 293 (t (go functionmatch))) 294 (go a) 295 functionmatch 296 (emit (list 'setq 297 (genref) 298 (list 'findfun e (memqargs (caaar p)) ''mtimes))) 299 (cond ((eq (caaar p) 'mtimes) 300 (mtell (intl:gettext "COMPILETIMES: warning: '*' within '*' in: ~M~%") (car p)) 301 (compiletimes (car reflist) (car p))) 302 (t (emit (list 'setq (genref) (list 'kdr (cadr reflist)))) 303 (compileeach (car reflist) (cdar p)))) 304 (emit (list 'setq 305 e 306 (list 'meval 307 (list 'quote (list '(mquotient) e (car p)))))) 308 (go a))) 309 310 311(defmspec $defmatch (form) 312 (let ((meta-prop-p nil)) 313 (proc-$defmatch (cdr form)))) 314 315(defun proc-$defmatch (l) 316 (prog (pt pt* args a boundlist reflist topreflist program name tem) 317 (setq name (car l)) 318 (setq pt (copy-tree (setq pt* (simplify (cadr l))))) 319 (cond ((atom pt) 320 (setq pt (copy-tree (setq pt* (meval pt)))) 321 (mtell (intl:gettext "defmatch: evaluation of atomic pattern yields: ~M~%") pt))) 322 (setq args (cddr l)) 323 (cond ((null (allatoms args)) (mtell (intl:gettext "defmatch: some pattern variables are not atoms.")) 324 (return nil))) 325 (setq boundlist args) 326 (setq a (genref)) 327 (cond ((atom (errset (compilematch a pt))) 328 (merror (intl:gettext "defmatch: failed to compile match for pattern ~M") pt)) 329 (t (meta-fset name 330 (list 'lambda 331 (cons a args) 332 `(declare (special ,a ,@ boundlist)) 333 (list 'catch ''match 334 (nconc (list 'prog) 335 (list (setq tem (cdr (reverse topreflist)))) 336 `((declare (special ,@ tem))) 337 program 338 (list (list 'return 339 (cond (boundlist (cons 'retlist 340 boundlist)) 341 (t t)))))))) 342 (meta-add2lnc name '$rules) 343 (meta-mputprop name (list '(mlist) pt* (cons '(mlist) args)) '$rule) 344 (return name))))) 345 346(defmspec $tellsimp (form) 347 (let ((meta-prop-p nil)) 348 (proc-$tellsimp (cdr form)))) 349 350(defmfun $clear_rules () 351 (mapc 'kill1 (cdr $rules)) 352 (loop for v in '(mexpt mplus mtimes) 353 do (setf (mget v 'rulenum) nil))) 354 355(defun proc-$tellsimp (l) 356 (prog (pt rhs boundlist reflist topreflist a program name tem 357 oldstuff pgname oname rulenum) 358 (setq pt (copy-tree (simplifya (car l) nil))) 359 (setq name pt) 360 (setq rhs (copy-tree (simplifya (cadr l) nil))) 361 (cond ((alike1 pt rhs) (merror (intl:gettext "tellsimp: circular rule attempted."))) 362 ((atom pt) (merror (intl:gettext "tellsimp: pattern must not be an atom; found: ~A") (fullstrip1 (getop name)))) 363 ((mget (setq name (caar pt)) 'matchdeclare) 364 (merror (intl:gettext "tellsimp: main operator of pattern must not be match variable; found: ~A") (fullstrip1 (getop name)))) 365 ((member name '(mplus mtimes) :test #'eq) 366 (mtell (intl:gettext "tellsimp: warning: rule will treat '~M' as noncommutative and nonassociative.~%") name))) 367 (setq a (genref)) 368 (cond ((atom (errset (compileeach a (cdr pt)))) 369 (merror (intl:gettext "tellsimp: failed to compile match for pattern ~M") (cdr pt)))) 370 (setq oldstuff (get name 'operators)) 371 (setq rulenum (mget name 'rulenum)) 372 (cond ((null rulenum) (setq rulenum 1.))) 373 (setq oname (getop name)) 374 (setq pgname (implode (append (%to$ (explodec oname)) 375 '(|r| |u| |l| |e|) 376 (mexploden rulenum)))) 377 (meta-mputprop pgname name 'ruleof) 378 (meta-add2lnc pgname '$rules) 379 (meta-mputprop name (f1+ rulenum) 'rulenum) 380 (meta-fset pgname 381 (list 'lambda '(x a2 a3) 382 `(declare (special x a2 a3)) 383 (list 'prog 384 (list 'ans a 'rule-hit) 385 `(declare (special ans ,a)) 386 (list 'setq 387 'x 388 (list 'cons 389 '(car x) 390 (list 'setq 391 a 392 '(cond (a3 (cdr x)) 393 (t (mapcar #'(lambda (h) (simplifya h a3)) 394 (cdr x))))))) 395 (list 396 'multiple-value-setq 397 '(ans rule-hit) 398 (list 'catch ''match 399 (nconc (list 'prog) 400 (list (setq tem (nconc boundlist 401 (cdr (reverse topreflist))))) 402 `((declare (special ,@ tem))) 403 program 404 (list (list 'return 405 (list 'values (memqargs rhs) t)))))) 406 (cond ((not (member name '(mtimes mplus) :test #'eq)) 407 (list 'return 408 (list 'cond 409 '(rule-hit ans) '((and (not dosimp) (member 'simp (cdar x) :test #'eq))x) 410 (list t 411 (cond (oldstuff (cons oldstuff 412 '(x a2 t))) 413 (t '(eqtest x x))))))) 414 ((eq name 'mtimes) 415 (list 'return 416 (list 'cond 417 (list '(and (equal 1. a2) rule-hit) 'ans) 418 '(rule-hit (meval '((mexpt) ans a2))) 419 (list t 420 (cond (oldstuff (cons oldstuff 421 '(x a2 a3))) 422 (t '(eqtest x x))))))) 423 ((eq name 'mplus) 424 (list 'return 425 (list 'cond 426 (list '(and (equal 1. a2) rule-hit) 'ans) 427 '(rule-hit (meval '((mtimes) ans a2))) 428 (list t 429 (cond (oldstuff (cons oldstuff 430 '(x a2 a3))) 431 (t '(eqtest x x))))))))))) 432 (meta-mputprop pgname (list '(mequal) pt rhs) '$rule) 433 (cond ((null (mget name 'oldrules)) 434 (meta-mputprop name 435 (list (get name 'operators)) 436 'oldrules))) 437 (meta-putprop name pgname 'operators) 438 (return (cons '(mlist) 439 (meta-mputprop name 440 (cons pgname (mget name 'oldrules)) 441 'oldrules))))) 442 443(defun %to$ (l) (cond ((eq (car l) '%) (rplaca l '$)) (l))) 444 445 446(defmspec $tellsimpafter (form) 447 (let ((meta-prop-p nil)) 448 (proc-$tellsimpafter (cdr form)))) 449 450(defun proc-$tellsimpafter (l) 451 (prog (pt rhs boundlist reflist topreflist a program name oldstuff plustimes pgname oname tem 452 rulenum my*afterflag) 453 (setq pt (copy-tree (simplifya (car l) nil))) 454 (setq name pt) 455 (setq rhs (copy-tree (simplifya (cadr l) nil))) 456 (cond ((alike1 pt rhs) (merror (intl:gettext "tellsimpafter: circular rule attempted."))) 457 ((atom pt) (merror (intl:gettext "tellsimpafter: pattern must not be an atom; found: ~A") (fullstrip1 (getop name)))) 458 ((mget (setq name (caar pt)) 'matchdeclare) 459 (merror (intl:gettext "tellsimpafter: main operator of pattern must not be match variable; found: ~A") (fullstrip1 (getop name))))) 460 (setq a (genref)) 461 (setq plustimes (member name '(mplus mtimes) :test #'eq)) 462 (if (atom (if plustimes (errset (compilematch a pt)) 463 (errset (compileeach a (cdr pt))))) 464 (merror (intl:gettext "tellsimpafter: failed to compile match for pattern ~M") (cdr pt))) 465 (setq oldstuff (get name 'operators)) 466 (setq rulenum (mget name 'rulenum)) 467 (if (null rulenum) (setq rulenum 1)) 468 (setq oname (getop name)) 469 (setq pgname (implode (append (%to$ (explodec oname)) 470 '(|r| |u| |l| |e|) (mexploden rulenum)))) 471 (setq my*afterflag (gensym "*AFTERFLAG-")) 472 (proclaim `(special ,my*afterflag)) 473 (setf (symbol-value my*afterflag) nil) 474 (meta-mputprop pgname name 'ruleof) 475 (meta-add2lnc pgname '$rules) 476 (meta-mputprop name (f1+ rulenum) 'rulenum) 477 (meta-fset 478 pgname 479 (list 480 'lambda 481 '(x ans a3) 482 (if oldstuff 483 (list 'setq 'x (list oldstuff 'x 'ans 'a3)) 484 (list 'setq 'x (list 'simpargs1 'x 'ans 'a3))) 485 (list 486 'cond 487 `(,my*afterflag x) 488 (list 't 489 (nconc (list 'prog) 490 (list (cons a `(,my*afterflag rule-hit))) 491 `((declare (special ,a ,my*afterflag))) 492 (list `(setq ,my*afterflag t)) 493 (cond (oldstuff (subst (list 'quote name) 494 'name 495 '((cond ((or (atom x) (not (eq (caar x) name))) 496 (return x))))))) 497 (list (list 'setq 498 a 499 (cond (plustimes 'x) (t '(cdr x))))) 500 (list (list 'multiple-value-setq 501 '(ans rule-hit) 502 (list 'catch ''match 503 (nconc (list 'prog) 504 (list (setq tem(nconc boundlist 505 (cdr (reverse topreflist))))) 506 `((declare (special ,@ tem))) 507 program 508 (cond 509 ($announce_rules_firing 510 (list (list 'return (list 'values (list 'announce-rule-firing `',pgname 'x (memqargs rhs)) t)))) 511 (t 512 (list (list 'return (list 'values (memqargs rhs) t))))))))) 513 (list '(return (if rule-hit ans (eqtest x x))))))))) 514 (meta-mputprop pgname (list '(mequal) pt rhs) '$rule) 515 (cond ((null (mget name 'oldrules)) 516 (meta-mputprop name (list (get name 'operators)) 'oldrules))) 517 (meta-putprop name pgname 'operators) 518 (return (cons '(mlist) 519 (meta-mputprop name 520 (cons pgname (mget name 'oldrules)) 521 'oldrules))))) 522 523(defun announce-rule-firing (rulename expr simplified-expr) 524 (let (($display2d nil) ($stringdisp nil)) 525 ($print "By" rulename "," expr "-->" simplified-expr)) 526 simplified-expr) 527 528(defmspec $defrule (form) 529 (let ((meta-prop-p nil)) 530 (proc-$defrule (cdr form)))) 531 532;;(defvar *match-specials* nil);;Hell lets declare them all special, its safer--wfs 533(defun proc-$defrule (l) 534 (prog (pt rhs boundlist reflist topreflist name a program lhs* rhs* tem) 535 (if (not (= (length l) 3)) (wna-err '$defrule)) 536 (setq name (car l)) 537 (if (or (not (symbolp name)) (mopp name) (member name '($all $%) :test #'eq)) 538 (merror (intl:gettext "defrule: rule name must be a symbol, and not an operator or 'all' or '%'; found: ~M") name)) 539 (setq pt (copy-tree (setq lhs* (simplify (cadr l))))) 540 (setq rhs (copy-tree (setq rhs* (simplify (caddr l))))) 541 (setq a (genref)) 542 (cond ((atom (errset (compilematch a pt))) 543 (merror (intl:gettext "defrule: failed to compile match for pattern ~M") pt)) 544 (t (meta-fset name 545 (list 'lambda 546 (list a) 547 `(declare (special ,a)) 548 (list 'catch ''match 549 (nconc (list 'prog) 550 (list (setq tem (nconc boundlist 551 (cdr (reverse topreflist))))) 552 `((declare (special ,@ tem))) 553 program 554 (list (list 'return 555 (list 'values (memqargs rhs) t))))))) 556 (meta-add2lnc name '$rules) 557 (meta-mputprop name (setq l (list '(mequal) lhs* rhs*)) '$rule) 558 (meta-mputprop name '$defrule '$ruletype) 559 (return (list '(msetq) name (cons '(marrow) (cdr l)))))))) 560 561; GETDEC constructs an expression of the form ``if <match> then <assign value> else <match failed>''. 562 563; matchdeclare (aa, true); 564; :lisp (symbol-plist '$aa) => (MPROPS (NIL MATCHDECLARE (T))) 565; tellsimpafter (fa(aa), ga(aa)); 566; getdec => (MSETQ $AA TR-GENSYM~1) 567 568; matchdeclare (bb, integerp); 569; :lisp (symbol-plist '$bb) => (MPROPS (NIL MATCHDECLARE ($INTEGERP))) 570; tellsimpafter (fb(bb), gb(bb)); 571; getdec => (COND ((IS '(($INTEGERP) TR-GENSYM~3)) (MSETQ $BB TR-GENSYM~3)) ((MATCHERR))) 572 573; my_p(x) := integerp(x) and x>100; 574; matchdeclare (cc, my_p); 575; :lisp (symbol-plist '$cc) => (MPROPS (NIL MATCHDECLARE ($MY_P))) 576; tellsimpafter (fc(cc), gc(cc)); 577; getdec => (COND ((IS '(($MY_P) TR-GENSYM~5)) (MSETQ $CC TR-GENSYM~5)) ((MATCHERR))) 578 579; :lisp (defmfun $my_p2 (y x) (is `((mgeqp) ,x ,y))) 580; matchdeclare (dd, my_p2 (200)); 581; :lisp (symbol-plist '$dd) => (MPROPS (NIL MATCHDECLARE ((($MY_P2) 200)))) 582; tellsimpafter (fd(dd), gd(dd)); 583; getdec => (COND ((IS '(($MY_P2) 200 TR-GENSYM~7)) (MSETQ $DD TR-GENSYM~7)) ((MATCHERR))) 584 585; my_p3 (y, x) := is (x > y); 586; matchdeclare (ee, my_p3 (300)); 587; :lisp (symbol-plist '$ee) => (MPROPS (NIL MATCHDECLARE ((($MY_P3) 300)))) 588; tellsimpafter (fe(ee), ge(ee)); 589; getdec => (COND ((IS '(($MY_P3) 300 TR-GENSYM~9)) (MSETQ $EE TR-GENSYM~9)) ((MATCHERR))) 590 591; matchdeclare (ff, lambda ([x], x > 400)); 592; :lisp (symbol-plist '$ff) => (MPROPS (NIL MATCHDECLARE (((LAMBDA) ((MLIST) $X) ((MGREATERP) $X 400))))) 593; tellsimpafter (fff(ff), ggg(ff)); 594; getdec => (COND ((IS (MAPPLY1 '((LAMBDA) ((MLIST) $X) ((MGREATERP) $X 400)) (LIST TR-GENSYM~11) T NIL)) (MSETQ $FF TR-GENSYM~11)) ((MATCHERR))) 595 596; matchdeclare (gg, lambda ([y, x], x > y) (500)); 597; :lisp (symbol-plist '$gg) => (MPROPS (NIL MATCHDECLARE (((MQAPPLY) ((LAMBDA) ((MLIST) $Y $X) ((MGREATERP) $X $Y)) 500)))) 598; tellsimpafter (fg(gg), gg(gg)); 599; getdec => (COND ((IS (MEVAL '((MQAPPLY) ((LAMBDA) ((MLIST) $Y $X) ((MGREATERP) $X $Y)) 500 TR-GENSYM~13))) (MSETQ $GG TR-GENSYM~13)) ((MATCHERR))) 600 601; pattern-variable is the pattern variable (as declared by matchdeclare) 602; match-against is the expression to match against 603 604; Return T if $MAYBE returns T, otherwise NIL. 605; That makes all non-T values (e.g. $UNKNOWN or noun expressions) act like NIL. 606 607(defun definitely-so (e) 608 (eq (mfuncall '$maybe e) t)) 609 610(defun getdec (pattern-variable match-against) 611 (let (p) 612 (if (setq p (mget pattern-variable 'matchdeclare)) 613 ; P is (<foo>) where <foo> is the matchdeclare predicate 614 ; If <foo> is an atom, it is T or the name of a Lisp or Maxima function 615 ; Otherwise, <foo> is ((<op>) <args>) 616 617 ; If <foo> is $TRUE, T, or $ALL, generated code always assigns gensym value to pattern variable 618 (if (and (atom (car p)) (member (car p) '($true t $all) :test #'eq)) 619 `(msetq ,pattern-variable ,match-against) 620 621 ; Otherwise, we have some work to do. 622 623 (let ((p-op (car p)) (p-args) (test-expr)) 624 (setq test-expr 625 (if (atom p-op) 626 ; P-OP is the name of a function. Try to generate a Lisp function call. 627 (if (and (fboundp p-op) (not (get p-op 'translated))) ; WHY THE TEST FOR TRANSLATED PROPERTY ?? 628 `(eq t (,p-op ,@(ncons match-against))) 629 `(definitely-so '((,p-op) ,@(ncons match-against)))) 630 631 ; Otherwise P-OP is something like ((<op>) <args>). 632 (progn 633 (setq p-args (cdr p-op)) 634 (cond 635 ((eq (caar p-op) 'lambda) 636 `(definitely-so (mapply1 ',p-op (list ,match-against) t nil))) 637 ((eq (caar p-op) 'mqapply) 638 `(definitely-so (meval ',(append p-op (ncons match-against))))) 639 ; Otherwise P-OP must be a function call with the last arg missing. 640 (t 641 (if (and (consp (car p-op)) (mget (caar p-op) 'mmacro)) 642 `(definitely-so (cons ',(car p-op) ,(append '(list) (mapcar 'memqargs p-args) (ncons match-against)))) 643 `(definitely-so (cons ',(car p-op) ',(append (mapcar 'memqargs p-args) (ncons match-against)))))))))) 644 645 `(cond 646 (,test-expr (msetq ,pattern-variable ,match-against)) 647 ((matcherr)))))))) 648 649(defun compilematch (e p) 650 (prog (reflist) 651 (cond ((fixedmatchp p) 652 (emit (list 'cond 653 (list (list 'not 654 (list 'alike1 655 e 656 (list 'meval (list 'quote 657 p)))) 658 '(matcherr))))) 659 ((atom p) (compileatom e p)) 660 ((eq (caar p) 'mplus) (compileplus e p)) 661 ((eq (caar p) 'mtimes) (compiletimes e p)) 662 (t (compileatom (list 'kaar e) 663 (caar p)) 664 (emit (list 'setq 665 (genref) 666 (list 'kdr e))) 667 (compileeach (car reflist) (cdr p)))) 668 (return program))) 669 670(defun genref nil 671 (prog (a) 672 (setq a (tr-gensym)) 673 (setq topreflist (cons a topreflist)) 674 (return (car (setq reflist (cons a reflist)))))) 675(defun compileeach (elist plist) 676 (prog (reflist count) 677 (setq count 0) 678 (setq reflist (cons elist reflist)) 679 a (setq count (f1+ count)) 680 (cond ((null plist) 681 (return (emit (list 'cond 682 (list (list 'nthkdr elist (f1- count)) 683 '(matcherr))))))) 684 (emit (list 'setq (genref) (list 'kar (cadr reflist)))) 685 (compilematch (car reflist) (car plist)) 686 (setq plist (cdr plist)) 687 (setq reflist (cons (list 'kdr (cadr reflist)) reflist)) 688 (go a))) 689 690(defun fixedmatchp (x) 691 (cond ((numberp x) t) 692 ((atom x) 693 (if (or (member x boundlist :test #'eq) (null (mget x 'matchdeclare))) t)) 694 (t (and (or (member (caar x) boundlist :test #'eq) 695 (null (mget (caar x) 'matchdeclare))) 696 (fmp1 (cdr x)))))) 697 698(defun fmp1 (x) 699 (if (null x) t (and (fixedmatchp (car x)) (fmp1 (cdr x))))) 700