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 displm macro)
14
15(declare-top
16 ;; evaluate for declarations
17 (special
18  ^w			;If T, then no output goes to the console.
19  linel			;Width of screen.
20  ttyheight		;Height of screen.
21
22  width height depth maxht maxdp level size lop rop break right
23  bkpt bkptwd bkptht bkptdp bkptlevel bkptout lines
24  oldrow oldcol in-p
25  mratp $aliases))
26
27;;; macros for the DISPLA package.
28
29;; (PUSH-STRING "foo" RESULT) --> (SETQ RESULT (APPEND '(#/o #/o #/f) RESULT))
30
31(defmacro push-string (string symbol)
32  (check-arg string stringp "a string")
33  (check-arg symbol symbolp "a symbol")
34  `(setq ,symbol (list* ,@(nreverse (exploden string)) ,symbol)))
35
36;; Macros for setting up dispatch table.
37;; Don't call this DEF-DISPLA, since it shouldn't be annotated by
38;; TAGS and @.  Syntax is:
39;; (DISPLA-DEF [<operator>] [<dissym> | <l-dissym> <r-dissym>] [<lbp>] [<rbp>])
40;; If only one integer appears in the form, then it is taken to be an RBP.
41
42;; This should be modified to use GJC's dispatch scheme where the subr
43;; object is placed directly on the symbol's property list and subrcall
44;; is used when dispatching.
45
46(defmacro displa-def (operator dim-function &rest rest &aux l-dissym r-dissym lbp rbp)
47  (dolist (x rest)
48    (cond ((stringp x)
49	   (if l-dissym (setq r-dissym x) (setq l-dissym x)))
50	  ((integerp x)
51	   (if rbp (setq lbp rbp))
52	   (setq rbp x))
53	  (t (merror "DISPLA-DEF: unrecognized object: ~a" x))))
54  (when l-dissym
55    (setq l-dissym (if r-dissym
56		       (cons (exploden l-dissym) (exploden r-dissym))
57		       (exploden l-dissym))))
58  `(progn
59    (defprop ,operator ,dim-function dimension)
60    ,(when l-dissym  `(defprop ,operator ,l-dissym dissym))
61    ,(when lbp       `(defprop ,operator ,lbp lbp))
62    ,(when rbp       `(defprop ,operator ,rbp rbp))))
63