src/transs.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 transs)
  14
  15 ;;; User-hacking code, file-io, translator toplevel.
  16 ;;; There are various macros to cons-up filename TEMPLATES
  17 ;;; which to mergef into. The filenames should be the only
  18 ;;; system dependent part of the code, although certain behavior
  19 ;;; of RENAMEF/MERGEF/DELETE-FILE is assumed.
  20
  21 (defmvar $tr_file_tty_messagesp nil
  22   "It TRUE messages about translation of the file are sent
  23          to the TTY also.")
  24
  25 (defvar *translation-msgs-files* nil
  26   "Where the warning and other comments goes.")
  27
  28 (defmvar transl-file nil "output stream of $compfile")
  29
  30 (defmvar $compgrind t "If `true' lisp output will be pretty-printed.")
  31
  32 (defmvar $tr_true_name_of_file_being_translated nil
  33   "This is set by TRANSLATE_FILE for use by user macros
  34          which want to know the name of the source file.")
  35
  36 (defmvar $tr_state_vars
  37     '((mlist)
  38       $translate_fast_arrays
  39       $tr_function_call_default
  40       $tr_bound_function_applyp
  41       $tr_array_as_ref
  42       $tr_numer
  43       $tr_float_can_branch_complex
  44       $define_variable))
  45
  46 (defmspec $compfile (forms)
  47     (setq forms (cdr forms))
  48     (if (eql 1 (length forms))
  49       (merror (intl:gettext "compfile: no functions specified; I refuse to create an empty file.")))
  50     (bind-transl-state
  51      (setq *in-compfile* t)
  52      (let
  53        ((out-file-name (namestring (maxima-string (meval (car forms)))))
  54         (t-error nil)
  55         (*translation-msgs-files* nil))
  56        (pop forms)
  57        (unwind-protect
  58             (with-maxima-io-syntax
  59               (setq transl-file (open out-file-name :direction :output :if-exists :overwrite :if-does-not-exist :create :element-type 'character))
  60               (cond ((or (member '$all forms :test #'eq)
  61                          (member '$functions forms :test #'eq))
  62                      (setq forms (mapcar #'caar (cdr $functions)))))
  63               (do ((l forms (cdr l))
  64                    (tr-abort nil nil)
  65                    (item)
  66                    (t-item))            ;
  67                   ((null l))
  68                 (setq item (car l))
  69                 (cond ((not (atom item))
  70                        (print* (dconvx (translate item))))
  71                       (t
  72                        (setq t-item (compile-function (setq item ($verbify item))))
  73                        (cond (tr-abort
  74                               (setq t-error (print-abort-msg item 'compfile)))
  75                              (t
  76                               (when $compgrind
  77                                 (mformat transl-file (intl:gettext "~2%;; Function ~:@M~%") item))
  78                               (print* t-item))))))
  79           out-file-name)
  80          ;; unwind-protected
  81          (if transl-file (close transl-file))
  82          (if t-error (delete-file transl-file))))))
  83
  84 (defun compile-function (f)
  85   (tr-format (intl:gettext "~%Translating ~:@M") f)
  86   (let ((fun (tr-mfun f)))
  87     (cond (tr-abort  nil)
  88           (t fun))))
  89
  90 (defmfun $compile_file (input-file &optional bin-file translation-output-file &aux result)
  91   (setq input-file (maxima-string input-file))
  92   (and bin-file(setq  bin-file (maxima-string bin-file)))
  93   (and translation-output-file
  94        (setq translation-output-file (maxima-string translation-output-file)))
  95   (cond ((string-equal (pathname-type input-file) "LISP")
  96          (setq result (list '(mlist) input-file)))
  97         (t (setq result (translate-file input-file translation-output-file))
  98            (setq input-file (third result))))
  99   #+(or cmu scl sbcl clisp allegro openmcl lispworks ecl)
 100   (multiple-value-bind (output-truename warnings-p failure-p)
 101       (if bin-file
 102           (compile-file input-file :output-file bin-file)
 103           (compile-file input-file))
 104     (declare (ignore warnings-p))
 105     ;; If the compiler encountered errors, don't set bin-file to
 106     ;; indicate that we found errors. Is this what we want?
 107     (unless failure-p
 108       (setq bin-file output-truename)))
 109   #-(or cmu scl sbcl clisp allegro openmcl lispworks ecl)
 110   (setq bin-file (compile-file input-file :output-file bin-file))
 111   (when bin-file
 112     (setq bin-file (namestring bin-file)))
 113   (append result (list bin-file)))
 114
 115 (defun maxima-string (symb)
 116   (print-invert-case symb))
 117
 118 (defmfun $translate_file (input-file &optional output-file)
 119   (setq input-file (maxima-string input-file))
 120   (cond (output-file (setq output-file (maxima-string output-file))))
 121   (translate-file input-file output-file))
 122
 123 (defvar *pretty-print-translation* t)
 124
 125 ;; Define a pprinter for defmtrfun.
 126
 127 #-gcl
 128 (defun pprint-defmtrfun (stream s)
 129   (pprint-logical-block (stream s :prefix "(" :suffix ")")
 130     (write (pprint-pop) :stream stream)
 131     (write-char #\space stream)
 132     (write (pprint-pop) :stream stream)
 133     (pprint-indent :block 4 stream)
 134     (pprint-newline :mandatory stream)
 135     (write (pprint-pop) :stream stream)
 136     (pprint-indent :block 2 stream)
 137     (pprint-newline :mandatory stream)
 138     (loop
 139        (pprint-exit-if-list-exhausted)
 140        (write (pprint-pop) :stream stream)
 141        (write-char #\space stream)
 142        (pprint-newline :linear stream))))
 143
 144 (defun call-batch1 (in-stream out-stream &aux expr transl)
 145   (cleanup)
 146   ;; we want the thing to start with a newline..
 147   (newline in-stream)
 148   (with-maxima-io-syntax
 149     (loop while (and (setq expr (mread in-stream)) (consp expr))
 150           do (setq transl (translate-macexpr-toplevel (third expr)))
 151              (cond
 152                (*pretty-print-translation*
 153                 (pprint transl out-stream))
 154                (t
 155                 (format out-stream "~a" transl))))))
 156
 157
 158 (defvar trf-start-hook nil)
 159
 160 (defun alter-pathname (pathname &rest options)
 161   (apply 'make-pathname :defaults (pathname  pathname) options))
 162
 163 (defun delete-with-side-effects-if (test list)
 164   "Rudimentary DELETE-IF which, however, is guaranteed to call
 165 the function TEST exactly once for each element of LIST, from
 166 left to right."
 167   (loop while (and list (funcall test (car list)))
 168      do (pop list))
 169   (loop with list = list
 170      while (cdr list)
 171      if (funcall test (cadr list))
 172      do (pop (cdr list))
 173      else
 174      do (pop list))
 175   list)
 176
 177 (defun insert-necessary-function-declares (stream)
 178   "Write to STREAM two lists: The functions which are known to be
 179 translated without actually being in the list passed to
 180 $DECLARE_TRANSLATED, and those which are not known to be
 181 translated."
 182   (let (translated hint)
 183     (setq *untranslated-functions-called*
 184           (delete-with-side-effects-if
 185            #'(lambda (v)
 186                (prog1
 187                    (or (setq translated
 188                              (or (get v 'once-translated)
 189                                  (get v 'translated)))
 190                        (and (fboundp v)
 191                             ;; might be traced
 192                             (not (mget v 'mexpr)))
 193                        (get v 'mfexpr*))
 194                  (when (and translated
 195                             (not (member v *declared-translated-functions* :test #'eq)))
 196                    (push v hint))))
 197            *untranslated-functions-called*))
 198     (when hint
 199       (format  stream
 200                (intl:gettext "~2%/* The compiler might be able to optimize some function calls if you prepend the following declaration to your Maxima code: */~%"))
 201       (mgrind `(($eval_when) $translate (($declare_translated) ,@hint))
 202               stream)
 203       (format stream "$"))
 204     (when *untranslated-functions-called*
 205       (format stream (intl:gettext "~2%/* The following functions are not known to be translated:~%"))
 206       (mgrind `((mlist) ,@(nreverse *untranslated-functions-called*)) stream)
 207       (format stream "$ */"))
 208     (fresh-line stream)
 209     (when (or hint *untranslated-functions-called*)
 210       (format t (intl:gettext "~&translator: see the 'unlisp' file for possible optimizations.~%")))))
 211
 212 (defun print-transl-herald (stream)
 213   (flet ((timezone-iso8601-name (dst tz)
 214            ;; This function was borrowed from CMUCL.
 215            (let ((tz (- tz)))
 216              (if (and (not dst) (= tz 0))
 217                  "Z"
 218                  (multiple-value-bind (hours minutes)
 219                      (truncate (if dst (1+ tz) tz))
 220                    (format nil "~C~2,'0D:~2,'0D"
 221                            (if (minusp tz) #\- #\+)
 222                            (abs hours)
 223                            (abs (truncate (* minutes 60)))))))))
 224     (multiple-value-bind (secs mins hours day month year dow dst tz)
 225         (decode-universal-time (get-universal-time))
 226       (declare (ignore dow))
 227       (format stream (intl:gettext "; Translated on: ~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D~A~%")
 228               year month day hours mins secs (timezone-iso8601-name dst tz))))
 229   (format stream (intl:gettext "; Maxima version: ~A~%") *autoconf-version*)
 230   (format stream (intl:gettext "; Lisp implementation: ~A~%") (lisp-implementation-type))
 231   (format stream (intl:gettext "; Lisp version: ~A~%;~%") (lisp-implementation-version))
 232   (format stream (intl:gettext "; Translator state vars:~%;~%"))
 233   (loop for v in (cdr $tr_state_vars)
 234         do (mformat stream ";   ~:M: ~:M;~%" v (symbol-value v))))
 235
 236 (defun translate-file (in-file-name out-file-name
 237                        &aux warn-file translated-file *translation-msgs-files*
 238                        *untranslated-functions-called* *declared-translated-functions*)
 239   (bind-transl-state
 240    (setq *in-translate-file* t)
 241    (setq translated-file (alter-pathname (or out-file-name in-file-name) :type "LISP"))
 242    (setq warn-file (alter-pathname in-file-name :type "UNLISP"))
 243    (with-open-file (in-stream in-file-name)
 244      (with-open-file (out-stream translated-file :direction :output :if-exists :supersede)
 245        (with-open-file (warn-stream warn-file :direction :output :if-exists :supersede)
 246          (setq *translation-msgs-files* (list warn-stream))
 247          (if $tr_file_tty_messagesp
 248              (setq *translation-msgs-files* (cons *standard-output* *translation-msgs-files*)))
 249          (format out-stream ";;; -*- Mode: Lisp; package:maxima; syntax:common-lisp ;Base: 10 -*- ;;;~%~%")
 250          (print-transl-herald out-stream)
 251          (format out-stream "~%(in-package :maxima)~%")
 252          (format warn-stream (intl:gettext "This is the unlisp file for ~A~%")
 253                  (namestring (pathname in-stream)))
 254          (mformat *terminal-io* (intl:gettext "translator: begin translating ~A.~%")
 255                   (pathname in-stream))
 256          (call-batch1 in-stream out-stream)
 257          (insert-necessary-function-declares warn-stream)
 258          ;; BATCH1 calls TRANSLATE-MACEXPR-toplevel on each expression read.
 259          (cons '(mlist)
 260                (mapcar 'namestring
 261                        (mapcar 'pathname (list in-stream out-stream warn-stream)))))))))
 262
 263 (defun print* (p)
 264   (unless (atom p)
 265     (let ((*print-pretty* (or $compgrind *print-pretty*)))
 266       (prin1 p transl-file))
 267     (terpri transl-file)))
 268
 269 (defun print-abort-msg (fun from)
 270   (tr-format (intl:gettext "compfile: failed to translate ~:@M.~%~
 271              ~A will continue, but file output will be aborted.~%") ;; WTF DOES THIS MEAN ???
 272              fun from))
 273
 274 (defmspec $translate (functs)
 275   (setq functs (cdr functs))
 276   (cond ((and functs (stringp (car functs)))
 277          (merror (intl:gettext "translate: call 'translate_file' to translate a file; found: ~M") (car functs)))
 278         (t
 279          (cond ((or (member '$functions functs :test #'eq)
 280                     (member '$all functs :test #'eq))
 281                 (setq functs (mapcar 'caar (cdr $functions)))))
 282          (do ((l functs (cdr l))
 283               (v nil))
 284              ((null l) `((mlist) ,@(nreverse v)))
 285            (cond ((atom (car l))
 286                   (let ((it (translate-function ($verbify (car l)))))
 287                     (if it (push it v))))
 288                  (t
 289                   (tr-format (intl:gettext "error: 'translate' argument must be an atom; found: ~M~%") (car l))))))))
 290
 291 (defmspec $compile (form)
 292   (let ((l (meval `(($translate) ,@(cdr form)))))
 293     (flet ((safe-compile (f)
 294              (when (fboundp f)
 295                (compile f))))
 296       (dolist (f (cdr l) l)
 297         ; First compile the named translated function.
 298         (safe-compile f)
 299         ; If DEFMFUN was used to define the function, then compile
 300         ; the impl function defined by DEFMFUN if it exists.  The
 301         ; impl function actually contains the translated user code
 302         ; that we want to compile.
 303         (let ((impl (get f 'impl-name)))
 304           (safe-compile impl))))))