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-EXTERNAL ($FOO <mode> <property> <&restp>))
  25
  26 ;;we don't make function type declarations yet.
  27 (defmacro defmtrfun-external (&rest ig)
  28   (declare (ignore ig))
  29   nil)
  30
  31 ;;; (DEFMTRFUN ($FOO <mode> <property> <&restp>) <ARGL> . BODY)
  32 ;;; If the MODE is numeric it should do something about the
  33 ;;; number declarations for compiling. Also, the information about the
  34 ;;; modes of the arguments should not be thrown away.
  35
  36 (defmacro defmtrfun  ((name mode prop restp . array-flag) argl . body )
  37   (let ((def-header)
  38         (rest (gensym "TR-REST-ARG")))
  39     (and array-flag
  40          ;; old DEFMTRFUN's might have this extra bit NIL
  41          ;; new ones will have (NIL) or (T)
  42          (setq array-flag (car array-flag)))
  43     (setq def-header
  44           (cond ((eq prop 'mdefine)
  45                  (cond (array-flag `(,name a-subr))
  46                        (t name)))
  47                 (t `(,name translated-mmacro))))
  48
  49     `(eval-when
  50       (:compile-toplevel :load-toplevel :execute)
  51
  52       ,@(and (not array-flag) `((remprop ',name 'translate)))
  53       ,@(and mode `((defprop ,name ,mode
  54                       ,(cond (array-flag 'arrayfun-mode)
  55                              (t 'function-mode)))))
  56       ,@(cond (array-flag
  57                ;; when loading in hashed array properties
  58                ;; most exist or be created. Other
  59                ;; array properties must be consistent if
  60                ;; they exist.
  61                `((insure-array-props ',name ',mode ',(length argl)))))
  62       ,@(cond ((and (eq prop 'mdefine) (not array-flag))
  63                `((cond ((status feature macsyma)
  64                         (mputprop ',name t
  65                                   ,(cond ((not restp)
  66                                           ''$fixed_num_args_function)
  67                                          (t
  68                                           ''$variable_num_args_function)))))
  69                  ,(cond ((not restp) nil)))))
  70       (,(cond ((consp def-header) 'defun-prop)
  71               (restp 'defun)
  72               (t 'defmfun))
  73        ,def-header ,(cond ((not restp) argl)
  74                           (t `(&rest ,rest)))
  75        ,@(if (not restp)
  76              body
  77              (let ((required-arg-count (1- (length argl))))
  78                (if (zerop required-arg-count)
  79                    `((let ((,(car argl) (cons '(mlist) ,rest)))
  80                        ,@body))
  81                    `((when (< (length ,rest) ,required-arg-count)
  82                        (merror (intl:gettext "~M: expected at least ~M arguments but got ~M: ~M")
  83                                ',name
  84                                ,required-arg-count
  85                                (length ,rest)
  86                                (cons '(mlist) ,rest)))
  87                      (apply (lambda ,argl ,@body)
  88                             (nconc (subseq ,rest 0 ,required-arg-count)
  89                                    (list (cons '(mlist) (nthcdr ,required-arg-count ,rest)))))))))))))