src/grind.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   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))
  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 ;; Formatting a mlabel-expression
 279
 280 (defprop mlabel msize-mlabel grind)
 281
 282 (defun msize-mlabel (x l r)
 283   (if *display-labels-p*
 284       (setq l (cons (msize (cadr x) (list #\( ) (list #\) #\ ) nil nil) l)))
 285   (msize (caddr x) l r lop rop))
 286
 287 ;;; ----------------------------------------------------------------------------
 288
 289 ;; Formatting a mtext-expression
 290
 291 (defprop mtext msize-mtext grind)
 292
 293 (defun msize-mtext (x l r)
 294   (setq x (cdr x))
 295   (if (null x)
 296       (msz nil l r)
 297       (do ((nl) (w 0))
 298           ((null (cdr x))
 299            (setq nl (cons (if (stringp (car x))
 300                               (msz (makestring (car x)) l r)
 301                               (msize (car x) l r lop rop))
 302                           nl))
 303            (cons (+ w (caar nl)) (nreverse nl)))
 304         (setq nl (cons (if (stringp (car x))
 305                            (msz (makestring (car x)) l r)
 306                            (msize (car x) l r lop rop))
 307                        nl)
 308               w (+ w (caar nl))
 309               x (cdr x)
 310               l nil))))
 311
 312 (defprop mqapply msz-mqapply grind)
 313
 314 (defun msz-mqapply (x l r)
 315   (setq l (msize (cadr x) l (list #\( ) lop 'mfunction)
 316         r (msize-list (cddr x) nil (cons #\) r)))
 317   (cons (+ (car l) (car r)) (cons l (cdr r))))
 318
 319 ; SPACEOUT appears solely in trace output. See mtrace.lisp.
 320
 321 (defprop spaceout msize-spaceout grind)
 322
 323 (defun msize-spaceout (x ll r)
 324   (declare (ignore ll r))
 325   (let ((n (cadr x))
 326         l)
 327     (dotimes (i n)
 328       (push #\space l))
 329     (cons n l)))
 330
 331 (defprop mquote msize-prefix grind)
 332
 333 (defprop msetq msize-infix grind)
 334 (defprop msetq (#\:) strsym)
 335 (defprop msetq 180. lbp)
 336 (defprop msetq 20. rbp)
 337
 338 (defprop mset msize-infix grind)
 339 (defprop mset (#\: #\:) strsym)
 340 (defprop mset 180. lbp)
 341 (defprop mset 20. rbp)
 342
 343 ;;; ----------------------------------------------------------------------------
 344
 345 ;; Formatting a mdefine or mdefmacro expression
 346
 347 (defprop mdefine msz-mdef grind)
 348 (defprop mdefine (#\: #\=) strsym)
 349 (defprop mdefine 180 lbp)
 350 (defprop mdefine  20 rbp)
 351
 352 ;; copy binding powers to nounified operator
 353 (setf (get '%mdefine 'lbp) (get 'mdefine 'lbp))
 354 (setf (get '%mdefine 'rbp) (get 'mdefine 'rbp))
 355
 356 (defprop mdefmacro msz-mdef grind)
 357 (defprop mdefmacro (#\: #\: #\=) strsym)
 358 (defprop mdefmacro 180 lbp)
 359 (defprop mdefmacro  20 rbp)
 360
 361 ;; copy binding powers to nounified operator
 362 (setf (get '%mdefmacro 'lbp) (get 'mdefmacro 'lbp))
 363 (setf (get '%mdefmacro 'rbp) (get 'mdefmacro 'rbp))
 364
 365 (defun msz-mdef (x l r)
 366   (setq l (msize (cadr x) l (copy-list (strsym (caar x))) lop (caar x))
 367         r (msize (caddr x) nil r (caar x) rop))
 368   (cond ((not (atom (cadr l)))
 369          ;; An expression like g(x):=x:
 370          ;;   left side  l = (6 (2 #\g #\( ) (4 #\x #\) #\: #\= ))
 371          ;;   right side r = (1 #\x )
 372          ;; the result is (7 (2 #\g #\( ) (4 #\x #\) #\: #\= ) (1 #\x ))
 373          (setq x (cons (- (car l) (caadr l)) (cddr l)))
 374          (if (and (not (atom (cadr r)))
 375                   (not (atom (caddr r)))
 376                   (< (+ (car l) (caadr r) (caaddr r)) $linel))
 377              (setq x (nconc x (list (cadr r) (caddr r)))
 378                    r (cons (car r) (cdddr r))))
 379          (cons (+ (car l) (car r)) (cons (cadr l) (cons x (cdr r)))))
 380         (t
 381          ;; An expression like x f :=x or f x:=x, where f is a postfix or a
 382          ;; prefix operator. Example for a postfix operator:
 383          ;;   left side  l = (5 #\x #\space #\f #\: #\= )
 384          ;;   right side r = (1 #\x)
 385          ;; the result is (6 (5 #\x #\space #\f #\: #\=) (1 #\x))
 386          (cons (+ (car l) (car r)) (cons l (ncons r))))))
 387
 388 (defprop mfactorial msize-postfix grind)
 389 (defprop mfactorial 160. lbp)
 390 (defprop mfactorial 159. rbp)
 391
 392 (defprop mexpt msz-mexpt grind)
 393 (defprop mexpt 140. lbp)
 394 (defprop mexpt 139. rbp)
 395
 396 (defun msz-mexpt (x l r)
 397   (setq l (msize (cadr x) l nil lop 'mexpt)
 398         r (if (mmminusp (setq x (nformat-check (caddr x))))
 399               (msize (cadr x) (reverse '(#\^ #\-)) r 'mexpt rop)
 400               (msize x (list #\^) r 'mexpt rop)))
 401   (list (+ (car l) (car r)) l r))
 402
 403
 404 (defprop mncexpt msize-infix grind)
 405 (defprop mncexpt 140. lbp)
 406 (defprop mncexpt 139. rbp)
 407
 408 (defprop mnctimes msize-nary grind)
 409 (defprop mnctimes 130. lbp)
 410 (defprop mnctimes 129. rbp)
 411
 412 (defprop mtimes msz-mtimes grind)
 413 (defprop mtimes 120. lbp)
 414 (defprop mtimes 120. rbp)
 415
 416 (defun msz-mtimes (x l r) (msznary x l r '(#\*)))
 417
 418
 419 (defprop mquotient msize-infix grind)
 420 (defprop mquotient 120. lbp)
 421 (defprop mquotient 120. rbp)
 422 (defprop rat msize-infix grind)
 423 (defprop rat 120. lbp)
 424 (defprop rat 120. rbp)
 425
 426 (defprop mplus msz-mplus grind)
 427 (defprop mplus 100. lbp)
 428 (defprop mplus 100. rbp)
 429
 430 (defun msz-mplus (x l r)
 431   (cond ((null (cddr x))
 432          (if (null (cdr x))
 433              (msize-function x l r t)
 434              (msize (cadr x) (append (ncons #\+) l) r 'mplus rop)))
 435         (t (setq l (msize (cadr x) l nil lop 'mplus) x (cddr x))
 436            (do ((nl (list l)) (w (car l)) (dissym))
 437                ((null (cdr x))
 438                 (if (mmminusp (car x)) (setq l (cadar x) dissym (list #\-))
 439                     (setq l (car x) dissym (list #\+)))
 440                 (setq r (msize l dissym r 'mplus rop))
 441                 (cons (+ (car r) w) (nreverse (cons r nl))))
 442              (declare (fixnum w))
 443              (if (mmminusp (car x)) (setq l (cadar x) dissym (list #\-))
 444                  (setq l (car x) dissym (list #\+)))
 445              (setq nl (cons (msize l dissym nil 'mplus 'mplus) nl)
 446                    w (+ (caar nl) w)
 447                    x (cdr x))))))
 448
 449 (defprop mminus msize-mminus grind)
 450 (defprop mminus (#\-) strsym)
 451 (defprop mminus 134. rbp)
 452 (defprop mminus 100. lbp)
 453
 454 (defun msize-mminus (x l r)
 455   (cond ((null (cddr x))
 456          (if (null (cdr x))
 457              (msize-function x l r t)
 458              (msize (cadr x) (append (ncons #\- ) l) r 'mminus rop)))
 459         (t
 460          (setq l (msize (cadr x) l nil lop 'mminus)
 461                x (cddr x))
 462          (do ((nl (list l))
 463               (w (car l))
 464               (dissym))
 465              ((null (cdr x))
 466               (if (mmminusp (car x))
 467                   (setq l (cadar x) dissym (list #\+ ))
 468                   (setq l (car x) dissym (list #\- )))
 469               (setq r (msize l dissym r 'mminus rop))
 470               (cons (+ (car r) w) (nreverse (cons r nl))))
 471            (declare (fixnum w))
 472            (if (mmminusp (car x))
 473                (setq l (cadar x) dissym (list #\+ ))
 474                (setq l (car x) dissym (list #\- )))
 475            (setq nl (cons (msize l dissym nil 'mminus 'mminus) nl)
 476                  w (+ (caar nl) w)
 477                  x (cdr x))))))
 478
 479 (defprop mequal msize-infix grind)
 480 (defprop mequal 80. lbp)
 481 (defprop mequal 80. rbp)
 482
 483 (defprop mnotequal msize-infix grind)
 484 (defprop mnotequal 80. lbp)
 485 (defprop mnotequal 80. rbp)
 486
 487 (defprop mgreaterp msize-infix grind)
 488 (defprop mgreaterp 80. lbp)
 489 (defprop mgreaterp 80. rbp)
 490
 491 (defprop mgeqp msize-infix grind)
 492 (defprop mgeqp 80. lbp)
 493 (defprop mgeqp 80. rbp)
 494
 495 (defprop mlessp msize-infix grind)
 496 (defprop mlessp 80. lbp)
 497 (defprop mlessp 80. rbp)
 498
 499 (defprop mleqp msize-infix grind)
 500 (defprop mleqp 80. lbp)
 501 (defprop mleqp 80. rbp)
 502
 503 (defprop mnot msize-prefix grind)
 504 (defprop mnot 70. rbp)
 505
 506 (defprop mand msize-nary grind)
 507 (defprop mand 65. lbp)
 508 (defprop mand 65. rbp)
 509
 510 (defprop mor msize-nary grind)
 511 (defprop mor 60. lbp)
 512 (defprop mor 60. rbp)
 513
 514 (defprop mcond msz-mcond grind)
 515 (defprop mcond 45. lbp)
 516 (defprop mcond 45. rbp)
 517
 518 (defprop %mcond msz-mcond grind)
 519 (defprop %mcond 45. lbp)
 520 (defprop %mcond 45. rbp)
 521
 522 ;; See comments above DIM-MCOND in displa.lisp concerning MCOND parsing and formatting.
 523
 524 (defun msz-mcond (x l r)
 525   (let ((if (nreconc l '(#\i #\f #\space))))
 526     (setq if (cons (length if) if)
 527           l (msize (cadr x) nil nil 'mcond 'mparen))
 528
 529
 530     (let ((args (cdddr x))
 531           (else-literal (reverse (exploden " else ")))
 532           (elseif-literal (reverse (exploden " elseif ")))
 533           (then-literal (reverse (exploden " then ")))
 534           (parts)
 535           (part))
 536
 537       (let ((sgra (reverse args)))
 538         (if (and (or (eq (car sgra) nil) (eq (car sgra) '$false)) (eq (cadr sgra) t))
 539             (setq args (reverse (cddr sgra)))))
 540
 541       (setq parts (list if l))
 542
 543       (setq part (cond ((= (length args) 0)
 544                         `(,(msize (caddr x) (copy-tree then-literal) r 'mcond rop)))
 545                        (t
 546                         `(,(msize (caddr x) (copy-tree then-literal) nil 'mcond 'mparen))))
 547
 548             parts (append parts part))
 549
 550       (loop while (>= (length args) 2) do
 551            (let ((maybe-elseif (car args)) (else-or-then (cadr args)))
 552              (cond
 553                ((= (length args) 2)
 554                 (cond
 555                   ((eq maybe-elseif t)
 556                    (let ((else-arg else-or-then))
 557                      (setq
 558                       part `(,(msize else-arg (copy-tree else-literal) r 'mcond rop))
 559                       parts (append parts part))))
 560                   (t
 561                    (let ((elseif-arg maybe-elseif) (then-arg else-or-then))
 562                      (setq
 563                       part `(,(msize elseif-arg (copy-tree elseif-literal) nil 'mcond 'mparen)
 564                               ,(msize then-arg (copy-tree then-literal) r 'mcond rop))
 565                       parts (append parts part))))))
 566                (t
 567                 (let ((elseif-arg maybe-elseif) (then-arg else-or-then))
 568                   (setq
 569                    part `(,(msize elseif-arg (copy-tree elseif-literal) nil 'mcond 'mparen)
 570                            ,(msize then-arg (copy-tree then-literal) nil 'mcond 'mparen))
 571                    parts (append parts part))))))
 572
 573            (setq args (cddr args)))
 574
 575       (cons (apply '\+ (mapcar #'car parts)) parts))))
 576
 577 (defprop text-string msize-text-string grind)
 578
 579 (defun msize-text-string (x ll r)
 580   (declare (ignore ll r))
 581   (cons (length (cdr x)) (cdr x)))
 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 (defprop %mdo msz-mdo grind)
 592 (defprop %mdo 25. lbp)
 593 (defprop %mdo 25. rbp)
 594
 595 (defprop %mdoin msz-mdoin grind)
 596 (defprop %mdoin 30. lbp)
 597 (defprop %mdoin 30. rbp)
 598
 599 (defun msz-mdo (x l r)
 600   (msznary (cons '(mdo) (strmdo x)) l r '(#\space)))
 601
 602 (defun msz-mdoin (x l r)
 603   (msznary (cons '(mdo) (strmdoin x)) l r '(#\space)))
 604
 605 (defun strmdo (x)
 606   (nconc (cond ((second x) `($for ,(second x))))
 607          (cond ((equal 1 (third x)) nil)
 608                ((third x)  `($from ,(third x))))
 609          (cond ((equal 1 (fourth x)) nil)
 610                ((fourth x) `($step ,(fourth x)))
 611                ((fifth x)  `($next ,(fifth x))))
 612          (cond ((sixth x)  `($thru ,(sixth x))))
 613          (cond ((null (seventh x)) nil)
 614                ((and (consp (seventh x)) (eq 'mnot (caar (seventh x))))
 615                 `($while ,(cadr (seventh x))))
 616                (t `($unless ,(seventh x))))
 617          `($do ,(eighth x))))
 618
 619 (defun strmdoin (x)
 620   (nconc `($for ,(second x) $in ,(third x))
 621          (cond ((sixth x) `($thru ,(sixth x))))
 622          (cond ((null (seventh x)) nil)
 623                ((and (consp (seventh x)) (eq 'mnot (caar (seventh x))))
 624                 `($while ,(cadr (seventh x))))
 625                (t `($unless ,(seventh x))))
 626          `($do ,(eighth x))))
 627
 628 (defprop mfunction 190. lbp)
 629 (defprop mfunction 190. rbp)