archive/src/numer.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 1982 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module numer)
  14
  15 (load-macsyma-macros numerm)
  16
  17 ;;; Interface of lisp numerical routines to macsyma.
  18 ;;; 4:34pm  Thursday, 28 May 1981 - George Carrette.
  19
  20 ;;; Trampolines for calling with numerical efficiency.
  21
  22 (defvar tramp$-alist ())
  23
  24 (defmacro deftramp$ (nargs)
  25   (let ((tramp$ (symbolconc 'tramp nargs '$))
  26         (tramp$-f (symbolconc 'tramp nargs '$-f))
  27         (tramp$-m (symbolconc 'tramp nargs '$-m))
  28         (l (make-list nargs)))
  29     (let ((arg-list (mapcar #'(lambda (ign)ign (gensym)) l)))
  30       `(progn
  31          (push '(,nargs ,tramp$ ,tramp$-f ,tramp$-m) tramp$-alist)
  32          (defmvar ,tramp$ "Contains the object to jump to if needed")
  33          (defun ,tramp$-f ,arg-list
  34            (float (funcall ,tramp$ ,@arg-list)))
  35          (defun ,tramp$-m ,arg-list
  36            (float (mapply1 ,tramp$ (list ,@arg-list) ',tramp$ nil)))))))
  37
  38 (deftramp$ 1)
  39 (deftramp$ 2)
  40 (deftramp$ 3)
  41
  42 (defmfun make-tramp$ (f n)
  43   (let ((l (assoc n tramp$-alist :test #'equal)))
  44     (if (null l)
  45         (merror "Bug: No trampoline of argument length ~M" n))
  46     (pop l)
  47     (let (tramp$ tramp$-m tramp$-f)
  48       (declare (special tramp$ tramp$-m tramp$-f))
  49       (setq tramp$ (pop l)
  50             tramp$-f (pop l)
  51             tramp$-m (pop l))
  52       (let ((whatnot (funtypep f)))
  53         (case (car whatnot)
  54           ((operators)
  55            (setf (symbol-value tramp$) f)
  56            (getsubr! tramp$-m))
  57           ((mexpr)
  58            (setf (symbol-value tramp$) (cadr whatnot))
  59            (getsubr! tramp$-m))
  60           ((expr lsubr)
  61            (setf (symbol-value tramp$) (cadr whatnot))
  62            (getsubr! tramp$-f))
  63           (t
  64            (merror "Undefined or inscrutable function~%~M" f)))))))
  65
  66
  67 (defun getsubr! (x)
  68   (or
  69    (and (symbolp x) (fboundp x) (symbol-function x))
  70    (maxima-error "No subr property for ~a!" x)))
  71
  72 (defun funtypep (f)
  73   (cond ((symbolp f)
  74          (let ((mprops (mgetl f '(mexpr)))
  75                (lprops (and (fboundp f)
  76                             (list 'expr (symbol-function f)))))
  77            (or (if $transrun
  78                    (or lprops mprops)
  79                    (or mprops lprops))
  80                (getl f '(operators)))))
  81         ((functionp f)
  82          (list 'expr f))
  83         ((consp f)
  84          (list (if (member (car f) '(function lambda named-lambda) :test #'eq)
  85                    'expr
  86                    'mexpr)
  87                f))
  88         (t
  89          nil)))