src/mforma.lisp

   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))