1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
5 ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
6 ;;; All rights reserved ;;;;;
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 (macsyma-module schatc
)
15 ;;;; I think this is described in Chapter 3 of J. Moses' thesis,
16 ;;;; "Symbolic Integration", MIT-LCS-TR-047. A scanned version of the
17 ;;;; thesis is available at
18 ;;;; http://www.lcs.mit.edu/publications/pubs/pdf/MIT-LCS-TR-047.pdf.
20 ;;;; Unfortunately, some important pages in the scan are all black.
22 ;;;; A version with the missing pages is available (2008-12-14) from
23 ;;;; http://www.softwarepreservation.org/projects/LISP/MIT
25 ;;;; Schatchen is Yiddish for "matchmaker" and Schatchen here is a
26 ;;;; pattern matching routine.
28 (declare-top (special *schatc-ans
*))
30 (defvar *schatfactor
* nil
) ;DETERMINES WHETHER FACTORING SHOULD BE USED.
32 (defmacro push-context
()
33 '(push nil
*schatc-ans
*))
35 (defmacro push-loop-context
()
36 '(rplacd *schatc-ans
* (cons '*loop
(cdr *schatc-ans
*))))
38 (defmacro preserve
(z)
39 `(rplacd *schatc-ans
* (cons (cons ,z
(cdr ,z
)) (cdr *schatc-ans
*))))
41 (defmacro add-to
(var val
)
42 `(rplacd *schatc-ans
* (cons (cons ,var
,val
) (cdr *schatc-ans
*))))
47 ;;VARIOUS SIMPLE PATTERNS
50 (declare (special var
))
51 (and (null (pzerop a
)) (free a var
)))
53 (defun not-zero-free (a var
)
54 (declare (special var
))
57 (defun linear* (e var
)
58 (declare(special var
))
60 (setq n
($ratcoef e var
))
61 (when (null (free n var
))
63 (setq a
(simplus (list '(mplus) e
(list '(mtimes) -
1 n var
)) 1 nil
))
64 (return (cond ((free a var
) (cons a n
))))))
66 (defun dvcoe (e pat args
)
67 (m1 ($ratsimp
(list '(mtimes) e args
)) pat
))
69 ;;; SCHATCHEN pattern matcher.
71 ;;; Match the (maxima) expression in E with the pattern given by P.
73 ;;; The pattern language is partially described in Moses thesis. We
74 ;;; summarize here some of the main ideas. (This is mostly taken from
77 ;;; A variable in the pattern is written in the form (VAR name pred
78 ;;; arg1 arg2 ... argn)
82 ;;; name = name of variable
83 ;;; pred = predicate associated with the variable
84 ;;; argi = arguments 2 through n+1 for pred
86 ;;; The first arg of pred is assumed to the expression that the match
87 ;;; assigns to the variable.
89 ;;; If the variable has a mode, it is written in prefix form. Thus
90 ;;; A*x, where A is a number and is a coefficient of plus or times
91 ;;; becomes (coeffpt (var a number) x).
95 ;;; coefft - coefficient of TIMES (matches A in A*x) coeffp -
96 ;;; coefficient of PLUS (matches B in x + B) coeffpt - coefficient of
97 ;;; PLUS and TIMES (like coefft and coeffp and matches things like
98 ;;; 2*x^2+sqrt(2)*x^2 so that the coefficient of x^2 is 2+sqrt(2).
100 ;;; A brief description of the algorithm:
102 ;;; If E equals P, the match succeeds.
104 ;;; If P is of the form (VAR name pred arg1 ... argn), then (pred e
105 ;;; arg1 arg2 ... argn) is evaluated. If the value of the pred is
106 ;;; true, the match succeeds and ((name . e) is appended to the
107 ;;; answer. Otherwise the match fails.
109 ;;; If P is of the form (op p1 ... pn) and op is not PLUS, TIMES, or
110 ;;; EXPT, then E must be of the form (op1 e1 ... en) and each pi must
111 ;;; match i1 and op must match op1. Otherwise the match fails.
113 ;;; If the pattern is of the form (EXPT p1 p2) then
114 ;;; 1) e is (EXPT e1 e2) and p1 matches e1 and p2 matches e2 or
115 ;;; 2) e is 0 and p1 matches 0 or
117 ;;; a) p2 matches 0 or
119 ;;; 4) p2 matches 1 and p1 matches e
121 ;;; Otherwise the match fails
123 ;;; If the pattern is of the form (op p1 p2 ... pn) and op = PLUS or
124 ;;; TIMES, then if E is not of the form (op e1 ... em), E is
125 ;;; transformed to (op E). In this case an attempt is made to match
126 ;;; each pi with some ej. The scan starts with p1 matched with e1.
127 ;;; If that fails p1 is matched with e2. If pi matches some ej, ej is
128 ;;; deleted (destructively) from E and the scan continues with pi=1
129 ;;; matched with he first subexpression remaining in E. If for some
130 ;;; pi no ej can be found to match it, then pi is matched with 0 if op
131 ;;; = PLUS or 1 if op = TIMES. If that also fails, the match fails.
132 ;;; If all the pi have been matched, but some ej have not, the match
135 ;;; Exceptions to the above are due to modes. If op = PLUS, and pi is
136 ;;; of the form (coeffpt (var name pred arg1 ... argn) p1 ... pk),
137 ;;; then the remaining expression is traversed with the pattern
138 ;;; (coefft (var name pred arg1 ... argn) p1 ... pk). Each
139 ;;; subexpression that is thus matched is deleted from the expression.
140 ;;; The simplified sum of the result of the scan becomes the value of
141 ;;; the variable. If no subexpression could thuse be matched, then
142 ;;; (pred 0 arg1 ... argn) is attempted. If this too fails, the match
145 ;;; If op = PLUS and pn is of the form (coeffp (var name pred arg1
146 ;;; ... argn), then if e is currently of the form (PLUS ei ... en),
147 ;;; then (pred e arg1 ... argn) is evaluated. If the value of pred is
148 ;;; true, ((name . e)) is appended. If no subexpressions remain in e,
149 ;;; then pred 0 arg1 ... argn) is attempted. If it succeeds, ((name
150 ;;; . )) is appended. Otherwise, the match fails.
152 ;;; If op = PLUS and pi is of the form (coefft (var name pred arg1
153 ;;; ... argn) p1 ... pk) then (times p1 .... pk) is matched with e.
154 ;;; If the match succeeds and e remains of the form (times e1 ... en),
155 ;;; then (pred e arg1 ... argn) is attempted. If it fails, the match
156 ;;; fails. If no subexpressions remain in e, then (pred 1 arg1
157 ;;; ... argn) is attempted. If this succeeds, ((name . 1) is
160 (defun schatchen (e p
)
163 ;;THE RESTORE FUNCTIONS RESTORE THE SPEC-VAR ANS
164 ;;AND RETURN TRUE OR FALSE AS FOLLOWS
166 ;;RESTORE1 - TRUE AND CLEARS UP ANS
167 ;;RESTORE2 - TRUE AND CLEARS OFF *LOOP INDICATORS
168 ;; DOES NOT FIX UP THE EXPRESSION AND
169 ;; IS THUS TO BE USED ONLY INTERNALLY
171 ;;TO INSURE THAT THERE IS NO CONFLICT IN SPECIAL VARIABLES,
172 ;;ESPECIALLY WITH THE VAR* (SET) MODE ALL SCHATCHEN VARIABLES
173 ;;ARE TO BE PRECEDED BY A "%"
178 (let ((*schatc-ans
* (list nil
))
180 (declare (special *splist
*))
181 (cond ((null (m1 (copy-tree e
) p
)) nil
)
182 ((null (cdr *schatc-ans
*)))
183 ((cdr *schatc-ans
*)))))
190 (cond ((equal e p
) t
)
194 (cond ((testa p e nil
)
198 (cond ((member 'simp
(cdar p
) :test
#'eq
) (alike1 e p
))
199 ((member (caar p
) '(mplus mtimes
) :test
#'eq
)
201 ((member (caar p
) '(mexpt zepow
) :test
#'eq
) (zepow e p t
))
202 ((and (not (atom e
)) (eq (caar e
) (caar p
))) (eachp e p
))
203 ((eq (caar p
) 'coefft
) (coefft e p t
))
204 ((eq (caar p
) 'coeffpt
) (coeffpt e p t
))
205 ((eq (caar p
) 'coeffp
) (coeffp e p t
))
206 ((eq (caar p
) 'coefftt
)
207 (coefftt e
(cadr p
) t
'mtimes
))
208 ((eq (caar p
) 'coeffpp
)
209 (coefftt e
(cadr p
) t
'mplus
))))
210 ((var-pat (caar p
)) ;HAIRY OPERATOR MATCHING SCHEME
211 (cond ((atom e
) nil
) ;NO OPERATOR TO MATCH
212 ((prog2 (push-context) ;BIND THE CONTEXT
213 (testa (caar p
) (car e
) nil
)) ;TRY IT
214 (cond ((member (caar e
) '(mplus mtimes
) :test
#'eq
) ;CHECK FOR COMMUTIVITY
215 (cond ((loopp e
(cons (car e
) (cdr p
)))
225 (setq e
(cond ((atom e
) (list (car p
) e
))
226 ((null (eq (caar p
) (caar e
)))
227 (cond ((and *schatfactor
*
229 (mtimesp (setq x
($factor e
))))
235 loop
(setq z
(cdr z
))
237 (return (cond ((null (cdr e
)) (restore1))
240 l5
(cond ((null (cdr x
))
241 (let ((ident (opident (caar p
))))
242 (cond ((and ident
(m1 ident
(car z
)))
244 ((return (restore))))))
245 ((or (atom (car z
)) (var-pat (car z
)))
246 (when (m1 (cadr x
) (car z
))
249 ((eq (caaar z
) 'coefft
)
250 (cond ((coefft e
(car z
) nil
)
252 ((return (restore)))))
253 ((eq (caaar z
) 'coeffp
)
254 (cond ((coeffp e
(car z
) nil
)
256 ((return (restore)))))
257 ((eq (caaar z
) 'coeffpt
)
258 (cond ((coeffpt e
(car z
) nil
) (go loop
))
259 ((return (restore)))))
260 ((eq (caaar z
) 'coefftt
)
261 (cond ((coefftt e
(cadar z
) nil
'mtimes
) (go loop
))
262 ((return (restore)))))
263 ((eq (caaar z
) 'coeffpp
)
264 (cond ((coefftt e
(cadar z
) nil
'mplus
) (go loop
))
265 ((return (restore)))))
266 ((member (caaar z
) '(mexpt zepow
) :test
#'eq
)
267 (when (zepow (cadr x
) (car z
) t
)
270 ((eq (caaar z
) 'loop
)
271 (cond ((sch-loop e
(cdar z
)) (go loop
))
272 ((return (restore)))))
273 ((m1 (cadr x
) (car z
))
279 ;;; IND = T MEANS AN INTERNAL CALL (USUALLY FROM LOOPP)
281 (defun coeffp (e p ind
)
283 (cond ((or (and (null (mplusp e
)) ;;;WITH IND SET, OR E = (PLUS <EXPR>)
284 (setq e
(list '(mplus) e
)))
286 (coeffport e p
0 ind
)) ;;; USE COEFFPORT
287 ((and (null (cddr p
)) ;;; P = ((COEFFP) (<VAR> <PRED> . . .))
288 (var-pat (cadr p
))) ;;; SO CALL TESTA
289 (cond ((testa (cadr p
) e nil
)
294 ((merror "COEFFP: incorrect arguments; E=~M, P=~M, IND=~M" e p ind
))))))
297 (cond ((m1 0 p
) (restore2))
299 (cond ((coeffp (cadr x
) p t
)
301 (return (restore2))))))))
303 (defun coefft (e p ind
)
305 (cond ((and (null ind
) (null (atom e
)) (member (caar e
) '(mplus mtimes
) :test
#'eq
))
308 (cond ((m1 1 p
) (restore2))
310 (cond ((coefft (cadr x
) p t
)
312 (return (restore2))))))
313 ((and (mplusp e
) (cddr e
))
314 (cond ((and *schatfactor
* (mtimesp (setq e
($factor e
))))
315 (coeffport e p
1 ind
))
317 (t (coeffport (if (mtimesp e
) e
(list '(mtimes) e
)) p
1 ind
))))
319 (defun coeffport (e p ident ind
)
320 (do ((z (cddr p
) (cdr z
))
323 (coeffret e
(cadr p
) ident ind
))
324 l
;;; EACH TIME HERE WE HAVE CDR'D DOWN THE EXP.
325 (cond ((null (cdr x
))
326 (and (null (m1 ident
(car z
)))
330 ((eq (caaar z
) 'coefftt
)
331 (and (null (coefftt e
(cadar z
) nil
'mtimes
))
332 (return (coeffret e p ident ind
))))
333 ((eq (caaar z
) 'coeffpp
)
334 (and (null (coefftt e
(cadar z
) nil
'mplus
))
335 (return (coeffret e p ident ind
)))))
336 (cond ((null (cdr x
)))
337 ((m1 (cadr x
) (car z
))
342 (defun coeffret (e p ident ind
)
343 (cond ((null (cdr e
))
344 (cond ((testa p ident nil
)
345 (cond (ind (restore1))
348 ((testa p
(cond ((cddr e
) (copy-list e
))
351 (cond (ind (restore1))
357 (defun coeffpt (e p ind
) ;THE PATTERN LIST (P) MUST BE OF VAR-PATTERNS
359 (do ((z (cond ((mplusp e
) e
) ((list '(mplus) e
))))
360 (zz (cons '(coefft) (cdr p
)))) ;THIS ROUTINE IS THE ONE WHICH PUTS
361 ;MOST OF THE THE GARBAGE ON ANS IT
362 ((null (cdr z
)) ;IT CANNOT USE THE *SPLIST* HACK
363 (setq z
(findit (cond ((eq (caadr p
) 'var
*) ;BECAUSE IT COULD BE USING
364 (car (cddadr p
))) ;MANY DIFFERENT VARIABLES ALTHOUGH
365 ((caadr p
))))) ;THOUGHT THE FIRST IS THE ONLY ONE
366 (let ((q (cond ((null z
) 0)
367 ((null (cdr z
)) (car z
))
368 ((simplus (cons '(mplus) z
) 1 nil
))))
369 (fl (if (and z
(cdr z
)) 'coeffpt
))) ;WHICH BECOMES A SUM AND MIGHT BE RESET
370 (cond ((null (testa (cadr p
) q fl
))
374 (cond ((null (m1 (cadr z
) zz
)) ;THIS IS THE DO BODY
378 (defun zepow (e p fl
) ;FL=NIL INDICATES A RECURSIVE CALL
379 (and fl
(push-context)) ;SO ANS SHOULD NOT BE MARKED
382 (cond ((not (or (m1 0 (caddr p
)) (m1 1 (cadr p
))))
386 (cond ((null (m1 0 (cadr p
))) (restore))
388 ((and (m1 e
(cadr p
)) (m1 1 (caddr p
)))
395 ((and (eq (caar e
) 'mtimes
)
397 (do ((e (cddr e
) (cdr e
))
401 ((null e
) ;OK NOW LETS TRY AGAIN
402 (zepow (list '(mexpt) (simplifya b t
)
403 (simplifya x t
)) p nil
))
404 (cond ((mexptp (car e
))
405 (cond ((alike1 (cadar e
) b
)
406 (setq x
(simplus (list '(mplus) x
(caddar e
)) 1 nil
)))
407 ((alike1 (caddar e
) x
)
408 (setq b
(simptimes (list '(mtimes) b
(cadar e
)) 1 nil
)))
409 ((signp e
(caddr (setq z
($divide x
(caddar e
)))))
410 (setq b
(simptimes (list '(mtimes) b
411 (list '(mexpt) (cadar e
)
412 (list '(mtimes) (caddar e
) (cadr z
)))) 1 nil
)))
413 ((return (restore)))))
415 (setq x
(simplus (list '(mplus) 1 x
) 1 t
)))
416 ((return (restore))))))
417 ((or (and (eq (caar e
) 'mexpt
)
418 (m1 (cadr e
) (cadr p
))
419 (m1 (caddr e
) (caddr p
)))
426 (cond ((= (length e
) (length p
))
428 (do ((e (cdr e
) (cdr e
)))
429 ((null e
) (restore1))
430 (unless (m1 (car e
) (cadr p
)) (return (restore)))
433 (defun sch-loop (e lp
)
434 (push-context) (push-loop-context)
435 (do ((x lp
) (z e
) (y)) ;Y A PSEUDO SAVE
437 (cond ((null (m1 (cadr z
) (car x
))) ;DIDN'T MATCH
438 (setq z
(cdr z
)) ;NEXT ARG FOR LOOP
440 ((eq x lp
) (return (restore)))
445 *schatc-ans
* (cdr *schatc-ans
*))
446 (pop-loop-context))))
451 (cond ((null x
) (return (restore2)))
452 (t (push-loop-context)
455 (defun coefftt (exp pat ind opind
) ;OPIND IS MPLUS OR MTIMES
457 (when (or (atom exp
) (and ind
(not (eq (caar exp
) opind
))))
458 (setq exp
(list (list opind
) exp
)))
459 (push (car pat
) *splist
*) ;SAVE VAR NAME HERE
462 (setq *splist
* (cdr *splist
*)) ;KILL NAME SAVED
463 (cond (res (setq res
(cond ((cdr res
) (cons (list opind
) res
))
465 (cond ((and (eq (car pat
) 'var
*)
466 (member 'set
(cadr pat
) :test
#'eq
))
467 (add-to (caddr pat
) (setf (symbol-value (caddr pat
)) (simplifya res nil
))))
468 ((add-to (car pat
) (simplifya res nil
))))
469 (cond (ind (restore1))
471 ((null (testa pat
(opident opind
) nil
))
475 (cond ((testa pat
(cadr z
) nil
)
478 (t (setq z
(cdr z
))))))
481 (do ((y (cdr *schatc-ans
*) (cdr y
)))
483 (cond ((eq (car y
) '*loop
)
487 (setq *schatc-ans
* y
)
489 ((null (atom (caar y
)))
490 (rplacd (caar y
) (cdar y
))))))
493 (do ((y *schatc-ans
*) (l)) ;L IS A LIST OF VAR'S NOTED
495 (cond ((null (cadr y
)) ;END OF CONTEXT
496 (rplacd y
(cddr y
)) ;SPLICE OUT THE CONTEXT MARKER
498 ((not (atom (caadr y
))) ;FIXUP NECESSARY
499 (rplacd (caadr y
) (cdadr y
))
501 ((member (car y
) l
:test
#'eq
) ;THIS VAR HAS ALREADY BEEN SEEN
502 (rplacd y
(cddr y
))) ;SO SPLICE IT OUT TO KEEP ANS CLEAN
504 l
(cons (caar y
) l
))))))
507 (do ((y (cdr *schatc-ans
*) (cdr y
)))
509 (cond ((eq (cadr y
) '*loop
)
515 (defun pop-loop-context nil
516 (do ((y *schatc-ans
*))
517 ((eq (cadr y
) '*loop
) nil
)
519 (rplacd (caadr y
) (cdadr y
)))
520 (rplacd y
(cddr y
))))
522 ;;WHEN THE CAR OF ALA IS VAR* THE CADR IS A LIST OF
523 ;;THE VARIOUS SWITCHES WHICH MAY BE SET.
524 ;;UVAR- INDICATES THIS SHOULD MATCH SOMETHING WHICH IS ALREADY ON ANS.
525 ;;SET - ACTUALLY SET THIS VARIABLE TO ITS VALUE IF IT MATCHES.
526 ;;COEFFPT - SPECIAL ARGUMENT IF IN COEFFPT.
528 (defun testa (ala exp b
)
529 (cond ((eq (car ala
) 'mvar
*)
531 ((eq (car ala
) 'var
*)
532 (do ((z (cadr ala
) (cdr z
))
536 (setq y
(cond (uvar (m1 exp y
))
537 ((testa* ala exp nil
))))
539 (set (setf (symbol-value (car ala
)) exp
))
541 (cond ((eq (car z
) 'set
) (setq set t
))
543 (cond ((setq y
(cdr (assoc (car ala
) *schatc-ans
* :test
#'equal
)))
545 ((eq (car z
) 'coeffpt
)
549 ((merror "TESTA: invalid switch ~M in pattern." (car z
))))))
550 ((testa* ala exp nil
))))
552 ;; ALA IS THE PREDICATE LIST (VAR PREDFN ARG2 ARG3 ARG4 . . .)
554 (defun testa* (ala exp loc
)
555 (declare (special var
))
556 (cond ((cond ((eq (cadr ala
) 'freevar
)
557 (cond ((eq var
'*novar
) (equal exp
1))
559 ((eq (cadr ala
) 'numberp
) (mnump exp
))
560 ((eq (cadr ala
) 'true
) t
)
561 ((eq (cadr ala
) 'linear
*)
562 (setq exp
(linear* exp
(caddr ala
))))
564 (cond ((atom (cadr ala
))
565 (cond ((fboundp (cadr ala
))
567 (findthem exp
(cddr ala
))))
568 ((mget (cadr ala
) 'mexpr
)
570 (findthem exp
(cddr ala
))
572 ((member (caadr ala
) '(lambda function
*function quote
) :test
#'eq
)
573 ;;;THE LAMBDA IS HERE ONLY BECAUSE OF SIN!!!
574 (apply (cadr ala
) (findthem exp
(cddr ala
))))
575 ((eval-pred (cadr ala
) (car ala
) exp
)))))
576 (cond ((member (car ala
) *splist
* :test
#'eq
))
577 ((add-to (car ala
) exp
))))
578 ((cond ((and loc
(atom (cadr ala
))
579 (fboundp (cadr ala
)))
580 (mapc #'(lambda (q v
) (and (null (member q
*splist
* :test
#'eq
))
583 (apply (cadr ala
) (findthem exp
(cddr ala
)))))))))
585 (defun eval-pred (exp %var value
)
586 (progv (list %var
) (list value
)
589 (defun findthem (exp args
)
591 (mapcar #'(lambda (q)
593 (or (cdr (assoc q
*schatc-ans
* :test
#'eq
))
594 ;; Evaluate a symbol which has a value.
595 (and (symbolp q
) (boundp q
) (symbol-value q
))
596 ;; Otherwise return the symbol.
602 (do ((y *schatc-ans
*) (z))
603 ((or (null (cdr y
)) (null (cadr y
))) z
)
604 (cond ((eq (caadr y
) a
)
605 (setq z
(nconc z
(list (cdadr y
))))
607 ((setq y
(cdr y
))))))
609 (defun sch-replace (dict exp1
)
610 (declare (special dict
))
614 (declare (special dict
))
616 (cond ((null exp1
) nil
)
618 (cond ((eq (car exp1
) 'eval
)
619 (simplifya (eval (replac (cadr exp1
))) nil
))
620 ((eq (car exp1
) 'quote
) (cadr exp1
))
621 (t (setq w1
(mapcar #'replac
(cdr exp1
)))
622 (cond ((equal w1
(cdr exp1
))
624 ((simplifya (cons (list (caar exp1
)) w1
) t
))))))
625 ((numberp exp1
) exp1
)
626 ((setq w1
(assoc exp1 dict
:test
#'eq
))
630 ;; Execute BODY with the variables in VARS bound using ALIST. If any variable is
631 ;; missing, it is set to NIL.
634 ;; (alist-bind (a b c) some-alist (+ a b c))
635 (defmacro alist-bind
(vars alist
&body body
)
636 (let ((alist-sym (gensym)))
637 `(let* ((,alist-sym
,alist
)
640 collecting
`(,var
(cdr (assoc ',var
,alist-sym
:test
#'eq
)))))
641 (declare (ignorable ,alist-sym
))
644 ;; Factor out the common logic to write a COND statement that uses the Schatchen
647 ;; Each clause in CLAUSES should match (TEST VARIABLES &body BODY). This will be
648 ;; transformed into a COND clause that first runs TEST and binds the result to
649 ;; W. TEST is assumed to boil down to a call to M2, which returns an alist of
650 ;; results for the matched variables. VARIABLES should be a list of symbols and
651 ;; the clause only matches if each of these symbols is bound in the alist.
653 ;; As a special rule, if the CAR of TEST is of the form (AND F1 F2 .. FN) then
654 ;; the result of evaluating F1 is bound to W and then the clause only matches if
655 ;; F2 .. FN all evaluate to true as well as the test described above.
657 ;; If the clause matches then the result of the cond is that of evaluating BODY
658 ;; (in an implicit PROGN) with each variable bound to the corresponding element
661 ;; To add an unconditional form at the bottom, use a clause of the form
665 ;; This will always match and doesn't try to bind any extra variables.
667 (defmacro schatchen-cond
(w &body clauses
)
671 for clause in clauses
673 (let ((test (car clause
))
674 (variables (cadr clause
))
675 (body (cddr clause
)))
676 ;; A clause matches in the cond if TEST returns non-nil and
677 ;; binds all the expected variables in the alist. As a special
678 ;; syntax, if the car of TEST is 'AND, then we bind W to the
679 ;; result of the first argument and then check the following
680 ;; arguments in an environment where W is bound (but the
681 ;; variables aren't).
683 (if (and (not (atom test
)) (eq 'and
(car test
)))
685 (setf ,w
,(cadr test
))
686 (and ,w
,@(loop for var in variables
687 collecting
`(cdras ',var
,w
))
691 (and ,w
,@(loop for var in variables
692 collecting
`(cdras ',var
,w
))))))
693 ;; If the clause matched, we explicitly bind all of those
694 ;; variables in a let form and then evaluate the
696 (cond-body `(alist-bind ,variables
,w
,@body
)))
697 `(,cond-test
,cond-body
)))))))
699 ;;(declare-top (unspecial var ans))