1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 (macsyma-module transl
)
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
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
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
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
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
))
178 (nil .
($boolean . nil
))))
180 (defvar mode-init-value-table
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
206 (tr-format (intl:gettext
"Internal translator error: ~M~%") msg
)
207 (cond (*transl-debug
*
208 (break "transl barfo"))
213 (defun specialp (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
224 ;;; (3) Summaries on a cross-referenced per-function and per-item
225 ;;; should be printed at the end, as a table.
227 ;;; Undefined Functions used in
228 ;;; FOO BAR, BAZ,BOMB
230 ;;; Undefined Variables ... same thing
231 ;;; Incomprehensible special forms
233 ;;; Predicate Mode Targeting failures.
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)
251 (member val
'($all $compile $compfile $translate
) :test
#'eq
))
252 ((or *in-compfile
* *in-translate-file
*)
253 (member val
'($all $compfile $translate
) :test
#'eq
))
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
)
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.~%"))
275 (dolist (v *translation-msgs-files
*)
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
*)
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
)
300 (dolist (v *translation-msgs-files
*)
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
)
312 (dolist (v *translation-msgs-files
*)
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
)))
338 (or (variable-p (car l
))
339 (bad-var-warn (car l
)))))
340 (($modedeclare
) ,@vars-modes
)
342 (let ((mode (car loc
))
343 (exp (car (last loc
))))
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
))
357 (if (member (car x
) '(ratexpr pexpr
) :test
#'eq
)
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
))))
369 (/ (float (cadadr (cdr x
))) (float (caddr (caddr x
)))))))
372 (defun dconv-$cre
(x)
373 (if (eq '$cre
(car 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
)
392 (tr-mdefine-toplevel def-form
)))))
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
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
)))
415 ((and (not full-restricted-flag
)
418 (cdr u
) (atom (cadr u
)))
419 (push (cadr u
) a-args
)
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
*)))
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
))
447 ((member (caar form
) '(mdefine mdefmacro
) :test
#'eq
)
448 (setq kind
(cond ((eq (caar form
) 'mdefmacro
) 'macro
)
449 ((member 'array flags
:test
#'eq
) 'array
)
452 (tr-lambda `((lambda) ((mlist) ,@a-args
) ,body
)))
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
)))
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
)
472 '((,name
,@flags
) ,@args
)
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
)
488 ;;once a function has been translated we want to make sure mfunction-call is eliminated.
490 (remprop (car desc-header
) 'undefined-warnp
)
491 (setf (get (car desc-header
) 'once-translated
) "I was once translated"))
493 ,@(nreverse out-forms
)
494 (defmtrfun ,desc-header
,@(cdr (cdr t-form
))))))
498 (defun translate-function (name)
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
)))))
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
)
514 (return-from translate-function nil
)))
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
)
523 (tr-format (intl:gettext
"Message: ~A~%") msg
))
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 "::=".
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)
537 (defun tr-eval-when-situation (situation)
539 (($compile compile
:compile-toplevel
)
541 (($load load
:load-toplevel
)
543 (($eval eval
: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
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
))
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
))
567 (cond ((member '$translate whens
:test
#'eq
)
569 (cond ((member '$loadfile whens
:test
#'eq
)
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
)
578 (:compile-toplevel
:load-toplevel
:execute
)
580 ((member (caar form
) '(mdefine mdefmacro
) :test
#'eq
)
581 (let ((name (caaadr form
))
583 (tr-format (intl:gettext
"note: translating ~:@M~%") name
)
584 (setq trl
(tr-mdefine-toplevel form
))
586 (tr-format (intl:gettext
"error: failed to translate ~:@M~%") name
)
587 (tr-format (intl:gettext
"note: keep going and hope for the best.~%"))
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
))
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
))
604 (let ((t-form (dtranslate 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.
623 (cond ((symbolp form
)
624 ;; If this symbol has the constant property, then
625 ;; use its assigned constant value in place of the
627 (let ((v (getl (mget form
'$props
) '($constant
))))
628 (if v
(cadr v
) 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
))
639 (setq new-form
(toplevel-optimize-1 form
))
640 (cond ((atom new-form
)
641 (return (toplevel-optimize new-form
)))
645 (setq form new-form
)))))))
647 (defun toplevel-optimize-1 (form &aux
(op (car form
)) prop
)
649 (member 'array op
:test
#'eq
)) form
)
650 ((progn (setq op
(car op
))
652 (if $transrun
; crock a minute.
653 (or (get op
'translated-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
)
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
674 (mgetl op
'(mexpr)))))
677 (cons (car form
) (cdr 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
*))
685 (and *transl-debug
* (push form
*transl-backtrace
*))
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
))
696 ((and (setq temp
(mget form
'$numer
)) $tr_numer
)
698 ((implied-quotep form
)
700 ((self-evaluating-lisp-object-p 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
))
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
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.
731 ;; TRANSLATE properties have priority.
732 ((setq temp
(get (caar form
) 'translate
))
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)
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
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
)
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
*)
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.
783 (punt-to-meval form
(function-mode (caar form
))))))
786 (defun attempt-translate-random-macro-op (form)
788 `($any .
,(cons (caar form
) (cdr form
))))
790 (defun attempt-translate-random-special-op (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
)))
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
)
816 ((mget fun
'$variable_num_args_function
)
818 ((setq temp
(getl fun
'(expr subr lsubr
)))
820 ((get fun
'once-translated
))
821 ((get fun
'translated
))
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)
854 (defun call-and-simp (mode fun args
)
855 (cond ((or (not (eq mode
'$any
))
857 `(,mode
,fun .
,args
))
859 `(,mode simplify
(,fun .
,args
)))))
861 (defmspec $declare_translated
(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.~%"))
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.
882 (punt-to-meval form
))
884 (def%tr $local
(form)
886 (tr-format (intl:gettext
"error: there is already a 'local' in this block.~%"))
888 (return-from $local nil
))
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
903 (arglist (mparams (cadr form
)))
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
))
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
)))
932 (assign (get var
'assign
)))
934 (cond ((eq assign
'assign-mode-check
)
935 (push `(,assign
',var
,(teval var
)) easy-assigns
))
938 ;; Case with EASY or no ASSIGN's
939 `(,mode .
(lambda ,(tunbinds arglist
)
943 ;; Case with arbitrary ASSIGN's.
944 (let ((temps (mapcar #'(lambda (ign) ign
(tr-gensym)) arglist
)))
945 `(,mode .
(lambda ,temps
948 ;; [1] Check before binding.
949 ,@(mapcan #'(lambda (var val
)
950 (let ((assign (get var
'assign
)))
952 (let ((assign-fn (if (symbolp assign
) `(quote ,assign
) (coerce assign
'function
))))
953 (list `(funcall ,assign-fn
',var
,val
))))))
955 ;; [2] do the binding.
956 ((lambda ,(tunbinds arglist
)
960 ;; [2] check when unbinding too.
961 ,@(mapcan #'(lambda (var)
962 (let ((assign (get var
'assign
)))
964 (let ((assign-fn (if (symbolp assign
) `(quote ,assign
) (coerce assign
'function
))))
965 (list `(funcall ,assign-fn
',var
969 ,(dtranslate var
)))))))
973 (defun make-declares (varlist localp
&aux
(dl) (fx) (fl) specs
)
974 (do ((l varlist
(cdr l
))
978 ;; When a variable is declared special, be sure to declare it
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
)))
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
))))
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
)
1022 (setq body
'(((mquote) $done
)))))
1023 (setq val-list
(mapcar #'(lambda (u)
1025 (translate (caddr u
))))
1027 arglist
(mapcar #'(lambda (u)
1028 ;; X or ((MSETQ) X Y)
1029 (if (atom u
) u
(cadr u
)))
1031 (let ((dup (find-duplicate arglist
:test
#'eq
)))
1033 (tr-format (intl:gettext
"error: ~M occurs more than once in block variable list") dup
)
1035 (return-from mprog nil
)))
1038 ;; [2] call the lambda translator.
1039 `((lambda) ((mlist) ,@arglist
) ,@body
)
1040 ;; [3] supply our own body translator.
1044 (cons (car form
) `(,(cdr form
) ,@val-list
))))
1046 (defun tr-mprog-body (body val-list arglist
1052 (*returns
* nil
) ;; not used but must be bound.
1056 ;; [5] hack the val-list for the mode context.
1057 (mapl #'(lambda (val-list arglist
)
1058 (cond ((atom (car val-list
))
1060 (or (cdr (assoc (value-mode (car arglist
))
1061 mode-init-value-table
:test
#'eq
))
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
))))))
1070 (setq l
(nreverse l
))
1073 `((prog () ,@(delete nil l
:test
#'equal
)))
1075 ;; [4] translate a form in the body
1076 (let ((form (pop 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.
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
1092 (setq form
(translate form
))
1093 (setq return-mode
(*union-mode
(car form
) return-mode
))
1094 (setq form
(cdr form
))
1097 (not (memq (car form
) '(go return
)))))
1098 ;; put a RETURN on just in case.
1099 (setq form
`(return ,form
))))))
1102 (setq form
(dtranslate form
))))
1105 (def%tr mreturn
(form)
1106 (unless inside-mprog
1107 (tr-format (intl:gettext
"error: 'return' not within 'block' or 'do': ~:M~%") form
)
1109 (return-from mreturn nil
))
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.
1119 (unless inside-mprog
1120 (tr-format (intl:gettext
"error: 'go' not within 'block' or 'do': ~:M~%") form
)
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
)
1126 (return-from mgo nil
))
1128 (setq form
`(go ,(cadr form
)))
1129 (push form
*go-forms
*)
1132 (def%tr mqapply
(form)
1133 (let ((fn (cadr form
)) (args (cddr form
))
1134 (aryp (member 'array
(cdar form
) :test
#'eq
)))
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
)
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
))))
1147 `($any simplify
(mapply ,(dconvx (translate fn
))
1148 (list ,@(tr-args args
))
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))
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
1166 (when (and (null (cddr l
))
1169 (eq (caaadr l
) 'mcond
))
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
)))
1181 `(eq t
(setq ,g
,pred-tr
))
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
)))
1188 (do ((l nl
(cddr l
))) ((null l
))
1190 (cons (cons (cadr l
)
1191 (cond ((and (not (atom (car l
)))
1193 (eq (caar l
) 'progn
))
1195 ((and (equal (car l
) (cadr l
))
1196 (atom (car l
))) nil
)
1197 (t (list (car l
)))))
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.
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
)))
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
1227 (cond ((null (cadr (cddddr form
))) nil
)
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
)
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
)
1257 (tunbind 'mdo
) (tunbind (cadr form
))
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
)
1269 (eq (car val
) 'quote
))
1271 `((lambda (,tn
) ,form
) ,val
)))
1273 (def%tr msetq
(form)
1274 (let ((var (cadr form
))
1279 (setq mode
(value-mode var
) val
(translate val
))
1280 (warn-mode var mode
(car val
))
1282 (setq mode
(car val
) val
(cdr val
))
1283 (setq val
(dconv val 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
*
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
))))
1317 (setq l
(translate l
))
1319 (setq mode
(car l
)))
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
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
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.
1346 (cond ((integerp x
) '$fixnum
)
1347 ((floatp x
) '$float
)
1348 ((member x
'(t nil
) :test
#'eq
) '$boolean
)
1350 ((eq 'rat
(caar x
)) '$rational
)
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
)
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
))
1370 (defun value-mode (var)
1371 (cond ((tr-get-mode var
))
1373 (warn-undeclared var
)
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-
))
1408 ;; an alist telling second order info
1409 ;; about APPLY(VAR,[X]), ARRAYAPPLY(F,[X]) etc.
1412 (defun tr-get-mode (a)
1414 (let ((my-slot (cdr (assoc a tstack
))))
1415 (tstack-slot-mode my-slot
))
1418 #-gcl
(defun (setf tr-get-mode
) (b a
)
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)
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
)
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)
1450 (let ((my-slot (cdr (assoc a tstack
))))
1451 (tstack-slot-special my-slot
))
1454 #-gcl
(defun (setf tr-get-special
) (b a
)
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
)
1493 (remprop var
'special
)))
1494 (putprop var var
'tbind
)
1495 (if $tr_bind_mode_hook
1496 (let ((mode?
(mapply $tr_bind_mode_hook
1498 '$tr_bind_mode_hook
)))
1499 (if mode?
(tr-declare-varmode var mode?
))))
1502 (bad-var-warn var
))))
1504 (defun tunbind (var &aux
(old (assoc var tstack
:test
#'eq
)))
1505 (when (variable-p var
)
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.
1520 (putprop name value key
)
1528 (setq nl
(cons (tunbind (caar tstack
)) nl
)
1531 (defun tboundp (var)
1532 ;; really LEXICAL-VARP.
1533 (and (symbolp var
) (get var
'tbind
) (not (tr-get-special var
))))
1536 (or (and (symbolp var
) (get var
'tbind
)) var
))