1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; The data in this file contains enhancments. ;;;;; 4;;; ;;;;; 5;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;; 6;;; All rights reserved ;;;;; 7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; 9;;; GJC 9:29am Saturday, 5 April 1980 ;;; 10;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 12(in-package :maxima) 13 14(macsyma-module transl) 15 16;;; File directory. 17 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. 46 47 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" 60 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. 85 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>. 90 91 92(defvar *untranslated-functions-called* nil) 93 94(defmvar *declared-translated-functions* nil 95 "List of functions which are believed to be translated.") 96 97(defmvar $tr_semicompile nil 98 "If TRUE TRANSLATE_FILE and COMPFILE output forms which will~ 99 be macroexpanded but not compiled into machine code by the~ 100 lisp compiler.") 101 102(defmvar $transcompile t 103 "If TRUE TRANSLATE_FILE outputs declarations for the COMPLR. 104 The only use of the switch is to save the space declarations take 105 up in interpreted code.") 106 107(defmvar tstack nil " stack of local variable modes ") 108 109(defmvar local nil "T if a $local statement is in the body.") 110(defmvar arrays nil "arrays to declare to `complr'") 111(defmvar lexprs nil "Lexprs to declare.") 112(defmvar exprs nil "what else?") 113(defmvar fexprs nil "Fexprs to declare.") 114(defmvar tr-progret t) 115(defmvar inside-mprog nil) 116(defmvar returns nil "list of `translate'd return forms in the block.") 117(defmvar return-mode nil "the highest(?) mode of all the returns.") 118(defmvar need-prog? nil) 119(defmvar assigns nil "These are very-special variables which have a Maxima 120 assign property which must be called to bind and unbind the variable 121 whenever it is `lambda' bound.") 122 123(defmvar specials nil "variables to declare special to the complr.") 124 125(defmvar translate-time-evalables 126 '($modedeclare $alias $declare $infix $nofix $declare_translated 127 $matchfix $prefix $postfix $compfile)) 128 129(defmvar *transl-backtrace* nil 130 " What do you think? ") 131 132(defmvar *transl-debug* nil "if T it pushes `backtrace' and `trace' ") 133 134(defmvar tr-abort nil "set to T if abortion is requested by any of the 135 sub-parts of the translation. A *THROW would be better, although it 136 wouldn't cause the rest of the translation to continue, which may 137 be useful in translation for MAXIMA-ERROR checking.") 138 139(defmvar tr-unique (gensym) 140 "this is just a unque object used for random purposes, 141 such as the second (file end) argument of READ.") 142 143 144(defmvar $tr_warn_undeclared '$compile 145 "When to send warnings about undeclared variables to the TTY") 146 147(defmvar $tr_warn_meval '$compfile 148 "If `meval' is called that indicates problems in the translation") 149 150(defmvar $tr_warn_fexpr 151 '$compfile 152 "FEXPRS should not normally be output in translated code, all legitimate 153special program forms are translated.") 154 155(defmvar $tr_warn_mode '$all 156 "Warn when variables are assigned values out of their mode.") 157 158(defmvar $tr_warn_undefined_variable '$all 159 "Warn when undefined global variables are seen.") 160 161 162(defmvar *warned-un-declared-vars* nil "Warning State variable") 163(defmvar *warned-fexprs* nil "Warning State variable") 164(defmvar *warned-mode-vars* nil "Warning State variable") 165 166(defmvar $tr_function_call_default '$general 167 " 168FALSE means punt to MEVAL, EXPR means assume lisp fixed arg function. 169GENERAL, the default gives code good for mexprs and mlexprs but not macros. 170GENERAL assures variable bindings are correct in compiled code. 171In GENERAL mode, when translating F(X), if F is a bound variable, then 172it assumes that APPLY(F,[X]) is meant, and translates a such, with 173appropriate warning. There is no need to turn this off. 174APPLY means like APPLY.") 175 176(defmvar $tr_array_as_ref t 177 "If true runtime code uses value of the variable as the array.") 178 179(defmvar $tr_numer nil 180 "If `true' numer properties are used for atoms which have them, e.g. %pi") 181 182(defvar boolean-object-table 183 '(($true . ($boolean . t)) 184 ($false . ($boolean . nil)) 185 (t . ($boolean . t)) 186 (nil . ($boolean . nil)))) 187 188(defvar mode-init-value-table 189 '(($float . 0.0) 190 ($fixnum . 0) 191 ($number . 0) 192 ($list . '((mlist))) 193 ($boolean . nil))) 194 195(defvar tr-lambda-punt-assigns nil 196 "Kludge argument to `tr-lambda' due to lack of keyword argument passing") 197 198(or (boundp '*in-compile*) 199 (setq *in-compile* nil)) 200 201;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 203 204(defun barfo (&rest l) 205 (apply #'tr-format 206 (nconc (list (intl:gettext "translator: internal error. Message: ~:M~%")) l)) 207 (cond (*transl-debug* 208 (break "transl barfo")) 209 (t 210 (setq tr-abort t) 211 nil))) 212 213(defun specialp (var) 214 (cond ((or (optionp var) 215 (tr-get-special var)) 216 (if $transcompile (pushnew var specials :test #'eq)) 217 t))) 218 219 220;;; The error message system. Crude as it is. 221;;; I tell you how this aught to work: 222;;; (1) All state should be in one structure, one state variable. 223;;; (2) Should print out short message on-the-fly so that it 224;;; gives something to watch, and also so that it says something 225;;; if things crash. 226;;; (3) Summaries on a cross-referenced per-function and per-item 227;;; should be printed at the end, as a table. 228;;; e.g. 229;;; Undefined Functions used in 230;;; FOO BAR, BAZ,BOMB 231;;; FOOA P,Q 232;;; Undefined Variables ... same thing 233;;; Incomprehensible special forms 234;;; EV .... 235;;; Predicate Mode Targeting failures. 236;;; ..... -gjc 237 238;;; The way it works now is to print too little or too much. 239;;; Many items are only warned about the first time seen. 240;;; However, this isn't too much of a problem when using Emacs 241;;; to edit code, because searching for warned-about tokens 242;;; is quick and easy. 243 244(defmvar *tr-warn-break* t 245 " if in debug mode `warning's signaled go to lisp break loops ") 246 247(defmacro tr-warnbreak () 248 `(and *transl-debug* *tr-warn-break* (break "transl"))) 249 250(defun tr-warnp (val) 251 (and val 252 (cond (*in-compile* 253 (member val '($all $compile $compfile $translate) :test #'eq)) 254 ((or *in-compfile* *in-translate-file*) 255 (member val '($all $compfile $translate) :test #'eq)) 256 (*in-translate* 257 (member val '($all $translate) :test #'eq))))) 258 259(defvar warned-undefined-variables nil) 260 261(defun warn-undefined-variable (form) 262 (and (tr-warnp $tr_warn_undefined_variable) 263 (cond ((member form warned-undefined-variables :test #'eq)) 264 (t 265 (push form warned-undefined-variables) 266 (tr-format (intl:gettext "warning: encountered undefined variable ~:M in translation.~%") form) 267 (tr-warnbreak))))) 268 269(defun warn-undeclared (form &optional comment) 270 (and (tr-warnp $tr_warn_undeclared) 271 (cond ((member form *warned-un-declared-vars* :test #'equal) t) 272 (t 273 (push form *warned-un-declared-vars*) 274 (tr-format (intl:gettext "warning: no type declaration for ~:M; assume type is 'any'.~%") form) 275 (tr-format (intl:gettext "note: 'modedeclare' declares types for translation.~%")) 276 (cond (comment 277 (dolist (v *translation-msgs-files*) 278 (terpri v) 279 (princ comment v)))) 280 (tr-warnbreak) 281 nil)))) 282 283(defun warn-meval (form &optional comment) 284 (cond ((tr-warnp $tr_warn_meval) 285 (tr-format (intl:gettext "warning: emit call to MEVAL for expression: ~:M~%") form) 286 (cond (comment (dolist (v *translation-msgs-files*) 287 (terpri v) 288 (princ comment v)))) 289 (tr-warnbreak) 290 'warned))) 291 292 293(defun warn-mode (var mode newmode &optional comment) 294 (cond ((eq mode newmode)) 295 (t 296 (cond ((and (tr-warnp $tr_warn_mode) 297 (not (covers mode newmode)) 298 (not (member (list var mode newmode) *warned-mode-vars* :test #'equal))) 299 (push (list var mode newmode) *warned-mode-vars*) 300 (tr-format (intl:gettext "warning: variable ~:M (declared type ~:M) assigned type ~:M.~%") var mode newmode) 301 (cond (comment 302 (dolist (v *translation-msgs-files*) 303 (terpri v) 304 (princ comment v)))) 305 (tr-warnbreak)))))) 306 307(defun warn-fexpr (form &optional comment) 308 (cond ((and (tr-warnp $tr_warn_fexpr) 309 (not (member form *warned-fexprs* :test #'equal))) 310 (push form *warned-fexprs*) 311 (tr-format (intl:gettext "warning: ~:M is a special function without a full Lisp translation.~%") form) 312 (tr-format (intl:gettext "warning: calling ~:M in compiled code might not have the desired effect.~%") form) 313 (cond (comment 314 (dolist (v *translation-msgs-files*) 315 (terpri v) 316 (princ comment v)))) 317 (tr-warnbreak)))) 318 319 320(defun macsyma-special-macro-p (fcn) 321 (getl-lm-fcn-prop fcn '(macro))) 322 323(defun macsyma-special-op-p (f) 324 (getl f '(fsubr fexpr mfexpr* mfexpr*s *fexpr))) 325 326(defun possible-predicate-op-p (f) 327 (member f '(mnotequal mequal $equal mgreaterp mgeqp mlessp mleqp) :test #'eq)) 328 329;;;***************************************************************;;; 330 331;;; This function is the way to call the TRANSLATOR on an expression with 332;;; locally bound internal mode declarations. Result of TR-LAMBDA will be 333;;; (MODE . (LAMBDA (...) (DECLARE ...) TRANSLATED-EXP)) 334 335(defun tr-local-exp (exp &rest vars-modes) 336 (let ((loc (let ((tr-lambda-punt-assigns t)) 337 (tr-lambda `((lambda) ((mlist) ,@(do ((l vars-modes (cddr l)) 338 (ll nil (cons (car l) ll))) 339 ((null l) ll) 340 (or (variable-p (car l)) 341 (bad-var-warn (car l))))) 342 (($modedeclare) ,@vars-modes) 343 ,exp))))) 344 (let ((mode (car loc)) 345 (exp (car (last loc)))) ;;; length varies with TRANSCOMPILE. 346 (cons mode exp)))) 347 348(defun tr-args (form) 349 (mapcar #'(lambda (x) (dconvx (translate x))) form)) 350 351(defun dtranslate (form) (cdr (translate form))) 352 353(defun dconv (x mode) 354 (cond ((eq '$float mode) (dconv-$float x)) 355 ((eq '$cre mode) (dconv-$cre x)) 356 (t (cdr x)))) 357 358(defun dconvx (x) 359 (if (member (car x) '(ratexpr pexpr) :test #'eq) 360 (dconv-$cre x) 361 (cdr x))) 362 363(defun dconv-$float (x) 364 (cond ((member (car x) '($fixnum $number) :test #'eq) 365 (if (integerp (cdr x)) (float (cdr x)) (list 'float (cdr x)))) 366 ((eq '$rational (car x)) 367 (cond ((not (eq 'quote (cadr x))) 368 `($float ,(cdr x))) 369 (t 370 (/ (float (cadadr (cdr x))) (float (caddr (caddr x))))))) 371 (t (cdr x)))) 372 373(defun dconv-$cre (x) 374 (if (eq '$cre (car x)) 375 (cdr x) 376 `(ratf ,(cdr x)))) 377 378(defmvar *$any-modes* '($any $list)) 379 380(defun covers (mode1 mode2) 381 (cond ((eq mode1 mode2) t) 382 ((eq '$float mode1) (member mode2 '($float $fixnum $rational) :test #'eq)) 383 ((eq '$number mode1) (member mode2 '($fixnum $float) :test #'eq)) 384 ((member mode1 *$any-modes* :test #'eq) t))) 385 386;;; takes a function name as input. 387 388(defun tr-mfun (name &aux (*transl-backtrace* nil)) 389 (let ((def-form (consfundef name nil nil))) 390 (cond ((null def-form) 391 (setq tr-abort t)) 392 (t 393 (tr-mdefine-toplevel def-form))))) 394 395;;; DEFUN 396;;; All the hair here to deal with macsyma fexprs has been flushed. 397;;; Right now this handles MDEFMACRO and MDEFINE. The decisions 398;;; of where to put the actual properties and what kind of 399;;; defuns to make (LEXPR EXPR for maclisp) are punted to the 400;;; macro package. 401 402(defun tr-mdefine-toplevel (form &aux (and-restp nil)) 403 (destructuring-let (((((name . flags) . args) body) (cdr form)) 404 (a-args) kind out-forms) 405 406 (do ((args args (cdr args)) 407 ;; array functions cannot be LEXPR-like. gee. 408 ;; there is no good reason for that, except for efficiency, 409 ;; and I know that efficiency was not a consideration. 410 (full-restricted-flag (or (eq name 'mqapply) 411 (member 'array flags :test #'eq)))) 412 ((null args) (setq a-args (nreverse a-args))) 413 (let ((u (car args))) 414 (cond ((atom u) 415 (push u a-args)) 416 ((and (not full-restricted-flag) 417 (not and-restp) 418 (eq (caar u) 'mlist) 419 (cdr u) (atom (cadr u))) 420 (push (cadr u) a-args) 421 (setq and-restp t)) 422 (t 423 (push tr-unique a-args))))) 424 425 426 (cond ((eq name 'mqapply) 427 ;; don't you love syntax! 428 ;; do a switch-a-roo here. Calling ourselves recursively 429 ;; like this allows all legal forms and also catches 430 ;; errors. However, certain generalizations are also 431 ;; allowed. They won't get passed the interpreter, but 432 ;; interesting things may happen here. Thats what you 433 ;; get from too much syntax, so don't sweat it. 434 (tr-mdefine-toplevel 435 `(,(car form) ,(car args) 436 ((lambda) ((mlist) ,@(cdr args)) ,body)))) 437 ((member tr-unique a-args :test #'eq) 438 ;; WHAT IS "BAD" ABOUT THE ARGUMENT LIST HERE ?? 439 (tr-format (intl:gettext "error: unhandled argument list in function definition: ~:M~%") `((mlist),@args)) 440 (setq tr-abort t) 441 nil) 442 ((member (caar form) '(mdefine mdefmacro) :test #'eq) 443 (setq kind (cond ((eq (caar form) 'mdefmacro) 'macro) 444 ((member 'array flags :test #'eq) 'array) 445 (t 'func))) 446 (let* ((t-form 447 (tr-lambda `((lambda) ((mlist) ,@a-args) ,body))) 448 (desc-header 449 `(,name ,(car t-form) ,(caar form) 450 ,and-restp ,(eq kind 'array)))) 451 (cond ((eq kind 'func) 452 (push-pre-transl-form 453 `(defmtrfun-external ,desc-header)) 454 (and (not (member (car t-form) '($any nil) :test #'eq)) 455 (putprop name (car t-form) 'function-mode))) 456 ((eq kind 'array) 457 (and (not (member (car t-form) '($any nil) :test #'eq)) 458 (decmode-arrayfun name (car t-form))))) 459 460 (cond ((or *in-translate* (not $packagefile)) 461 ; These are all properties which tell the 462 ; user that functions are in the environment, 463 ; and that also allow him to SAVE the functions. 464 (push `(defprop ,name t translated) out-forms) 465 (push `(add2lnc ',name $props) out-forms) 466 (cond ((eq '$all $savedef) 467 (push 468 `(add2lnc 469 '((,name ,@flags) ,@args) 470 ,(case kind 471 (array '$arrays) 472 (func '$functions) 473 (macro '$macros))) out-forms))))) 474 (cond ((eq '$all $savedef) 475 ;; For some reason one may want to save the 476 ;; interpreted definition even if in a PACKAGEFILE. 477 ;; not a good idea to use SAVEDEF anyway though. 478 (push `(mdefprop ,name 479 ((lambda) ((mlist) ,@args) ,body) 480 ,(case kind 481 (array 'aexpr) 482 (macro 'mmacro) 483 (func 'mexpr))) 484 out-forms))) 485 ;;once a function has been translated we want to make sure mfunction-call is eliminated. 486 (progn 487 (remprop (car desc-header) 'undefined-warnp) 488 (setf (get (car desc-header) 'once-translated) "I was once translated")) 489 `(progn 490 ,@(nreverse out-forms) 491 (defmtrfun ,desc-header ,@(cdr (cdr t-form)))))) 492 (t 493 (barfo '?))))) 494 495 496(defun lisp-fcn-typep (fcn type) 497 (get fcn type)) 498 499(defun translate-function (name) 500 (bind-transl-state 501 (setq *in-translate* t) 502 (let ((lisp-def-form (tr-mfun name)) 503 (delete-subr? (and (get name 'translated) 504 (not (lisp-fcn-typep name 'expr))))) 505 (cond (tr-abort 506 (trfail name)) 507 (t 508 (if delete-subr? (remprop name 'subr)) 509 (if (mget name 'trace) (macsyma-untrace name)) 510 (if (not $savedef) (meval `(($remfunction) ,name))) 511 (let ((lisp-action 512 ; apply EVAL so it is easy to TRACE. 513 ; ERRSET is crude, but... 514 (errset (apply 'eval (list lisp-def-form))))) 515 (cond ((not lisp-action) 516 (trfail name)) 517 (t (values name lisp-def-form))))))))) 518 519 520(defun trfail (x) 521 (tr-format (intl:gettext "error: failed to translate ~:@M~%") x) 522 nil) 523 524(defun translate-and-eval-macsyma-expression (form) 525 ;; this is the hyper-random entry to the transl package! 526 ;; it is used by MLISP for TRANSLATE:TRUE ":=". 527 (bind-transl-state 528 (setq *in-translate* t) 529 ;; Use FUNCALL so that we can be sure we can TRACE this even when 530 ;; JPG sets PURE to NIL. Also, use a function named TRANSLATOR-EVAL 531 ;; so we don't have to lose badly by tracing EVAL! 532 (funcall (progn 'translator-eval) 533 (funcall (progn 'translate-macexpr-toplevel) form)))) 534 535(defun translator-eval (x) 536 (eval x)) 537 538;; This basically tells the msetq def%tr to use defparameter insetad 539;; of setq because we're doing a setq at top-level, which isn't 540;; specified by ANSI CL. 541(defvar *macexpr-top-level-form-p* nil) 542 543(defun translate-macexpr-toplevel (form &aux (*transl-backtrace* nil) tr-abort) 544 ;; there are very few top-level special cases, I don't 545 ;; think it would help the code any to generalize TRANSLATE 546 ;; to target levels. 547 ;; 548 ;; Except msetq at top-level is special for ANSI CL. See below. 549 (setq form (toplevel-optimize form)) 550 (cond ((atom form) nil) 551 ((eq (caar form) '$eval_when) 552 (let ((whens (cadr form)) 553 (body (cddr form)) tr-whens) 554 (setq whens (cond (($listp whens) (cdr whens)) 555 ((atom whens) (list whens)) 556 (t 557 (tr-format (intl:gettext "error: 'eval-when' argument must be a list or atom; found: ~:M~%") (cadr form)) 558 nil))) 559 (setq tr-whens (mapcar 'stripdollar whens)) 560 (cond ((member '$translate whens :test #'eq) 561 (mapc 'meval body))) 562 (cond ((member '$loadfile whens :test #'eq) 563 `(progn 564 ,@(mapcar 'translate-macexpr-toplevel body))) 565 ((setq tr-whens (intersect tr-whens '(:compile-toplevel :load-toplevel :execute))) 566 `(eval-when 567 ,tr-whens 568 ,@(mapcar 'translate-macexpr-toplevel body))) 569 ((member '$compile whens :test #'eq) 570 ;; strictly for the knowledgeable user. 571 ;; I.E. so I can use EVAL_WHEN(COMPILE,?SPECIALS:TRUE) 572 `(eval-when 573 #+gcl (compile) 574 #-gcl (:compile-toplevel) 575 ,@(mapcar 'translate-macexpr-toplevel body)))))) 576 ((member (caar form) translate-time-evalables :test #'eq) 577 (meval1 form) 578 `(eval-when 579 #+gcl (compile load eval) 580 #-gcl (:compile-toplevel :load-toplevel :execute) 581 (meval* ',form))) 582 ((member (caar form) '(mdefine mdefmacro) :test #'eq) 583 (let ((name (caaadr form)) 584 (trl)) 585 (tr-format (intl:gettext "note: translating ~:@M~%") name) 586 (setq trl (tr-mdefine-toplevel form)) 587 (cond (tr-abort 588 (tr-format (intl:gettext "error: failed to translate ~:@M~%") name) 589 (tr-format (intl:gettext "note: keep going and hope for the best.~%")) 590 `(meval* ',form)) 591 (t trl)))) 592 ((eq 'mprogn (caar form)) 593 ;; note that this ignores the $%% crock. 594 `(progn ,@(mapcar #'translate-macexpr-toplevel (cdr form)))) 595 ((eq 'msetq (caar form)) 596 ;; Toplevel msetq's should really be defparameter instead of 597 ;; setq for Common Lisp. 598 (let ((*macexpr-top-level-form-p* t)) 599 (dtranslate form))) 600 ((eq '$define_variable (caar form)) 601 ;; Toplevel msetq's should really be defparameter instead of 602 ;; setq for Common Lisp. 603 (let ((*macexpr-top-level-form-p* t)) 604 (dtranslate form))) 605 (t 606 (let ((t-form (dtranslate form))) 607 (cond (tr-abort 608 `(meval* ',form)) 609 (t 610 t-form)))))) 611 612 613 614(defmvar $tr_optimize_max_loop 100. 615 "The maximum number of times the macro-expansion and optimization 616 pass of the translator will loop in considering a form. 617 This is to catch macro expansion errors, and non-terminating 618 optimization properties.") 619 620(defun toplevel-optimize (form) 621 ;; it is vital that optimizations be done within the 622 ;; context of variable meta bindings, declarations, etc. 623 ;; Also: think about calling the simplifier here. 624 (cond ((atom form) 625 (cond ((symbolp form) 626 ;; FOLLOWING CODE APPEARS TO BE BROKEN; NOT SURE WHAT WAS THE INTENT. 627 ;; FOLLOWING CODE ALWAYS RETURNS SYMBOL ITSELF EVEN WHEN '$CONSTANTP IS A PROPERTY 628 ;; IS IT SUPPOSED TO FETCH A DECLARED CONSTANT VALUE ?? 629 ;; JUST LEAVE IT BE FOR NOW; DO NOT TRY TO REVISE WITH KINDP 630 (let ((v (getl (mget form '$props) '($constant)))) 631 (if v (cadr v) form))) 632 (t form))) 633 (t 634 (do ((new-form) 635 (kount 0 (1+ kount))) 636 ;; tailrecursion should always arrange for a counter 637 ;; to check for mobylossage. 638 ((> kount $tr_optimize_max_loop) 639 (tr-format (intl:gettext "warning: I've looped ~A times in macro expansion; just give up and return ~:@M~%") 640 $tr_optimize_max_loop (caar form)) 641 form) 642 (setq new-form (toplevel-optimize-1 form)) 643 (cond ((atom new-form) 644 (return (toplevel-optimize new-form))) 645 ((eq new-form form) 646 (return form)) 647 (t 648 (setq form new-form))))))) 649 650(defun toplevel-optimize-1 (form &aux (op (car form)) prop) 651 (cond ((or (atom op) 652 (member 'array op :test #'eq)) form) 653 ((progn (setq op (car op)) 654 (setq prop 655 (if $transrun ; crock a minute. 656 (or (get op 'translated-mmacro) 657 (mget op 'mmacro)) 658 (or (mget op 'mmacro) 659 (get op 'translated-mmacro))))) 660 (mmacro-apply prop form)) 661 ((setq prop ($get op '$optimize)) 662 ;; interesting, the MAPPLY here causes the simplification 663 ;; of the form and the result. 664 ;; The optimize property can be used to implement 665 ;; such niceties as the $%% crock. 666 (mapply1 prop (list form) "an optimizer property" nil)) 667 ((and ($get op '$transload) 668 (get op 'autoload) 669 ;; check for all reasonable definitions, 670 ;; $OPTIMIZE and MACRO already checked. 671 (not (or (get-lisp-fun-type op) 672 (getl op '(translate mfexpr* mfexpr*s 673 fsubr fexpr *fexpr 674 macro 675 ;; foobar? 676 )) 677 (mgetl op '(mexpr))))) 678 (load-function op t) 679 ;; to loop. 680 (cons (car form) (cdr form))) 681 (t form))) 682 683(defun translate (form) 684 (and *transl-debug* (push form *transl-backtrace*)) 685 (setq form (toplevel-optimize form)) 686 (and *transl-debug* (pop *transl-backtrace*)) 687 (prog2 688 (and *transl-debug* (push form *transl-backtrace*)) 689 (cond ((atom form) 690 (translate-atom form)) 691 ((consp form) 692 (translate-form form)) 693 (t 694 (barfo "help"))) 695 ;; hey boy, reclaim that cons, just don't pop it! 696 (and *transl-debug* (pop *transl-backtrace*)))) 697 698(defun translate-atom (form &aux temp) 699 (cond ((numberp form) (cons (tr-class form) form)) 700 ((setq temp (assoc form boolean-object-table :test #'eq)) 701 (cdr temp)) 702 ((and (setq temp (mget form '$numer)) $tr_numer) 703 `($float . ,temp)) 704 ((setq temp (implied-quotep form)) 705 `($any . ',temp)) 706 ((tboundp form) 707 (specialp form) ;; notes its usage if special. 708 (setq form (teval form)) 709 `(,(value-mode form) . ,form)) 710 (t 711 (cond ((not (specialp form)) 712 (warn-undefined-variable form) 713 (if $transcompile (pushnew form specials :test #'eq)))) 714 ;; note that the lisp analysis code must know that 715 ;; the TRD-MSYMEVAL form is a semantic variable. 716 (let* ((mode (value-mode form)) 717 (init-val (assoc mode mode-init-value-table :test #'eq))) 718 (setq init-val (cond (init-val (cdr init-val)) 719 (t `',form))) 720 ;; in the compiler TRD-MSYMEVAL doesn't do a darn 721 ;; thing, but it provides dynamic initialization of 722 ;; variables in interpreted code which is translated 723 ;; in-core. In FILE loaded code the DEFVAR will take 724 ;; care of this. 725 (push-defvar form init-val) 726 `(,mode . (trd-msymeval ,form ,init-val)))))) 727 728(defun translate-form (form &aux temp) 729 (cond ((eq (car form) 'meval) (cons '$any form)) ;;for those lispy macsyma forms 730 ((not (atom (caar form))) 731 ;; this is a check like that in the simplifier. form could 732 ;; result from substitution macros. 733 (translate `((mqapply) ,(caar form) . ,(cdr form)))) 734 ((member 'array (cdar form) :test #'eq) 735 ;; dispatch this bad-boy to another module quick. 736 (tr-arraycall form)) 737 ;; TRANSLATE properties have priority. 738 ((setq temp (get (caar form) 'translate)) 739 (funcall temp form)) 740 ((setq temp (get-lisp-fun-type (caar form))) 741 (tr-lisp-function-call form temp)) 742 ((setq temp (macsyma-special-macro-p (caar form))) 743 (attempt-translate-random-macro-op form temp)) 744 ((setq temp (macsyma-special-op-p (caar form))) 745 ;; a special form not handled yet! foobar! 746 (attempt-translate-random-special-op form temp)) 747 ((or (get (caar form) 'noun) (get (caar form) 'operators)) 748 ;; puntastical case. the weird ones are presumably taken care 749 ;; of by TRANSLATE properties by now. 750 (tr-infamous-noun-form form)) 751 752 ;; "What does a macsyma function call mean?". 753 ;; By the way, (A:'B,B:'C,C:'D)$ A(3) => D(3) 754 ;; is not supported. 755 (t 756 (tr-macsyma-user-function-call (caar form) (cdr form) form)))) 757 758 759 760(defmvar $tr_bound_function_applyp t) 761 762(defun tr-macsyma-user-function-call (function args form) 763 ;; this needs some work, output load-time code to 764 ;; check for MMACRO properties, etc, to be really 765 ;; foolproof. 766 (cond ((eq $tr_function_call_default '$apply) 767 (translate `(($apply) ,(caar form) ((mlist) ,@(cdr form))))) 768 ((eq $tr_function_call_default '$expr) 769 (tr-lisp-function-call form 'subr)) 770 ((eq $tr_function_call_default '$general) 771 (cond 772 ;;; G(F,X):=F(X+1); case. 773 ((and $tr_bound_function_applyp (tboundp function)) 774 (let ((new-form `(($apply) ,function ((mlist) ,@args)))) 775 (tr-format (intl:gettext "warning: ~:M is a bound variable in ~:M, but it is used as a function.~%") function form) 776 (tr-format (intl:gettext "note: instead I'll translate it as: ~:M~%") new-form) 777 (translate new-form))) 778 ;; MFUNCTION-CALL cleverely punts this question to a FSUBR in the 779 ;; interpreter, and a macro in the compiler. This is good style, 780 ;; if a user is compiling then assume he is less lossage prone. 781 (t 782 (pushnew (caar form) *untranslated-functions-called*) 783 (call-and-simp 784 (function-mode (caar form)) 785 'mfunction-call `(,(caar form) ,@(tr-args args)))))) 786 (t 787 ;; This case used to be the most common, a real loser. 788 (warn-meval form) 789 `(,(function-mode (caar form)) . (meval ',form))))) 790 791 792(defun attempt-translate-random-macro-op (form typel &aux tem) 793 (warn-fexpr form) 794 (setq tem (translate-atoms form)) 795 (setf (car tem) (caar tem)) 796 `($any . ,tem)) 797 798(defun attempt-translate-random-special-op (form typel) 799 (warn-fexpr form) 800 `(,(function-mode (caar form)) . (meval ',(translate-atoms form)))) 801 802 803(defun tr-lisp-function-call (form type) 804 (let ((op (caar form)) (mode) (args)) 805 (setq args (cond ((member type '(subr lsubr expr) :test #'eq) 806 (if $transcompile 807 (case type 808 ((subr) (pushnew op exprs :test #'eq)) 809 ((lsubr) (pushnew op lexprs :test #'eq)) 810 (t nil))) 811 (mapcar #'(lambda (llis) (dconvx (translate llis))) 812 (cdr form))) 813 (t 814 (if $transcompile (pushnew op fexprs :test #'eq)) 815 (mapcar 'dtranslate (cdr form)))) 816 mode (function-mode op)) 817 (call-and-simp mode op args))) 818 819;;the once-translated is so that inside translate file where a function 820;;has been translated, subsequent calls won't use mfunction call 821(defun get-lisp-fun-type (fun &aux temp) 822 ;; N.B. this is Functional types. NOT special-forms, 823 ;; lisp special forms are meaningless to macsyma. 824 (cond ((get fun '*lexpr) 'lsubr) 825 ((get fun '*expr) 'subr) 826 ;; *LEXPR & *EXPR gotten from DEFMFUN declarations 827 ;; which is loaded by TrData. 828 ((mget fun '$fixed_num_args_function) 829 'subr) 830 ((mget fun '$variable_num_args_function) 831 'lsubr) 832 ((setq temp (getl fun '(expr subr lsubr))) 833 (car temp)) 834 ((get fun 'once-translated)) 835 ((get fun 'translated)) 836 (t nil))) 837 838(defun tr-infamous-noun-form (form) 839 ;; 'F(X,Y) means noun-form. The arguments are evaluated. 840 ;; but the function is cons on, not applied. 841 ;; N.B. for special forms and macros this is totally wrong. 842 ;; But, those cases are filtered out already, presumably. 843 844 (let ((op (cond ((member 'array (car form) :test #'eq) 845 `(,(caar form) array)) 846 (t `(,(caar form))))) 847 (args (tr-args (cdr form)))) 848 `($any . (simplify (list ',op ,@args))))) 849 850 851 852;;; Some atoms, solely by usage, are self evaluating. 853 854(defun implied-quotep (atom) 855 (cond 856 ((stringp atom) 857 (cond 858 ;; I WONDER IF THIS NEXT CONDITION CAN BE CUT OUT ?? !! 859 ((equal atom "**") ;;; foolishness. The PARSER should do this. 860 ;; Losing Fortran hackers. 861 (tr-format "~% `**' is obsolete, use `^' !!!") 862 "^") 863 (t atom))) 864 ((get atom 'implied-quotep) atom) 865 (t nil))) 866 867(defun translate-atoms (form) 868 ;; This is an oldy moldy which tries to declare everything 869 ;; special so that calling fexpr's will work in compiled 870 ;; code. What a joke. 871 (cond ((atom form) 872 (cond ((or (numberp form) (member form '(t nil) :test #'eq)) form) 873 ((tboundp form) 874 (if $transcompile 875 (or (specialp form) 876 (pushnew form specials :test #'eq))) 877 form) 878 (t 879 (if $transcompile (pushnew form specials :test #'eq)) 880 form))) 881 ((eq 'mquote (caar form)) form) 882 (t (cons (car form) (mapcar #'translate-atoms (cdr form)))))) 883 884 885;;; the Translation Properties. the heart of TRANSL. 886 887;;; This conses up the call to the function, adding in the 888;;; SIMPLIFY i the mode is $ANY. This should be called everywhere. 889;;; instead of duplicating the COND everywhere, as is done now in TRANSL. 890 891(defun tr-nosimpp (op) 892 (cond ((atom op) 893 (get op 'tr-nosimp)) 894 (t nil))) 895 896(defun call-and-simp (mode fun args) 897 (cond ((or (not (eq mode '$any)) 898 (tr-nosimpp fun)) 899 `(,mode ,fun . ,args)) 900 (t 901 `(,mode simplify (,fun . ,args))))) 902 903(defmspec $declare_translated (fns) 904 (setq fns (cdr fns)) 905 (loop for v in fns 906 when (or (symbolp v) (and (stringp v) (setq v ($verbify v)))) 907 do (setf (get v 'once-translated) t) 908 (pushnew v *declared-translated-functions*) 909 else do (merror (intl:gettext "declare_translated: arguments must be symbols or strings; found: ~:M") v))) 910 911(def%tr $declare (form) 912 (do ((l (cdr form) (cddr l)) (nl)) 913 ((null l) (if nl `($any $declare . ,(nreverse nl)))) 914 (setq nl (cons (cadr l) (cons (car l) nl))))) 915 916(def%tr $eval_when (form) 917 (tr-format (intl:gettext "error: found 'eval_when' in a function or expression: ~:M~%") form) 918 (tr-format (intl:gettext "note: 'eval_when' can appear only at the top level in a file.~%")) 919 (setq tr-abort t) 920 '($any . nil)) 921 922(def%tr mdefmacro (form) 923 (tr-format (intl:gettext "warning: globally defining macro ~:M now to ensure correct macro expansions.~%") (caaadr form)) 924 ; Define the macro now to ensure that it's defined when it's time 925 ; to expand it. It's a bug that this definition occurs during 926 ; translation without being cleaned it up afterward, but simply 927 ; removing this breaks things. 928 (meval form) 929 `($any . (meval ',form))) 930 931(def%tr $local (form) 932 (cond (local 933 (tr-format (intl:gettext "error: there is already a 'local' in this block.~%")) 934 (setq tr-abort t)) 935 (t 936 (setq local t))) 937 (cons nil `(mapply 'mlocal ',(cdr form) '$local))) 938 939 940(def%tr mquote (form) 941 (list (tr-class (cadr form)) 'quote (cadr form))) 942 943 944(defun tr-lambda (form &optional (tr-body #'tr-seq) &rest tr-body-argl 945 &aux 946 (arglist (mparams (cadr form))) 947 (easy-assigns nil)) 948 ;; This function is defined to take a simple macsyma lambda expression and 949 ;; return a simple lisp lambda expression. The optional TR-BODY hook 950 ;; can be used for translating other special forms that do lambda binding. 951 952 ;; Local SPECIAL declarations are not used because 953 ;; the multics lisp compiler does not support them. They are of course 954 ;; a purely syntactic construct that doesn't buy much. I have been 955 ;; advocating the use of DEFINE_VARIABLE in macsyma user programs so 956 ;; that the use of DECLARE(FOO,SPECIAL) will be phased out at that level. 957 958 (mapc #'tbind arglist) 959 (destructuring-let (((mode . nbody) (apply tr-body (cddr form) tr-body-argl)) 960 (local-declares (make-declares arglist t))) 961 ;; -> BINDING of variables with ASSIGN properties may be difficult to 962 ;; do correctly and efficiently if arbitrary code is to be run. 963 (if (or tr-lambda-punt-assigns 964 (do ((l arglist (cdr l))) 965 ((null l) t) 966 (let* ((var (car l)) 967 (assign (get var 'assign))) 968 (if assign 969 (cond ((eq assign 'assign-mode-check) 970 (push `(,assign ',var ,(teval var)) easy-assigns)) 971 (t 972 (return nil))))))) 973 ;; Case with EASY or no ASSIGN's 974 (progn ;;-have to undo any local assignments. --wfs 975 `(,mode . (lambda ,(tunbinds arglist) 976 ,local-declares 977 ,@easy-assigns 978 ,@nbody))) 979 ;; Case with arbitrary ASSIGN's. 980 (let ((temps (mapcar #'(lambda (ign) ign (tr-gensym)) arglist))) 981 `(,mode . (lambda ,temps 982 (unwind-protect 983 (progn 984 ;; [1] Check before binding. 985 ,@(mapcan #'(lambda (var val) 986 (let ((assign (get var 'assign))) 987 (if assign 988 (let ((assign-fn (if (symbolp assign) (symbol-function assign) (coerce assign 'function)))) 989 (list `(funcall ,assign-fn ',var ,val)))))) 990 arglist temps) 991 ;; [2] do the binding. 992 ((lambda ,(tunbinds arglist) 993 ,local-declares 994 ,@nbody) 995 ,@temps)) 996 ;; [2] check when unbinding too. 997 ,@(mapcan #'(lambda (var) 998 (let ((assign (get var 'assign))) 999 (if assign 1000 (let ((assign-fn (if (symbolp assign) (symbol-function assign) (coerce assign 'function)))) 1001 (list `(funcall ,assign-fn ',var 1002 ;; use DTRANSLATE to 1003 ;; catch global 1004 ;; scoping if any. 1005 ,(dtranslate var))))))) 1006 arglist)))))))) 1007 1008 1009(defun make-declares (varlist localp &aux (dl) (fx) (fl) specs) 1010 (when $transcompile 1011 (do ((l varlist (cdr l)) 1012 (mode) (var)) 1013 ((null l)) 1014 1015 ;; When a variable is declared special, be sure to declare it 1016 ;; special here. 1017 (when (and localp (tr-get-special (car l))) 1018 (push (car l) specs)) 1019 1020 (when (or (not localp) 1021 (not (tr-get-special (car l)))) 1022 ;; don't output local declarations on special variables. 1023 (setq var (teval (car l)) mode (value-mode var)) 1024 (setq specs (cons var specs)) 1025 1026 (cond ((eq '$fixnum mode) (pushnew var fx :test #'eq)) 1027 ((eq '$float mode) (pushnew var fl :test #'eq))))) 1028 (if fx (pushnew `(fixnum . ,fx) dl :test #'eq)) 1029 (if fl (pushnew `(type flonum . ,fl) dl :test #'eq)) 1030 (if specs (pushnew `(special . ,specs) dl :test #'eq)) 1031 (if dl `(declare . ,dl)))) 1032 1033(def%tr dolist (form) 1034 (translate `((mprogn) . ,(cdr form)))) 1035 1036(defun tr-seq (l) 1037 (do ((mode nil) 1038 (body nil)) 1039 ((null l) 1040 (cons mode (nreverse body))) 1041 (let ((exp (translate (pop l)))) 1042 (setq mode (car exp)) 1043 (push (cdr exp) body)))) 1044 1045(def%tr mprogn (form) 1046 (setq form (tr-seq (cdr form))) 1047 (cons (car form) `(progn ,@(cdr form)))) 1048 1049 1050(def%tr mprog (form) 1051 (let (arglist body val-list) 1052 ;; [1] normalize the MPROG syntax. 1053 (cond (($listp (cadr form)) 1054 (setq arglist (cdadr form) 1055 body (cddr form))) 1056 (t 1057 (setq arglist nil 1058 body (cdr form)))) 1059 (cond ((null body) 1060 (setq body '(((mquote) $done))))) 1061 (setq val-list (mapcar #'(lambda (u) 1062 (if (atom u) u 1063 (translate (caddr u)))) 1064 arglist) 1065 arglist (mapcar #'(lambda (u) 1066 ;; X or ((MSETQ) X Y) 1067 (if (atom u) u (cadr u))) 1068 arglist)) 1069 (let ((dup (find-duplicate arglist :test #'eq))) 1070 (when dup 1071 (tr-format (intl:gettext "error: ~M occurs more than once in block variable list") dup) 1072 (setq tr-abort t))) 1073 (unless tr-abort 1074 (setq form 1075 (tr-lambda 1076 ;; [2] call the lambda translator. 1077 `((lambda) ((mlist) ,@arglist) ,@body) 1078 ;; [3] supply our own body translator. 1079 #'tr-mprog-body 1080 val-list 1081 arglist)) 1082 (cons (car form) `(,(cdr form) ,@val-list))))) 1083 1084(defun tr-mprog-body (body val-list arglist 1085 &aux 1086 (inside-mprog t) 1087 (return-mode nil) 1088 (need-prog? nil) 1089 (returns nil) ;; not used but must be bound. 1090 (local nil) 1091 ) 1092 (do ((l nil)) 1093 ((null body) 1094 ;; [5] hack the val-list for the mode context. 1095 ;; Perhaps the only use of the function MAP in all of macsyma. 1096 (mapl #'(lambda (val-list arglist) 1097 (cond ((atom (car val-list)) 1098 (rplaca val-list 1099 (or (cdr (assoc (value-mode (car arglist)) 1100 mode-init-value-table :test #'eq)) 1101 `',(car arglist)))) 1102 (t 1103 (warn-mode (car arglist) 1104 (value-mode (car arglist)) 1105 (car (car val-list)) 1106 "in a `block' statement") 1107 (rplaca val-list (cdr (car val-list)))))) 1108 val-list arglist) 1109 (setq l (nreverse l)) 1110 (cons return-mode 1111 (if need-prog? 1112 `((prog () ,@(delete nil l :test #'equal))) 1113 l))) 1114 ;; [4] translate a form in the body 1115 (let ((form (pop body))) 1116 (cond ((null body) 1117 ;; this is a really bad case. 1118 ;; we don't really know if the return mode 1119 ;; of the expression is for the value of the block. 1120 ;; Some people write RETURN at the end of a block 1121 ;; and some don't. In any case, the people not 1122 ;; use the PROG programming style won't be screwed 1123 ;; by this. 1124 (setq form (translate form)) 1125 (setq return-mode (*union-mode (car form) return-mode)) 1126 (setq form (cdr form)) 1127 (if (and need-prog? 1128 (or (atom form) 1129 (not (eq (car form) 'return)))) 1130 ;; put a RETURN on just in case. 1131 (setq form `(return ,form)))) 1132 ((symbolp form)) 1133 (t 1134 (setq form (dtranslate form)))) 1135 (push form l)))) 1136 1137(def%tr mreturn (form) 1138 (if (null inside-mprog) 1139 (tr-format (intl:gettext "warning: 'return' not within 'block' or 'do': ~:M~%") form)) 1140 (setq need-prog? t) 1141 (setq form (translate (cadr form))) 1142 (setq return-mode (if return-mode (*union-mode (car form) return-mode) 1143 (car form))) 1144 (setq form `(return ,(cdr form))) 1145 (push form returns) ;; USED by lusing MDO etc not yet re-written. 1146 ;; MODE here should be $PHANTOM or something. 1147 `($any . ,form)) 1148 1149(def%tr mgo (form) 1150 (if (null inside-mprog) 1151 (tr-format (intl:gettext "warning: 'go' not within 'block' or 'do': ~:M~%") form)) 1152 (if (not (symbolp (cadr form))) 1153 (tr-format (intl:gettext "warning: 'go' tag must be a symbol: ~:M~%") form)) 1154 (setq need-prog? t) 1155 `($any . (go ,(cadr form)))) 1156 1157(def%tr mqapply (form) 1158 (let ((fn (cadr form)) (args (cddr form)) 1159 (aryp (member 'array (cdar form) :test #'eq))) 1160 (cond ((atom fn) 1161 ;; I'm guessing (ATOM FN) is a parser error or other Lisp error, 1162 ;; so don't bother to translate the following error message. 1163 (mformat *translation-msgs-files* "translator: MQAPPLY operator must be a cons; found: ~:M" form) 1164 nil) 1165 ((eq (caar fn) 'mquote) 1166 `($any list ',(cons (cadr fn) aryp) ,@(tr-args args))) 1167 ((eq (caar fn) 'lambda) 1168 ;; LAMBDA([X,'Y,[L]],...)(A,B,C) is a bogus form. Don't bother with it. 1169 ;; ((LAMBDA) ((MLIST) ....) ....) 1170 (cond ((member 'bogus (mapcar #'(lambda (arg) 1171 (cond ((or (mquotep arg) 1172 ($listp arg)) 1173 'bogus))) 1174 (cdr (cadr fn))) :test #'eq) 1175 (tr-format (intl:gettext "error: quote or list arguments are not allowed in MQAPPLY; found: ~:M~%") form) 1176 (setq tr-abort t) 1177 nil) 1178 (t 1179 (setq fn (tr-lambda fn) 1180 args (tr-args args)) 1181 `(,(car fn) ,(cdr fn) ,@args)))) 1182 ((not aryp) 1183 `($any simplify (mapply ,(dconvx (translate fn)) 1184 (list ,@(tr-args args)) 1185 ',fn))) 1186 (t 1187 (warn-meval form) 1188 `($any meval ',form))))) 1189 1190 1191 1192(def%tr mcond (form) 1193 (prog (dummy mode nl) 1194 (setq dummy (translate (caddr form)) 1195 mode (car dummy) 1196 nl (list dummy (translate-predicate (cadr form)))) 1197 (do ((l (cdddr form) (cddr l))) ((null l)) 1198 (cond ((and (not (atom (cadr l))) (eq 'mcond (caaadr l))) 1199 (setq l (cdadr l)))) 1200 (setq dummy (translate (cadr l)) 1201 mode (*union-mode mode (car dummy)) 1202 nl (cons dummy 1203 (cons (translate-predicate (car l)) 1204 nl)))) 1205 (setq form nil) 1206 (do ((l nl (cddr l))) ((null l)) 1207 (cond ((and (eq t (cadr l)) (null (cdar l)))) 1208 (t (setq form 1209 (cons (cons (cadr l) 1210 (cond ((and (not (atom (cdar l))) 1211 (cddar l) 1212 (eq (cadar l) 'progn)) 1213 (nreverse 1214 (cons (dconv (cons (caar l) 1215 (car (reverse (cddar l)))) 1216 mode) 1217 (cdr (reverse (cddar l)))))) 1218 ((and (equal (cdar l) (cadr l)) 1219 (atom (cdar l))) nil) 1220 (t (list (cdr (car l)))))) 1221 form))))) 1222 ;; Wrap (LET (($PREDERROR T)) ...) around translation of MCOND. 1223 ;; Nested MCOND expressions (e.g. if x > 0 then if y > 0 then ...) 1224 ;; will therefore yield nested (LET (($PREDERROR T)) ... (LET (($PREDERROR T)) ...)). 1225 ;; I suppose only the topmost one is needed, but there is very little harm 1226 ;; in the redundant ones, so I'll let it stand. 1227 (return (cons mode (list 'let '(($prederror t)) (cons 'cond form)))))) 1228 1229 1230 1231;; The MDO and MDOIN translators should be changed to use the TR-LAMBDA. 1232;; Perhaps a mere expansion into an MPROG would be best. 1233 1234(def%tr mdo (form) 1235 (let (returns assigns return-mode local (inside-mprog t) need-prog?) 1236 (let (mode var init next test action varmode) 1237 (setq var (cond ((cadr form)) (t 'mdo))) 1238 (specialp var) 1239 (tbind var) 1240 (setq init (if (caddr form) (translate (caddr form)) '($fixnum . 1))) 1241 (cond ((not (setq varmode (tr-get-mode var))) 1242 (declvalue var (car init) t))) 1243 (setq next (translate (cond ((cadddr form) (list '(mplus) (cadddr form) var)) 1244 ((car (cddddr form))) 1245 (t (list '(mplus) 1 var))))) 1246 (setq form (copy-list form)) 1247 ;;to make the end test for thru be numberp if the index is numberp 1248 ;;and to eliminate reevaluation 1249 (cond ((not varmode) 1250 (declvalue var (*union-mode (car init) (car next)) t)) 1251 (t 1252 (warn-mode var varmode (*union-mode (car init) (car next))))) 1253 (setq test (translate-predicate 1254 (list '(mor) 1255 (cond ((null (cadr (cddddr form))) nil) 1256 ((and (cadddr form) 1257 (mnegp ($numfactor (simplify (cadddr form))))) 1258 (list '(mlessp) var (cadr (cddddr form)))) 1259 (t (list '(mgreaterp) var (cadr (cddddr form))))) 1260 (caddr (cddddr form))))) 1261 (setq action (translate (cadddr (cddddr form))) 1262 mode (cond ((null returns) '$any) 1263 (t return-mode))) 1264 (setq var (tunbind (cond ((cadr form)) (t 'mdo)))) 1265 `(,mode do ((,var ,(cdr init) ,(cdr next))) 1266 (,test '$done) . ((declare (special ,var)) . 1267 ,(cond ((atom (cdr action)) nil) 1268 ((eq 'progn (cadr action)) (cddr action)) 1269 (t (list (cdr action))))))))) 1270 1271(def%tr mdoin (form) 1272 (let (returns assigns return-mode local (inside-mprog t) need-prog?) 1273 (prog (mode var init action) 1274 (setq var (tbind (cadr form))) (tbind 'mdo) 1275 (specialp var) 1276 (setq init (dtranslate (caddr form))) 1277 (cond ((or (cadr (cddddr form)) (caddr (cddddr form))) 1278 (tunbind 'mdo) (tunbind (cadr form)) 1279 (return `($any meval '((mdoin) . ,(cdr form)))))) 1280 (setq action (translate (cadddr (cddddr form))) 1281 mode (cond ((null returns) '$any) 1282 (t return-mode))) 1283 (tunbind 'mdo) (tunbind (cadr form)) 1284 (return 1285 `(,mode do ((,var) (mdo (cdr ,init) (cdr mdo))) 1286 ((null mdo) '$done) . 1287 ((declare (special ,var)) (setq ,var (car mdo)) . 1288 ,(cond ((atom (cdr action)) nil) 1289 ((eq 'progn (cadr action)) (cddr action)) 1290 (t (list (cdr action)))))))))) 1291 1292 1293(defun lambda-wrap1 (tn val form) 1294 (if (or (atom val) 1295 (eq (car val) 'quote)) 1296 (subst val tn form) 1297 `((lambda (,tn) ,form) ,val))) 1298 1299(def%tr msetq (form) 1300 (let ((var (cadr form)) 1301 (val (caddr form)) 1302 assign 1303 mode) 1304 (cond ((atom var) 1305 (setq mode (value-mode var) val (translate val)) 1306 (cond ((not (tboundp var)) 1307 (pushnew var specials :test #'eq))) 1308 (warn-mode var mode (car val)) 1309 (if (eq '$any mode) 1310 (setq mode (car val) val (cdr val)) 1311 (setq val (dconv val mode))) 1312 (cons mode 1313 (if (setq assign (get var 'assign)) 1314 (let ((tn (tr-gensym)) 1315 (assign-fn (if (symbolp assign) (symbol-function assign) (coerce assign 'function)))) 1316 (lambda-wrap1 tn val `(let nil 1317 (declare (special ,var ,(teval var))) 1318 (funcall ,assign-fn ',var ,tn) 1319 (setq ,(teval var) ,tn)))) 1320 `(let nil (declare (special ,(teval var))) 1321 (if (not (boundp ',(teval var))) 1322 (add2lnc ',(teval var) $values)) 1323 (,(if *macexpr-top-level-form-p* 1324 'defparameter 1325 'setq) 1326 ,(teval var) ,val))))) 1327 ((member 'array (car var) :test #'eq) 1328 (tr-arraysetq var val)) 1329 (t 1330 (unless (safe-get (caar var) 'mset_extension_operator) 1331 (tr-format (intl:gettext "warning: no assignment operator known for ~:M~%") var) 1332 (tr-format (intl:gettext "note: just keep going and hope for the best.~%"))) 1333 (setq val (translate val)) 1334 `(,(car val) mset ',(translate-atoms var) ,(cdr val)))))) 1335 1336(def%tr $max (x) (translate-$max-$min x)) 1337(def%tr $min (x) (translate-$max-$min x)) 1338(def%tr %max (x) (translate-$max-$min x)) 1339(def%tr %min (x) (translate-$max-$min x)) 1340 1341(defun translate-$max-$min (form) 1342 (let ((mode) (arglist) (op (stripdollar (caar form)))) 1343 (setq arglist 1344 (mapcar #'(lambda (l) (setq l (translate l) 1345 mode (*union-mode (car l) mode)) 1346 l) 1347 (cdr form))) 1348 (if (member mode '($fixnum $float $number) :test #'eq) 1349 `(,mode ,(if (eq 'min op) 'min 'max) . ,(mapcar 'cdr arglist)) 1350 `($any ,(if (eq 'min op) '$lmin '$lmax) 1351 (list '(mlist) . ,(mapcar 'dconvx arglist)))))) 1352 1353 1354;;; mode acessing, binding, handling. Super over-simplified. 1355 1356(defun tr-class (x) 1357 (cond ((integerp x) '$fixnum) 1358 ((floatp x) '$float) 1359 ((member x '(t nil) :test #'eq) '$boolean) 1360 ((atom x) '$any) 1361 ((eq 'rat (caar x)) '$rational) 1362 (t '$any))) 1363 1364(defun *union-mode (mode1 mode2) 1365 (cond ((eq mode1 mode2) mode1) 1366 ((null mode1) mode2) 1367 ((null mode2) mode1) 1368 ((member mode2 *$any-modes* :test #'eq) '$any) 1369 ((member mode1 *$any-modes* :test #'eq) '$any) 1370 ((eq '$fixnum mode1) mode2) 1371 ((eq '$float mode1) 1372 (if (eq '$number mode2) '$number '$float)) 1373 ((eq '$rational mode1) 1374 (if (eq '$float mode2) '$float '$any)) 1375 ((eq '$number mode1) 1376 (if (eq '$rational mode2) '$any '$number)) 1377 (t '$any))) 1378 1379(defun value-mode (var) 1380 (cond ((tr-get-mode var)) 1381 (t 1382 (warn-undeclared var) 1383 '$any))) 1384 1385(defun decmode-arrayfun (f m) 1386 (putprop f m 'arrayfun-mode)) 1387 1388(defun array-mode (ar) 1389 (cond ((get ar 'array-mode)) (t '$any))) 1390 1391(defun arrayfun-mode (ar) 1392 (cond ((get ar 'arrayfun-mode)) (t '$any))) 1393 1394(defun function-mode (f) 1395 (cond ((get f 'function-mode)) (t '$any))) 1396 1397(defun function-mode-@ (f) 1398 (ass-eq-ref (tr-get-val-modes f) 'function-mode '$any)) 1399 1400(defun array-mode-@ (f) 1401 (ass-eq-ref (tr-get-val-modes f) 'array-mode '$any)) 1402 1403 1404(defvar $tr_bind_mode_hook nil 1405 "A hack to allow users to key the modes of variables 1406 off of variable spelling, and other things like that.") 1407 1408;; TBIND, below, copies the MODE, VAL-MODES, and SPECIAL properties 1409;; into the a table named TSTACK, and then removes those properties. 1410;; So if TBIND has been called, we will need to look for those 1411;; properties in TSTACK instead of the symbol property list. 1412 1413(defstruct (tstack-slot (:conc-name tstack-slot-)) 1414 mode 1415 tbind 1416 val-modes 1417 ;; an alist telling second order info 1418 ;; about APPLY(VAR,[X]), ARRAYAPPLY(F,[X]) etc. 1419 special) 1420 1421(defun tr-get-mode (a) 1422 (if (get a 'tbind) 1423 (let ((my-slot (cdr (assoc a tstack)))) 1424 (tstack-slot-mode my-slot)) 1425 (get a 'mode))) 1426 1427#-gcl (defun (setf tr-get-mode) (b a) 1428 (if (get a 'tbind) 1429 (let ((my-slot (cdr (assoc a tstack)))) 1430 (setf (tstack-slot-mode my-slot) b)) 1431 (setf (get a 'mode) b))) 1432 1433#+gcl (defsetf tr-get-mode (a) (b) 1434 `(if (get ,a 'tbind) 1435 (let ((my-slot (cdr (assoc ,a tstack)))) 1436 (setf (tstack-slot-mode my-slot) ,b)) 1437 (setf (get ,a 'mode) ,b))) 1438 1439(defun tr-get-val-modes (a) 1440 (if (get a 'tbind) 1441 (let ((my-slot (cdr (assoc a tstack)))) 1442 (tstack-slot-val-modes my-slot)) 1443 (get a 'val-modes))) 1444 1445#-gcl (defun (setf tr-get-val-modes) (b a) 1446 (if (get a 'tbind) 1447 (let ((my-slot (cdr (assoc a tstack)))) 1448 (setf (tstack-slot-val-modes my-slot) b)) 1449 (setf (get a 'val-modes) b))) 1450 1451#+gcl (defsetf tr-get-val-modes (a) (b) 1452 `(if (get ,a 'tbind) 1453 (let ((my-slot (cdr (assoc ,a tstack)))) 1454 (setf (tstack-slot-val-modes my-slot) ,b)) 1455 (setf (get ,a 'val-modes) ,b))) 1456 1457(defun tr-get-special (a) 1458 (if (get a 'tbind) 1459 (let ((my-slot (cdr (assoc a tstack)))) 1460 (tstack-slot-special my-slot)) 1461 (get a 'special))) 1462 1463#-gcl (defun (setf tr-get-special) (b a) 1464 (if (get a 'tbind) 1465 (let ((my-slot (cdr (assoc a tstack)))) 1466 (setf (tstack-slot-special my-slot) b)) 1467 (setf (get a 'special) b))) 1468 1469#+gcl (defsetf tr-get-special (a) (b) 1470 `(if (get ,a 'tbind) 1471 (let ((my-slot (cdr (assoc ,a tstack)))) 1472 (setf (tstack-slot-special my-slot) ,b)) 1473 (setf (get ,a 'special) ,b))) 1474;;; 1475;;; should be a macro (TBINDV <var-list> ... forms) 1476;;; so that TUNBIND is assured, and also so that the stupid ASSQ doesn't 1477;;; have to be done on the darn TSTACK. This will have to wait till 1478;;; the basic special form translation properties are rewritten. 1479 1480(defun variable-p (var) 1481 (and var (symbolp var) (not (eq var t)))) 1482 1483(defun bad-var-warn (var) 1484 (tr-format (intl:gettext "warning: ~:M cannot be used as a variable.~%") var)) 1485 1486(defun tbind (var &aux old) 1487 (cond ((variable-p var) 1488 (setq old (make-tstack-slot :mode (get var 'mode) 1489 :tbind (get var 'tbind) 1490 :val-modes (get var 'val-modes) 1491 :special (get var 'special))) 1492 (push (cons var old) tstack) 1493 (cond ((not (specialp var)) 1494 ;; It is the lisp convention in use to inherit 1495 ;; specialness from higher context. 1496 ;; Spurious MODEDECLARATIONS get put in the environment 1497 ;; when code is MEVAL'd since there is no way to stack 1498 ;; the mode properties. Certainly nobody is willing 1499 ;; to hack MEVAL in JPG;MLISP 1500 (remprop var 'val-modes) 1501 (remprop var 'mode) 1502 (remprop var 'special))) 1503 (putprop var var 'tbind) 1504 (if $tr_bind_mode_hook 1505 (let ((mode? (mapply $tr_bind_mode_hook 1506 (list var) 1507 '$tr_bind_mode_hook))) 1508 (if mode? (tr-declare-varmode var mode?)))) 1509 var) 1510 (t 1511 (bad-var-warn var)))) 1512 1513(defun tunbind (var &aux (old (assoc var tstack :test #'eq))) 1514 (when (variable-p var) 1515 (prog1 1516 (teval var) 1517 (cond (old 1518 (setq tstack (delete old tstack :test #'eq)) ; POP should be all we need. 1519 (setq old (cdr old)) 1520 (putprop1 var (tstack-slot-mode old) 'mode) 1521 (putprop1 var (tstack-slot-tbind old) 'tbind) 1522 (putprop1 var (tstack-slot-val-modes old) 'val-modes) 1523 (putprop1 var (tstack-slot-special old) 'special)))))) 1524 1525(defun putprop1 (name value key) 1526 ;; leaves property list clean after unwinding, this 1527 ;; is an efficiency/storage issue only. 1528 (if value 1529 (putprop name value key) 1530 (progn 1531 (remprop name key) 1532 nil))) 1533 1534(defun tunbinds (l) 1535 (do ((nl)) 1536 ((null l) nl) 1537 (setq nl (cons (tunbind (caar tstack)) nl) 1538 l (cdr l)))) 1539 1540(defun tboundp (var) 1541 ;; really LEXICAL-VARP. 1542 (and (symbolp var) (get var 'tbind) (not (tr-get-special var)))) 1543 1544(defun teval (var) 1545 (or (and (symbolp var) (get var 'tbind)) var)) 1546 1547;; Local Modes: 1548;; Mode: LISP 1549;; Comment Col: 40 1550;; END: 1551