src/transq.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;;          Compilation environment for TRANSLATED MACSYMA code.        ;;;
  10 ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12
  13 (in-package :maxima)
  14
  15 ;;; this are COMPILE-TIME macros for TRANSLATE MACSYMA code.
  16
  17 (macsyma-module transq macro)
  18
  19 (load-macsyma-macros transm)
  20
  21 (defmacro def-mtrvar (v a &optional (priority 1))
  22   (declare (ignore priority))
  23   ;; ignored variable around for TRANSLATED files pre
  24   ;; 3:03pm  Thursday, 11 March 1982 -gjc
  25   `(progn
  26     (declare-top (special ,v))
  27
  28     (if (or (not (boundp ',v))
  29             ;; a SYMBOL SET to ITSELF is considered to be
  30             ;; UNBOUND for our purposes in Macsyma.
  31             (eq ,v ',v))
  32         (setq ,v ,a))))
  33
  34 (define-compiler-macro mfunction-call (f &rest l &aux l1)
  35   (setq l1 l)
  36   (cond ((or (fboundp f)
  37              (get f 'once-translated)
  38              (get f 'translated))
  39          (cons f l1))
  40         (t `(lispm-mfunction-call-aux ',f ', l1 (list ,@ l1) nil))))
  41
  42
  43 ;;; macros for compiled environments.
  44
  45 ;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list> .  <EXP>)
  46 ;;; will define a function globally with a unique name
  47 ;;; (defun <name> <list of variables> <exp>). And return
  48 ;;; `((<name>) ,@<eval>> . <late eval>). The resulting expression may
  49 ;;; then be passed to a function which will bind variables from
  50 ;;; the <late eval vars list> and possibly other variables free in
  51 ;;; <exp> and then call MEVAL on the expression.
  52 ;;; the expression was translated using TR-LAMBDA.
  53
  54 (defvar *infile-name-key* '||
  55   "This is a key gotten from the infile name, in the interpreter
  56   other completely hackish things with FSUBRS will go on.")
  57
  58 (defmacro pop-declare-statement (l)
  59   `(and (not (atom (car ,l)))
  60     (eq (caar ,l) 'declare)
  61     (pop ,l)))
  62
  63
  64 ;;; Lambda expressions emitted by the translator.
  65
  66 ;; lambda([u,...],...) where any free unquoted variable in the body is
  67 ;; either unbound or globally bound or locally bound in some
  68 ;; non-enclosing block.  At this point, BODY has already the correct
  69 ;; special declarations for elements of ARGL.
  70 (defmacro m-tlambda (argl &body body)
  71   `(function
  72     (lambda ,argl
  73      ,@body)))
  74
  75 ;; lambda([u,...,[v]],...) with the same condition as above.
  76 (defmacro m-tlambda& (argl &rest body)
  77   `(function (lambda (,@(reverse (cdr (reverse argl)))
  78                       &rest ,@(last argl))
  79      ,(pop-declare-statement body)
  80      (setq ,(car (last argl))
  81            (cons '(mlist) ,(car (last argl))))
  82      ,@ body)))
  83
  84 ;; lambda([u,...],...) with free unquoted variables in the body which
  85 ;; have a local binding in some enclosing block, but no global one,
  86 ;; i.e, the complement of the condition for m-tlambda above.
  87 (defmacro m-tlambda&env ((reg-argl env-argl) &body body)
  88   (declare (ignore env-argl))
  89   `(function
  90     (lambda ,reg-argl
  91      ;;(,@(or (pop-declare-statement body) '(declare)) (special ,@env-argl))
  92      ,@body)))
  93
  94 ;; lambda([u,...,[v]],...) with the same condition as above.
  95 (defmacro m-tlambda&env& ((reg-argl env-argl) &body body)
  96   (declare (ignore env-argl))
  97   (let ((last-arg (car (last reg-argl))))
  98     `(function
  99       (lambda (,@(butlast reg-argl) &rest ,last-arg)
 100        ;;(,@(or (pop-declare-statement body) '(declare)) (special ,@env-argl))
 101        ,(pop-declare-statement body)
 102        (setq ,last-arg (cons '(mlist) ,last-arg))
 103        ,@body))))
 104
 105
 106 ;; Problem: You can pass a lambda expression around in macsyma
 107 ;; because macsyma "general-rep" has a CAR which is a list.
 108 ;; Solution: Just as well anyway.
 109
 110
 111 ;;the lexical scoping  handles the environment in most cases
 112 ;;and it is messy to queue things
 113
 114 ;;; this is the important case for numerical hackery.
 115
 116
 117 ;;; This is not optimal code.
 118 ;;; I.E. IT SUCKS ROCKS.
 119
 120 (defmacro set-vals-into-list (argl var)
 121   (do ((j 0 (1+ j))
 122        (argl argl (cdr argl))
 123        (l nil `((setf (nth ,j ,var) ,(car argl)) ,@l)))
 124       ((null argl) `(progn ,@l))))