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 1982 Massachusetts Institute of Technology         ;;;
9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
11(in-package :maxima)
12
13(macsyma-module mforma macro)
14
15;;; A mini version of FORMAT for macsyma error messages, and other
16;;; user interaction.
17;;; George J. Carrette - 10:59am  Tuesday, 21 October 1980
18
19;;; This file is used at compile-time for macsyma system code in general,
20;;; and also for MFORMT and MERROR.
21;;; Open-coding of MFORMAT is supported, as are run-time MFORMAT string
22;;; interpretation. In all cases syntax checking of the MFORMAT string
23;;; at compile-time is done.
24
25;;; For the prettiest output the normal mode here will be to
26;;; cons up items to pass as MTEXT forms.
27
28;;; Macro definitions for defining a format string interpreter.
29;;; N.B. All of these macros expand into forms which contain free
30;;; variables, i.e. they assume that they will be expanded in the
31;;; proper context of an MFORMAT-LOOP definition. It's a bit
32;;; ad-hoc, and not as clean as it should be.
33;;; (Macrofy DEFINE-AN-MFORMAT-INTERPRETER, and give the free variables
34;;; which are otherwise invisible, better names to boot.)
35
36;;; There are 3 definitions of MFORMAT.
37;;; [1] The interpreter.
38;;; [2] The compile-time syntax checker.
39;;; [3] The open-compiler.
40
41;; Some commentary as to what the hell is going on here would be greatly
42;; appreciated.  This is probably very elegant code, but I can't figure
43;; it out. -cwh
44;; This is macros defining macros defining function bodies man.
45;; top-level side-effects during macroexpansion consing up shit
46;; for an interpreter loop. I only do this to save address space (sort of
47;; kidding.) -gjc
48
49(defmacro +def-mformat-var (type var val init-condition)
50  (push (list var val)
51	(cdr (or (assoc init-condition (get type 'mformat-state-vars))
52		 (car (push (ncons init-condition)
53			    (get type 'mformat-state-vars))))))
54  `',var)
55
56(defmacro +def-mformat-op (type char &rest body) ;; can also be a list of CHAR's
57  (when (atom char)
58    (setq char (list char)))
59  (push (cons char body) (get type 'mformat-ops))
60  `',(maknam (nconc (exploden (symbol-name '#:mformat-)) (mapcar #'ascii char))))
61
62(defmacro pop-mformat-arg ()
63  `(cond ((= arg-index n)
64	  (maxima-error "POP-MFORMAT-ARG: ran out of mformat args ~a" (listify n)))
65	 (t
66	  (incf arg-index)
67	  (arg arg-index))))
68
69(defmacro leftover-mformat-args? () ;; To be called after we are done.
70  '(unless (= arg-index n)
71     (maxima-error "LEFTOVER-MFORMAT-ARGS?: extra mformat args ~a" (listify n))))
72
73(defmacro bind-mformat-state-vars (type &rest body)
74  `(let ,(do ((l nil)
75	      (v (get type 'mformat-state-vars) (cdr v)))
76	     ((null v) l)
77	     (do ((conds (cdr (car v)) (cdr conds)))
78		 ((null conds))
79	       (push (car conds) l)))
80    ,@body))
81
82(defmacro pop-mformat-string ()
83  '(if (null sstring)
84    (maxima-error "POP-MFORMAT-STRING: 'mformat' string already exhausted.")
85    (pop sstring)))
86
87(defmacro null-mformat-string ()
88  '(null sstring))
89
90(defmacro top-mformat-string ()
91  '(if (null sstring)
92    (maxima-error "TOP-MFORMAT-STRING: 'mformat' string already exhausted.")
93    (car sstring)))
94
95(defmacro cdr-mformat-string ()
96  `(setq sstring (cdr sstring)))
97
98(defmacro mformat-dispatch-on-char (type)
99  `(progn
100     (cond ,@(mapcar #'(lambda (pair)
101			 `(,(if (atom (car pair))
102				`(char-equal char ,(car pair))
103				`(or ,@(mapcar
104					#'(lambda (c)  `(char-equal char ,c))
105					(car pair))))
106			    ,@(cdr pair)))
107		     (get type 'mformat-ops))
108	   ;; perhaps optimize the COND to use ">" "<".
109	   (t
110	    (maxima-error "MFORMAT-DISPATCH-ON-CHAR: unknown format op. _~a_ ~a" ',type (ascii char))))
111    ,@(mapcar #'(lambda (state)
112		  `(if ,(car state)
113		    (setq ,@(apply #'append (cdr state)))))
114	      (get type 'mformat-state-vars))))
115
116
117(defmacro white-space-p (x)
118  `(member ,x '(#\linefeed #\return #\space #\tab #\page
119		#-(or clisp gcl openmcl abcl) #\vt
120		#+clisp #\code11)
121    :test #'char=))
122
123
124(defmacro +mformat-loop (type &rest end-code)
125  `(bind-mformat-state-vars ,type
126    (do ((char))
127	((null-mformat-string)
128	 (leftover-mformat-args?)
129	 ,@end-code)
130      (setq char (pop sstring))
131      (cond ((char= char #\~)
132	     (do ()
133		 (nil)
134	       (setq char (pop-mformat-string))
135	       (cond ((char= char #\@)
136		      (setq |@-FLAG| t))
137		     ((char= char #\:)
138		      (setq |:-FLAG| t))
139		     ((char= char #\~)
140		      (push char text-temp)
141		      (return nil))
142		     ((white-space-p char)
143		      (do ()
144			  ((not (white-space-p (top-mformat-string))))
145			(cdr-mformat-string))
146		      (return nil))
147		     ((or (char< char #\0) (char> char #\9))
148		      (mformat-dispatch-on-char ,type)
149		      (return nil))
150		     (t
151		      (setq parameter (+ (- (char-code char) (char-code #\0))
152					 (* 10. parameter))
153			    parameter-p t)))))
154
155	    (t
156	     (push char text-temp))))))
157
158;;; The following definitions of MFORMAT ops are for compile-time,
159;;; the runtime definitions are in MFORMT.
160
161(defvar *want-open-compiled-mformat* nil)
162(defvar *cant-open-compile-mformat* nil)
163
164(setf (get '-c 'mformat-ops) nil)
165(setf (get '-c 'mformat-state-vars) nil)
166
167(defmacro def-mformat-op-c (char &rest body)
168  `(+def-mformat-op ,'-c ,char ,@body))
169
170(defmacro def-mformat-var-c (var val init)
171  `(+def-mformat-var ,'-c ,var ,val ,init))
172
173(defmacro mformat-loop-c (&rest endcode)
174  `(+mformat-loop ,'-c ,@endcode))
175
176(def-mformat-var-c |:-FLAG| nil t)
177(def-mformat-var-c |@-FLAG| nil t)
178(def-mformat-var-c parameter 0  t)
179(def-mformat-var-c parameter-p nil t)
180(def-mformat-var-c text-temp nil nil)
181(def-mformat-var-c code nil nil)
182
183(defmacro emitc (x)
184  `(push ,x code))
185
186(defmacro push-text-temp-c ()
187  '(and text-temp
188    (progn
189      (emitc `(princ ',(maknam (nreverse text-temp)) ,stream))
190      (setq text-temp nil))))
191
192(def-mformat-op-c (#\% #\&)
193    (cond (*want-open-compiled-mformat*
194	   (push-text-temp-c)
195	   (if (char= char #\&)
196	       (emitc `(fresh-line ,stream))
197	       (emitc `(terpri ,stream))))))
198
199(def-mformat-op-c #\M
200    (cond (*want-open-compiled-mformat*
201	   (push-text-temp-c)
202	   (emitc `(,(if |:-FLAG| 'mgrind 'displaf)
203		    (,(if |@-FLAG| 'getop 'progn)
204		     ,(pop-mformat-arg))
205		    ,stream)))
206	  (t (pop-mformat-arg))))
207
208(def-mformat-op-c (#\A #\S)
209    (cond (*want-open-compiled-mformat*
210	   (push-text-temp-c)
211	   (emitc `(,(if (char-equal char #\A) 'princ 'prin1)
212		    ,(pop-mformat-arg)
213		    ,stream)))
214	  (t (pop-mformat-arg))))
215
216(defun optimize-print-inst (l)
217  ;; Should remove extra calls to TERPRI around DISPLA.
218  ;; Mainly want to remove (PRINC FOO NIL) => (PRINC FOO)
219  ;; although I'm not sure this is correct. geezz.
220  (do ((new nil))
221      ((null l) `(progn ,@new))
222    (let ((a (pop l)))
223      (cond ((eq (car a) 'terpri)
224	     (if (eq (cadr a) nil)
225		 (push '(terpri) new)
226		 (push a new)))
227	    ((and (eq (caddr a) nil)
228		  (not (eq (car a) 'mgrind)))
229	     (if (eq (car a) 'displaf)
230	         (push `(displa ,(cadr a)) new)
231		 (push `(,(car a) ,(cadr a)) new)))
232	    (t
233	     (push a new))))))
234
235(defun-maclisp mformat-translate-open n
236  (let ((stream (arg 1))
237	(sstring (exploden (arg 2)))
238	(*want-open-compiled-mformat* t)
239	(*cant-open-compile-mformat* nil)
240	(arg-index 2))
241    (mformat-loop-c
242     (progn
243       (push-text-temp-c)
244       (when *cant-open-compile-mformat*
245	 (maxima-error "MFORMAT-TRANSLATE-OPEN: can't open compile 'mformat' on this case: ~a" (listify n)))
246       (optimize-print-inst code)))))
247
248
249(defmacro mformat-open (stream sstring &rest other-shit)
250  (if (not (stringp sstring))
251      (maxima-error "MFORMAT-OPEN: ~a is not a string, can't open-compile the 'mformat' call." sstring)
252      (apply #'mformat-translate-open stream sstring other-shit)))
253
254(defmacro mtell-open (message &rest other-shit)
255  `(mformat-open nil ,message ,@other-shit))
256