src/trmode.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;; gjc: 6:27pm  sunday, 20 july 1980
  10 ;;;       (c) copyright 1979 massachusetts institute of technology       ;;;
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12
  13 (in-package :maxima)
  14
  15 (macsyma-module trmode)
  16
  17 (defmvar $mode_checkp t "if true, modedeclare checks the modes of bound variables.")
  18 (defmvar $mode_check_warnp t "if true, mode errors are described.")
  19 (defmvar $mode_check_errorp nil "if true, modedeclare calls error.")
  20
  21 (defun mseemingly-unbound (x)
  22   (or (not (boundp x)) (eq (symbol-value x) x)))
  23
  24 (defun assign-mode-check (var value)
  25   (let ((mode (tr-get-mode var))
  26         (user-level ($get var '$value_check)))
  27     (when mode
  28       (let (($mode_check_warnp t)
  29             ($mode_check_errorp t))
  30         (chekvalue var mode value)))
  31     (when user-level
  32       (mcall user-level value)))
  33   value)
  34
  35 (def%tr $define_variable (form) ;;VAR INIT MODE.
  36   (cond ((> (length form) 3)
  37          (destructuring-let (((var val mode) (cdr form)))
  38                             (let ((mode-form `(($modedeclare) ,var ,mode)))
  39                               (translate mode-form)
  40                               (push-pre-transl-form
  41                                ;; POSSIBLE OVERKILL HERE
  42                                `(declaim (special ,var)))
  43                               (push var defined_variables)
  44                               ;; Get rid of previous definitions put on by
  45                               ;; the translator.
  46                               (do ((l *pre-transl-forms* (cdr l)))
  47                                   ((null l))
  48                                 ;; REMOVE SOME OVERKILL
  49                                 (cond ((and (eq (caar l) 'def-mtrvar)
  50                                             (eq (cadar l) var))
  51                                        (setq *pre-transl-forms* (delete (car l) *pre-transl-forms* :test #'eq)))))
  52                               (if (not (eq mode '$any))
  53                                   ;; so that the rest of the translation gronks this.
  54                                   (putprop var 'assign-mode-check 'assign))
  55                               `($any . (eval-when
  56                                            (:compile-toplevel :load-toplevel :execute)
  57                                            (meval* ',mode-form)
  58                                            ,(if (not (eq mode '$any))
  59                                                 `(defprop ,var assign-mode-check assign))
  60                                            (def-mtrvar ,var ,(dtranslate val)))))))
  61         (t
  62          (tr-format (intl:gettext "error: 'define_variable' must have 3 arguments; found: ~:M~%") form)
  63          nil)))
  64
  65 ;; the priority fails when a DEF-MTRVAR is done, then the user
  66 ;; sets the variable, because the set-priority stays the same.
  67 ;; This causes some Define_Variable's to over-ride the user setting,
  68 ;; but only in the case of re-loading, what we were worried about
  69 ;; is pre-setting of variables of autoloading files.
  70
  71 (defmspec $define_variable  (l)
  72   (setq l (cdr l))
  73   (unless (> (length l) 2)
  74     (merror (intl:gettext "define_variable: expected three arguments; found: ~M") `((mlist) ,@l)))
  75   (unless (symbolp (car l))
  76     (merror (intl:gettext "define_variable: first argument must be a symbol; found: ~M") (car l)))
  77   (meval `(($modedeclare) ,(car l) ,(caddr l)))
  78   (unless (eq (caddr l) '$any)
  79     (putprop (car l) 'assign-mode-check 'assign))
  80   (if (mseemingly-unbound (car l))
  81       (meval `((msetq) ,(car l) ,(cadr l)))
  82       (meval (car l))))
  83
  84
  85 (defmspec $mode_identity (l)
  86   (setq l (cdr l))
  87   (unless (= (length l) 2)
  88     (merror (intl:gettext "mode_identity: expected two arguments; found: ~M") `((mlist) ,@l)))
  89   (let* ((obj (cadr l))
  90          (v (meval obj)))
  91     (chekvalue obj (ir-or-extend (car l)) v)
  92     v))
  93
  94 (def%tr $mode_identity (form)
  95   `(,(ir-or-extend (cadr form)) . ,(dtranslate (caddr form))))
  96
  97 (defun ir-or-extend (x)
  98   (let ((built-in-type (case x
  99                          (($float $real $floatp $flonum $floatnum) '$float)
 100                          (($fixp $fixnum $integer) '$fixnum)
 101                          (($rational $rat) '$rational)
 102                          (($number $bignum $big) '$number)
 103                          (($boolean $bool) '$boolean)
 104                          (($list $listp) '$list)
 105                          ($complex '$complex)
 106                          (($any $none $any_check) '$any))))
 107     (if built-in-type built-in-type
 108         (prog1
 109             x
 110           (mtell (intl:gettext "modedeclare: ~M is not a built-in type; assuming it is a Maxima extension type.") x)))))
 111
 112 (def%tr $modedeclare (form)
 113   (do ((l (cdr form) (cddr l)))
 114       ((null l))
 115     (declmode (car l) (ir-or-extend (cadr l)) t)))
 116
 117 (defun ass-eq-ref (table key &optional dflt)
 118   (let ((val (assoc key table :test #'eq)))
 119     (if val
 120         (cdr val)
 121         dflt)))
 122
 123 (defun ass-eq-set (val table key)
 124   (let ((cell (assoc key table :test #'eq)))
 125     (if cell
 126         (setf (cdr cell) val)
 127         (push (cons key val) table)))
 128   table)
 129
 130
 131 ;;; Possible calls to MODEDECLARE.
 132 ;;; MODEDECLARE(<oblist>,<mode>,<oblist>,<mode>,...)
 133 ;;; where <oblist> is:
 134 ;;; an ATOM, signifying a VARIABLE.
 135 ;;; a LIST, giving a list of objects of <mode>
 136 ;;;
 137
 138 (defmspec $modedeclare (x)
 139   (setq x (cdr x))
 140   (when (oddp (length x))
 141     (merror (intl:gettext "mode_declare: expected an even number of arguments; found: ~M") `((mlist) ,@x)))
 142   (do ((l x (cddr l)) (nl))
 143       ((null l) (cons '(mlist) (nreverse nl)))
 144     (declmode (car l) (ir-or-extend (cadr l)) nil)
 145     (push (car l) nl)))
 146
 147 (defun tr-declare-varmode (variable mode)
 148   (declvalue variable (ir-or-extend mode) t))
 149
 150 ;;; If TRFLAG is TRUE, we are in the translator, if NIL, we are in the
 151 ;;; interpreter.
 152
 153 (defun declmode (form mode trflag)
 154   (cond ((atom form)
 155          (declvalue form mode trflag)
 156          (and (not trflag) $mode_checkp (chekvalue form mode)))
 157         ((eq 'mlist (caar form))
 158          (mapc #'(lambda (l) (declmode l mode trflag)) (cdr form)))
 159         ((member 'array (cdar form) :test #'eq)
 160          (declarray (caar form) mode))
 161         ((eq '$function (caar form))
 162          (mapc
 163        #'(lambda (l)
 164            (if (stringp l) (setq l ($verbify l)))
 165            (declfun l mode))
 166        (cdr form)))
 167         ((member (caar form) '($fixed_num_args_function $variable_num_args_function) :test #'eq)
 168          (mapc
 169        #'(lambda (f)
 170            (if (stringp f) (setq f ($verbify f)))
 171            (declfun f mode)
 172            (mputprop f t (caar form)))
 173        (cdr form)))
 174         ((eq '$completearray (caar form))
 175          (mapc #'(lambda (l)
 176                    (putprop (if (atom l) l (caar l)) mode 'array-mode))
 177                (cdr form)))
 178         ((eq '$array (caar form))
 179          (mapc #'(lambda (l) (mputprop l mode 'array-mode)) (cdr form)))
 180         ((eq '$arrayfun (caar form))
 181          (mapc #'(lambda (l) (mputprop l mode 'arrayfun-mode)) (cdr form)))
 182         (t
 183          (declfun (caar form) mode))))
 184
 185 (defun declvalue (v mode trflag)
 186   (when trflag (setq v (teval v)))
 187   (add2lnc v $props)
 188   (setf (tr-get-mode v) mode))
 189
 190 (defun chekvalue (my-v mode &optional (val (meval1 my-v) val-givenp))
 191   (cond ((or val-givenp (not (eq my-v val)))
 192          ;; hack because macsyma PROG binds variable to itself.
 193          (let ((checker (assoc mode `(($float . floatp)
 194                                       ($fixnum . integerp)
 195                                       ($number . numberp)
 196                                       ($list . $listp)
 197                                       ($boolean . ,#'(lambda (u) (member u '(t nil) :test #'eq))))
 198                                :test #'eq))
 199                (nchecker (assoc mode '(($float . $real)
 200                                        ($fixnum . $integer)
 201                                        ($complex . $complex))
 202                                 :test #'eq))
 203                (not-done t))
 204            (if (cond ((and checker (not (funcall (cdr checker) val))
 205                            (if nchecker
 206                                (prog1
 207                                    (not (mfuncall '$featurep val (cdr nchecker)))
 208                                  (setq not-done nil))
 209                                t)))
 210                      ((if not-done (and nchecker (not (mfuncall '$featurep val (cdr nchecker)))))))
 211                (signal-mode-error my-v mode val))))))
 212
 213 (defun signal-mode-error (object mode value)
 214   (cond ((and $mode_check_warnp (not $mode_check_errorp))
 215          (mtell (intl:gettext "translator: ~:M was declared with mode ~:M, but it has value: ~M") object mode value))
 216         ($mode_check_errorp
 217          (merror (intl:gettext "translator: ~:M was declared with mode ~:M, but it has value: ~M") object mode value))))
 218
 219 (defun put-mode (name mode type)
 220   (if (get name 'tbind)
 221       (setf (tr-get-val-modes name) (ass-eq-set mode (tr-get-val-modes name) type))
 222       (setf (get name type) mode)))
 223
 224 (defun declarray (ar mode)
 225   (put-mode ar mode 'array-mode))
 226
 227 (defun declfun (f mode)
 228   (put-mode f mode 'function-mode))
 229
 230 ;;; 1/2 is not $RATIONAL. bad name. it means CRE form.
 231
 232 (defun udm-err (mode)
 233   (mtell (intl:gettext "translator: no such mode declaration: ~:M~%") mode))