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 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 flexibilty 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 t))
140	(displa object))))
141
142(defun mtell (&rest l)
143  (apply #'mformat nil l))
144