share/contrib/alt-display/alt-display.lisp

   1 ;; -*- mode: lisp -*-
   2 ;; Copyright Leo Butler (l_butler@users.sourceforge.net) 2013
   3 ;; Released under the terms of GPLv2+
   4 (in-package :maxima)
   5
   6 (eval-when (:compile-toplevel :load-toplevel :execute)
   7   (defmacro massert (assertion vars &rest action)
   8     `(handler-bind ((error (lambda(msg) (merror "~a" msg))))
   9        (assert ,assertion ,vars ,@action))))
  10
  11 (defun $alt_display_output_type (&optional (form nil))
  12   (massert (and (listp form) (car form) (listp (car form)) (caar form))
  13            (form)
  14            ($printf nil "alt_display_output_type(form): form is ill-structured, found: ~a." form))
  15   (case (caar form)
  16     (mlabel '$label)
  17     (mtext  '$text)
  18     (t      '$unknown)))
  19
  20 (defvar *set-prompt-alist*
  21   '(($prefix    . *prompt-prefix*)
  22     ($suffix    . *prompt-suffix*)
  23     ($general   . *general-display-prefix*)
  24     ($prolog    . *maxima-prolog*)
  25     ($epilog    . *maxima-epilog*))
  26   "An alist of options to set_prompt, and the corresponding Lisp special variables.")
  27
  28 (defun $set_prompt (type value &rest args)
  29   (declare (special *prompt-prefix* *prompt-suffix* *general-display-prefix* *maxima-prolog* *maxima-epilog* *set-prompt-alist*))
  30   (massert (and (symbolp type) (member type '($prefix $suffix $general $prolog $epilog))
  31                (or (stringp value) (null value)))
  32            (type value)
  33            ($printf nil "set_prompt(type, value): type must be one of prefix, suffix, general, prolog or epilog; value must be a string or false.~%type=~a value=~a" type value))
  34   (set (cdr (assoc type *set-prompt-alist*)) (or value ""))
  35   (cond ((null args)
  36          '$done)
  37         ((and args (listp args) (> (length args) 1))
  38          (apply '$set_prompt args))
  39         (t
  40          (merror "set_prompt(type,value): missing value."))))
  41
  42 (defun $reset_prompts ()
  43   (declare (special *set-prompt-alist*))
  44   (dolist (v *set-prompt-alist* '$done)
  45     ($set_prompt (car v) (or (gethash (cdr v) *variable-initial-values*) ""))))
  46
  47 (defun $set_alt_display (type &optional (f nil) (warn nil))
  48   (declare (special *alt-display1d* *alt-display2d*))
  49   (massert (and (member type '(1 2))
  50                 (or (and (symbolp f) (or (fboundp f) (mfboundp f)))
  51                     (and (consp f) (member (caar f) '(lambda mfexpr)))
  52                     (null f)))
  53            (type f)
  54            "set_alt_display(type,f): type must equal 1 or 2, f must be a function, lambda expression or false.")
  55   (let* ((alt-display (ecase type
  56                         (1 '*alt-display1d*)
  57                         (2 '*alt-display2d*))))
  58     (cond (f
  59            (if warn (warn "Setting ~dd-display to ~(~a~)." type ($printf nil "~a" f)))
  60            (let ((error? t))
  61              (labels ((error-handler ()
  62                                      (merror "Error in ~a.~%Message: ~a~a reset to default." alt-display
  63                                              (with-output-to-string (*standard-output*) ($errormsg)) alt-display))
  64                       (alt-display-fun (form)
  65                                        ;; convert maxima errors to maxima-$error conditions (a type of error)
  66                                        ;; we can't use handler case to forcibly reset *alt-display[12]d*, because of dynamic scope
  67                                        ;; so we manually keep track of whether an error occurs.
  68                                        (ignore-errors
  69                                          (with-$error (mfuncall f form))
  70                                          (setq error? nil))
  71                                        (when error?
  72                                          ($set_alt_display type nil)
  73                                          (error-handler))))
  74                (set alt-display #'alt-display-fun))))
  75           (t
  76            (if warn (warn "Resetting ~dd-display to default." type))
  77            (set alt-display nil))))
  78   '$done)
  79
  80 ;; end of alt-display.lisp