src/transq.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   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 `(mfunction-call-aux ',f ',l1 nil))))
  41
  42 ;;; macros for compiled environments.
  43
  44 ;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list> .  <EXP>)
  45 ;;; will define a function globally with a unique name
  46 ;;; (defun <name> <list of variables> <exp>). And return
  47 ;;; `((<name>) ,@<eval>> . <late eval>). The resulting expression may
  48 ;;; then be passed to a function which will bind variables from
  49 ;;; the <late eval vars list> and possibly other variables free in
  50 ;;; <exp> and then call MEVAL on the expression.
  51 ;;; the expression was translated using TR-LAMBDA.
  52
  53 (defvar *infile-name-key* '||
  54   "This is a key gotten from the infile name, in the interpreter
  55   other completely hackish things with FSUBRS will go on.")
  56
  57 (defun skip-declare-exprs (l)
  58   (do ((l l (cdr l)))
  59       ((not (and (consp (car l))
  60                  (eq (caar l) 'declare)))
  61        l)))
  62
  63 (defun vanilla-lambda (bvl body)
  64   `(lambda ,bvl
  65      (declare (special ,@bvl))
  66      ,@(skip-declare-exprs body)))
  67
  68 (defun rest-arg-lambda (bvl body)
  69   (let ((req-args (butlast bvl))
  70         (rest-arg (car (last bvl))))
  71     `(lambda (,@req-args &rest ,rest-arg)
  72        (declare (special ,@bvl))
  73        (push '(mlist) ,rest-arg)
  74        ,@(skip-declare-exprs body))))
  75
  76 (defun lambda-with-free-vars (bvl fvl cfvl lambda-header body)
  77   (let* ((lfvl (set-difference fvl cfvl))
  78          (lexicals (mapcar (lambda (x) (gensym (symbol-name x))) cfvl))
  79          (symevals (mapcar (lambda (x) `(maybe-msymeval ',x)) lfvl)))
  80     `(let ,(mapcar #'list lexicals cfvl)
  81        ,(funcall lambda-header bvl
  82           `((let (,@(mapcar #'list cfvl lexicals)
  83                   ,@(mapcar #'list lfvl symevals))
  84               (declare (special ,@cfvl ,@lfvl))
  85               ,@body))))))
  86
  87 (defun make-tlambda (bvl fvl cfvl rest-p body)
  88   (let ((lambda-header (if rest-p #'rest-arg-lambda #'vanilla-lambda)))
  89     (if (null fvl)
  90         (funcall lambda-header bvl body)
  91         (lambda-with-free-vars bvl fvl cfvl lambda-header body))))
  92
  93 ;;; Lambda expressions emitted by the translator.
  94
  95 ;; lambda([u,...],...) where any free unquoted variable in the body is
  96 ;; either unbound or globally bound or locally bound in some
  97 ;; non-enclosing block.
  98 (defmacro m-tlambda (bvl &rest body)
  99   (make-tlambda bvl '() '() nil body))
 100
 101 ;; lambda([u,...,[v]],...) with the same condition as above.
 102 (defmacro m-tlambda& (bvl &rest body)
 103   (make-tlambda bvl '() '() t body))
 104
 105 ;; lambda([u,...],...) with free unquoted variables in the body which
 106 ;; have a local binding in some enclosing block, but no global one,
 107 ;; i.e, the complement of the condition for m-tlambda above.
 108 ;;
 109 ;; fvl is a list of all free vars.  cfvl is a list of the free vars
 110 ;; to capture.
 111 (defmacro m-tlambda&env ((bvl fvl cfvl) &rest body)
 112   (make-tlambda bvl fvl cfvl nil body))
 113
 114 ;; lambda([u,...,[v]],...) with the same condition as above.
 115 (defmacro m-tlambda&env& ((bvl fvl cfvl) &rest body)
 116   (make-tlambda bvl fvl cfvl t body))
 117
 118 ;; Problem: You can pass a lambda expression around in macsyma
 119 ;; because macsyma "general-rep" has a CAR which is a list.
 120 ;; Solution: Just as well anyway.
 121
 122
 123 ;;the lexical scoping  handles the environment in most cases
 124 ;;and it is messy to queue things
 125
 126 ;;; this is the important case for numerical hackery.
 127
 128
 129 ;;; This is not optimal code.
 130 ;;; I.E. IT SUCKS ROCKS.
 131
 132 (defmacro set-vals-into-list (argl var)
 133   (do ((j 0 (1+ j))
 134        (argl argl (cdr argl))
 135        (l nil `((setf (nth ,j ,var) ,(car argl)) ,@l)))
 136       ((null argl) `(progn ,@l))))