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:
171