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