src/trutil.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 1980 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module trutil)
  14
  15 (defun tr-gensym ()
  16   (gentemp (symbol-name 'tr-gensym)))
  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 push-autoload-def (old-entry new-entries)
  53   (and (get old-entry 'autoload)
  54        ;; don't need this if it is IN-CORE.
  55        ;; this automaticaly punts this shit for systems
  56        ;; that don't need it.
  57        (do ((entry))
  58            ((null new-entries))
  59          (setq entry (pop new-entries))
  60          (push-pre-transl-form
  61               `(putprop ',entry
  62                         ;; this ensures that the autoload definition
  63                         ;; will not get out of date.
  64                 (or (get ',old-entry 'autoload) t)
  65                 'autoload)))))
  66
  67 (defun tr-nargs-check (form &optional (args-p nil) (nargs (length (cdr form))))
  68   ;; the maclisp args info format is NIL meaning no info,
  69   ;; probably a lexpr. or cons (min . max)
  70   (and args-p
  71        (let ((nargs (length (cdr form)))
  72              (min (or (car args-p) (cdr args-p)))
  73              (max (cdr args-p)))
  74          (cond ((and min (< nargs min))
  75                 (mformat *translation-msgs-files* (intl:gettext "error: too few arguments supplied to ~:@M~%")
  76                          (caar form))
  77                 (mgrind form *translation-msgs-files*))
  78                ((and max (> nargs max))
  79                 (tr-format  (intl:gettext "error: too many arguments supplied to ~:@M~%") (caar form))
  80                 (mgrind form *translation-msgs-files*)))))
  81   nargs) ;; return the number of arguments.
  82