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