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 <BVLSPEC> . <BODY>)
 125
 126 (defun-prop (prog free-lisp-vars) (form)
 127   (sum-var-sets
 128     ; get free lisp vars from init forms
 129     (union-var-set
 130       (mapcar (lambda (e) (when (consp e) (free-lisp-vars (cadr e))))
 131               (cadr form)))
 132     (difference-var-sets
 133       ; get free lisp vars from body forms
 134       (union-var-set (mapcar (lambda (e)
 135                                ; skip go tags
 136                                (if (go-tag-p e) '() (free-lisp-vars e)))
 137                              (cddr form)))
 138       ; get vars bound by PROG
 139       (make-var-set (mapcar (lambda (e) (if (consp e) (car e) e))
 140                             (cadr form))))))
 141
 142 ;;; (LET <BVLSPEC> . <BODY>)
 143
 144 (defun-prop (let free-lisp-vars) (form)
 145   (sum-var-sets
 146     ; get free lisp vars from init forms
 147     (union-var-set
 148       (mapcar (lambda (e) (when (consp e) (free-lisp-vars (cadr e))))
 149               (cadr form)))
 150     (difference-var-sets
 151       ; get free lisp vars from body forms
 152       (free-lisp-vars-of-argl (cddr form))
 153       ; get vars bound by LET
 154       (make-var-set (mapcar (lambda (e) (if (atom e) e (car e)))
 155                             (cadr form))))))
 156
 157 ;;; (DO (<VARSPEC> ...) (<END-TEST-FORM> . <RESULT-FORMS>) . <BODY>)
 158
 159 (defun-prop (do free-lisp-vars) (form)
 160   (sum-var-sets
 161     ; get free lisp vars from init forms
 162     (union-var-set (mapcar (lambda (e)
 163                              (when (consp e)
 164                                (free-lisp-vars (cadr e))))
 165                            (cadr form)))
 166     (difference-var-sets
 167       (sum-var-sets
 168         ; get free lisp vars from body forms
 169         (union-var-set (mapcar (lambda (e)
 170                                  ; skip go tags
 171                                  (if (go-tag-p e) '() (free-lisp-vars e)))
 172                                (cdddr form)))
 173         ; get free lisp vars from the end test form and result forms
 174         (free-lisp-vars-of-argl (caddr form))
 175         ; get free lisp vars from step forms
 176         (union-var-set (mapcar (lambda (e)
 177                                  (when (consp e)
 178                                    (free-lisp-vars (caddr e))))
 179                                (cadr form))))
 180       ; get vars bound by DO
 181       (make-var-set (mapcar (lambda (e) (if (atom e) e (car e)))
 182                             (cadr form))))))
 183
 184 ;;; (COND (<I> ..) (<J> ..) ...)
 185
 186 (defun-prop (cond free-lisp-vars) (form)
 187   (union-var-set (mapcar #'free-lisp-vars-of-argl (cdr form))))
 188
 189 ;;; (SETQ ... ODD AND EVENS...)
 190
 191 (defun-prop (setq free-lisp-vars) (form)
 192   (do ((free-vars nil (sum-var-sets `((,(car form) . t))
 193                                     (free-lisp-vars (cadr form))
 194                                     free-vars))
 195        (form (cdr form) (cddr form)))
 196       ((null form) free-vars)))
 197
 198 ;;; uhm. LAMBDA, PROG, GO, DO, COND, QUOTE, SETQ.
 199
 200 (defun-prop (and free-lisp-vars)(form)(free-lisp-vars-of-argl (cdr form)))
 201 (defun-prop (or free-lisp-vars)(form)(free-lisp-vars-of-argl (cdr form)))
 202
 203 ;;; these next forms are generated by TRANSLATE.
 204
 205 (defprop $piece t sort-of-lexical)
 206
 207 (defun-prop (trd-msymeval free-lisp-vars) (form)
 208   (if (get (cadr form) 'sort-of-lexical)
 209       ;; acts like a lexical variable because of the $SUBSTPART translator.
 210       (list (list (cadr form)))
 211       ()))
 212
 213 (defun-prop (mfunction-call free-lisp-vars) (form)
 214   ;; it is not strictly known if the name of the function being called
 215   ;; is a variable or not. lets say its not.
 216   (free-lisp-vars-of-argl (cddr form)))
 217
 218 ;;; (FUNGEN&ENV-FOR-MEVAL () () EXP)
 219 (defun-prop (fungen&env-for-meval free-lisp-vars) (form)
 220   (free-lisp-vars (car (cdddr form))))
 221
 222 ;;; the various augmented lambda forms.
 223
 224 (defun free-lisp-vars-m-tlambda (form)
 225   (difference-var-sets (free-lisp-vars-of-argl (cddr form))
 226                        (free-lisp-vars-of-argl (cadr form))))
 227
 228 (mapc #'(lambda (u) (putprop u 'free-lisp-vars-m-tlambda 'free-lisp-vars))
 229       '(m-tlambda m-tlambda&))
 230
 231 (defun free-lisp-vars-m-tlambda&env (form)
 232   (difference-var-sets (free-lisp-vars-of-argl (cddr form))
 233                        (free-lisp-vars-of-argl (car (cadr form)))))
 234
 235 (defprop m-tlambda&env free-lisp-vars-m-tlambda&env free-lisp-vars)
 236 (defprop m-tlambda&env& free-lisp-vars-m-tlambda&env free-lisp-vars)
 237
 238 ;;; Other entry points:
 239
 240 (defun tbound-free-vars (free-varl)
 241   ;; Takes a FREE-VAR list and returns a list of two lists.
 242   ;; the tbound free vars and the tbound free vars that are
 243   ;; side effected also.
 244   (do ((free nil)
 245        (free&s nil))
 246       ((null free-varl) (list free free&s))
 247     (let ((v (pop free-varl)))
 248       (cond ((and (tboundp (car v))
 249                   (not (tr-get-special (car v))))
 250              (push (car v) free)
 251              (cond ((cdr v)
 252                     (push (car v) free&s))))))))
 253
 254 (defun side-effect-free-check (varl form)
 255   (cond ((null varl) t)
 256         (t
 257          (tr-format (intl:gettext "error: unsupported side effects on ~:M in expression ~M~%") `((mlist) ,@varl) form)
 258          nil)))
 259
 260
 261 ;;; O.K. here is the translate property for LAMBDA.
 262 ;;; given catch and throw we don't know where a funarg lambda
 263 ;;; may end up.
 264
 265 ;;; Cases:
 266 ;;; I. No side effects on free variables.
 267 ;;;    A. one funarg only, not reconsed. e.g.
 268 ;;;       F(N,L):=MAP(LAMBDA([U],Q(N,U)),L)$
 269 ;;;       (PROGN (SET-ENV <*LINK*> N)
 270 ;;;              (FUNCTION (LAMBDA (U) (LET ((N (GET-ENV *LINK*))) (f* U N)))))
 271 ;;;    B. need new instance of the environment each time,
 272 ;;;       F(N):=LAMBDA([U],N*U);
 273 ;;;       `(LAMBDA (U) (gen-func U 'N)) without extend loaded.
 274 ;;; II. side effects.
 275 ;;;    A. Those since effects need to be propogated to the environment
 276 ;;;       where the LAMBDA was made. This is difficult to do in the
 277 ;;;       present translator. e.g.
 278 ;;;       F(L):=BLOCK([SUM:0],FULLMAP(LAMBDA([U],SUM:SUM+U),L),SUM);
 279 ;;;       every function which guarantees the order of argument evalation
 280 ;;;       (MPROG and MPROGN), must translate and expression and get information
 281 ;;;       about environment propagation.
 282 ;;;       (PROGN (FULLMAP (PROGN (SET-ENV) '(LAMBDA ...)) L)
 283 ;;;              (GET-ENV)), uhm. this is pretty tricky anyway.
 284 ;;;    B. side effects only have to be maintained inside the LAMBDA.
 285 ;;;       this is easier, and if you have it, you really don't need II.A.
 286 ;;;       since you can always ask the LAMBDA for its environment by
 287 ;;;       calling it on the proper message {If the LAMBDA is written that way}.
 288
 289
 290 ;;; ((LAMBDA) ((MLIST) X Y ((MLIST Z))) . <BODY>)
 291 ;;; must also handle the &REST arguments. N.B. MAPPLY correctly handles
 292 ;;; the application of a lisp lambda form.
 293
 294
 295 ;;; Some forms know that the lambda is not going to
 296 ;;; be an upward funarg, that it is not possible (wanted)
 297 ;;; have two different lambda's generated from the same
 298 ;;; place. e.g. INTERPOLATE(SIN(X^2)=A,X,0,N) (implied lambda
 299 ;;; which is contructed by the translation property for
 300 ;;; interpolate. MAP(LAMBDA([U],...),L) is another example)
 301 ;;; these forms will be called I-LAMBDA's, and will be generated
 302 ;;; from LAMBDA's by the functions that want to. All this
 303 ;;; is meaningless in the present macsyma evaluator of course, since
 304 ;;; it uses dynamic binding and just hopes for the best.
 305
 306 (def%tr lambda (form)
 307   (gen-tr-lambda form))
 308
 309 ;;; we keep a pointer to the original FORM so that we can
 310 ;;; generate messages with it if need be.
 311
 312 (defun gen-tr-lambda (form &aux arg-info frees t-form dup)
 313   (unless ($listp (cadr form))
 314     (tr-format (intl:gettext "error: first argument of lambda expression must be a list; found ~M") (cadr form))
 315     (tr-abort)
 316     (return-from gen-tr-lambda nil))
 317   (when (null (cddr form))
 318     (tr-format (intl:gettext "error: empty body in lambda expression.~%"))
 319     (tr-abort)
 320     (return-from gen-tr-lambda nil))
 321   (setq arg-info (mapcar #'(lambda (v)
 322                              (cond ((mdefparam v) nil)
 323                                    ((and (op-equalp v 'mlist)
 324                                          (mdefparam (cadr v))
 325                                          (null (cddr v)))
 326                                     t)
 327                                    (t '*bad*)))
 328                          (cdr (cadr form))))
 329   (cond ((or (member '*bad* arg-info :test #'eq)
 330              (and (member t arg-info :test #'eq)
 331                   (cdr (member t arg-info :test #'eq)))) ;;; the &REST is not the last one.
 332          (tr-format (intl:gettext "error: unsupported argument list ~:M in lambda expression.~%") (cadr form))
 333          (tr-abort)
 334          nil)
 335         ((setq dup (find-duplicate (cdadr form) :test #'eq :key #'mparam))
 336          (tr-format (intl:gettext "error: ~M occurs more than once in lambda expression parameter list") (mparam dup))
 337          (tr-abort)
 338          nil)
 339         (t
 340          (setq arg-info (member t arg-info :test #'eq) ;; &RESTP
 341                t-form
 342                (tr-lambda `((lambda)
 343                             ((mlist) ,@(mapcar #'(lambda (v)
 344                                                    (cond ((atom v) v)
 345                                                          (t (cadr v))))
 346                                                (cdr (cadr form))))
 347                             ,@(cddr form)))
 348                t-form (cdr t-form)
 349                frees (tbound-free-vars (free-lisp-vars t-form)))))
 350   (cond ((null (car frees))
 351          (let ((tlambda (if arg-info 'm-tlambda& 'm-tlambda)))
 352            `($any . (,tlambda ,(cadr t-form) ,@(cddr t-form)))))
 353         ((null (cadr frees))
 354          (let* ((tlambda (if arg-info 'm-tlambda&env& 'm-tlambda&env))
 355                 (fvl (car frees))
 356                 (cfvl (intersection fvl *tr-free-vars-to-capture*)))
 357            `($any . (,tlambda (,(cadr t-form) ,fvl ,cfvl) ,@(cddr t-form)))))
 358         (t
 359          (warn-meval form)
 360          (side-effect-free-check (cadr frees) form)
 361          (punt-to-meval form))))