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