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 (defun skip-declare-exprs (l)
  59   (do ((l l (cdr l)))
  60       ((not (and (consp (car l))
  61                  (eq (caar l) 'declare)))
  62        l)))
  63
  64 (defun vanilla-lambda (bvl body)
  65   `(lambda ,bvl
  66      (declare (special ,@bvl))
  67      ,@(skip-declare-exprs body)))
  68
  69 (defun rest-arg-lambda (bvl body)
  70   (let ((req-args (butlast bvl))
  71         (rest-arg (car (last bvl))))
  72     `(lambda (,@req-args &rest ,rest-arg)
  73        (declare (special ,@bvl))
  74        (push '(mlist) ,rest-arg)
  75        ,@(skip-declare-exprs body))))
  76
  77 (defun lambda-with-free-vars (bvl fvl lambda-header body)
  78   (let ((symevals (mapcar (lambda (x) `(maybe-msymeval ',x)) fvl)))
  79     (funcall lambda-header bvl
  80       `((let ,(mapcar #'list fvl symevals)
  81           (declare (special ,@fvl))
  82           ,@body)))))
  83
  84 (defun make-tlambda (bvl fvl rest-p body)
  85   (let ((lambda-header (if rest-p #'rest-arg-lambda #'vanilla-lambda)))
  86     (if (null fvl)
  87         (funcall lambda-header bvl body)
  88         (lambda-with-free-vars bvl fvl lambda-header body))))
  89
  90 ;;; Lambda expressions emitted by the translator.
  91
  92 ;; lambda([u,...],...) where any free unquoted variable in the body is
  93 ;; either unbound or globally bound or locally bound in some
  94 ;; non-enclosing block.
  95 (defmacro m-tlambda (bvl &rest body)
  96   (make-tlambda bvl '() nil body))
  97
  98 ;; lambda([u,...,[v]],...) with the same condition as above.
  99 (defmacro m-tlambda& (bvl &rest body)
 100   (make-tlambda bvl '() t body))
 101
 102 ;; lambda([u,...],...) with free unquoted variables in the body which
 103 ;; have a local binding in some enclosing block, but no global one,
 104 ;; i.e, the complement of the condition for m-tlambda above.
 105 (defmacro m-tlambda&env ((bvl fvl) &rest body)
 106   (make-tlambda bvl fvl nil body))
 107
 108 ;; lambda([u,...,[v]],...) with the same condition as above.
 109 (defmacro m-tlambda&env& ((bvl fvl) &rest body)
 110   (make-tlambda bvl fvl t body))
 111
 112 ;; Problem: You can pass a lambda expression around in macsyma
 113 ;; because macsyma "general-rep" has a CAR which is a list.
 114 ;; Solution: Just as well anyway.
 115
 116
 117 ;;the lexical scoping  handles the environment in most cases
 118 ;;and it is messy to queue things
 119
 120 ;;; this is the important case for numerical hackery.
 121
 122
 123 ;;; This is not optimal code.
 124 ;;; I.E. IT SUCKS ROCKS.
 125
 126 (defmacro set-vals-into-list (argl var)
 127   (do ((j 0 (1+ j))
 128        (argl argl (cdr argl))
 129        (l nil `((setf (nth ,j ,var) ,(car argl)) ,@l)))
 130       ((null argl) `(progn ,@l))))