src/trutil.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 ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module trutil)
  14
  15 (defun tr-gensym ()
  16   (intern (symbol-name (gensym "TR-GENSYM")) :maxima))
  17
  18 (defun push-defvar (var val)
  19   ;; makes sure there is a form in the beginning of the
  20   ;; file that insures the special variable is declared and bound.
  21   (or (member var defined_variables :test #'eq)
  22       ;; $NO_DEFAULT says that the user takes responsibility for binding.
  23       (eq $define_variable '$no_default)
  24       ;; $MODE is same, but double-checks with the declarations available.
  25       (and (eq $define_variable '$mode)
  26            (tr-get-mode var))
  27       (do ((l *pre-transl-forms* (cdr l)))
  28           ((null l)
  29            ;; push one with a priority of 1, which will be over-rided
  30            ;; by any user-specified settings.
  31            (if (eq $define_variable '$mode)
  32                (tr-format (intl:gettext "note: variable ~:M being given a default assignment ~:M~%")
  33                           var (if (atom val) val
  34                                   ;; strip off the quote
  35                                   (cadr val))))
  36            (push-pre-transl-form `(def-mtrvar ,var ,val 1)))
  37         (let ((form (car l)))
  38           (and (eq (car form) 'def-mtrvar)
  39                (eq (cadr form) var)
  40                (return ()))))))
  41
  42 (defun push-pre-transl-form (form)
  43   (cond ((member form *pre-transl-forms* :test #'equal))
  44         (t
  45          (push form *pre-transl-forms*)
  46          (and *in-translate*
  47               (let ((winp nil))
  48                 (unwind-protect (progn (eval form) (setq winp t))
  49                   (unless winp
  50                     (barfo "Bad *pre-transl-forms*"))))))))
  51
  52 (defun tr-nargs-check (form &optional (args-p nil) (nargs (length (cdr form))))
  53   ;; the maclisp args info format is NIL meaning no info,
  54   ;; probably a lexpr. or cons (min . max)
  55   (and args-p
  56        (let ((nargs (length (cdr form)))
  57              (min (or (car args-p) (cdr args-p)))
  58              (max (cdr args-p)))
  59          (cond ((and min (< nargs min))
  60                 (tr-format (intl:gettext "error: too few arguments supplied to ~:@M~%~:M~%")
  61                            (caar form)
  62                            form))
  63                ((and max (> nargs max))
  64                 (tr-format (intl:gettext "error: too many arguments supplied to ~:@M~%~:M~%")
  65                            (caar form)
  66                            form)))))
  67   nargs) ;; return the number of arguments.
  68