src/transm.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   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                       $tr_numer))
  51
  52 (defmacro bind-transl-state (&rest forms)
  53   ;; this binds all transl state variables to NIL.
  54   ;; and binds user-settable variables to themselves.
  55   ;; $TR_NUMER for example can be set to TRUE while translating
  56   ;; a file, yet will only affect that file.
  57   ;; Called in 3 places, for compactness maybe this should be a PROGV
  58   ;; which references a list of variables?
  59   `(let (*warned-un-declared-vars*
  60          *warned-fexprs*
  61          *warned-mode-vars*
  62          warned-undefined-variables
  63          tr-abort
  64          transl-file
  65          *in-compfile*
  66          *in-translate-file*
  67          *in-translate*
  68          *pre-transl-forms*
  69          ($tr_numer $tr_numer)
  70          defined_variables
  71          local)
  72     ,@forms))
  73
  74 (defun tr-format (sstring &rest argl &aux strs)
  75   (if (consp *translation-msgs-files*)
  76       (setq strs *translation-msgs-files*)
  77       (setq strs (list *translation-msgs-files*)))
  78   (loop for v in strs
  79         do (apply #'mformat v sstring argl)))
  80
  81 ;; to use in mixing maxima and lisp
  82 ;; (tr #$$f(x):=x+2$)
  83 (defmacro tr (u)
  84   (and (consp u)
  85        (eq (car u) 'quote)
  86        (bind-transl-state (translate-macexpr-toplevel (second u)))))
  87
  88 (defmacro maset (val ar &rest inds)
  89   (if (or (eq ar 'mqapply)
  90           (and (consp ar) (member 'mqapply ar :test #'eq)))
  91       `(marrayset ,val ,(car inds) ,@(cdr inds))
  92       `(progn
  93          (when (symbolp ,ar)
  94            (setf ,ar (make-equal-hash-table ,(if (cdr inds) t nil))))
  95          (maset1 ,val ,ar ,@inds))))
  96
  97 (defmacro maref (ar &rest inds)
  98   (cond ((or (eql ar 'mqapply)(and (consp ar) (member 'mqapply ar :test #'eq)))
  99          `(marrayref ,(first inds) ,@(cdr inds)))
 100         ((consp ar)`(marrayref ,ar ,(first inds) ,@(cdr inds)))
 101         (t
 102          `(maref1 ,ar ,@inds))))