src/buildq.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 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))))))