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