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