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