Add note that the lapack package needs to loaded to get the functions.
[maxima.git] / src / transl.lisp
blob4fe261f298cfec3eae72f4b0db5a996b0ce6a01e
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 ;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
9 ;;; GJC 9:29am Saturday, 5 April 1980 ;;;
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 (in-package :maxima)
14 (macsyma-module transl)
16 ;;; File directory.
18 ;;; TRANSL Driver. Basic translation properties.
19 ;;; TRANSS User-interaction, FILE-I/O etc.
20 ;;; TRANS1 Translation of JPG;MLISP and other FSUBRS.
21 ;;; which take call-by-name parameters.
22 ;;; TRANS2 LISTS, ARRAYs, other random operators.
23 ;;; TRANS3 LAMBDA. CLOSURES. also used by fsubr call-by-name
24 ;;; compatibility package.
25 ;;; TRANS4 operators, ".", "^^" some functions such as GAMMA.
26 ;;; TRANS5 FSUBRS from COMM, and others, these are mere MACRO
27 ;;; FSUBRS.
28 ;;; TRANSF floating point intensive properties. BIGFLOAT stuff.
29 ;;; TROPER Basic OPERATORS.
30 ;;; TRUTIL transl utilities.
31 ;;; TRMODE definition of MODEDECLARE. run time error checking code.
32 ;;; TRDATA this is the MODE data for the "built-in" functions.
33 ;;; TRANSM This defines the macro DEF%TR. When compiled on MC
34 ;;; DEF%TR produces autoload definitions for TRANS1 thru L.
35 ;;; PROCS macro's needed.
36 ;;; TRANSQ these are macros for translated code. Loaded by TPRELU
37 ;;; this is compile-time only.
38 ;;; MDEFUN contains the macro which defines macsyma functions.
39 ;;; runtime and compile-time.
40 ;;; ACALL is some run time support for translated code, array calls.
41 ;;; FCALL run-time translated function call support for uncompiled
42 ;;; code. Many FSUBRS which are macros in TRANSQ.
43 ;;; EVALW EVAL-WHEN definition for interpreter.
44 ;;; MLOAD This has a hack hook into BATCH, which is needed to do
45 ;;; TRANSLATE_FILE I/O. when using old-i/o SUPRV.
48 ;;; Functions and literals have various MODE properties;;; >
49 ;;; (at user level set up by $MODEDECLARE), such as "$FLOAT" and "$ANY".
50 ;;; The main problem solved by this translator (and the reason that
51 ;;; it works on forms from the "inside out" as an evaluator would do
52 ;;; (expect for macro forms)), is the problem of type (MODE) dependent
53 ;;; function calling and mode conversion. The function TRANSLATE
54 ;;; returns a list where the CAR of the list is the MODE of the
55 ;;; expression and the CDR is the expression to be evaluated by
56 ;;; the lisp evaluator to give the equivalent result of evaluating
57 ;;; the given macsyma expression with the macsyma evaluator.
58 ;;; One doesn't know the MODE of an expression until seeing the modes
59 ;;; of all its parts. See "*UNION-MODE"
61 ;;; weak points in the code
62 ;;; [1] duplication of functionality in the translators for
63 ;;; MPLUS MTIMES etc.
64 ;;; [3] primitive mode scheme. lack of even the most primitive general
65 ;;; type coercion code. Most FORTRAN compilers are better than this.
66 ;;; [4] for a compiler, this code SUCKS when it comes to error checking
67 ;;; of the code it is munging. It doesn't even do a WNA check of system
68 ;;; functions!
69 ;;; [5]
70 ;;; The duplication of the code which handles lambda binding, in MDO, MDOIN
71 ;;; TR-LAMBDA, and MPROG, is very stupid. For macsyma this is one of
72 ;;; the hairier things. Declarations must be handled, ASSIGN properties...
73 ;;; -> Binding of ASSIGN properties should be handled with he "new"
74 ;;; UNWIND-PROTECT instead of at each RETURN, and at "hope" points such as
75 ;;; the ERRLIST. {Why wasn't this obvious need for UNWIND-PROTECT made
76 ;;; known to the lisp implementers by the macsyma implementers? Why did it
77 ;;; have to wait for the lisp machine group? Isn't this just a generalization
78 ;;; of special binding?}
79 ;;; [6] the DCONVX idea here is obscurely coded, incomplete, and totally
80 ;;; undocumented. It was probably an attempt to hack efficient
81 ;;; internal representations (internal to a given function), for some macsyma
82 ;;; data constructs, and yet still be sure that fully general legal data
83 ;;; frobs are seen outside of the functions. Note: this can be done
84 ;;; simply by type coercion and operator folding.
86 ;;; General comments on the structure of the code.
87 ;;; A function named TR-<something> means that it translates
88 ;;; something having to do with that something.
89 ;;; N.B. It does not mean that that is the translate property for <something>.
92 (defvar *untranslated-functions-called* nil)
94 (defmvar *declared-translated-functions* nil
95 "List of functions which are believed to be translated.")
97 (defmvar tstack nil " stack of local variable modes ")
99 (defmvar *local* nil "T if a $local statement is in the body.")
100 (defmvar tr-progret t)
101 (defmvar inside-mprog nil)
102 (defmvar *go-forms* nil "list of `translate'd go forms in the block.")
103 (defmvar *returns* nil "list of `translate'd return forms in the block.")
104 (defmvar return-mode nil "the highest(?) mode of all the returns.")
105 (defmvar need-prog? nil)
106 (defmvar assigns nil "These are very-special variables which have a Maxima
107 assign property which must be called to bind and unbind the variable
108 whenever it is `lambda' bound.")
110 (defmvar translate-time-evalables
111 '($modedeclare $alias $declare $infix $nofix $declare_translated
112 $matchfix $prefix $postfix $compfile))
114 (defmvar *transl-backtrace* nil
115 " What do you think? ")
117 (defmvar *transl-debug* nil "if T it pushes `backtrace' and `trace' ")
119 (defmvar tr-abort nil "set to T if abortion is requested by any of the
120 sub-parts of the translation. A *THROW would be better, although it
121 wouldn't cause the rest of the translation to continue, which may
122 be useful in translation for MAXIMA-ERROR checking.")
124 (defmvar tr-unique (gensym)
125 "this is just a unique object used for random purposes,
126 such as the second (file end) argument of READ.")
129 (defmvar $tr_warn_undeclared '$compile
130 "When to send warnings about undeclared variables to the TTY"
131 :setting-list ($all $compile $compfile $translate))
133 (defmvar $tr_warn_meval '$compfile
134 "If `meval' is called that indicates problems in the translation"
135 :setting-list ($all $compile $compfile $translate))
137 (defmvar $tr_warn_fexpr
138 '$compfile
139 "FEXPRS should not normally be output in translated code, all legitimate
140 special program forms are translated."
141 :setting-list ($all $compile $compfile $translate))
143 (defmvar $tr_warn_mode '$all
144 "Warn when variables are assigned values out of their mode."
145 :setting-list ($all $compile $compfile $translate))
147 (defmvar $tr_warn_undefined_variable '$all
148 "Warn when undefined global variables are seen."
149 :setting-list ($all $compile $compfile $translate))
152 (defmvar *warned-un-declared-vars* nil "Warning State variable")
153 (defmvar *warned-fexprs* nil "Warning State variable")
154 (defmvar *warned-mode-vars* nil "Warning State variable")
156 (defmvar $tr_function_call_default '$general
158 FALSE means punt to MEVAL, EXPR means assume lisp fixed arg function.
159 GENERAL, the default gives code good for mexprs and mlexprs but not macros.
160 GENERAL assures variable bindings are correct in compiled code.
161 In GENERAL mode, when translating F(X), if F is a bound variable, then
162 it assumes that APPLY(F,[X]) is meant, and translates a such, with
163 appropriate warning. There is no need to turn this off.
164 APPLY means like APPLY.")
166 (defmvar $tr_array_as_ref t
167 "If true runtime code uses value of the variable as the array.")
169 (defmvar $tr_numer nil
170 "If `true' numer properties are used for atoms which have them, e.g. %pi")
172 (defvar *tr-free-vars-to-capture* '())
174 (defvar boolean-object-table
175 '(($true . ($boolean . t))
176 ($false . ($boolean . nil))
177 (t . ($boolean . t))
178 (nil . ($boolean . nil))))
180 (defvar mode-init-value-table
181 '(($float . 0.0)
182 ($fixnum . 0)
183 ($number . 0)
184 ($list . '((mlist)))
185 ($boolean . nil)))
187 (defvar tr-lambda-punt-assigns nil
188 "Kludge argument to `tr-lambda' due to lack of keyword argument passing")
190 (defvar defined_variables ())
192 (defvar $define_variable ())
194 ;; FIXME: AFAICT (rtoy), *in-compile* is only used in this file and no
195 ;; one ever changes the value of *in-compile* to anything other than
196 ;; NIL. Perhaps remove this and the only other use of it below.
197 (defvar *in-compile* nil)
199 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
201 (defun tr-abort ()
202 (setq tr-abort t)
203 nil)
205 (defun barfo (msg)
206 (tr-format (intl:gettext "Internal translator error: ~M~%") msg)
207 (cond (*transl-debug*
208 (break "transl barfo"))
210 (tr-abort)
211 nil)))
213 (defun specialp (var)
214 (or (optionp var)
215 (tr-get-special var)))
218 ;;; The error message system. Crude as it is.
219 ;;; I tell you how this aught to work:
220 ;;; (1) All state should be in one structure, one state variable.
221 ;;; (2) Should print out short message on-the-fly so that it
222 ;;; gives something to watch, and also so that it says something
223 ;;; if things crash.
224 ;;; (3) Summaries on a cross-referenced per-function and per-item
225 ;;; should be printed at the end, as a table.
226 ;;; e.g.
227 ;;; Undefined Functions used in
228 ;;; FOO BAR, BAZ,BOMB
229 ;;; FOOA P,Q
230 ;;; Undefined Variables ... same thing
231 ;;; Incomprehensible special forms
232 ;;; EV ....
233 ;;; Predicate Mode Targeting failures.
234 ;;; ..... -gjc
236 ;;; The way it works now is to print too little or too much.
237 ;;; Many items are only warned about the first time seen.
238 ;;; However, this isn't too much of a problem when using Emacs
239 ;;; to edit code, because searching for warned-about tokens
240 ;;; is quick and easy.
242 (defmvar *tr-warn-break* t
243 " if in debug mode `warning's signaled go to lisp break loops ")
245 (defmacro tr-warnbreak ()
246 `(and *transl-debug* *tr-warn-break* (break "transl")))
248 (defun tr-warnp (val)
249 (and val
250 (cond (*in-compile*
251 (member val '($all $compile $compfile $translate) :test #'eq))
252 ((or *in-compfile* *in-translate-file*)
253 (member val '($all $compfile $translate) :test #'eq))
254 (*in-translate*
255 (member val '($all $translate) :test #'eq)))))
257 (defvar warned-undefined-variables nil)
259 (defun warn-undefined-variable (form)
260 (and (tr-warnp $tr_warn_undefined_variable)
261 (cond ((member form warned-undefined-variables :test #'eq))
263 (push form warned-undefined-variables)
264 (tr-format (intl:gettext "warning: encountered undefined variable ~:M in translation.~%") form)
265 (tr-warnbreak)))))
267 (defun warn-undeclared (form &optional comment)
268 (and (tr-warnp $tr_warn_undeclared)
269 (cond ((member form *warned-un-declared-vars* :test #'equal) t)
271 (push form *warned-un-declared-vars*)
272 (tr-format (intl:gettext "warning: no type declaration for ~:M; assume type is 'any'.~%") form)
273 (tr-format (intl:gettext "note: 'modedeclare' declares types for translation.~%"))
274 (cond (comment
275 (dolist (v *translation-msgs-files*)
276 (terpri v)
277 (princ comment v))))
278 (tr-warnbreak)
279 nil))))
281 (defun warn-meval (form &optional comment)
282 (cond ((tr-warnp $tr_warn_meval)
283 (tr-format (intl:gettext "warning: emit call to MEVAL for expression: ~:M~%") form)
284 (cond (comment (dolist (v *translation-msgs-files*)
285 (terpri v)
286 (princ comment v))))
287 (tr-warnbreak)
288 'warned)))
291 (defun warn-mode (var mode newmode &optional comment)
292 (cond ((eq mode newmode))
294 (cond ((and (tr-warnp $tr_warn_mode)
295 (not (covers mode newmode))
296 (not (member (list var mode newmode) *warned-mode-vars* :test #'equal)))
297 (push (list var mode newmode) *warned-mode-vars*)
298 (tr-format (intl:gettext "warning: variable ~:M (declared type ~:M) assigned type ~:M.~%") var mode newmode)
299 (cond (comment
300 (dolist (v *translation-msgs-files*)
301 (terpri v)
302 (princ comment v))))
303 (tr-warnbreak))))))
305 (defun warn-fexpr (form &optional comment)
306 (cond ((and (tr-warnp $tr_warn_fexpr)
307 (not (member form *warned-fexprs* :test #'equal)))
308 (push form *warned-fexprs*)
309 (tr-format (intl:gettext "warning: ~:M is a special function without a full Lisp translation.~%") form)
310 (tr-format (intl:gettext "warning: calling ~:M in compiled code might not have the desired effect.~%") form)
311 (cond (comment
312 (dolist (v *translation-msgs-files*)
313 (terpri v)
314 (princ comment v))))
315 (tr-warnbreak))))
318 (defun macsyma-special-macro-p (fcn)
319 (getl-lm-fcn-prop fcn '(macro)))
321 (defun macsyma-special-op-p (f)
322 (getl f '(fsubr fexpr mfexpr* mfexpr*s *fexpr)))
324 (defun possible-predicate-op-p (f)
325 (member f '(mnotequal mequal $equal mgreaterp mgeqp mlessp mleqp) :test #'eq))
327 ;;;***************************************************************;;;
329 ;;; This function is the way to call the TRANSLATOR on an expression with
330 ;;; locally bound internal mode declarations. Result of TR-LAMBDA will be
331 ;;; (MODE . (LAMBDA (...) (DECLARE ...) TRANSLATED-EXP))
333 (defun tr-local-exp (exp &rest vars-modes)
334 (let ((loc (let ((tr-lambda-punt-assigns t))
335 (tr-lambda `((lambda) ((mlist) ,@(do ((l vars-modes (cddr l))
336 (ll nil (cons (car l) ll)))
337 ((null l) ll)
338 (or (variable-p (car l))
339 (bad-var-warn (car l)))))
340 (($modedeclare) ,@vars-modes)
341 ,exp)))))
342 (let ((mode (car loc))
343 (exp (car (last loc))))
344 (cons mode exp))))
346 (defun tr-args (form)
347 (mapcar #'(lambda (x) (dconvx (translate x))) form))
349 (defun dtranslate (form) (cdr (translate form)))
351 (defun dconv (x mode)
352 (cond ((eq '$float mode) (dconv-$float x))
353 ((eq '$cre mode) (dconv-$cre x))
354 (t (cdr x))))
356 (defun dconvx (x)
357 (if (member (car x) '(ratexpr pexpr) :test #'eq)
358 (dconv-$cre x)
359 (cdr x)))
361 (defun dconv-$float (x)
362 (cond ((member (car x) '($fixnum $number) :test #'eq)
363 (if (integerp (cdr x)) (float (cdr x)) (list 'float (cdr x))))
364 ((eq '$rational (car x))
365 (cond ((or (atom (cdr x))
366 (not (eq 'quote (cadr x))))
367 `($float ,(cdr x)))
369 (/ (float (cadadr (cdr x))) (float (caddr (caddr x)))))))
370 (t (cdr x))))
372 (defun dconv-$cre (x)
373 (if (eq '$cre (car x))
374 (cdr x)
375 `(ratf ,(cdr x))))
377 (defmvar *$any-modes* '($any $list))
379 (defun covers (mode1 mode2)
380 (cond ((eq mode1 mode2) t)
381 ((eq '$float mode1) (member mode2 '($float $fixnum $rational) :test #'eq))
382 ((eq '$number mode1) (member mode2 '($fixnum $float) :test #'eq))
383 ((member mode1 *$any-modes* :test #'eq) t)))
385 ;;; takes a function name as input.
387 (defun tr-mfun (name &aux (*transl-backtrace* nil))
388 (let ((def-form (consfundef name nil nil)))
389 (cond ((null def-form)
390 (tr-abort))
392 (tr-mdefine-toplevel def-form)))))
394 ;;; DEFUN
395 ;;; All the hair here to deal with macsyma fexprs has been flushed.
396 ;;; Right now this handles MDEFMACRO and MDEFINE. The decisions
397 ;;; of where to put the actual properties and what kind of
398 ;;; defuns to make (LEXPR EXPR for maclisp) are punted to the
399 ;;; macro package.
401 (defun tr-mdefine-toplevel (form &aux (and-restp nil))
402 (destructuring-let (((((name . flags) . args) body) (cdr form))
403 (a-args) kind out-forms)
405 (do ((args args (cdr args))
406 ;; array functions cannot be LEXPR-like. gee.
407 ;; there is no good reason for that, except for efficiency,
408 ;; and I know that efficiency was not a consideration.
409 (full-restricted-flag (or (eq name 'mqapply)
410 (member 'array flags :test #'eq))))
411 ((null args) (setq a-args (nreverse a-args)))
412 (let ((u (car args)))
413 (cond ((atom u)
414 (push u a-args))
415 ((and (not full-restricted-flag)
416 (not and-restp)
417 (eq (caar u) 'mlist)
418 (cdr u) (atom (cadr u)))
419 (push (cadr u) a-args)
420 (setq and-restp t))
422 (push tr-unique a-args)))))
425 (cond ((eq name 'mqapply)
426 ;; don't you love syntax!
427 ;; do a switch-a-roo here. Calling ourselves recursively
428 ;; like this allows all legal forms and also catches
429 ;; errors. However, certain generalizations are also
430 ;; allowed. They won't get passed the interpreter, but
431 ;; interesting things may happen here. That's what you
432 ;; get from too much syntax, so don't sweat it.
434 ;; the allowed generalizations aren't necessarily subscripted
435 ;; functions, but we'll act like they are when determining
436 ;; the free vars to capture.
437 ;; don't sweat this either.
438 (let ((*tr-free-vars-to-capture* (union (cdar args) *tr-free-vars-to-capture*)))
439 (tr-mdefine-toplevel
440 `(,(car form) ,(car args)
441 ((lambda) ((mlist) ,@(cdr args)) ,body)))))
442 ((member tr-unique a-args :test #'eq)
443 ;; WHAT IS "BAD" ABOUT THE ARGUMENT LIST HERE ??
444 (tr-format (intl:gettext "error: unhandled argument list in function definition: ~:M~%") `((mlist),@args))
445 (tr-abort)
446 nil)
447 ((member (caar form) '(mdefine mdefmacro) :test #'eq)
448 (setq kind (cond ((eq (caar form) 'mdefmacro) 'macro)
449 ((member 'array flags :test #'eq) 'array)
450 (t 'func)))
451 (let* ((t-form
452 (tr-lambda `((lambda) ((mlist) ,@a-args) ,body)))
453 (desc-header
454 `(,name ,(car t-form) ,(caar form)
455 ,and-restp ,(eq kind 'array))))
456 (cond ((eq kind 'func)
457 (and (not (member (car t-form) '($any nil) :test #'eq))
458 (putprop name (car t-form) 'function-mode)))
459 ((eq kind 'array)
460 (and (not (member (car t-form) '($any nil) :test #'eq))
461 (decmode-arrayfun name (car t-form)))))
463 (cond ((or *in-translate* (not $packagefile))
464 ; These are all properties which tell the
465 ; user that functions are in the environment,
466 ; and that also allow him to SAVE the functions.
467 (push `(defprop ,name t translated) out-forms)
468 (push `(add2lnc ',name $props) out-forms)
469 (cond ((eq '$all $savedef)
470 (push
471 `(add2lnc
472 '((,name ,@flags) ,@args)
473 ,(case kind
474 (array '$arrays)
475 (func '$functions)
476 (macro '$macros))) out-forms)))))
477 (cond ((eq '$all $savedef)
478 ;; For some reason one may want to save the
479 ;; interpreted definition even if in a PACKAGEFILE.
480 ;; not a good idea to use SAVEDEF anyway though.
481 (push `(mdefprop ,name
482 ((lambda) ((mlist) ,@args) ,body)
483 ,(case kind
484 (array 'aexpr)
485 (macro 'mmacro)
486 (func 'mexpr)))
487 out-forms)))
488 ;;once a function has been translated we want to make sure mfunction-call is eliminated.
489 (progn
490 (remprop (car desc-header) 'undefined-warnp)
491 (setf (get (car desc-header) 'once-translated) "I was once translated"))
492 `(progn
493 ,@(nreverse out-forms)
494 (defmtrfun ,desc-header ,@(cdr (cdr t-form))))))
496 (barfo '?)))))
498 (defun translate-function (name)
499 (bind-transl-state
500 (setq *in-translate* t)
501 (let ((lisp-def-form (tr-mfun name))
502 (delete-subr? (and (get name 'translated)
503 (not (get name 'expr)))))
504 (cond (tr-abort
505 (trfail name))
507 (if delete-subr? (remprop name 'subr))
508 (if (mget name 'trace) (macsyma-untrace name))
509 (if (not $savedef) (meval `(($remfunction) ,name)))
510 (handler-case (eval lisp-def-form)
511 (error (e)
512 (tr-abort)
513 (trfail name e)
514 (return-from translate-function nil)))
515 name)))))
517 (defun punt-to-meval (form &optional (mode '$any))
518 (cons mode `(meval ',form)))
520 (defun trfail (x &optional msg)
521 (tr-format (intl:gettext "Error: failed to translate ~:@M~%") x)
522 (when msg
523 (tr-format (intl:gettext "Message: ~A~%") msg))
524 nil)
526 (defun translate-and-eval-macsyma-expression (form)
527 ;; this is the hyper-random entry to the transl package!
528 ;; it is used by MLISP for TRANSLATE:TRUE "::=".
529 (bind-transl-state
530 (setq *in-translate* t)
531 ;; Use TRANSLATOR-EVAL so we don't have to lose badly by tracing EVAL
532 (translator-eval (translate-macexpr-toplevel form))))
534 (defun translator-eval (x)
535 (eval x))
537 (defun tr-eval-when-situation (situation)
538 (ecase situation
539 (($compile compile :compile-toplevel)
540 :compile-toplevel)
541 (($load load :load-toplevel)
542 :load-toplevel)
543 (($eval eval :execute)
544 :execute)))
546 ;; This basically tells the msetq def%tr to use defparameter instead
547 ;; of setq because we're doing a setq at top-level, which isn't
548 ;; specified by ANSI CL.
549 (defvar *macexpr-top-level-form-p* nil)
551 (defun translate-macexpr-toplevel (form &aux (*transl-backtrace* nil) tr-abort)
552 ;; there are very few top-level special cases, I don't
553 ;; think it would help the code any to generalize TRANSLATE
554 ;; to target levels.
556 ;; Except msetq at top-level is special for ANSI CL. See below.
557 (setq form (toplevel-optimize form))
558 (cond ((atom form) nil)
559 ((eq (caar form) '$eval_when)
560 (let ((whens (cadr form))
561 (body (cddr form)))
562 (setq whens (cond (($listp whens) (cdr whens))
563 ((atom whens) (list whens))
565 (tr-format (intl:gettext "error: 'eval_when' argument must be a list or atom; found: ~:M~%") (cadr form))
566 nil)))
567 (cond ((member '$translate whens :test #'eq)
568 (mapc 'meval body)))
569 (cond ((member '$loadfile whens :test #'eq)
570 `(progn
571 ,@(mapcar 'translate-macexpr-toplevel body)))
572 ((setq whens (intersect whens '($compile $load $eval)))
573 `(eval-when ,(mapcar #'tr-eval-when-situation whens)
574 ,@(mapcar 'translate-macexpr-toplevel body))))))
575 ((member (caar form) translate-time-evalables :test #'eq)
576 (meval1 form)
577 `(eval-when
578 (:compile-toplevel :load-toplevel :execute)
579 (meval* ',form)))
580 ((member (caar form) '(mdefine mdefmacro) :test #'eq)
581 (let ((name (caaadr form))
582 (trl))
583 (tr-format (intl:gettext "note: translating ~:@M~%") name)
584 (setq trl (tr-mdefine-toplevel form))
585 (cond (tr-abort
586 (tr-format (intl:gettext "error: failed to translate ~:@M~%") name)
587 (tr-format (intl:gettext "note: keep going and hope for the best.~%"))
588 `(meval* ',form))
589 (t trl))))
590 ((eq 'mprogn (caar form))
591 ;; note that this ignores the $%% crock.
592 `(progn ,@(mapcar #'translate-macexpr-toplevel (cdr form))))
593 ((eq 'msetq (caar form))
594 ;; Toplevel msetq's should really be defparameter instead of
595 ;; setq for Common Lisp.
596 (let ((*macexpr-top-level-form-p* t))
597 (dtranslate form)))
598 ((eq '$define_variable (caar form))
599 ;; Toplevel msetq's should really be defparameter instead of
600 ;; setq for Common Lisp.
601 (let ((*macexpr-top-level-form-p* t))
602 (dtranslate form)))
604 (let ((t-form (dtranslate form)))
605 (cond (tr-abort
606 `(meval* ',form))
608 t-form))))))
612 (defmvar $tr_optimize_max_loop 100.
613 "The maximum number of times the macro-expansion and optimization
614 pass of the translator will loop in considering a form.
615 This is to catch macro expansion errors, and non-terminating
616 optimization properties.")
618 (defun toplevel-optimize (form)
619 ;; it is vital that optimizations be done within the
620 ;; context of variable meta bindings, declarations, etc.
621 ;; Also: think about calling the simplifier here.
622 (cond ((atom form)
623 (cond ((symbolp form)
624 ;; If this symbol has the constant property, then
625 ;; use its assigned constant value in place of the
626 ;; symbol.
627 (let ((v (getl (mget form '$props) '($constant))))
628 (if v (cadr v) form)))
629 (t form)))
631 (do ((new-form)
632 (kount 0 (1+ kount)))
633 ;; tailrecursion should always arrange for a counter
634 ;; to check for mobylossage.
635 ((> kount $tr_optimize_max_loop)
636 (tr-format (intl:gettext "warning: I've looped ~A times in macro expansion; just give up and return ~:@M~%")
637 $tr_optimize_max_loop (caar form))
638 form)
639 (setq new-form (toplevel-optimize-1 form))
640 (cond ((atom new-form)
641 (return (toplevel-optimize new-form)))
642 ((eq new-form form)
643 (return form))
645 (setq form new-form)))))))
647 (defun toplevel-optimize-1 (form &aux (op (car form)) prop)
648 (cond ((or (atom op)
649 (member 'array op :test #'eq)) form)
650 ((progn (setq op (car op))
651 (setq prop
652 (if $transrun ; crock a minute.
653 (or (get op 'translated-mmacro)
654 (mget op 'mmacro))
655 (or (mget op 'mmacro)
656 (get op 'translated-mmacro)))))
657 (mmacro-apply prop form))
658 ((setq prop ($get op '$optimize))
659 ;; interesting, the MAPPLY here causes the simplification
660 ;; of the form and the result.
661 ;; The optimize property can be used to implement
662 ;; such niceties as the $%% crock.
663 (mapply1 prop (list form) "an optimizer property" nil))
664 ((and ($get op '$transload)
665 (get op 'autoload)
666 ;; check for all reasonable definitions,
667 ;; $OPTIMIZE and MACRO already checked.
668 (not (or (get-lisp-fun-type op)
669 (getl op '(translate mfexpr* mfexpr*s
670 fsubr fexpr *fexpr
671 macro
672 ;; foobar?
674 (mgetl op '(mexpr)))))
675 (load-function op t)
676 ;; to loop.
677 (cons (car form) (cdr form)))
678 (t form)))
680 (defun translate (form)
681 (and *transl-debug* (push form *transl-backtrace*))
682 (setq form (toplevel-optimize form))
683 (and *transl-debug* (pop *transl-backtrace*))
684 (prog2
685 (and *transl-debug* (push form *transl-backtrace*))
686 (if (atom form)
687 (translate-atom form)
688 (translate-form form))
689 ;; hey boy, reclaim that cons, just don't pop it!
690 (and *transl-debug* (pop *transl-backtrace*))))
692 (defun translate-atom (form &aux temp)
693 (cond ((numberp form) (cons (tr-class form) form))
694 ((setq temp (assoc form boolean-object-table :test #'eq))
695 (cdr temp))
696 ((and (setq temp (mget form '$numer)) $tr_numer)
697 `($float . ,temp))
698 ((implied-quotep form)
699 `($any . ',form))
700 ((self-evaluating-lisp-object-p form)
701 `($any . ,form))
702 ((tboundp form)
703 (setq form (teval form))
704 `(,(value-mode form) . ,form))
706 (cond ((not (specialp form))
707 (warn-undefined-variable form)))
708 ;; note that the lisp analysis code must know that
709 ;; the TRD-MSYMEVAL form is a semantic variable.
710 (let* ((mode (value-mode form))
711 (init-val (assoc mode mode-init-value-table :test #'eq)))
712 (setq init-val (cond (init-val (cdr init-val))
713 (t `',form)))
714 ;; in the compiler TRD-MSYMEVAL doesn't do a darn
715 ;; thing, but it provides dynamic initialization of
716 ;; variables in interpreted code which is translated
717 ;; in-core. In FILE loaded code the DEFVAR will take
718 ;; care of this.
719 (push-defvar form init-val)
720 `(,mode . (trd-msymeval ,form ,init-val))))))
722 (defun translate-form (form &aux temp)
723 (cond ((eq (car form) 'meval) (cons '$any form)) ;;for those lispy macsyma forms
724 ((not (atom (caar form)))
725 ;; this is a check like that in the simplifier. form could
726 ;; result from substitution macros.
727 (translate `((mqapply) ,(caar form) . ,(cdr form))))
728 ((member 'array (cdar form) :test #'eq)
729 ;; dispatch this bad-boy to another module quick.
730 (tr-arraycall form))
731 ;; TRANSLATE properties have priority.
732 ((setq temp (get (caar form) 'translate))
733 (funcall temp form))
734 ((setq temp (get-lisp-fun-type (caar form)))
735 (tr-lisp-function-call form temp))
736 ((macsyma-special-macro-p (caar form))
737 (attempt-translate-random-macro-op form))
738 ((macsyma-special-op-p (caar form))
739 ;; a special form not handled yet! foobar!
740 (attempt-translate-random-special-op form))
741 ((or (get (caar form) 'noun) (get (caar form) 'operators))
742 ;; puntastical case. the weird ones are presumably taken care
743 ;; of by TRANSLATE properties by now.
744 (tr-infamous-noun-form form))
746 ;; "What does a macsyma function call mean?".
747 ;; By the way, (A:'B,B:'C,C:'D)$ A(3) => D(3)
748 ;; is not supported.
750 (tr-macsyma-user-function-call (caar form) (cdr form) form))))
754 (defmvar $tr_bound_function_applyp t)
756 (defun tr-macsyma-user-function-call (function args form)
757 ;; this needs some work, output load-time code to
758 ;; check for MMACRO properties, etc, to be really
759 ;; foolproof.
760 (cond ((eq $tr_function_call_default '$apply)
761 (translate `(($apply) ,(caar form) ((mlist) ,@(cdr form)))))
762 ((eq $tr_function_call_default '$expr)
763 (tr-lisp-function-call form 'subr))
764 ((eq $tr_function_call_default '$general)
765 (cond
766 ;;; G(F,X):=F(X+1); case.
767 ((and $tr_bound_function_applyp (tboundp function))
768 (let ((new-form `(($apply) ,function ((mlist) ,@args))))
769 (tr-format (intl:gettext "warning: ~:M is a bound variable in ~:M, but it is used as a function.~%") function form)
770 (tr-format (intl:gettext "note: instead I'll translate it as: ~:M~%") new-form)
771 (translate new-form)))
772 ;; MFUNCTION-CALL cleverely punts this question to a FSUBR in the
773 ;; interpreter, and a macro in the compiler. This is good style,
774 ;; if a user is compiling then assume he is less lossage prone.
776 (pushnew (caar form) *untranslated-functions-called*)
777 (call-and-simp
778 (function-mode (caar form))
779 'mfunction-call `(,(caar form) ,@(tr-args args))))))
781 ;; This case used to be the most common, a real loser.
782 (warn-meval form)
783 (punt-to-meval form (function-mode (caar form))))))
786 (defun attempt-translate-random-macro-op (form)
787 (warn-fexpr form)
788 `($any . ,(cons (caar form) (cdr form))))
790 (defun attempt-translate-random-special-op (form)
791 (warn-fexpr form)
792 (punt-to-meval form (function-mode (caar form))))
795 (defun tr-lisp-function-call (form type)
796 (let ((op (caar form)) (mode) (args))
797 (setq args (cond ((member type '(subr lsubr expr) :test #'eq)
798 (mapcar #'(lambda (llis) (dconvx (translate llis)))
799 (cdr form)))
801 (mapcar 'dtranslate (cdr form))))
802 mode (function-mode op))
803 (call-and-simp mode op args)))
805 ;;the once-translated is so that inside translate file where a function
806 ;;has been translated, subsequent calls won't use mfunction call
807 (defun get-lisp-fun-type (fun &aux temp)
808 ;; N.B. this is Functional types. NOT special-forms,
809 ;; lisp special forms are meaningless to macsyma.
810 (cond ((get fun '*lexpr) 'lsubr)
811 ((get fun '*expr) 'subr)
812 ;; *LEXPR & *EXPR gotten from DEFMFUN declarations
813 ;; which is loaded by TrData.
814 ((mget fun '$fixed_num_args_function)
815 'subr)
816 ((mget fun '$variable_num_args_function)
817 'lsubr)
818 ((setq temp (getl fun '(expr subr lsubr)))
819 (car temp))
820 ((get fun 'once-translated))
821 ((get fun 'translated))
822 (t nil)))
824 (defun tr-infamous-noun-form (form)
825 ;; 'F(X,Y) means noun-form. The arguments are evaluated.
826 ;; but the function is cons on, not applied.
827 ;; N.B. for special forms and macros this is totally wrong.
828 ;; But, those cases are filtered out already, presumably.
830 (let ((op (cond ((member 'array (car form) :test #'eq)
831 `(,(caar form) array))
832 (t `(,(caar form)))))
833 (args (tr-args (cdr form))))
834 `($any . (simplify (list ',op ,@args)))))
836 ;;; Some atoms, solely by usage, are self evaluating.
837 (defun implied-quotep (x)
838 (safe-get x 'implied-quotep))
840 (defun self-evaluating-lisp-object-p (x)
841 (not (or (symbolp x) (consp x))))
843 ;;; the Translation Properties. the heart of TRANSL.
845 ;;; This conses up the call to the function, adding in the
846 ;;; SIMPLIFY i the mode is $ANY. This should be called everywhere.
847 ;;; instead of duplicating the COND everywhere, as is done now in TRANSL.
849 (defun tr-nosimpp (op)
850 (cond ((atom op)
851 (get op 'tr-nosimp))
852 (t nil)))
854 (defun call-and-simp (mode fun args)
855 (cond ((or (not (eq mode '$any))
856 (tr-nosimpp fun))
857 `(,mode ,fun . ,args))
859 `(,mode simplify (,fun . ,args)))))
861 (defmspec $declare_translated (fns)
862 (setq fns (cdr fns))
863 (loop for v in fns
864 when (or (symbolp v) (and (stringp v) (setq v ($verbify v))))
865 do (setf (get v 'once-translated) t)
866 (pushnew v *declared-translated-functions*)
867 else do (merror (intl:gettext "declare_translated: arguments must be symbols or strings; found: ~:M") v)))
869 (def%tr $eval_when (form)
870 (tr-format (intl:gettext "error: found 'eval_when' in a function or expression: ~:M~%") form)
871 (tr-format (intl:gettext "note: 'eval_when' can appear only at the top level in a file.~%"))
872 (tr-abort)
873 '($any . nil))
875 (def%tr mdefmacro (form)
876 (tr-format (intl:gettext "warning: globally defining macro ~:M now to ensure correct macro expansions.~%") (caaadr form))
877 ; Define the macro now to ensure that it's defined when it's time
878 ; to expand it. It's a bug that this definition occurs during
879 ; translation without being cleaned it up afterward, but simply
880 ; removing this breaks things.
881 (meval form)
882 (punt-to-meval form))
884 (def%tr $local (form)
885 (when *local*
886 (tr-format (intl:gettext "error: there is already a 'local' in this block.~%"))
887 (tr-abort)
888 (return-from $local nil))
889 (setq *local* t)
890 ; We can't just translate to a call to MLOCAL here (which is
891 ; what used to happen). That would push onto LOCLIST and bind
892 ; MLOCP at the "wrong time". The push onto LOCLIST and the
893 ; binding of MLOCP are handled in TR-LAMBDA.
894 (punt-to-meval form))
897 (def%tr mquote (form)
898 (list (tr-class (cadr form)) 'quote (cadr form)))
901 (defun tr-lambda (form &optional (tr-body #'tr-seq) &rest tr-body-argl
902 &aux
903 (arglist (mparams (cadr form)))
904 (easy-assigns nil)
905 (*local* nil))
906 ;; This function is defined to take a simple macsyma lambda expression and
907 ;; return a simple lisp lambda expression. The optional TR-BODY hook
908 ;; can be used for translating other special forms that do lambda binding.
910 ;; Local SPECIAL declarations are not used because
911 ;; the multics lisp compiler does not support them. They are of course
912 ;; a purely syntactic construct that doesn't buy much. I have been
913 ;; advocating the use of DEFINE_VARIABLE in macsyma user programs so
914 ;; that the use of DECLARE(FOO,SPECIAL) will be phased out at that level.
916 (mapc #'tbind arglist)
917 (destructuring-let* (((mode . nbody) (apply tr-body (cddr form) tr-body-argl))
918 (local-declares (make-declares arglist t))
919 (body (if *local*
920 `((let ((mlocp t))
921 (push nil loclist)
922 (unwind-protect
923 (progn ,@nbody)
924 (munlocal))))
925 nbody)))
926 ;; -> BINDING of variables with ASSIGN properties may be difficult to
927 ;; do correctly and efficiently if arbitrary code is to be run.
928 (if (or tr-lambda-punt-assigns
929 (do ((l arglist (cdr l)))
930 ((null l) t)
931 (let* ((var (car l))
932 (assign (get var 'assign)))
933 (if assign
934 (cond ((eq assign 'assign-mode-check)
935 (push `(,assign ',var ,(teval var)) easy-assigns))
937 (return nil)))))))
938 ;; Case with EASY or no ASSIGN's
939 `(,mode . (lambda ,(tunbinds arglist)
940 ,local-declares
941 ,@easy-assigns
942 ,@body))
943 ;; Case with arbitrary ASSIGN's.
944 (let ((temps (mapcar #'(lambda (ign) ign (tr-gensym)) arglist)))
945 `(,mode . (lambda ,temps
946 (unwind-protect
947 (progn
948 ;; [1] Check before binding.
949 ,@(mapcan #'(lambda (var val)
950 (let ((assign (get var 'assign)))
951 (if assign
952 (let ((assign-fn (if (symbolp assign) `(quote ,assign) (coerce assign 'function))))
953 (list `(funcall ,assign-fn ',var ,val))))))
954 arglist temps)
955 ;; [2] do the binding.
956 ((lambda ,(tunbinds arglist)
957 ,local-declares
958 ,@body)
959 ,@temps))
960 ;; [2] check when unbinding too.
961 ,@(mapcan #'(lambda (var)
962 (let ((assign (get var 'assign)))
963 (if assign
964 (let ((assign-fn (if (symbolp assign) `(quote ,assign) (coerce assign 'function))))
965 (list `(funcall ,assign-fn ',var
966 ;; use DTRANSLATE to
967 ;; catch global
968 ;; scoping if any.
969 ,(dtranslate var)))))))
970 arglist))))))))
973 (defun make-declares (varlist localp &aux (dl) (fx) (fl) specs)
974 (do ((l varlist (cdr l))
975 (mode) (var))
976 ((null l))
978 ;; When a variable is declared special, be sure to declare it
979 ;; special here.
980 (when (and localp (tr-get-special (car l)))
981 (push (car l) specs))
983 (when (or (not localp)
984 (not (tr-get-special (car l))))
985 ;; don't output local declarations on special variables.
986 (setq var (teval (car l)) mode (value-mode var))
987 (setq specs (cons var specs))
989 (cond ((eq '$fixnum mode) (pushnew var fx :test #'eq))
990 ((eq '$float mode) (pushnew var fl :test #'eq)))))
991 (if fx (pushnew `(fixnum . ,fx) dl :test #'eq))
992 (if fl (pushnew `(type flonum . ,fl) dl :test #'eq))
993 (if specs (pushnew `(special . ,specs) dl :test #'eq))
994 (if dl `(declare . ,dl)))
996 (defun tr-seq (l)
997 (do ((mode nil)
998 (body nil))
999 ((null l)
1000 (cons mode (nreverse body)))
1001 (let ((exp (translate (pop l))))
1002 (setq mode (car exp))
1003 (push (cdr exp) body))))
1005 (def%tr mprogn (form)
1006 (setq form (tr-seq (cdr form)))
1007 (cons (car form) `(progn ,@(cdr form))))
1009 (defun go-tag-p (e)
1010 (or (symbolp e) (integerp e)))
1012 (def%tr mprog (form)
1013 (let (arglist body val-list)
1014 ;; [1] normalize the MPROG syntax.
1015 (cond (($listp (cadr form))
1016 (setq arglist (cdadr form)
1017 body (cddr form)))
1019 (setq arglist nil
1020 body (cdr form))))
1021 (cond ((null body)
1022 (setq body '(((mquote) $done)))))
1023 (setq val-list (mapcar #'(lambda (u)
1024 (if (atom u) u
1025 (translate (caddr u))))
1026 arglist)
1027 arglist (mapcar #'(lambda (u)
1028 ;; X or ((MSETQ) X Y)
1029 (if (atom u) u (cadr u)))
1030 arglist))
1031 (let ((dup (find-duplicate arglist :test #'eq)))
1032 (when dup
1033 (tr-format (intl:gettext "error: ~M occurs more than once in block variable list") dup)
1034 (tr-abort)
1035 (return-from mprog nil)))
1036 (setq form
1037 (tr-lambda
1038 ;; [2] call the lambda translator.
1039 `((lambda) ((mlist) ,@arglist) ,@body)
1040 ;; [3] supply our own body translator.
1041 #'tr-mprog-body
1042 val-list
1043 arglist))
1044 (cons (car form) `(,(cdr form) ,@val-list))))
1046 (defun tr-mprog-body (body val-list arglist
1047 &aux
1048 (inside-mprog t)
1049 (return-mode nil)
1050 (need-prog? nil)
1051 (*go-forms* nil)
1052 (*returns* nil) ;; not used but must be bound.
1054 (do ((l nil))
1055 ((null body)
1056 ;; [5] hack the val-list for the mode context.
1057 (mapl #'(lambda (val-list arglist)
1058 (cond ((atom (car val-list))
1059 (rplaca val-list
1060 (or (cdr (assoc (value-mode (car arglist))
1061 mode-init-value-table :test #'eq))
1062 `',(car arglist))))
1064 (warn-mode (car arglist)
1065 (value-mode (car arglist))
1066 (car (car val-list))
1067 "in a `block' statement")
1068 (rplaca val-list (cdr (car val-list))))))
1069 val-list arglist)
1070 (setq l (nreverse l))
1071 (cons return-mode
1072 (if need-prog?
1073 `((prog () ,@(delete nil l :test #'equal)))
1074 l)))
1075 ;; [4] translate a form in the body
1076 (let ((form (pop body)))
1077 (cond ((null body)
1078 (cond ((and (go-tag-p form) (find form *go-forms* :key #'cadr))
1079 ; we treat the last expression in the body as a go tag
1080 ; if (1) it looks like a go tag, and (2) we have seen a
1081 ; go form with this tag.
1082 (push form l)
1083 (setq form '(return '$done)))
1085 ;; this is a really bad case.
1086 ;; we don't really know if the return mode
1087 ;; of the expression is for the value of the block.
1088 ;; Some people write RETURN at the end of a block
1089 ;; and some don't. In any case, the people not
1090 ;; use the PROG programming style won't be screwed
1091 ;; by this.
1092 (setq form (translate form))
1093 (setq return-mode (*union-mode (car form) return-mode))
1094 (setq form (cdr form))
1095 (if (and need-prog?
1096 (or (atom form)
1097 (not (memq (car form) '(go return)))))
1098 ;; put a RETURN on just in case.
1099 (setq form `(return ,form))))))
1100 ((go-tag-p form))
1102 (setq form (dtranslate form))))
1103 (push form l))))
1105 (def%tr mreturn (form)
1106 (unless inside-mprog
1107 (tr-format (intl:gettext "error: 'return' not within 'block' or 'do': ~:M~%") form)
1108 (tr-abort)
1109 (return-from mreturn nil))
1110 (setq need-prog? t)
1111 (setq form (translate (cadr form)))
1112 (setq return-mode (*union-mode (car form) return-mode))
1113 (setq form `(return ,(cdr form)))
1114 (push form *returns*) ;; USED by lusing MDO etc not yet re-written.
1115 ;; MODE here should be $PHANTOM or something.
1116 `($any . ,form))
1118 (def%tr mgo (form)
1119 (unless inside-mprog
1120 (tr-format (intl:gettext "error: 'go' not within 'block' or 'do': ~:M~%") form)
1121 (tr-abort)
1122 (return-from mgo nil))
1123 (unless (go-tag-p (cadr form))
1124 (tr-format (intl:gettext "error: 'go' tag must be a symbol or an integer: ~:M~%") form)
1125 (tr-abort)
1126 (return-from mgo nil))
1127 (setq need-prog? t)
1128 (setq form `(go ,(cadr form)))
1129 (push form *go-forms*)
1130 `($any . ,form))
1132 (def%tr mqapply (form)
1133 (let ((fn (cadr form)) (args (cddr form))
1134 (aryp (member 'array (cdar form) :test #'eq)))
1135 (cond ((atom fn)
1136 ;; I'm guessing (ATOM FN) is a parser error or other Lisp error,
1137 ;; so don't bother to translate the following error message.
1138 (tr-format "translator: MQAPPLY operator must be a cons; found: ~:M" form)
1139 nil)
1140 ((eq (caar fn) 'mquote)
1141 `($any list ',(cons (cadr fn) aryp) ,@(tr-args args)))
1142 ((eq (caar fn) 'lambda)
1143 (let ((args (tr-args args))
1144 (fn (translate fn)))
1145 (cons (car fn) `(mfuncall ,(cdr fn) ,@args))))
1146 ((not aryp)
1147 `($any simplify (mapply ,(dconvx (translate fn))
1148 (list ,@(tr-args args))
1149 ',fn)))
1151 (warn-meval form)
1152 (punt-to-meval form)))))
1154 (defun mcond-eval-symbols-tr (form)
1155 (mcond-eval-symbols #'maybe-msymeval form))
1157 (def%tr mcond (form)
1158 (let ((g (tr-gensym))
1159 (nl nil)
1160 (mode nil))
1161 (do ((l (cdr form) (cddr l))) ((null l))
1162 ; Optimize the else-if case: if we're at the else case at the end
1163 ; and the body is just another conditional, then we just continue
1164 ; directly with the clauses of the inner conditional instead of
1165 ; nesting.
1166 (when (and (null (cddr l))
1167 (eq (car l) t)
1168 (consp (cadr l))
1169 (eq (caaadr l) 'mcond))
1170 (setq l (cdadr l)))
1171 (let ((wrap-a-pred 'mcond))
1172 (declare (special wrap-a-pred))
1173 (destructuring-let (((pred-mode . pred-tr) (translate-predicate (car l)))
1174 ((body-mode . body-tr) (translate (cadr l))))
1175 (setq mode (*union-mode mode body-mode))
1176 (if (eq pred-mode '$boolean)
1177 (setq nl (list* body-tr pred-tr nl))
1178 (setq nl (list* `(list* '(mcond) ,g (mapcar #'mcond-eval-symbols-tr ',(cdr l)))
1179 `(not (null ,g))
1180 body-tr
1181 `(eq t (setq ,g ,pred-tr))
1182 nl))))))
1183 ; We leave off the final clause if the condition is true
1184 ; and the consequent is false.
1185 (when (and (eq t (cadr nl)) (null (car nl)))
1186 (setq nl (cddr nl)))
1187 (setq form nil)
1188 (do ((l nl (cddr l))) ((null l))
1189 (setq form
1190 (cons (cons (cadr l)
1191 (cond ((and (not (atom (car l)))
1192 (cdr l)
1193 (eq (caar l) 'progn))
1194 (cdar l))
1195 ((and (equal (car l) (cadr l))
1196 (atom (car l))) nil)
1197 (t (list (car l)))))
1198 form)))
1199 (if (among g form)
1200 (cons '$any `(let (,g) (cond ,@form)))
1201 (cons mode `(cond ,@form)))))
1203 ;; The MDO and MDOIN translators should be changed to use the TR-LAMBDA.
1204 ;; Perhaps a mere expansion into an MPROG would be best.
1206 (def%tr mdo (form)
1207 (let (*returns* *go-forms* assigns return-mode (inside-mprog t) need-prog?)
1208 (let (mode var init next test-form action varmode)
1209 (setq var (cond ((cadr form)) (t 'mdo)))
1210 (tbind var)
1211 (setq init (if (caddr form) (translate (caddr form)) '($fixnum . 1)))
1212 (cond ((not (setq varmode (tr-get-mode var)))
1213 (declvalue var (car init) t)))
1214 (setq next (translate (cond ((cadddr form) (list '(mplus) (cadddr form) var))
1215 ((car (cddddr form)))
1216 (t (list '(mplus) 1 var)))))
1217 (setq form (copy-list form))
1218 ;;to make the end test for thru be numberp if the index is numberp
1219 ;;and to eliminate reevaluation
1220 (cond ((not varmode)
1221 (declvalue var (*union-mode (car init) (car next)) t))
1223 (warn-mode var varmode (*union-mode (car init) (car next)))))
1224 (destructuring-bind (test-mode . test-pred)
1225 (translate-predicate
1226 (list '(mor)
1227 (cond ((null (cadr (cddddr form))) nil)
1228 ((and (cadddr form)
1229 (mnegp ($numfactor (simplify (cadddr form)))))
1230 (list '(mlessp) var (cadr (cddddr form))))
1231 (t (list '(mgreaterp) var (cadr (cddddr form)))))
1232 (caddr (cddddr form))))
1233 (if (eq test-mode '$boolean)
1234 (setq test-form test-pred)
1235 (setq test-form `(let (($prederror t)) ,test-pred))))
1236 (setq action (translate (cadddr (cddddr form)))
1237 mode (cond ((null *returns*) '$any)
1238 (t return-mode)))
1239 (setq var (tunbind (cond ((cadr form)) (t 'mdo))))
1240 `(,mode do ((,var ,(cdr init) ,(cdr next)))
1241 (,test-form '$done) . ((declare (special ,var)) .
1242 ,(cond ((atom (cdr action)) nil)
1243 ((eq 'progn (cadr action)) (cddr action))
1244 (t (list (cdr action)))))))))
1246 (def%tr mdoin (form)
1247 (let (*returns* *go-forms* assigns return-mode (inside-mprog t) need-prog?)
1248 (prog (mode var init action)
1249 (setq var (tbind (cadr form))) (tbind 'mdo)
1250 (setq init (dtranslate (caddr form)))
1251 (cond ((or (cadr (cddddr form)) (caddr (cddddr form)))
1252 (tunbind 'mdo) (tunbind (cadr form))
1253 (return (punt-to-meval `((mdoin) . ,(cdr form))))))
1254 (setq action (translate (cadddr (cddddr form)))
1255 mode (cond ((null *returns*) '$any)
1256 (t return-mode)))
1257 (tunbind 'mdo) (tunbind (cadr form))
1258 (return
1259 `(,mode do ((,var) (mdo (cdr ,init) (cdr mdo)))
1260 ((null mdo) '$done) .
1261 ((declare (special ,var)) (setq ,var (car mdo)) .
1262 ,(cond ((atom (cdr action)) nil)
1263 ((eq 'progn (cadr action)) (cddr action))
1264 (t (list (cdr action))))))))))
1267 (defun lambda-wrap1 (tn val form)
1268 (if (or (atom val)
1269 (eq (car val) 'quote))
1270 (subst val tn form)
1271 `((lambda (,tn) ,form) ,val)))
1273 (def%tr msetq (form)
1274 (let ((var (cadr form))
1275 (val (caddr form))
1276 assign
1277 mode)
1278 (cond ((atom var)
1279 (setq mode (value-mode var) val (translate val))
1280 (warn-mode var mode (car val))
1281 (if (eq '$any mode)
1282 (setq mode (car val) val (cdr val))
1283 (setq val (dconv val mode)))
1284 (cons mode
1285 (if (setq assign (get var 'assign))
1286 (let ((tn (tr-gensym))
1287 (assign-fn (if (symbolp assign) `(quote ,assign) (coerce assign 'function))))
1288 (lambda-wrap1 tn val `(let nil
1289 (declare (special ,var ,(teval var)))
1290 (funcall ,assign-fn ',var ,tn)
1291 (setq ,(teval var) ,tn))))
1292 `(let nil (declare (special ,(teval var)))
1293 (if (not (boundp ',(teval var)))
1294 (add2lnc ',(teval var) $values))
1295 (,(if *macexpr-top-level-form-p*
1296 'defparameter
1297 'setq)
1298 ,(teval var) ,val)))))
1299 ((member 'array (car var) :test #'eq)
1300 (tr-arraysetq var val))
1302 (unless (safe-get (caar var) 'mset_extension_operator)
1303 (tr-format (intl:gettext "warning: no assignment operator known for ~:M~%") var)
1304 (tr-format (intl:gettext "note: just keep going and hope for the best.~%")))
1305 (setq val (translate val))
1306 `(,(car val) mset ',var ,(cdr val))))))
1308 (def%tr $max (x) (translate-$max-$min x))
1309 (def%tr $min (x) (translate-$max-$min x))
1310 (def%tr %max (x) (translate-$max-$min x))
1311 (def%tr %min (x) (translate-$max-$min x))
1313 (defun translate-$max-$min (form)
1314 (let ((mode) (arglist) (op (stripdollar (caar form))))
1315 (setq arglist
1316 (mapcar (lambda (l)
1317 (setq l (translate l))
1318 (cond ((null mode)
1319 (setq mode (car l)))
1320 ((eq mode (car l)))
1322 (setq mode '$any)))
1324 (cdr form)))
1325 ; To match the interpreted case, and to make sure we use the
1326 ; correct mode for the return value, we do not apply float
1327 ; contagion to the arguments and we use a special translation
1328 ; to call MAX or MIN only when every argument has the same
1329 ; mode (either all fixnum or all float). CLHS says that
1330 ; implementations have choices they can make about what MAX
1331 ; and MIN return when the arguments are a mix of float and
1332 ; rational types.
1333 ; Example: if an implementation decides to apply float contagion
1334 ; to the arguments of MAX (MIN), then it can return either an
1335 ; integer or a float if the greatest (least) argument was an
1336 ; integer.
1337 (if (member mode '($fixnum $float) :test #'eq)
1338 `(,mode ,(if (eq 'min op) 'min 'max) . ,(mapcar 'cdr arglist))
1339 `($any ,(if (eq 'min op) '$lmin '$lmax)
1340 (list '(mlist) . ,(mapcar 'dconvx arglist))))))
1343 ;;; mode accessing, binding, handling. Super over-simplified.
1345 (defun tr-class (x)
1346 (cond ((integerp x) '$fixnum)
1347 ((floatp x) '$float)
1348 ((member x '(t nil) :test #'eq) '$boolean)
1349 ((atom x) '$any)
1350 ((eq 'rat (caar x)) '$rational)
1351 (t '$any)))
1353 (defun *union-mode (mode1 mode2)
1354 (cond ((eq mode1 mode2) mode1)
1355 ((null mode1) mode2)
1356 ((null mode2) mode1)
1357 ((eq '$boolean mode1) '$any)
1358 ((eq '$boolean mode2) '$any)
1359 ((member mode2 *$any-modes* :test #'eq) '$any)
1360 ((member mode1 *$any-modes* :test #'eq) '$any)
1361 ((eq '$fixnum mode1) mode2)
1362 ((eq '$float mode1)
1363 (if (eq '$number mode2) '$number '$float))
1364 ((eq '$rational mode1)
1365 (if (eq '$float mode2) '$float '$any))
1366 ((eq '$number mode1)
1367 (if (eq '$rational mode2) '$any '$number))
1368 (t '$any)))
1370 (defun value-mode (var)
1371 (cond ((tr-get-mode var))
1373 (warn-undeclared var)
1374 '$any)))
1376 (defun decmode-arrayfun (f m)
1377 (putprop f m 'arrayfun-mode))
1379 (defun array-mode (ar)
1380 (cond ((get ar 'array-mode)) (t '$any)))
1382 (defun arrayfun-mode (ar)
1383 (cond ((get ar 'arrayfun-mode)) (t '$any)))
1385 (defun function-mode (f)
1386 (cond ((get f 'function-mode)) (t '$any)))
1388 (defun function-mode-@ (f)
1389 (ass-eq-ref (tr-get-val-modes f) 'function-mode '$any))
1391 (defun array-mode-@ (f)
1392 (ass-eq-ref (tr-get-val-modes f) 'array-mode '$any))
1395 (defvar $tr_bind_mode_hook nil
1396 "A hack to allow users to key the modes of variables
1397 off of variable spelling, and other things like that.")
1399 ;; TBIND, below, copies the MODE, VAL-MODES, and SPECIAL properties
1400 ;; into the a table named TSTACK, and then removes those properties.
1401 ;; So if TBIND has been called, we will need to look for those
1402 ;; properties in TSTACK instead of the symbol property list.
1404 (defstruct (tstack-slot (:conc-name tstack-slot-))
1405 mode
1406 tbind
1407 val-modes
1408 ;; an alist telling second order info
1409 ;; about APPLY(VAR,[X]), ARRAYAPPLY(F,[X]) etc.
1410 special)
1412 (defun tr-get-mode (a)
1413 (if (get a 'tbind)
1414 (let ((my-slot (cdr (assoc a tstack))))
1415 (tstack-slot-mode my-slot))
1416 (get a 'mode)))
1418 #-gcl (defun (setf tr-get-mode) (b a)
1419 (if (get a 'tbind)
1420 (let ((my-slot (cdr (assoc a tstack))))
1421 (setf (tstack-slot-mode my-slot) b))
1422 (setf (get a 'mode) b)))
1424 #+gcl (defsetf tr-get-mode (a) (b)
1425 `(if (get ,a 'tbind)
1426 (let ((my-slot (cdr (assoc ,a tstack))))
1427 (setf (tstack-slot-mode my-slot) ,b))
1428 (setf (get ,a 'mode) ,b)))
1430 (defun tr-get-val-modes (a)
1431 (if (get a 'tbind)
1432 (let ((my-slot (cdr (assoc a tstack))))
1433 (tstack-slot-val-modes my-slot))
1434 (get a 'val-modes)))
1436 #-gcl (defun (setf tr-get-val-modes) (b a)
1437 (if (get a 'tbind)
1438 (let ((my-slot (cdr (assoc a tstack))))
1439 (setf (tstack-slot-val-modes my-slot) b))
1440 (setf (get a 'val-modes) b)))
1442 #+gcl (defsetf tr-get-val-modes (a) (b)
1443 `(if (get ,a 'tbind)
1444 (let ((my-slot (cdr (assoc ,a tstack))))
1445 (setf (tstack-slot-val-modes my-slot) ,b))
1446 (setf (get ,a 'val-modes) ,b)))
1448 (defun tr-get-special (a)
1449 (if (get a 'tbind)
1450 (let ((my-slot (cdr (assoc a tstack))))
1451 (tstack-slot-special my-slot))
1452 (get a 'special)))
1454 #-gcl (defun (setf tr-get-special) (b a)
1455 (if (get a 'tbind)
1456 (let ((my-slot (cdr (assoc a tstack))))
1457 (setf (tstack-slot-special my-slot) b))
1458 (setf (get a 'special) b)))
1460 #+gcl (defsetf tr-get-special (a) (b)
1461 `(if (get ,a 'tbind)
1462 (let ((my-slot (cdr (assoc ,a tstack))))
1463 (setf (tstack-slot-special my-slot) ,b))
1464 (setf (get ,a 'special) ,b)))
1466 ;;; should be a macro (TBINDV <var-list> ... forms)
1467 ;;; so that TUNBIND is assured, and also so that the stupid ASSQ doesn't
1468 ;;; have to be done on the darn TSTACK. This will have to wait till
1469 ;;; the basic special form translation properties are rewritten.
1471 (defun variable-p (var)
1472 (and var (symbolp var) (not (eq var t))))
1474 (defun bad-var-warn (var)
1475 (tr-format (intl:gettext "warning: ~:M cannot be used as a variable.~%") var))
1477 (defun tbind (var &aux old)
1478 (cond ((variable-p var)
1479 (setq old (make-tstack-slot :mode (get var 'mode)
1480 :tbind (get var 'tbind)
1481 :val-modes (get var 'val-modes)
1482 :special (get var 'special)))
1483 (push (cons var old) tstack)
1484 (cond ((not (specialp var))
1485 ;; It is the lisp convention in use to inherit
1486 ;; specialness from higher context.
1487 ;; Spurious MODEDECLARATIONS get put in the environment
1488 ;; when code is MEVAL'd since there is no way to stack
1489 ;; the mode properties. Certainly nobody is willing
1490 ;; to hack MEVAL in JPG;MLISP
1491 (remprop var 'val-modes)
1492 (remprop var 'mode)
1493 (remprop var 'special)))
1494 (putprop var var 'tbind)
1495 (if $tr_bind_mode_hook
1496 (let ((mode? (mapply $tr_bind_mode_hook
1497 (list var)
1498 '$tr_bind_mode_hook)))
1499 (if mode? (tr-declare-varmode var mode?))))
1500 var)
1502 (bad-var-warn var))))
1504 (defun tunbind (var &aux (old (assoc var tstack :test #'eq)))
1505 (when (variable-p var)
1506 (prog1
1507 (teval var)
1508 (cond (old
1509 (setq tstack (delete old tstack :test #'eq)) ; POP should be all we need.
1510 (setq old (cdr old))
1511 (putprop1 var (tstack-slot-mode old) 'mode)
1512 (putprop1 var (tstack-slot-tbind old) 'tbind)
1513 (putprop1 var (tstack-slot-val-modes old) 'val-modes)
1514 (putprop1 var (tstack-slot-special old) 'special))))))
1516 (defun putprop1 (name value key)
1517 ;; leaves property list clean after unwinding, this
1518 ;; is an efficiency/storage issue only.
1519 (if value
1520 (putprop name value key)
1521 (progn
1522 (remprop name key)
1523 nil)))
1525 (defun tunbinds (l)
1526 (do ((nl))
1527 ((null l) nl)
1528 (setq nl (cons (tunbind (caar tstack)) nl)
1529 l (cdr l))))
1531 (defun tboundp (var)
1532 ;; really LEXICAL-VARP.
1533 (and (symbolp var) (get var 'tbind) (not (tr-get-special var))))
1535 (defun teval (var)
1536 (or (and (symbolp var) (get var 'tbind)) var))
1538 ;; Local Modes:
1539 ;; Mode: LISP
1540 ;; Comment Col: 40
1541 ;; END: