src/mdefun.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;;          Compilation environment for TRANSLATED MACSYMA code.        ;;;
  10 ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12
  13 (in-package :maxima)
  14
  15 (macsyma-module mdefun macro)
  16
  17 (load-macsyma-macros transm)
  18
  19 ;;; DEFMTRFUN will be the new standard.
  20 ;;; It will punt macsyma fexprs since the macro scheme is now
  21 ;;; available. I have tried to generalize this enough to do
  22 ;;; macsyma macros also.
  23
  24 ;;; (DEFMTRFUN ($FOO <mode> <property> <&restp>) <ARGL> . BODY)
  25 ;;; If the MODE is numeric it should do something about the
  26 ;;; number declarations for compiling. Also, the information about the
  27 ;;; modes of the arguments should not be thrown away.
  28
  29 (defmacro defmtrfun  ((name mode prop restp . array-flag) argl . body )
  30   (let ((def-header)
  31         (rest (gensym "TR-REST-ARG")))
  32     (and array-flag
  33          ;; old DEFMTRFUN's might have this extra bit NIL
  34          ;; new ones will have (NIL) or (T)
  35          (setq array-flag (car array-flag)))
  36     (setq def-header
  37           (cond ((eq prop 'mdefine)
  38                  (cond (array-flag `(,name a-subr))
  39                        (t name)))
  40                 (t `(,name translated-mmacro))))
  41
  42     `(eval-when
  43       (:compile-toplevel :load-toplevel :execute)
  44
  45       ,@(and (not array-flag) `((remprop ',name 'translate)))
  46       ,@(and mode `((defprop ,name ,mode
  47                       ,(cond (array-flag 'arrayfun-mode)
  48                              (t 'function-mode)))))
  49       ,@(cond (array-flag
  50                ;; when loading in hashed array properties
  51                ;; most exist or be created. Other
  52                ;; array properties must be consistent if
  53                ;; they exist.
  54                `((insure-array-props ',name ',mode ',(length argl)))))
  55       ,@(cond ((and (eq prop 'mdefine) (not array-flag))
  56                `((cond ((status feature macsyma)
  57                         (mputprop ',name t
  58                                   ,(cond ((not restp)
  59                                           ''$fixed_num_args_function)
  60                                          (t
  61                                           ''$variable_num_args_function)))))
  62                  ,(cond ((not restp) nil)))))
  63       (,(cond ((consp def-header) 'defun-prop)
  64               (restp 'defun)
  65               (t 'defmfun))
  66        ,def-header ,(cond ((not restp) argl)
  67                           (t `(&rest ,rest)))
  68        ,@(if (not restp)
  69              body
  70              (let ((required-arg-count (1- (length argl))))
  71                (if (zerop required-arg-count)
  72                    `((let ((,(car argl) (cons '(mlist) ,rest)))
  73                        ,@body))
  74                    `((when (< (length ,rest) ,required-arg-count)
  75                        (merror (intl:gettext "~M: expected at least ~M arguments but got ~M: ~M")
  76                                ',name
  77                                ,required-arg-count
  78                                (length ,rest)
  79                                (cons '(mlist) ,rest)))
  80                      (apply (lambda ,argl ,@body)
  81                             (nconc (subseq ,rest 0 ,required-arg-count)
  82                                    (list (cons '(mlist) (nthcdr ,required-arg-count ,rest)))))))))))))