src/matcom.lisp

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