src/mmacro.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 mmacro)
  14
  15 ;; Exported functions are MDEFMACRO, $MACROEXPAND, $MACROEXPAND1, MMACRO-APPLY
  16 ;;                        MMACROEXPANDED, MMACROEXPAND and MMACROEXPAND1
  17
  18
  19 (declare-top (special $macros $functions $transrun $translate))
  20
  21
  22 ;; $MACROS declared in jpg;mlisp >
  23
  24
  25 (defmvar $macroexpansion ()
  26   "Governs the expansion of Maxima Macros.  The following settings are
  27 available:  FALSE means to re-expand the macro every time it gets called.
  28 EXPAND means to remember the expansion for each individual call do that it
  29 won't have to be re-expanded every time the form is evaluated.  The form will
  30 still grind and display as if the expansion had not taken place.  DISPLACE
  31 means to completely replace the form with the expansion.  This is more space
  32 efficient than EXPAND but grinds and displays the expansion instead of the
  33 call."
  34   modified-commands '($macroexpand)
  35   setting-list      '( () $expand $displace ) )
  36
  37
  38 ;;; LOCAL MACRO ;;;
  39
  40 (defmacro copy1cons (name) `(cons (car ,name) (cdr ,name)))
  41
  42 ;;; DEFINING A MACRO ;;;
  43
  44 (defmspec mdefmacro (form) (setq form (cdr form))
  45           (cond ((or (null (cdr form)) (cdddr form))
  46                  (merror (intl:gettext "macro definition: must have exactly two arguments; found: ~M")
  47                          `((mdefmacro) ,@form))
  48                  )
  49                 (t (mdefmacro1 (car form) (cadr form)))))
  50
  51
  52 (defun mdefmacro1 (fun body)
  53   (let ((name) (args))
  54     (cond ((or (atom fun)
  55                (not (atom (caar fun)))
  56                (member 'array (cdar fun) :test #'eq)
  57                (mopp (setq name ($verbify (caar fun))))
  58                (member name '($all $% $%% mqapply) :test #'eq))
  59            (merror (intl:gettext "macro definition: illegal definition: ~M") ;ferret out all the
  60                    fun))                ;  illegal forms
  61           ((not (eq name (caar fun)))   ;efficiency hack I guess
  62            (rplaca (car fun) name)))    ;  done in jpg;mlisp
  63     (setq args (cdr fun))               ;  (in MDEFINE).
  64     (let ((dup (find-duplicate args :test #'eq :key #'mparam)))
  65       (when dup
  66         (merror (intl:gettext "macro definition: ~M occurs more than once in the parameter list") (mparam dup))))
  67     (mredef-check name)
  68     (do ((a args (cdr a)) (mlexprp))
  69         ((null a)
  70          (remove1 (ncons name) 'mexpr t $functions t) ;do all arg checking,
  71          (cond (mlexprp (mputprop name t 'mlexprp)) ; then remove MEXPR defn
  72                (t nil)))
  73       (cond ((mdefparam (car a)))
  74             ((and (mdeflistp a)
  75                   (mdefparam (cadr (car a))))
  76              (setq mlexprp t))
  77             (t
  78              (merror (intl:gettext "macro definition: bad argument: ~M")
  79                      (car a)))))
  80     (remove-transl-fun-props name)
  81     (add2lnc `((,name) ,@args) $macros)
  82     (mputprop name (mdefine1 args body) 'mmacro)
  83
  84     (cond ($translate (translate-and-eval-macsyma-expression
  85                        `((mdefmacro) ,fun ,body))))
  86     `((mdefmacro simp) ,fun ,body)))
  87
  88
  89
  90
  91 ;;; EVALUATING A MACRO CALL ;;;
  92
  93
  94 (defmfun mmacro-apply (defn form)
  95   (mmacroexpansion-check form
  96                          (if (and (atom defn)
  97                                   (not (symbolp defn)))
  98                              ;; added this clause for NIL. MAPPLY
  99                              ;; doesn't really handle applying interpreter
 100                              ;; closures and subrs very well.
 101                              (apply defn (cdr form))
 102                              (mapply1 defn (cdr form) (caar form) form))))
 103
 104
 105
 106
 107 ;;; MACROEXPANSION HACKERY ;;;
 108
 109
 110 ;; does any reformatting necessary according to the current setting of
 111 ;; $MACROEXPANSION.  Note that it always returns the expansion returned
 112 ;; by displace, for future displacing.
 113
 114 (defun mmacroexpansion-check (form expansion)
 115   (case $macroexpansion
 116     (( () )
 117      (cond ((eq (caar form) 'mmacroexpanded)
 118             (mmacro-displace form expansion))
 119            (t expansion)))
 120     (($expand)
 121      (cond ((not (eq (caar form) 'mmacroexpanded))
 122             (displace form `((mmacroexpanded)
 123                              ,expansion
 124                              ,(copy1cons form)))))
 125      expansion)
 126     (($displace)
 127      (mmacro-displace form expansion))
 128     (t (mtell (intl:gettext "warning: unrecognized value of 'macroexpansion'.")))))
 129
 130
 131 (defun mmacro-displace (form expansion)
 132   (displace form (cond ((atom expansion) `((mprogn) ,expansion))
 133                        (t expansion))))
 134
 135
 136 ;; Handles memo-ized forms.  Reformats them if $MACROEXPANSION has changed.
 137 ;; Format is ((MMACROEXPANDED) <expansion> <original form>)
 138
 139 (defmspec mmacroexpanded (form)
 140   (meval (mmacroexpansion-check form (cadr form))))
 141
 142
 143 ;;; MACROEXPANDING FUNCTIONS ;;;
 144
 145
 146 (defmspec $macroexpand (form) (setq form (cdr form))
 147           (cond ((or (null form) (cdr form))
 148                  (merror (intl:gettext "macroexpand: must have exactly one argument; found: ~M")
 149                          `(($macroexpand) ,@form)))
 150                 (t (mmacroexpand (car form)))))
 151
 152 (defmspec $macroexpand1 (form) (setq form (cdr form))
 153           (cond ((or (null form) (cdr form))
 154                  (merror (intl:gettext "macroexpand1: must have exactly one argument; found: ~M")
 155                          `(($macroexpand1) ,@form)))
 156                 (t (mmacroexpand1 (car form)))))
 157
 158
 159 ;; Expands the top-level form repeatedly until it is no longer a macro
 160 ;; form.  Has to copy the form each time because if macros are displacing
 161 ;; the form given to mmacroexpand1 will get bashed each time.  Recursion
 162 ;; is used instead of iteration so the user gets a pdl overflow error
 163 ;; if he tries to expand recursive macro definitions that never terminate.
 164
 165 (defun mmacroexpand (form)
 166   (let ((test-form (if (atom form) form (copy1cons form)))
 167         (expansion (mmacroexpand1 form)))
 168     (cond ((equal expansion test-form)
 169            expansion)
 170           (t (mmacroexpand expansion)))))
 171
 172
 173 ;; only expands the form once.  If the form is not a valid macro
 174 ;; form it just gets returned (eq'ness is preserved).  Note that if the
 175 ;; macros are displacing, the returned form is also eq to the given
 176 ;; form (which has been bashed).
 177
 178 (defun mmacroexpand1 (form)
 179   (let ((funname) (macro-defn))
 180     (cond ((or (atom form)
 181                (atom (car form))
 182                (member 'array (cdar form) :test #'eq)
 183                (not (symbolp (setq funname (mop form)))))
 184            form)
 185           ((eq funname 'mmacroexpanded)
 186            (mmacroexpansion-check form (cadr form)))
 187           ((setq macro-defn
 188                  (or (and $transrun
 189                           (get (caar form) 'translated-mmacro))
 190                      (mget (caar form) 'mmacro)))
 191            (mmacro-apply macro-defn form))
 192           (t form))))
 193
 194 ;;; SIMPLIFICATION ;;;
 195
 196 (defprop mdefmacro simpmdefmacro operators)
 197
 198 ;; emulating simpmdef (for mdefine) in jm;simp
 199 (defmfun simpmdefmacro (x ignored simp-flag)
 200   (declare (ignore ignored simp-flag))
 201   (cons '(mdefmacro simp) (cdr x)))
 202
 203 (defun displace (x y)
 204   (setf (car x) (car y))
 205   (setf (cdr x) (cdr y))
 206   x)