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     (mredef-check name)
  65     (do ((a args (cdr a)) (mlexprp))
  66         ((null a)
  67          (remove1 (ncons name) 'mexpr t $functions t) ;do all arg checking,
  68          (cond (mlexprp (mputprop name t 'mlexprp)) ; then remove MEXPR defn
  69                (t nil)))
  70       (cond ((mdefparam (car a)))
  71             ((and (mdeflistp a)
  72                   (mdefparam (cadr (car a))))
  73              (setq mlexprp t))
  74             (t
  75              (merror (intl:gettext "macro definition: bad argument: ~M")
  76                      (car a)))))
  77     (remove-transl-fun-props name)
  78     (add2lnc `((,name) ,@args) $macros)
  79     (mputprop name (mdefine1 args body) 'mmacro)
  80
  81     (cond ($translate (translate-and-eval-macsyma-expression
  82                        `((mdefmacro) ,fun ,body))))
  83     `((mdefmacro simp) ,fun ,body)))
  84
  85
  86
  87
  88 ;;; EVALUATING A MACRO CALL ;;;
  89
  90
  91 (defmfun mmacro-apply (defn form)
  92   (mmacroexpansion-check form
  93                          (if (and (atom defn)
  94                                   (not (symbolp defn)))
  95                              ;; added this clause for NIL. MAPPLY
  96                              ;; doesn't really handle applying interpreter
  97                              ;; closures and subrs very well.
  98                              (apply defn (cdr form))
  99                              (mapply1 defn (cdr form) (caar form) form))))
 100
 101
 102
 103
 104 ;;; MACROEXPANSION HACKERY ;;;
 105
 106
 107 ;; does any reformatting necessary according to the current setting of
 108 ;; $MACROEXPANSION.  Note that it always returns the expansion returned
 109 ;; by displace, for future displacing.
 110
 111 (defun mmacroexpansion-check (form expansion)
 112   (case $macroexpansion
 113     (( () )
 114      (cond ((eq (caar form) 'mmacroexpanded)
 115             (mmacro-displace form expansion))
 116            (t expansion)))
 117     (($expand)
 118      (cond ((not (eq (caar form) 'mmacroexpanded))
 119             (displace form `((mmacroexpanded)
 120                              ,expansion
 121                              ,(copy1cons form)))))
 122      expansion)
 123     (($displace)
 124      (mmacro-displace form expansion))
 125     (t (mtell (intl:gettext "warning: unrecognized value of 'macroexpansion'.")))))
 126
 127
 128 (defun mmacro-displace (form expansion)
 129   (displace form (cond ((atom expansion) `((mprogn) ,expansion))
 130                        (t expansion))))
 131
 132
 133 ;; Handles memo-ized forms.  Reformats them if $MACROEXPANSION has changed.
 134 ;; Format is ((MMACROEXPANDED) <expansion> <original form>)
 135
 136 (defmspec mmacroexpanded (form)
 137   (meval (mmacroexpansion-check form (cadr form))))
 138
 139
 140 ;;; MACROEXPANDING FUNCTIONS ;;;
 141
 142
 143 (defmspec $macroexpand (form) (setq form (cdr form))
 144           (cond ((or (null form) (cdr form))
 145                  (merror (intl:gettext "macroexpand: must have exactly one argument; found: ~M")
 146                          `(($macroexpand) ,@form)))
 147                 (t (mmacroexpand (car form)))))
 148
 149 (defmspec $macroexpand1 (form) (setq form (cdr form))
 150           (cond ((or (null form) (cdr form))
 151                  (merror (intl:gettext "macroexpand1: must have exactly one argument; found: ~M")
 152                          `(($macroexpand1) ,@form)))
 153                 (t (mmacroexpand1 (car form)))))
 154
 155
 156 ;; Expands the top-level form repeatedly until it is no longer a macro
 157 ;; form.  Has to copy the form each time because if macros are displacing
 158 ;; the form given to mmacroexpand1 will get bashed each time.  Recursion
 159 ;; is used instead of iteration so the user gets a pdl overflow error
 160 ;; if he tries to expand recursive macro definitions that never terminate.
 161
 162 (defun mmacroexpand (form)
 163   (let ((test-form (if (atom form) form (copy1cons form)))
 164         (expansion (mmacroexpand1 form)))
 165     (cond ((equal expansion test-form)
 166            expansion)
 167           (t (mmacroexpand expansion)))))
 168
 169
 170 ;; only expands the form once.  If the form is not a valid macro
 171 ;; form it just gets returned (eq'ness is preserved).  Note that if the
 172 ;; macros are displacing, the returned form is also eq to the given
 173 ;; form (which has been bashed).
 174
 175 (defun mmacroexpand1 (form)
 176   (let ((funname) (macro-defn))
 177     (cond ((or (atom form)
 178                (atom (car form))
 179                (member 'array (cdar form) :test #'eq)
 180                (not (symbolp (setq funname (mop form)))))
 181            form)
 182           ((eq funname 'mmacroexpanded)
 183            (mmacroexpansion-check form (cadr form)))
 184           ((setq macro-defn
 185                  (or (and $transrun
 186                           (get (caar form) 'translated-mmacro))
 187                      (mget (caar form) 'mmacro)))
 188            (mmacro-apply macro-defn form))
 189           (t form))))
 190
 191 ;;; SIMPLIFICATION ;;;
 192
 193 (defprop mdefmacro simpmdefmacro operators)
 194
 195 ;; emulating simpmdef (for mdefine) in jm;simp
 196 (defmfun simpmdefmacro (x ignored simp-flag)
 197   (declare (ignore ignored simp-flag))
 198   (cons '(mdefmacro simp) (cdr x)))
 199
 200 (defun displace (x y)
 201   (setf (car x) (car y))
 202   (setf (cdr x) (cdr y))
 203   x)