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)) 239