src/mformt.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 1981 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module mformt)
  14
  15 (load-macsyma-macros mforma)
  16
  17 (setf (get '|| 'mformat-ops) nil)
  18 (setf (get '|| 'mformat-state-vars) nil)
  19
  20 (defmacro def-mformat-op (char &rest body)
  21   `(+def-mformat-op ,'|| ,char ,@body))
  22
  23 (defmacro def-mformat-var (var val init)
  24   `(+def-mformat-var ,'|| ,var ,val ,init))
  25
  26 (defmacro mformat-loop (&rest endcode)
  27   `(+mformat-loop ,'|| ,@endcode))
  28
  29 (def-mformat-var |:-FLAG| nil t)
  30 (def-mformat-var |@-FLAG| nil t)
  31 (def-mformat-var parameter 0 t) ; Who can read "~33,34,87A" ?
  32 (def-mformat-var parameter-p nil t)
  33 (def-mformat-var text nil nil)
  34 (def-mformat-var text-temp nil nil)
  35 (def-mformat-var displa-p nil nil)
  36 (def-mformat-var pre-%-p nil nil)
  37 (def-mformat-var post-%-p nil nil)
  38
  39 (defmacro push-text-temp ()
  40   '(when text-temp
  41      (push (cons '(text-string) (nreverse text-temp)) text)
  42      (setq text-temp nil)))
  43
  44 (defmacro output-text ()
  45   '(progn
  46     (push-text-temp)
  47     (output-text* stream text displa-p pre-%-p post-%-p)
  48     (setq text nil
  49      displa-p nil
  50      pre-%-p nil
  51      post-%-p nil)))
  52
  53 (def-mformat-op (#\% #\&)
  54     (cond ((or text text-temp) ;; there is text to output.
  55            (setq post-%-p t)
  56            (output-text))
  57           (t
  58            (setq pre-%-p t))))
  59
  60 (def-mformat-op #\M
  61     (push-text-temp)
  62   (let ((arg (pop-mformat-arg)))
  63     (and |@-FLAG| (atom arg)
  64          (setq arg (or (and (symbolp arg) (get arg 'op)) arg)))
  65     (cond (|:-FLAG|
  66            (push (cons '(text-string) (mstring arg)) text))
  67           (t
  68            (setq displa-p t)
  69            (push arg text)))))
  70
  71 (def-mformat-op #\A
  72     (push-text-temp)
  73   (push (cons '(text-string) (exploden (pop-mformat-arg))) text))
  74
  75 (def-mformat-op #\S
  76     (push-text-temp)
  77   (push (cons '(text-string)
  78               (mapl #'(lambda (c)
  79                         (rplaca c (get-first-char (car c))))
  80                     (explode (pop-mformat-arg))))
  81         text))
  82
  83 (defun-maclisp mformat n
  84   (unless (> n 1)
  85     ;; make error message without new symbols.
  86     ;; This error should not happen in compiled code because
  87     ;; this check is done at compile time too.
  88     (maxima-error "MFORMAT: expected two or more arguments."))
  89   (let* ((stream (arg 1))
  90          (sstring (exploden (arg 2)))
  91          (arg-index 2))
  92     (when (or (null stream) (eq t stream))
  93       (setq stream *standard-output*))
  94     ;; This is all done via macros to save space,
  95     ;; (No functions, no special variable symbols.)
  96     ;; If the lack of flexibility becomes an issue then
  97     ;; it can be changed easily.
  98     (mformat-loop (output-text))
  99     ;; Keep from getting bitten by buffering.
 100     (finish-output stream)))
 101
 102 ;;can't change mformat since there are various places where stream = nil means
 103 ;; standard output not a string
 104 ;;note: compile whole file, incremental compiling will not work.
 105
 106 ;; AFORMAT
 107 ;;
 108 ;; Basically the same as MFORMAT, which is a "souped-up" FORMAT implementation
 109 ;; with support for the ~M control string. However, unlike MFORMAT, when
 110 ;; DESTINATION is NIL, the function writes its result to a string.
 111 (defun aformat (destination control-string &rest arguments)
 112   (if destination
 113       (apply 'mformat destination control-string arguments)
 114       (with-output-to-string (st)
 115                              (let ((*standard-output* st))
 116                                (apply 'mformat t control-string arguments)))))
 117
 118 (defun output-text* (stream text displa-p pre-%-p post-%-p)
 119   (setq text (nreverse text))
 120   ;; outputs a META-LINE of text.
 121   (cond (displa-p (displaf (cons '(mtext) text) stream))
 122         (t
 123          (if pre-%-p (terpri stream))
 124          (do ()
 125              ((null text))
 126            (do ((l (cdr (pop text)) (cdr l)))
 127                ((null l))
 128              (write-char (car l) stream)))
 129          (if post-%-p (terpri stream)))))
 130
 131 (defun-prop (text-string dimension) (form result)
 132   (dimension-atom (maknam (cdr form)) result))
 133
 134 (defun displaf (object stream)
 135   ;; for DISPLA to a file.
 136   (if (or (eq stream nil) (eq stream *standard-output*))
 137       (displa object)
 138       (let ((*standard-output* stream)
 139             ($ttyoff nil))
 140         (displa object))))
 141
 142 (defun mtell (&rest l)
 143   (apply #'mformat nil l))