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