src/trmode.lisp

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