src/fortra.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 fortra)
  14
  15 (declare-top (special *lb* *rb*  ;Used for communication with MSTRING.
  16                       ))
  17
  18 (defmvar $fortspaces nil
  19   "If T, Fortran card images are filled out to 80 columns using spaces."
  20   boolean
  21   modified-commands '$fortran)
  22
  23 (defmvar $fortindent 0
  24   "The number of spaces (beyond 6) to indent Fortran statements as they
  25    are printed."
  26   fixnum
  27   modified-commands '$fortran
  28   :setting-predicate #'(lambda (val)
  29                          ;; The value must be non-negative fixnum
  30                          (and (fixnump val)
  31                               (>= val 0))))
  32
  33 ;; This function is called from Macsyma toplevel.  If the argument is a
  34 ;; symbol, and the symbol is bound to a matrix or list, then the value is printed
  35 ;; using an array assignment notation.
  36
  37 (defmspec $fortran (l)
  38   (setq l (fexprcheck l))
  39   (let ((value (strmeval l)))
  40     (cond ((msetqp l) (setq value `((mequal) ,(cadr l) ,(meval l)))))
  41     (cond ((and (symbolp l) (or ($matrixp value) ($listp value)))
  42            ($fortmx l value))
  43           ((and (not (atom value)) (eq (caar value) 'mequal)
  44                 (symbolp (cadr value)) (or ($matrixp (caddr value)) ($listp (caddr value))))
  45            ($fortmx (cadr value) (caddr value)))
  46           (t (fortran-print value)))))
  47
  48 ;; This function is called from Lisp programs.  It takes an expression and
  49 ;; a stream argument.  Default stream is *STANDARD-OUTPUT*.
  50 ;; $LOADPRINT is NIL to keep a message from being printed when the file containing MSTRING
  51 ;; is loaded.  (MRG;GRIND)
  52
  53 (defprop mexpt (#\* #\*) dissym)
  54
  55 (defun fortran-print (x &optional (stream *standard-output*))
  56   ;; Restructure the expression for displaying.
  57   (setq x (fortscan x))
  58
  59   ;; Linearize the expression using MSTRING.  Some global state must be
  60   ;; modified for MSTRING to generate using Fortran syntax.  This must be
  61   ;; undone so as not to modify the toplevel behavior of MSTRING.
  62   (unwind-protect
  63        (defprop mexpt msize-infix grind)
  64     (defprop mminus 100. lbp)
  65
  66     (defprop msetq (#\:) strsym)
  67     (let ((*fortran-print* t)
  68           (*read-default-float-format* 'single-float))
  69       ;; The above makes sure we an exponent marker for Fortran
  70       ;; numbers.
  71       (setq x (mstring x)))
  72     ;; Make sure this gets done before exiting this frame.
  73     (defprop mexpt msz-mexpt grind)
  74     (remprop 'mminus 'lbp))
  75
  76   ;; MSTRING returns a list of characters.   Now print them.
  77   (do ((c #.(char-int #\0)
  78           (+ 1 (rem (- c #.(char-int #\0)) 16) #.(char-int #\0)))
  79        (column (+ 6 $fortindent) (+ 9 $fortindent)))
  80       ((null x))
  81     ;; Print five spaces, a continuation character if needed, and then
  82     ;; more spaces.  COLUMN points to the last column printed in.  When
  83     ;; it equals 80, we should quit.
  84     (cond ((= c #.(char-int #\0))
  85            (print-spaces column stream))
  86           (t (print-spaces 5 stream)
  87              (write-char (code-char c) stream)
  88              (print-spaces (- column 6) stream)))
  89     ;; Print the expression.  Remember, Fortran ignores blanks and line
  90     ;; terminators, so we don't care where the expression is broken.
  91     (do ()
  92         ((= column 72.))
  93       (if (null x)
  94           (if $fortspaces (write-char #\space stream) (return nil))
  95           (progn
  96             (and (equal (car x) #\\) (setq x (cdr x)))
  97             (write-char (pop x) stream)))
  98       (incf column))
  99     ;; Columns 73 to 80 contain spaces
 100     (if $fortspaces (print-spaces 8 stream))
 101     (terpri stream))
 102   '$done)
 103
 104 (defun print-spaces (n stream)
 105   (dotimes (i n) (write-char #\space stream)))
 106
 107 ;; This function is similar to NFORMAT.  Prepare an expression
 108 ;; for printing by converting x^(1/2) to sqrt(x), etc.  A better
 109 ;; way of doing this would be to have a programmable printer and
 110 ;; not cons any new expressions at all.  Some of this formatting, such
 111 ;; as E^X --> EXP(X) is specific to Fortran, but why isn't the standard
 112 ;; function used for the rest?
 113
 114 (defun fortscan (e)
 115   (cond ((atom e) (cond ((eq e '$%i) '((mprogn) 0.0 1.0))
 116                         (t e)))         ;%I is (0,1)
 117         ((and (eq (caar e) 'mexpt) (eq (cadr e) '$%e))
 118          (list '(%exp simp) (fortscan (caddr e))))
 119         ((and (eq (caar e) 'mexpt) (alike1 (caddr e) 1//2))
 120          (list '(%sqrt simp) (fortscan (cadr e))))
 121         ((and (eq (caar e) 'mexpt) (alike1 (caddr e) -1//2))
 122          (list '(mquotient simp) 1 (list '(%sqrt simp) (fortscan (cadr e)))))
 123         ((and (eq (caar e) 'mtimes) (ratnump (cadr e))
 124               (member (cadadr e) '(1 -1) :test #'equal))
 125          (cond ((equal (cadadr e) 1) (fortscan-mtimes e))
 126                (t (list '(mminus simp) (fortscan-mtimes e)))))
 127         ((eq (caar e) 'rat)
 128          (list '(mquotient simp) (float (cadr e)) (float (caddr e))))
 129         ((eq (caar e) 'mrat) (fortscan (ratdisrep e)))
 130         ;;  complex numbers to f77 syntax a+b%i ==> (a,b)
 131         ((and (member (caar e) '(mtimes mplus) :test #'eq)
 132               (let ((a (simplify ($bothcoef e '$%i))))
 133                 (and (numberp (cadr a))
 134                      (numberp (caddr a))
 135                      (not (zerop1 (cadr a)))
 136                      (list '(mprogn) (caddr a) (cadr a))))))
 137         (t (cons (car e) (mapcar 'fortscan (cdr e))))))
 138
 139 (defun fortscan-mtimes (e)
 140   (list '(mquotient simp)
 141         (cond ((null (cdddr e)) (fortscan (caddr e)))
 142               (t (cons (car e) (mapcar 'fortscan (cddr e)))))
 143         (float (caddr (cadr e)))))
 144
 145 ;; Takes a name and a matrix and prints a sequence of Fortran assignment
 146 ;; statements of the form
 147 ;;  NAME(I,J) = <corresponding matrix element>
 148 ;; or, when the second argument is a list,
 149 ;;  NAME(I) = <list element>
 150
 151 (defmfun $fortmx (name mat &optional (stream *standard-output*) &aux ($loadprint nil))
 152   (cond ((not (symbolp name))
 153          (merror (intl:gettext "fortmx: first argument must be a symbol; found: ~M") name))
 154         ((not (or ($matrixp mat) ($listp mat)))
 155          (merror (intl:gettext "fortmx: second argument must be a list or matrix; found: ~M") mat)))
 156   (cond
 157     (($matrixp mat)
 158      (do ((mat (cdr mat) (cdr mat)) (i 1 (1+ i)))
 159        ((null mat))
 160        (do ((m (cdar mat) (cdr m)) (j 1 (1+ j)))
 161          ((null m))
 162          (fortran-print `((mequal) ((,name) ,i ,j) ,(car m)) stream))))
 163     (($listp mat)
 164      (do ((mat (cdr mat) (cdr mat)) (i 1 (1+ i)))
 165        ((null mat))
 166        (fortran-print `((mequal) ((,name) ,i) ,(car mat)) stream))))
 167   '$done)
 168
 169 ;; Local Modes:
 170 ;; Comment Column:26
 171 ;; End: