src/mdefun.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   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       #+gcl (compile load eval)
  51       #-gcl (:compile-toplevel :load-toplevel :execute)
  52
  53       ,@(and (not array-flag) `((remprop ',name 'translate)))
  54       ,@(and mode `((defprop ,name ,mode
  55                       ,(cond (array-flag 'arrayfun-mode)
  56                              (t 'function-mode)))))
  57       ,@(cond (array-flag
  58                ;; when loading in hashed array properties
  59                ;; most exist or be created. Other
  60                ;; array properties must be consistent if
  61                ;; they exist.
  62                `((insure-array-props ',name ',mode ',(length argl)))))
  63       ,@(cond ((and (eq prop 'mdefine) (not array-flag))
  64                `((cond ((status feature macsyma)
  65                         (mputprop ',name t
  66                                   ,(cond ((not restp)
  67                                           ''$fixed_num_args_function)
  68                                          (t
  69                                           ''$variable_num_args_function)))))
  70                  ,(cond ((not restp) nil)))))
  71       (,(cond ((consp def-header) 'defun-prop)
  72               (restp 'defun)
  73               (t 'defmfun))
  74        ,def-header ,(cond ((not restp) argl)
  75                           (t `(&rest ,rest)))
  76        ,@(if (not restp)
  77              body
  78              (let ((required-arg-count (1- (length argl))))
  79                (if (zerop required-arg-count)
  80                    `((let ((,(car argl) (cons '(mlist) ,rest)))
  81                        ,@body))
  82                    `((when (< (length ,rest) ,required-arg-count)
  83                        (merror (intl:gettext "~M: expected at least ~M arguments but got ~M: ~M")
  84                                ',name
  85                                ,required-arg-count
  86                                (length ,rest)
  87                                (cons '(mlist) ,rest)))
  88                      (apply (lambda ,argl ,@body)
  89                             (nconc (subseq ,rest 0 ,required-arg-count)
  90                                    (list (cons '(mlist) (nthcdr ,required-arg-count ,rest)))))))))))))