src/grind.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 1981 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module grind)
  14
  15 (declare-top (special lop rop *grind-charlist* chrps $aliases linel))
  16
  17 (defun chrct* () (- linel chrps))
  18
  19 (defmspec $grind (x)
  20   (setq x (cdr x))
  21   (let (($lispdisp t) y)
  22     (fresh-line)
  23     (cond
  24       ((null x))
  25       ((cdr x) (mapc #'(lambda (xx) (funcall (get '$grind 'mfexpr*) `(($grind) ,xx))) x))
  26       ((or
  27          (symbolp (setq x (strmeval (car x))))
  28          (and (stringp x) (symbolp (getopr x))))
  29        (setq x ($verbify x))
  30        (cond ((setq y (mget x 'mexpr))
  31               (mgrind (list '(mdefine) (cons (list x) (cdadr y)) (caddr y)) nil))
  32              ((setq y (mget x 'mmacro))
  33               (mgrind (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y)) nil))
  34              ((setq y (mget x 'aexpr))
  35               (mgrind (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)) nil))
  36              (t (mgrind x nil)))
  37        (write-char #\$ nil) (write-char #\Newline nil))
  38       (t (mgrind x nil) (write-char #\$ nil) (write-char #\Newline nil)))
  39     '$done))
  40
  41 ;;Msize returns a list whose first member is the number of characters
  42 ;;in the printed representation of the rest of the list.
  43
  44 (defun i-$grind (x)
  45   (let (y)
  46     (fresh-line)
  47     (cond  ((symbolp (setq x (strmeval  x)))
  48             (setq x ($verbify x))
  49             (cond ((setq y (mget x 'mexpr))
  50                    (mgrind (list '(mdefine) (cons (list x) (cdadr y)) (caddr y)) nil))
  51                   ((setq y (mget x 'mmacro))
  52                    (mgrind (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y)) nil))
  53                   ((setq y (mget x 'aexpr))
  54                    (mgrind (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)) nil))
  55                   (t (mgrind x nil)))
  56             (write-char #\$ nil))
  57            (t (mgrind x nil) (write-char #\$ nil)))
  58     '$done))
  59
  60
  61 (defun mgrind (x out)
  62   (setq chrps 0)
  63   (mprint (msize x nil nil 'mparen 'mparen) out))
  64
  65 (defun mprint (x out)
  66   (cond ((characterp x)
  67          (incf chrps)
  68          (write-char x out))
  69         ((< (car x) (chrct*)) (mapc #'(lambda (l) (mprint l out)) (cdr x)))
  70         (t (prog (i) (setq i chrps)
  71                  (mprint (cadr x) out)
  72                  (cond ((null (cddr x)) (return nil))
  73                        ((and (or (atom (cadr x)) (< (caadr x) (chrct*)))
  74                              (or (> (chrct*) (truncate linel 2))
  75                                  (atom (caddr x)) (< (caaddr x) (chrct*))))
  76                         (setq i chrps)
  77                         (mprint (caddr x) out))
  78                        (t (setq i (1+ i)) (setq chrps 0) (terpri out)
  79                           (mtyotbsp i out) (mprint (caddr x) out)))
  80                  (do ((l (cdddr x) (cdr l))) ((null l))
  81                    (cond
  82                      ((or (atom (car l)) (< (caar l) (chrct*))) nil)
  83                      (t (setq chrps 0) (terpri out) (mtyotbsp i out)))
  84                    (mprint (car l) out))))))
  85
  86 (defun mtyotbsp (n out)
  87   (declare (fixnum n))
  88   (incf chrps n)
  89   (do () ((< n 1)) (write-char #\space out) (decf n)))
  90
  91 (defun strgrind (x)
  92   (let (*grind-charlist* (chrps 0))
  93     (strprint (msize x nil nil 'mparen 'mparen))
  94     (nreverse *grind-charlist*)))
  95
  96 (defun strprint (x)
  97   (cond ((atom x) (styo x))
  98         ((< (car x) (chrct*)) (mapc #'strprint (cdr x)))
  99         (t (prog (i)
 100               (setq i chrps)
 101               (strprint (cadr x))
 102               (cond ((null (cddr x)) (return nil))
 103                     ((and (or (atom (cadr x)) (< (caadr x) (chrct*)))
 104                           (or (> (chrct*) (truncate linel 2))
 105                               (atom (caddr x)) (< (caaddr x) (chrct*))))
 106                      (setq i chrps)
 107                      (strprint (caddr x)))
 108                     (t (setq i (1+ i)) (setq chrps 0) (sterpri)
 109                        (styotbsp i) (strprint (caddr x))))
 110               (do ((l (cdddr x) (cdr l))) ((null l))
 111                 (cond
 112                   ((or (atom (car l)) (< (caar l) (chrct*))) nil)
 113                   (t (setq chrps 0) (sterpri) (styotbsp i)))
 114                 (strprint (car l)))))))
 115
 116 (defun styo (x) (setq *grind-charlist* (cons x *grind-charlist*) chrps (1+ chrps)))
 117
 118 (defun sterpri () (setq *grind-charlist* (cons #\newline *grind-charlist*) chrps 0))
 119
 120 (defun styotbsp (n) (declare (fixnum n)) (setq chrps n)
 121        (do () ((< n 1)) (setq *grind-charlist* (cons #\space *grind-charlist*) n (1- n))))
 122
 123 (defun mstring (x)
 124   (nreverse (string1 (msize x nil nil 'mparen 'mparen) nil)))
 125
 126 (defun string1 (x l)
 127   (cond
 128     ((atom x) (cons x l))
 129     (t (setq x  (cdr x))
 130        (do () ((null x) l) (setq l (string1 (car x) l) x (cdr x))))))
 131
 132 (defun msize (x l r lop rop)
 133   (setq x (nformat-check x))
 134   (cond ((atom x) (msize-atom x l r))
 135         ((and (atom (car x)) (setq x (cons '(mprogn) x)) nil))
 136         ((or (<= (lbp (caar x)) (rbp lop)) (>= (lbp rop) (rbp (caar x))))
 137          (msize-paren x l r))
 138         ((member 'array (cdar x) :test #'eq) (msize-array x l r))
 139         ((safe-get (caar x) 'grind)
 140          (the #-ecl (values t) #+ecl t (funcall (get (caar x) 'grind) x l r)))
 141         (t (msize-function x l r nil))))
 142
 143 (defun msize-atom (x l r)
 144   (prog (y)
 145      (cond ((numberp x) (setq y (exploden x)))
 146            ((stringp x)
 147             (setq y (coerce x 'list))
 148             (do ((l y (cdr l))) ((null l))
 149               (cond ((member (car l) '(#\" #\\ ) :test #'equal)
 150                      (rplacd l (cons (car l) (cdr l)))
 151                      (rplaca l #\\ )
 152                      (setq l (cdr l)))))
 153             (setq y (cons #\" (nconc y (list #\")))))
 154            ((and (setq y (safe-get x 'reversealias))
 155                  (not (and (member x $aliases :test #'eq) (get x 'noun))))
 156             (setq y (exploden (stripdollar y))))
 157            ((null (setq y (exploden x))))
 158            ((safe-get x 'noun) (return (msize-atom (get x 'noun) l r)))
 159            ((char= #\$ (car y)) (setq y (slash (cdr y))))
 160            ((member (marray-type x) '(array hash-table $functional))
 161             (return (msize-array-object x l r)))
 162            (t (setq y (if $lispdisp (cons #\? (slash y)) (slash y)))))
 163      (return (msz y l r))))
 164
 165 (defun msz (x l r)
 166   (setq x (nreconc l (nconc x r))) (cons (length x) x))
 167
 168 (defun slash (x)
 169   (do ((l (cdr x) (cdr l))) ((null l))
 170     ; Following test is the same (except backslash is not included,
 171     ; so backslash is preceded by backslash) as in SCAN-TOKEN (src/nparse.lisp).
 172     (if (or (ascii-numberp (car l)) (alphabetp (car l)))
 173         nil
 174         (progn (rplacd l (cons (car l) (cdr l)))
 175                (rplaca l #\\) (setq l (cdr l)))))
 176   (if (alphabetp (car x)) x (cons #\\ x)))
 177
 178 ;;#-cl
 179 ;;(DEFUN ALPHANUMP (N) (DECLARE (FIXNUM N))
 180 ;;  (OR (ASCII-NUMBERP N) (ALPHABETP N)))
 181
 182 (defun msize-paren (x l r)
 183   (msize x (cons #\( l) (cons #\) r) 'mparen 'mparen))
 184
 185 ;; The variables LB and RB are not uses here syntactically, but for
 186 ;; communication.  The FORTRAN program rebinds them to #/( and #/) since
 187 ;; Fortran array references are printed with parens instead of brackets.
 188
 189 (defvar *lb* #\[)
 190 (defvar *rb* #\])
 191
 192 (defun msize-array (x l r &aux f)
 193   (if (eq (caar x) 'mqapply) (setq f (cadr x) x (cdr x)) (setq f (caar x)))
 194   (cond ((atom (car x)))
 195         ((and (symbolp (caar x)) (get (caar x) 'verb) (get (caar x) 'alias))
 196          (setq l (revappend '(#\' #\') l)))
 197         ((and (symbolp (caar x))
 198               (get (caar x) 'noun)
 199               (not (member (caar x) (cdr $aliases) :test #'eq))
 200               (not (get (caar x) 'reversealias)))
 201          (setq l (cons #\' l))))
 202   (setq l (msize f l (list *lb*) lop 'mfunction)
 203         r (msize-list (cdr x) nil (cons *rb* r)))
 204   (cons (+ (car l) (car r)) (cons l (cdr r))))
 205
 206 (defun msize-function (x l r op)
 207   (cond ((not (symbolp (caar x))))
 208         ((and (get (caar x) 'verb) (get (caar x) 'alias))
 209          (setq l (revappend '(#\' #\') l)))
 210         ((and (get (caar x) 'noun) (not (member (caar x) (cdr $aliases) :test #'eq))
 211               (not (get (caar x) 'reversealias)))
 212          (setq l (cons #\' l))))
 213   (setq l (msize (if op (getop (caar x)) (caar x)) l (ncons #\( ) 'mparen 'mparen)
 214         r (msize-list (cdr x) nil (cons #\) r)))
 215   (cons (+ (car l) (car r)) (cons l (cdr r))))
 216
 217 (defun msize-list (x l r)
 218   (if (null x) (msz nil l r)
 219       (do ((nl) (w 0))
 220           ((null (cdr x))
 221            (setq nl (cons (msize (car x) l r 'mparen 'mparen) nl))
 222            (cons (+ w (caar nl)) (nreverse nl)))
 223         (declare (fixnum w))
 224         (setq nl (cons (msize (car x) l (list #\,) 'mparen 'mparen) nl)
 225               w (+ w (caar nl)) x (cdr x) l nil))))
 226
 227 (defun msize-prefix (x l r)
 228   (msize (cadr x) (revappend (strsym (caar x)) l) r (caar x) rop))
 229
 230 (defun msize-infix (x l r)
 231   (if (not (= (length (cdr x)) 2))
 232     (return-from msize-infix (msize-function x l r t)))
 233   (setq l (msize (cadr x) l nil lop (caar x))
 234         r (msize (caddr x) (reverse (strsym (caar x))) r (caar x) rop))
 235   (list (+ (car l) (car r)) l r))
 236
 237 (defun msize-postfix (x l r)
 238   (msize (cadr x) l (append (strsym (caar x)) r) lop (caar x)))
 239
 240 (defun msize-nary (x l r) (msznary x l r (strsym (caar x))))
 241
 242 (defun msize-nofix (x l r) (msize (caar x) l r (caar x) rop))
 243
 244 (defun msize-matchfix (x l r)
 245   (setq l (nreconc l (car (strsym (caar x))))
 246         l (cons (length l) l)
 247         r (append (cdr (strsym (caar x))) r)
 248         x (msize-list (cdr x) nil r))
 249   (cons (+ (car l) (car x)) (cons l (cdr x))))
 250
 251 (defun msznary (x l r dissym)
 252   (cond ((null (cddr x)) (msize-function x l r t))
 253         (t (setq l (msize (cadr x) l nil lop (caar x)))
 254            (do ((ol (cddr x) (cdr ol)) (nl (list l)) (w (car l)))
 255                ((null (cdr ol))
 256                 (setq r (msize (car ol) (reverse dissym) r (caar x) rop))
 257                 (cons (+ (car r) w) (nreverse (cons r nl))))
 258              (declare (fixnum w))
 259              (setq nl (cons (msize (car ol) (reverse dissym) nil (caar x) (caar x))
 260                             nl)
 261                    w (+ (caar nl) w))))))
 262
 263 (defun strsym (x) (or (get x 'strsym) (get x 'dissym)))
 264
 265 (defprop bigfloat msz-bigfloat grind)
 266
 267 (defun msz-bigfloat (x l r)
 268   (msz (mapcar #'get-first-char (fpformat x)) l r))
 269
 270 (defprop mprogn msize-matchfix grind)
 271 (defprop mprogn ((#\( ) #\) ) strsym)
 272
 273 (defprop mlist msize-matchfix grind)
 274 (setf (get '%mlist 'grind) (get 'mlist 'grind))
 275
 276 ;;; ----------------------------------------------------------------------------
 277
 278 ;; Formating a mlabel-expression
 279
 280 (defprop mlabel msize-mlabel grind)
 281
 282 (defun msize-mlabel (x l r)
 283   (declare (special *display-labels-p*))
 284   (if *display-labels-p*
 285       (setq l (cons (msize (cadr x) (list #\( ) (list #\) #\ ) nil nil) l)))
 286   (msize (caddr x) l r lop rop))
 287
 288 ;;; ----------------------------------------------------------------------------
 289
 290 ;; Formating a mtext-expression
 291
 292 (defprop mtext msize-mtext grind)
 293
 294 (defun msize-mtext (x l r)
 295   (setq x (cdr x))
 296   (if (null x)
 297       (msz nil l r)
 298       (do ((nl) (w 0))
 299           ((null (cdr x))
 300            (setq nl (cons (if (stringp (car x))
 301                               (msz (makestring (car x)) l r)
 302                               (msize (car x) l r lop rop))
 303                           nl))
 304            (cons (+ w (caar nl)) (nreverse nl)))
 305         (setq nl (cons (if (stringp (car x))
 306                            (msz (makestring (car x)) l r)
 307                            (msize (car x) l r lop rop))
 308                        nl)
 309               w (+ w (caar nl))
 310               x (cdr x)
 311               l nil))))
 312
 313 (defprop mqapply msz-mqapply grind)
 314
 315 (defun msz-mqapply (x l r)
 316   (setq l (msize (cadr x) l (list #\( ) lop 'mfunction)
 317         r (msize-list (cddr x) nil (cons #\) r)))
 318   (cons (+ (car l) (car r)) (cons l (cdr r))))
 319
 320 ; SPACEOUT appears solely in trace output. See mtrace.lisp.
 321
 322 (defprop spaceout msize-spaceout grind)
 323
 324 (defun msize-spaceout (x ll r)
 325   (declare (ignore ll r))
 326   (let ((n (cadr x))
 327         l)
 328     (dotimes (i n)
 329       (push #\space l))
 330     (cons n l)))
 331
 332 (defprop mquote msize-prefix grind)
 333
 334 (defprop msetq msize-infix grind)
 335 (defprop msetq (#\:) strsym)
 336 (defprop msetq 180. lbp)
 337 (defprop msetq 20. rbp)
 338
 339 (defprop mset msize-infix grind)
 340 (defprop mset (#\: #\:) strsym)
 341 (defprop mset 180. lbp)
 342 (defprop mset 20. rbp)
 343
 344 ;;; ----------------------------------------------------------------------------
 345
 346 ;; Formating a mdefine or mdefmacro expression
 347
 348 (defprop mdefine msz-mdef grind)
 349 (defprop mdefine (#\: #\=) strsym)
 350 (defprop mdefine 180 lbp)
 351 (defprop mdefine  20 rbp)
 352
 353 (defprop mdefmacro msz-mdef grind)
 354 (defprop mdefmacro (#\: #\: #\=) strsym)
 355 (defprop mdefmacro 180 lbp)
 356 (defprop mdefmacro  20 rbp)
 357
 358 (defun msz-mdef (x l r)
 359   (setq l (msize (cadr x) l (copy-list (strsym (caar x))) lop (caar x))
 360         r (msize (caddr x) nil r (caar x) rop))
 361   (cond ((not (atom (cadr l)))
 362          ;; An expression like g(x):=x:
 363          ;;   left side  l = (6 (2 #\g #\( ) (4 #\x #\) #\: #\= ))
 364          ;;   right side r = (1 #\x )
 365          ;; the result is (7 (2 #\g #\( ) (4 #\x #\) #\: #\= ) (1 #\x ))
 366          (setq x (cons (- (car l) (caadr l)) (cddr l)))
 367          (if (and (not (atom (cadr r)))
 368                   (not (atom (caddr r)))
 369                   (< (+ (car l) (caadr r) (caaddr r)) linel))
 370              (setq x (nconc x (list (cadr r) (caddr r)))
 371                    r (cons (car r) (cdddr r))))
 372          (cons (+ (car l) (car r)) (cons (cadr l) (cons x (cdr r)))))
 373         (t
 374          ;; An expression like x f :=x or f x:=x, where f is a postfix or a
 375          ;; prefix operator. Example for a postfix operator:
 376          ;;   left side  l = (5 #\x #\space #\f #\: #\= )
 377          ;;   right side r = (1 #\x)
 378          ;; the result is (6 (5 #\x #\space #\f #\: #\=) (1 #\x))
 379          (cons (+ (car l) (car r)) (cons l (ncons r))))))
 380
 381 (defprop mfactorial msize-postfix grind)
 382 (defprop mfactorial 160. lbp)
 383
 384 (defprop mexpt msz-mexpt grind)
 385 (defprop mexpt 140. lbp)
 386 (defprop mexpt 139. rbp)
 387
 388 (defun msz-mexpt (x l r)
 389   (setq l (msize (cadr x) l nil lop 'mexpt)
 390         r (if (mmminusp (setq x (nformat-check (caddr x))))
 391               (msize (cadr x) (reverse '(#\^ #\-)) r 'mexpt rop)
 392               (msize x (list #\^) r 'mexpt rop)))
 393   (list (+ (car l) (car r)) l r))
 394
 395
 396 (defprop mncexpt msize-infix grind)
 397 (defprop mncexpt 140. lbp)
 398 (defprop mncexpt 139. rbp)
 399
 400 (defprop mnctimes msize-nary grind)
 401 (defprop mnctimes 130. lbp)
 402 (defprop mnctimes 129. rbp)
 403
 404 (defprop mtimes msz-mtimes grind)
 405 (defprop mtimes 120. lbp)
 406 (defprop mtimes 120. rbp)
 407
 408 (defun msz-mtimes (x l r) (msznary x l r '(#\*)))
 409
 410
 411 (defprop mquotient msize-infix grind)
 412 (defprop mquotient 120. lbp)
 413 (defprop mquotient 120. rbp)
 414 (defprop rat msize-infix grind)
 415 (defprop rat 120. lbp)
 416 (defprop rat 120. rbp)
 417
 418 (defprop mplus msz-mplus grind)
 419 (defprop mplus 100. lbp)
 420 (defprop mplus 100. rbp)
 421
 422 (defun msz-mplus (x l r)
 423   (cond ((null (cddr x))
 424          (if (null (cdr x))
 425              (msize-function x l r t)
 426              (msize (cadr x) (append (ncons #\+) l) r 'mplus rop)))
 427         (t (setq l (msize (cadr x) l nil lop 'mplus) x (cddr x))
 428            (do ((nl (list l)) (w (car l)) (dissym))
 429                ((null (cdr x))
 430                 (if (mmminusp (car x)) (setq l (cadar x) dissym (list #\-))
 431                     (setq l (car x) dissym (list #\+)))
 432                 (setq r (msize l dissym r 'mplus rop))
 433                 (cons (+ (car r) w) (nreverse (cons r nl))))
 434              (declare (fixnum w))
 435              (if (mmminusp (car x)) (setq l (cadar x) dissym (list #\-))
 436                  (setq l (car x) dissym (list #\+)))
 437              (setq nl (cons (msize l dissym nil 'mplus 'mplus) nl)
 438                    w (+ (caar nl) w)
 439                    x (cdr x))))))
 440
 441 (defprop mminus msize-mminus grind)
 442 (defprop mminus (#\-) strsym)
 443 (defprop mminus 100. rbp)
 444 (defprop mminus 100. lbp)
 445
 446 (defun msize-mminus (x l r)
 447   (cond ((null (cddr x))
 448          (if (null (cdr x))
 449              (msize-function x l r t)
 450              (msize (cadr x) (append (ncons #\- ) l) r 'mminus rop)))
 451         (t
 452          (setq l (msize (cadr x) l nil lop 'mminus)
 453                x (cddr x))
 454          (do ((nl (list l))
 455               (w (car l))
 456               (dissym))
 457              ((null (cdr x))
 458               (if (mmminusp (car x))
 459                   (setq l (cadar x) dissym (list #\+ ))
 460                   (setq l (car x) dissym (list #\- )))
 461               (setq r (msize l dissym r 'mminus rop))
 462               (cons (+ (car r) w) (nreverse (cons r nl))))
 463            (declare (fixnum w))
 464            (if (mmminusp (car x))
 465                (setq l (cadar x) dissym (list #\+ ))
 466                (setq l (car x) dissym (list #\- )))
 467            (setq nl (cons (msize l dissym nil 'mminus 'mminus) nl)
 468                  w (+ (caar nl) w)
 469                  x (cdr x))))))
 470
 471 (defprop mequal msize-infix grind)
 472 (defprop mequal 80. lbp)
 473 (defprop mequal 80. rbp)
 474
 475 (defprop mnotequal msize-infix grind)
 476 (defprop mnotequal 80. lbp)
 477 (defprop mnotequal 80. rbp)
 478
 479 (defprop mgreaterp msize-infix grind)
 480 (defprop mgreaterp 80. lbp)
 481 (defprop mgreaterp 80. rbp)
 482
 483 (defprop mgeqp msize-infix grind)
 484 (defprop mgeqp 80. lbp)
 485 (defprop mgeqp 80. rbp)
 486
 487 (defprop mlessp msize-infix grind)
 488 (defprop mlessp 80. lbp)
 489 (defprop mlessp 80. rbp)
 490
 491 (defprop mleqp msize-infix grind)
 492 (defprop mleqp 80. lbp)
 493 (defprop mleqp 80. rbp)
 494
 495 (defprop mnot msize-prefix grind)
 496 (defprop mnot 70. rbp)
 497
 498 (defprop mand msize-nary grind)
 499 (defprop mand 65. lbp)
 500 (defprop mand 65. rbp)
 501
 502 (defprop mor msize-nary grind)
 503 (defprop mor 60. lbp)
 504 (defprop mor 60. rbp)
 505
 506 (defprop mcond msz-mcond grind)
 507 (defprop mcond 45. lbp)
 508 (defprop mcond 45. rbp)
 509
 510 (defprop %mcond msz-mcond grind)
 511 (defprop %mcond 45. lbp)
 512 (defprop %mcond 45. rbp)
 513
 514 ;; See comments above DIM-MCOND in displa.lisp concerning MCOND parsing and formatting.
 515
 516 (defun msz-mcond (x l r)
 517   (let ((if (nreconc l '(#\i #\f #\space))))
 518     (setq if (cons (length if) if)
 519           l (msize (cadr x) nil nil 'mcond 'mparen))
 520
 521
 522     (let ((args (cdddr x))
 523           (else-literal (reverse (exploden " else ")))
 524           (elseif-literal (reverse (exploden " elseif ")))
 525           (then-literal (reverse (exploden " then ")))
 526           (parts)
 527           (part))
 528
 529       (let ((sgra (reverse args)))
 530         (if (and (or (eq (car sgra) nil) (eq (car sgra) '$false)) (eq (cadr sgra) t))
 531             (setq args (reverse (cddr sgra)))))
 532
 533       (setq parts (list if l))
 534
 535       (setq part (cond ((= (length args) 0)
 536                         `(,(msize (caddr x) (copy-tree then-literal) r 'mcond rop)))
 537                        (t
 538                         `(,(msize (caddr x) (copy-tree then-literal) nil 'mcond 'mparen))))
 539
 540             parts (append parts part))
 541
 542       (loop while (>= (length args) 2) do
 543            (let ((maybe-elseif (car args)) (else-or-then (cadr args)))
 544              (cond
 545                ((= (length args) 2)
 546                 (cond
 547                   ((eq maybe-elseif t)
 548                    (let ((else-arg else-or-then))
 549                      (setq
 550                       part `(,(msize else-arg (copy-tree else-literal) r 'mcond rop))
 551                       parts (append parts part))))
 552                   (t
 553                    (let ((elseif-arg maybe-elseif) (then-arg else-or-then))
 554                      (setq
 555                       part `(,(msize elseif-arg (copy-tree elseif-literal) nil 'mcond 'mparen)
 556                               ,(msize then-arg (copy-tree then-literal) r 'mcond rop))
 557                       parts (append parts part))))))
 558                (t
 559                 (let ((elseif-arg maybe-elseif) (then-arg else-or-then))
 560                   (setq
 561                    part `(,(msize elseif-arg (copy-tree elseif-literal) nil 'mcond 'mparen)
 562                            ,(msize then-arg (copy-tree then-literal) nil 'mcond 'mparen))
 563                    parts (append parts part))))))
 564
 565            (setq args (cddr args)))
 566
 567       (cons (apply '\+ (mapcar #'car parts)) parts))))
 568
 569 (defprop text-string msize-text-string grind)
 570
 571 (defun msize-text-string (x ll r)
 572   (declare (ignore ll r))
 573   (cons (length (cdr x)) (cdr x)))
 574
 575 (defprop mdo msz-mdo grind)
 576 (defprop mdo 25. lbp)
 577 (defprop mdo 25. rbp)
 578
 579 (defprop mdoin msz-mdoin grind)
 580 (defprop mdoin 30. lbp)
 581 (defprop mdoin 30. rbp)
 582
 583 (defprop %mdo msz-mdo grind)
 584 (defprop %mdo 25. lbp)
 585 (defprop %mdo 25. rbp)
 586
 587 (defprop %mdoin msz-mdoin grind)
 588 (defprop %mdoin 30. lbp)
 589 (defprop %mdoin 30. rbp)
 590
 591 (defun msz-mdo (x l r)
 592   (msznary (cons '(mdo) (strmdo x)) l r '(#\space)))
 593
 594 (defun msz-mdoin (x l r)
 595   (msznary (cons '(mdo) (strmdoin x)) l r '(#\space)))
 596
 597 (defun strmdo (x)
 598   (nconc (cond ((second x) `($for ,(second x))))
 599          (cond ((equal 1 (third x)) nil)
 600                ((third x)  `($from ,(third x))))
 601          (cond ((equal 1 (fourth x)) nil)
 602                ((fourth x) `($step ,(fourth x)))
 603                ((fifth x)  `($next ,(fifth x))))
 604          (cond ((sixth x)  `($thru ,(sixth x))))
 605          (cond ((null (seventh x)) nil)
 606                ((and (consp (seventh x)) (eq 'mnot (caar (seventh x))))
 607                 `($while ,(cadr (seventh x))))
 608                (t `($unless ,(seventh x))))
 609          `($do ,(eighth x))))
 610
 611 (defun strmdoin (x)
 612   (nconc `($for ,(second x) $in ,(third x))
 613          (cond ((sixth x) `($thru ,(sixth x))))
 614          (cond ((null (seventh x)) nil)
 615                ((and (consp (seventh x)) (eq 'mnot (caar (seventh x))))
 616                 `($while ,(cadr (seventh x))))
 617                (t `($unless ,(seventh x))))
 618          `($do ,(eighth x))))
 619
 620 (defprop mfunction 190. lbp)
 621 (defprop mfunction 190. rbp)