src/trans3.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 ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  10 ;;;       Maintained by GJC                                              ;;;
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12
  13 (in-package :maxima)
  14
  15 (macsyma-module trans3)
  16
  17 ;;; The translation of macsyma LAMBDA into lexicaly scoped closures.
  18 ;;; Two cases [1] the downward transmission of variable binding environment,
  19 ;;; e.g. MAP(LAMBDA([U],F(U,X)),EXP)
  20 ;;; [2] downward and upward, requiring a full closure, e.g.
  21 ;;; MAP(LAMBDA([U],SUM:SUM+U),EXP);
  22
  23 ;;; LAMBDA([U],F(U,X)) =>
  24 ;;; (DOWN-CLOSE (LAMBDA (U) (F U X)) (X))
  25
  26 ;;; TBIND, TBOUNDP, and TUNBIND and TUNBINDS hack lexical scoping.
  27
  28 ;;; A function to determine free vars from a lisp expression.
  29 ;;; It returns a <var-set> which is a list of pairs
  30 ;;; (<var> . <side-effectp>)
  31
  32 ;;; N.B. This code does a veritable storm of consing, it need not
  33 ;;; do any if it used the lambda-bound plist scheme of GJC;UTRANS >
  34 ;;; a compiler is allowed to cons though, isn't it?
  35
  36 (defun free-lisp-vars (exp &aux prop)
  37   (cond ((atom exp)
  38          (cond ((or (null exp)(eq t exp)) nil)
  39                ((symbolp exp) `((,exp . nil)))
  40                (t nil)))
  41         ((atom (car exp))
  42          (cond ((setq prop (get (car exp) 'free-lisp-vars))
  43                 (funcall prop exp))
  44                ((setq prop (get (car exp) 'macro))
  45                 (free-lisp-vars (funcall prop exp)))
  46                ((getl (car exp) '(fsubr fexpr))
  47                 (warn-fexpr (car exp)
  48                             "environment may fail to be correct.")
  49                 (free-lisp-vars-of-argl (cdr exp)))
  50                (t
  51                 (free-lisp-vars-of-argl (cdr exp)))))
  52         ((eq (caar exp) 'lambda)
  53          (sum-var-sets (free-lisp-vars (car exp))
  54                        (free-lisp-vars-of-argl (cdr exp))))
  55         (t
  56          (barfo (intl:gettext "encountered an unrecognized Lisp expression in FREE-LISP-VARS.")))))
  57
  58
  59 (defun free-lisp-vars-of-argl (argl)
  60   (union-var-set (mapcar #'free-lisp-vars argl)))
  61
  62 ;;; (REDUCE-VAR-SET '((A . NIL) NIL (B . T) (B . NIL))) => ((A . NIL) (B . T))
  63 ;;;  mult-set reduction.
  64
  65 (defun reduce-var-set&op (var-set op)
  66   (do ((var-set var-set (cdr var-set))
  67        (reduced-var-set nil)
  68        (var1)
  69        (var2))
  70       ((null var-set) reduced-var-set)
  71     (setq var1 (car var-set))
  72     (cond ((null var1))
  73           ((setq var2 (assoc (car var1) reduced-var-set :test #'eq))
  74            (rplacd var2 (funcall op (cdr var1) (cdr var2))))
  75           (t
  76            (push var1 reduced-var-set)))))
  77
  78 (defun reduce-var-set (var-set)
  79   (reduce-var-set&op var-set #'(lambda (p1 p2)(or p1 p2))))
  80
  81 ;;; S1 - S2. S1 reduced, minus any vars that are in S2.
  82
  83 (defun difference-var-sets (s1 s2)
  84   (setq s1 (reduce-var-set s1))
  85   (do ((s nil))
  86       ((null s1) s)
  87     (cond ((assoc (caar s1) s2 :test #'eq))     ;;; is the first elem of S1 a member of S2?
  88           (t
  89            (push (car s1) s)))  ;;; yes. shove it in.
  90     (pop s1)))
  91
  92 ;;; N.B. union of var sets is defined classicaly ala G.F.
  93
  94 (defun union-var-set (set-of-var-sets)
  95   (reduce-var-set (apply #'append set-of-var-sets)))
  96
  97 ;;; SUM-VAR-SETS is the usual convention.
  98
  99 (defun sum-var-sets (&rest l)
 100   (reduce-var-set (apply #'append l))) ; consing up a storm aren't we?
 101
 102 (defun make-var-set (vars)
 103   (loop for v in vars collect (ncons v)))
 104
 105 (macrolet ((empty-free-lisp-vars (name)
 106              (let ((form (gensym)))
 107                `(defun-prop (,name free-lisp-vars) (,form)
 108                   (declare (ignore ,form))
 109                   '()))))
 110   (empty-free-lisp-vars declare)
 111   (empty-free-lisp-vars function)
 112   (empty-free-lisp-vars go)
 113   (empty-free-lisp-vars quote))
 114
 115 ;;; (LAMBDA <BVL> . <BODY>)
 116
 117 (defun-prop (lambda free-lisp-vars) (form)
 118   (difference-var-sets
 119     ; get free lisp vars from body forms
 120     (free-lisp-vars-of-argl (cddr form))
 121     ; get vars bound by LAMBDA
 122     (make-var-set (cadr form))))
 123
 124 ;;; (PROG <BVL> . <BODY>)
 125
 126 (defun-prop (prog free-lisp-vars) (form)
 127   (difference-var-sets (union-var-set
 128                         (mapcar #'(lambda (u)
 129                                     (cond ((atom u) nil) ;; go tag.
 130                                           (t
 131                                            (free-lisp-vars u))))
 132                                 (cddr form)))
 133                        (make-var-set (cadr form))))
 134
 135 ;;; (LET <BVL> . <BODY>)
 136
 137 ;; Take the union of the free variables from the init-forms
 138 ;; and the free variables of the body (less the variables bound by LET).
 139
 140 (defun-prop (let free-lisp-vars) (form)
 141   (union-var-set
 142     (list
 143       ;; extract (FOO BAR NIL NIL) from (LET ((A FOO) (B BAR) C D) ...)
 144       ;; and apply FREE-LISP-VARS to each.
 145       (union-var-set (mapcar #'free-lisp-vars (mapcar #'(lambda (e) (if (consp e) (cadr e))) (cadr form))))
 146       (difference-var-sets
 147         ;; cargo-cult programming: copy this next bit from (DEFUN-PROP (PROG ...)) above.
 148         (union-var-set
 149           (mapcar #'(lambda (u)
 150                       (cond ((atom u) nil) ;; go tag.
 151                             (t
 152                               (free-lisp-vars u))))
 153                   (cddr form)))
 154         ;; extract A B C D from (LET ((A FOO) (B BAR) C D) ...)
 155         (make-var-set (mapcar #'(lambda (e) (if (atom e) e (car e))) (cadr form)))))))
 156
 157 ;;; (DO ((<V> <V> <V>) ...) ((<in-scope>) ..) ...)
 158
 159 (defun-prop (do free-lisp-vars) (form)
 160   (difference-var-sets
 161    (sum-var-sets (free-lisp-vars-of-argl (cdddr form))
 162                  (free-lisp-vars-of-argl (caddr form))
 163                  (union-var-set (mapcar #'(lambda (do-iter)
 164                                             (free-lisp-vars-of-argl
 165                                              (cdr do-iter)))
 166                                         (cadr form))))
 167    (make-var-set (mapcar #'car (cadr form)))))
 168
 169 ;;; (COND (<I> ..) (<J> ..) ...)
 170
 171 (defun-prop (cond free-lisp-vars) (form)
 172   (union-var-set (mapcar #'free-lisp-vars-of-argl (cdr form))))
 173
 174 ;;; (SETQ ... ODD AND EVENS...)
 175
 176 (defun-prop (setq free-lisp-vars) (form)
 177   (do ((free-vars nil (sum-var-sets `((,(car form) . t))
 178                                     (free-lisp-vars (cadr form))
 179                                     free-vars))
 180        (form (cdr form) (cddr form)))
 181       ((null form) free-vars)))
 182
 183 ;;; uhm. LAMBDA, PROG, GO, DO, COND, QUOTE, SETQ.
 184
 185 (defun-prop (and free-lisp-vars)(form)(free-lisp-vars-of-argl (cdr form)))
 186 (defun-prop (or free-lisp-vars)(form)(free-lisp-vars-of-argl (cdr form)))
 187
 188 ;;; these next forms are generated by TRANSLATE.
 189
 190 (defprop $piece t sort-of-lexical)
 191
 192 (defun-prop (trd-msymeval free-lisp-vars) (form)
 193   (if (get (cadr form) 'sort-of-lexical)
 194       ;; acts like a lexical variable because of the $SUBSTPART translator.
 195       (list (list (cadr form)))
 196       ()))
 197
 198 (defun-prop (mfunction-call free-lisp-vars) (form)
 199   ;; it is not strictly known if the name of the function being called
 200   ;; is a variable or not. lets say its not.
 201   (free-lisp-vars-of-argl (cddr form)))
 202
 203 ;;; (FUNGEN&ENV-FOR-MEVAL () () EXP)
 204 (defun-prop (fungen&env-for-meval free-lisp-vars) (form)
 205   (free-lisp-vars (car (cdddr form))))
 206
 207 ;;; the various augmented lambda forms.
 208
 209 (defun free-lisp-vars-m-tlambda (form)
 210   (difference-var-sets (free-lisp-vars-of-argl (cddr form))
 211                        (free-lisp-vars-of-argl (cadr form))))
 212
 213 (mapc #'(lambda (u) (putprop u 'free-lisp-vars-m-tlambda 'free-lisp-vars))
 214       '(m-tlambda m-tlambda&))
 215
 216 (defun free-lisp-vars-m-tlambda&env (form)
 217   (difference-var-sets (free-lisp-vars-of-argl (cddr form))
 218                        (free-lisp-vars-of-argl (car (cadr form)))))
 219
 220 (defprop m-tlambda&env free-lisp-vars-m-tlambda&env free-lisp-vars)
 221 (defprop m-tlambda&env& free-lisp-vars-m-tlambda&env free-lisp-vars)
 222
 223 ;;; Other entry points:
 224
 225 (defun tbound-free-vars (free-varl)
 226   ;; Takes a FREE-VAR list and returns a list of two lists.
 227   ;; the tbound free vars and the tbound free vars that are
 228   ;; side effected also.
 229   (do ((free nil)
 230        (free&s nil))
 231       ((null free-varl) (list free free&s))
 232     (let ((v (pop free-varl)))
 233       (cond ((and (tboundp (car v))
 234                   (not (tr-get-special (car v))))
 235              (push (car v) free)
 236              (cond ((cdr v)
 237                     (push (car v) free&s))))))))
 238
 239 (defun side-effect-free-check (varl form)
 240   (cond ((null varl) t)
 241         (t
 242          (tr-format (intl:gettext "error: unsupported side effects on ~:M in expression ~M~%") `((mlist) ,@varl) form)
 243          nil)))
 244
 245
 246 ;;; O.K. here is the translate property for LAMBDA.
 247 ;;; given catch and throw we don't know where a funarg lambda
 248 ;;; may end up.
 249
 250 ;;; Cases:
 251 ;;; I. No side effects on free variables.
 252 ;;;    A. one funarg only, not reconsed. e.g.
 253 ;;;       F(N,L):=MAP(LAMBDA([U],Q(N,U)),L)$
 254 ;;;       (PROGN (SET-ENV <*LINK*> N)
 255 ;;;              (FUNCTION (LAMBDA (U) (LET ((N (GET-ENV *LINK*))) (f* U N)))))
 256 ;;;    B. need new instance of the environment each time,
 257 ;;;       F(N):=LAMBDA([U],N*U);
 258 ;;;       `(LAMBDA (U) (gen-func U 'N)) without extend loaded.
 259 ;;; II. side effects.
 260 ;;;    A. Those since effects need to be propogated to the environment
 261 ;;;       where the LAMBDA was made. This is difficult to do in the
 262 ;;;       present translator. e.g.
 263 ;;;       F(L):=BLOCK([SUM:0],FULLMAP(LAMBDA([U],SUM:SUM+U),L),SUM);
 264 ;;;       every function which guarantees the order of argument evalation
 265 ;;;       (MPROG and MPROGN), must translate and expression and get information
 266 ;;;       about environment propagation.
 267 ;;;       (PROGN (FULLMAP (PROGN (SET-ENV) '(LAMBDA ...)) L)
 268 ;;;              (GET-ENV)), uhm. this is pretty tricky anyway.
 269 ;;;    B. side effects only have to be maintained inside the LAMBDA.
 270 ;;;       this is easier, and if you have it, you really don't need II.A.
 271 ;;;       since you can always ask the LAMBDA for its environment by
 272 ;;;       calling it on the proper message {If the LAMBDA is written that way}.
 273
 274
 275 ;;; ((LAMBDA) ((MLIST) X Y ((MLIST Z))) . <BODY>)
 276 ;;; must also handle the &REST arguments. N.B. MAPPLY correctly handles
 277 ;;; the application of a lisp lambda form.
 278
 279
 280 ;;; Some forms know that the lambda is not going to
 281 ;;; be an upward funarg, that it is not possible (wanted)
 282 ;;; have two different lambda's generated from the same
 283 ;;; place. e.g. INTERPOLATE(SIN(X^2)=A,X,0,N) (implied lambda
 284 ;;; which is contructed by the translation property for
 285 ;;; interpolate. MAP(LAMBDA([U],...),L) is another example)
 286 ;;; these forms will be called I-LAMBDA's, and will be generated
 287 ;;; from LAMBDA's by the functions that want to. All this
 288 ;;; is meaningless in the present macsyma evaluator of course, since
 289 ;;; it uses dynamic binding and just hopes for the best.
 290
 291 (def%tr lambda (form)
 292   (gen-tr-lambda form))
 293
 294 ;;; we keep a pointer to the original FORM so that we can
 295 ;;; generate messages with it if need be.
 296
 297 (defun gen-tr-lambda (form &aux arg-info frees t-form dup)
 298   (unless ($listp (cadr form))
 299     (tr-format (intl:gettext "error: first argument of lambda expression must be a list; found ~M") (cadr form))
 300     (setq tr-abort t)
 301     (return-from gen-tr-lambda nil))
 302   (when (null (cddr form))
 303     (tr-format (intl:gettext "error: empty body in lambda expression.~%"))
 304     (setq tr-abort t)
 305     (return-from gen-tr-lambda nil))
 306   (setq arg-info (mapcar #'(lambda (v)
 307                              (cond ((mdefparam v) nil)
 308                                    ((and (op-equalp v 'mlist)
 309                                          (mdefparam (cadr v))
 310                                          (null (cddr v)))
 311                                     t)
 312                                    (t '*bad*)))
 313                          (cdr (cadr form))))
 314   (cond ((or (member '*bad* arg-info :test #'eq)
 315              (and (member t arg-info :test #'eq)
 316                   (cdr (member t arg-info :test #'eq)))) ;;; the &REST is not the last one.
 317          (tr-format (intl:gettext "error: unsupported argument list ~:M in lambda expression.~%") (cadr form))
 318          (setq tr-abort t)
 319          nil)
 320         ((setq dup (find-duplicate (cdadr form) :test #'eq :key #'mparam))
 321          (tr-format (intl:gettext "error: ~M occurs more than once in lambda expression parameter list") (mparam dup))
 322          (setq tr-abort t)
 323          nil)
 324         (t
 325          (setq arg-info (member t arg-info :test #'eq) ;; &RESTP
 326                t-form
 327                (tr-lambda `((lambda)
 328                             ((mlist) ,@(mapcar #'(lambda (v)
 329                                                    (cond ((atom v) v)
 330                                                          (t (cadr v))))
 331                                                (cdr (cadr form))))
 332                             ,@(cddr form)))
 333                t-form (cdr t-form)
 334                frees (tbound-free-vars (free-lisp-vars t-form)))))
 335                                         ; with this info we now dispatch to the various macros forms.
 336                                         ; (cadr t-form) is a lambda list. (cddr t-form) is a progn body.
 337   (cond ((null (car frees))             ; woopie.
 338          (cond ((null arg-info)
 339                 `($any . (m-tlambda ,@(cdr t-form))))
 340                (t
 341                 `($any . (m-tlambda& ,@(cdr t-form))))))
 342         ((null (cadr frees))
 343         `($any . (,(cond ((null arg-info) 'm-tlambda&env)
 344                          (t               'm-tlambda&env&))
 345                    (,(cadr t-form) ,(car frees))
 346                    ,@(cddr t-form))))
 347         (t
 348          (warn-meval form)
 349          (side-effect-free-check (cadr frees) form)
 350          `($any . (meval ',form)))))