share/contrib/f90.lisp

   1 ;;;; f90.lisp -- Application command line argument retrieval
   2 ;;;;                      and processing for Common Lisp.
   3
   4 ;;;; Copyright (C) 2004 James F. Amundson
   5
   6 ;;;; f90.lisp is free software; you can redistribute it
   7 ;;;; and/or modify it under the terms of the GNU General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 2, or (at your option) any later version.
  10
  11 ;;;; f90.lisp is distributed in the hope that it will be
  12 ;;;; useful, but WITHOUT ANY WARRANTY; without even the implied
  13 ;;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14 ;;;; See the GNU General Public License for more details.
  15
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with f90.lisp; see the file COPYING.  If not,
  18 ;;;; write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA
  19
  20 ;;;; Based on fortra.lisp. Copyright statements for fortra.lisp follow:
  21 ;;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas
  22 ;;;;     All rights reserved
  23 ;;;;  (c) Copyright 1980 Massachusetts Institute of Technology
  24
  25 ;;;; Output from f90 is "free form": no special attention to columns.
  26 ;;;; Lines longer than *F90-OUTPUT-LINE-LENGTH-MAX* are broken with
  27 ;;;; trailing ampersand (no additional spaces).
  28
  29 ;;;; Commentary from the Texinfo for f90:
  30 ;;;; "The @code{f90} implementation was done as a quick hack.
  31 ;;;; It is not a necessarily a good example upon which to base
  32 ;;;; other language translations."
  33
  34 (in-package :maxima)
  35
  36 (macsyma-module f90)
  37
  38 (defmvar *f90-output-line-length-max* 65.)
  39
  40 (defvar $f90_output_line_length_max *f90-output-line-length-max*)
  41
  42 (progn
  43   (putprop '$f90_output_line_length_max '*f90-output-line-length-max* 'alias)
  44   (putprop '*f90-output-line-length-max* '$f90_output_line_length_max 'reversealias))
  45
  46 (defun f90-print (x
  47                   &aux
  48                   ;; This is a poor way of saying that array references
  49                   ;; are to be printed with parens instead of brackets.
  50                   (*lb* #\()
  51                   (*rb* #\)))
  52   ;; Restructure the expression for displaying.
  53   (setq x (fortscan x))
  54   ;; Linearize the expression using MSTRING.  Some global state must be
  55   ;; modified for MSTRING to generate using Fortran syntax.  This must be
  56   ;; undone so as not to modify the toplevel behavior of MSTRING.
  57   (unwind-protect
  58        (defprop mexpt msize-infix grind)
  59     (defprop mminus 100 lbp)
  60
  61     (defprop msetq (#\:) strsym)
  62     (let ((*fortran-print* t)
  63           (*read-default-float-format* 'single-float))
  64       ;; The above makes sure we an exponent marker for Fortran
  65       ;; numbers.
  66       (setq x (coerce (mstring x) 'string)))
  67     ;; Make sure this gets done before exiting this frame.
  68     (defprop mexpt msz-mexpt grind)
  69     (remprop 'mminus 'lbp))
  70
  71   (if (>= (length x) *f90-output-line-length-max*)
  72
  73     ;; Split this line and print it with trailing ampersand.
  74     ;; Previous scheme to break the lines nicely had some bugs;
  75     ;; it's simpler to break at a fixed length.
  76
  77     (let ((line x) (break-point *f90-output-line-length-max*))
  78       (princ (subseq line 0 break-point))
  79       (princ "&")
  80       (terpri)
  81       (princ "&")
  82       (setf line (subseq line break-point))
  83
  84       (loop while (> (length line) break-point) do
  85         (princ (subseq line 0 break-point))
  86         (princ "&")
  87         (terpri)
  88         (princ "&")
  89         (setf line (subseq line break-point)))
  90
  91       (if (> (length line) 0)
  92         (princ line)))
  93
  94     (princ x))
  95
  96   (terpri)
  97   '$done)
  98
  99 ;; Takes a name and a matrix and prints a sequence of F90 assignment
 100 ;; statements of the form
 101 ;;  NAME(I,J) = <corresponding matrix element>
 102 ;; or, when the second argument is a list,
 103 ;;  NAME(I) = <list element>
 104
 105 (defmfun $f90mx (name mat)
 106   (cond ((not (symbolp name))
 107          (merror "f90mx: first argument must be a symbol; found: ~M" name))
 108         ((not (or ($matrixp mat) ($listp mat)))
 109          (merror "f90mx: second argument must be a list or matrix; found: ~M" mat)))
 110   (cond
 111     (($matrixp mat)
 112      (do ((mat (cdr mat) (cdr mat)) (i 1 (1+ i)))
 113        ((null mat))
 114        (do ((m (cdar mat) (cdr m)) (j 1 (1+ j)))
 115          ((null m))
 116          (f90-print `((mequal) ((,name) ,i ,j) ,(car m))))))
 117     (($listp mat)
 118      (do ((mat (cdr mat) (cdr mat)) (i 1 (1+ i)))
 119        ((null mat))
 120        (f90-print `((mequal) ((,name) ,i) ,(car mat))))))
 121   '$done)
 122
 123 (defmspec $f90 (expr)
 124   (dolist (l (cdr expr))
 125   (let ((value (strmeval l)))
 126     (cond ((msetqp l) (setq value `((mequal) ,(cadr l) ,(meval l)))))
 127     (cond ((and (symbolp l) (or ($matrixp value) ($listp value)))
 128            ($f90mx l value))
 129           ((and (not (atom value)) (eq (caar value) 'mequal)
 130                 (symbolp (cadr value)) (or ($matrixp (caddr value)) ($listp (caddr value))))
 131            ($f90mx (cadr value) (caddr value)))
 132           (t (f90-print value))))))