src/transm.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 ;;;                Macros for TRANSL source compilation.                 ;;;
  10 ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12
  13 (in-package :maxima)
  14
  15 (macsyma-module transm macro)
  16
  17 (defmacro def%tr (name lambda-list &body body &aux definition)
  18   (setq definition
  19         (if (and (null body) (symbolp lambda-list))
  20             `(def-same%tr ,name ,lambda-list)
  21             `(defun-prop (,name translate) ,lambda-list ,@body)))
  22   `(eval-when (:compile-toplevel :execute :load-toplevel)
  23     ,definition))
  24
  25 (defmacro def-same%tr (name same-as)
  26   ;; right now MUST be used in the SAME file.
  27   `(putprop ',name
  28     (or (get ',same-as 'translate)
  29      (maxima-error "DEF-SAME%TR: ~a has no TRANSLATE property, so I can't make an alias." ',same-as))
  30     'translate))
  31
  32 ;;; declarations for the TRANSL PACKAGE.
  33
  34 (declare-top
  35              ;; The warning and error subsystem.
  36              (special tr-abort      ; set this T if you want to abort.
  37                       *translation-msgs-files*) ; the stream to print messages to.
  38              ;; State variables.
  39              (special *pre-transl-forms* ; push onto this, gets output first into the transl file.
  40                       *warned-un-declared-vars*
  41                       *warned-fexprs*
  42                       *warned-mode-vars*
  43                       warned-undefined-variables
  44                       transl-file
  45                       *in-compfile*
  46                       *in-translate-file*
  47                       *in-translate*
  48                       *untranslated-functions-called*))
  49
  50 (defmacro bind-transl-state (&rest forms)
  51   ;; this binds all transl state variables to NIL.
  52   ;; and binds user-settable variables to themselves.
  53   ;; $TR_NUMER for example can be set to TRUE while translating
  54   ;; a file, yet will only affect that file.
  55   ;; Called in 3 places, for compactness maybe this should be a PROGV
  56   ;; which references a list of variables?
  57   `(let (*warned-un-declared-vars*
  58          *warned-fexprs*
  59          *warned-mode-vars*
  60          warned-undefined-variables
  61          tr-abort
  62          transl-file
  63          *in-compfile*
  64          *in-translate-file*
  65          *in-translate*
  66          *pre-transl-forms*
  67          ($tr_numer $tr_numer)
  68          defined_variables
  69          local)
  70     ,@forms))
  71
  72 (defun tr-format (sstring &rest argl &aux strs)
  73   (if (consp *translation-msgs-files*)
  74       (setq strs *translation-msgs-files*)
  75       (setq strs (list *translation-msgs-files*)))
  76   (loop for v in strs
  77         do (apply #'mformat v sstring argl)))
  78
  79 ;; to use in mixing maxima and lisp
  80 ;; (tr #$$f(x):=x+2$)
  81 (defmacro tr (u)
  82   (and (consp u)
  83        (eq (car u) 'quote)
  84        (bind-transl-state (translate-macexpr-toplevel (second u)))))
  85
  86 (defmacro maset (val ar &rest inds)
  87   (if (or (eq ar 'mqapply)
  88           (and (consp ar) (member 'mqapply ar :test #'eq)))
  89       `(marrayset ,val ,(car inds) ,@(cdr inds))
  90       `(progn
  91          (when (symbolp ,ar)
  92            (setf ,ar (make-equal-hash-table ,(if (cdr inds) t nil))))
  93          (maset1 ,val ,ar ,@inds))))
  94
  95 (defmacro maref (ar &rest inds)
  96   (cond ((or (eql ar 'mqapply)(and (consp ar) (member 'mqapply ar :test #'eq)))
  97          `(marrayref ,(first inds) ,@(cdr inds)))
  98         ((consp ar)`(marrayref ,ar ,(first inds) ,@(cdr inds)))
  99         (t
 100          `(maref1 ,ar ,@inds))))