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 1980 Massachusetts Institute of Technology         ;;;
9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
11(in-package :maxima)
12
13(macsyma-module buildq)
14
15;; Exported functions are $BUILDQ and MBUILDQ-SUBST
16;; TRANSLATION property for $BUILDQ in MAXSRC;TRANS5 >
17
18;;**************************************************************************
19;;******                                                              ******
20;;******      BUILDQ:  A backquote-like construct for Macsyma         ******
21;;******                                                              ******
22;;**************************************************************************
23
24;;DESCRIPTION:
25
26
27;; Syntax:
28
29;; BUILDQ([<varlist>],<expression>);
30
31;; <expression> is any single macsyma expression
32;; <varlist> is a list of elements of the form <atom> or <atom>:<value>
33
34
35;; Semantics:
36
37;; the <value>s in the <varlist> are evaluated left to right (the syntax
38;; <atom> is equivalent to <atom>:<atom>).  then these values are substituted
39;; into <expression> in parallel.  If any <atom> appears as a single
40;; argument to the special form SPLICE (i.e. SPLICE(<atom>) ) inside
41;; <expression>, then the value associated with that <atom> must be a macsyma
42;; list, and it is spliced into <expression> instead of substituted.
43
44;;SIMPLIFICATION:
45
46
47;; the arguments to $BUILDQ need to be protected from simplification until
48;; the substitutions have been carried out.  This code should affect that.
49
50(defprop $buildq simpbuildq operators)
51(defprop %buildq simpbuildq operators)
52
53;; This is modeled after SIMPMDEF, SIMPLAMBDA etc. in JM;SIMP >
54
55(defun simpbuildq (x ignored simp-flags)
56  (declare (ignore ignored simp-flags))
57  (cons '($buildq simp) (cdr x)))
58
59;; Note that supression of simplification is very important to the semantics
60;; of BUILDQ.  Consider BUILDQ([A:'[B,C,D]],SPLICE(A)+SPLICE(A));
61
62;; If no simplification takes place, $BUILDQ returns B+C+D+B+C+D.
63;; If the expression is simplified into 2*SPLICE(A), then 2*B*C*D results.
64
65
66
67;;INTERPRETIVE CODE:
68
69
70(defmspec $buildq (form) (setq form (cdr form))
71	  (cond ((or (null (cdr form))
72		     (cddr form))
73		 (merror (intl:gettext "buildq: expected exactly two arguments; found ~M") `(($buildq) ,@form)))
74		(t (mbuildq (car form) (cadr form)))))
75
76;; this macro definition is NOT equivalent because of the way lisp macros
77;; are currently handled in the macsyma interpreter.  When the subr form
78;; is returned the arguments get MEVAL'd (and hence simplified) before
79;; we get ahold of them.
80
81;; Lisp MACROS, and Lisp FEXPR's are meaningless to the macsyma evaluator
82;; and should be ignored, the proper things to use are MFEXPR* and
83;; MMACRO properties.  -GJC
84
85;;(DEFMACRO ($BUILDQ DEFMACRO-FOR-COMPILING T)
86;;          (VARLIST . EXPRESSIONS)
87;;   (COND ((OR (NULL VARLIST)
88;;	       (NULL EXPRESSIONS)
89;;	       (CDR EXPRESSIONS))
90;;	   (DISPLA `(($BUILDQ) ,VARLIST ,@EXPRESSIONS))
91;;	   (MERROR "`buildq' takes 2 args"))
92;;	  (T `(MBUILDQ ',VARLIST ',(CAR EXPRESSIONS)))))
93
94
95(defun mbuildq (substitutions expression)
96  (cond ((not ($listp substitutions))
97	 (merror (intl:gettext "buildq: first argument must be a list; found ~M") substitutions)))
98  (mbuildq-subst
99   (mapcar #'(lambda (form)             ; make a variable/value alist
100	       (cond ((symbolp form)
101		      (cons form (meval form)))
102		     ((and (eq (caar form) 'msetq)
103			   (symbolp (cadr form)))
104		      (cons (cadr form) (meval (caddr form))))
105		     (t
106		      (merror (intl:gettext "buildq: variable must be a symbol or an assignment to a symbol; found ~M")
107			      form
108			      ))))
109	   (cdr substitutions))
110   expression))
111
112
113;; this performs the substitutions for the variables in the expressions.
114;; it tries to be smart and only copy what list structure it has to.
115;; the first arg is an alist of pairs:  (<variable> . <value>)
116;; the second arg is the macsyma expression to substitute into.
117
118(defun mbuildq-subst (alist expression)
119  (prog (new-car)
120     (cond ((atom expression)
121	    (return (mbuildq-associate expression alist)))
122	   ((atom (car expression))
123	    (setq new-car (mbuildq-associate (car expression) alist)))
124	   ((mbuildq-splice-associate expression alist)
125					; if the expression is a legal SPLICE, this clause is taken.
126					; a SPLICE should never occur here.  It corresponds to `,@form
127
128	    (merror (intl:gettext "splice: encountered 'splice' in an unexpected place: ~M") expression))
129	   ((atom (caar expression))
130	    (setq new-car (mbuildq-associate (caar expression) alist))
131	    (cond ((eq new-car (caar expression))
132		   (setq new-car (car expression)))
133		  ((atom new-car)
134		   (setq new-car (cons new-car (cdar expression))))
135		  (t (return
136		       `(,(cons 'mqapply (cdar expression))
137			 ,new-car
138			 ,@(mbuildq-subst alist (cdr expression)))))))
139	   ((setq new-car
140		  (mbuildq-splice-associate (car expression) alist))
141	    (return (append (cdr new-car)
142			    (mbuildq-subst alist (cdr expression)))))
143	   (t (setq new-car (mbuildq-subst alist (car expression)))))
144     (return
145       (let ((new-cdr (mbuildq-subst alist (cdr expression))))
146	 (cond ((and (eq new-car (car expression))
147		     (eq new-cdr (cdr expression)))
148		expression)
149	       (t (cons new-car new-cdr)))))))
150
151;; this function returns the appropriate thing to substitute for an atom
152;; appearing inside a backquote.  If it's not in the varlist, it's the
153;; atom itself.
154
155(defun mbuildq-associate (atom alist)
156  (let ((form))
157    (cond ((not (symbolp atom))
158	   atom)
159	  ((setq form (assoc atom alist :test #'eq))
160	   (cdr form))
161	  ((setq form (assoc ($verbify atom) alist :test #'eq))
162					;trying to match a nounified substitution variable
163	   (cond ((atom (cdr form))
164		  ($nounify (cdr form)))
165		 ((member (caar (cdr form))
166			'(mquote mlist mprog mprogn lambda) :test #'eq)
167					;list gotten from the parser.
168		  `((mquote) ,(cdr form)))
169		 (t `( (,($nounify (caar (cdr form)))
170			,@(cdar (cdr form)))
171		      ,@(cdr (cdr form))))))
172	  ;; ((<verb> ...) ...)  ==>  ((<noun> ...) ...)
173	  (t atom))))
174
175;; this function decides whether the SPLICE is one of ours or not.
176;; the basic philosophy is that the SPLICE is ours if it has exactly
177;; one symbolic argument and that arg appears in the current varlist.
178;; if it's one of ours, this function returns the list it's bound to.
179;; otherwise it returns nil.  Notice that the list returned is an
180;; MLIST and hence the cdr of the return value is what gets spliced in.
181
182(defun mbuildq-splice-associate (expression alist)
183  (and (eq (caar expression) '$splice)
184       (cdr expression)
185       (null (cddr expression))
186       (let ((match (assoc (cadr expression) alist :test #'eq)))
187	 (cond ((null match) () )
188	       ((not ($listp (cdr match)))
189		(merror (intl:gettext "buildq: 'splice' must return a list, but ~M returned: ~M~%")
190			expression (cdr match)))
191	       (t (cdr match))))))
192