;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The data in this file contains enhancments. ;;;;; ;;; ;;;;; ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;; ;;; All rights reserved ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; ;;; Maintained by GJC ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package "MAXIMA") (macsyma-module trans3) (TRANSL-MODULE TRANS3) (declare-top(*lexpr sum-var-sets) (genprefix trans3_)) ;;; The translation of macsyma LAMBDA into lexicaly scoped closures. ;;; Two cases [1] the downward transmission of variable binding environment, ;;; e.g. MAP(LAMBDA([U],F(U,X)),EXP) ;;; [2] downward and upward, requiring a full closure, e.g. ;;; MAP(LAMBDA([U],SUM:SUM+U),EXP); ;;; LAMBDA([U],F(U,X)) => ;;; (DOWN-CLOSE (LAMBDA (U) (F U X)) (X)) ;;; TBIND, TBOUNDP, and TUNBIND and TUNBINDS hack lexical scoping. ;;; A function to determine free vars from a lisp expression. ;;; It returns a which is a list of pairs ;;; (. ) ;;; N.B. This code does a veritable storm of consing, it need not ;;; do any if it used the lambda-bound plist scheme of GJC;UTRANS > ;;; a compiler is allowed to cons though, isn't it? (DEFTRFUN FREE-LISP-VARS (EXP &AUX PROP) (COND ((ATOM EXP) (COND ((OR (NULL EXP)(EQ T EXP)) NIL) ((SYMBOLP EXP) `((,EXP . NIL))) (T NIL))) ((ATOM (CAR EXP)) (COND ((SETQ PROP (GET (CAR EXP) 'FREE-LISP-VARS)) (FUNCALL PROP EXP)) ((setq prop (get (car exp) 'free-lisp-vars-macro)) (free-lisp-vars (funcall prop exp))) ((SETQ PROP (GET (CAR EXP) 'MACRO)) (FREE-LISP-VARS (FUNCALL PROP EXP))) ((GETL (CAR EXP) '(FSUBR FEXPR)) (WARN-FEXPR (CAR EXP) "environment may fail to be correct.") (FREE-LISP-VARS-OF-ARGL (CDR EXP))) (T (FREE-LISP-VARS-OF-ARGL (CDR EXP))))) ((EQ (CAAR EXP) 'LAMBDA) (SUM-VAR-SETS (FREE-LISP-VARS (CAR EXP)) (FREE-LISP-VARS-OF-ARGL (CDR EXP)))) (T (BARFO "Bad lisp expression generated.")))) (DEFUN FREE-LISP-VARS-OF-ARGL (ARGL) (UNION-VAR-SET (MAPCAR #'FREE-LISP-VARS ARGL))) ;;; (REDUCE-VAR-SET '((A . NIL) NIL (B . T) (B . NIL))) => ((A . NIL) (B . T)) ;;; mult-set reduction. (DEFUN REDUCE-VAR-SET&OP (VAR-SET OP) (DO ((VAR-SET VAR-SET (CDR VAR-SET)) (REDUCED-VAR-SET NIL) (VAR1) (VAR2)) ((NULL VAR-SET) REDUCED-VAR-SET) (SETQ VAR1 (CAR VAR-SET)) (COND ((NULL VAR1)) ((SETQ VAR2 (ASSQ (CAR VAR1) REDUCED-VAR-SET)) (RPLACD VAR2 (FUNCALL OP (CDR VAR1) (CDR VAR2)))) (T (PUSH VAR1 REDUCED-VAR-SET))))) (DEFUN REDUCE-VAR-SET (VAR-SET) (REDUCE-VAR-SET&OP VAR-SET #'(LAMBDA (P1 P2)(OR P1 P2)))) ;;; S1 - S2. S1 reduced, minus any vars that are in S2. (DEFUN DIFFERENCE-VAR-SETS (S1 S2) (SETQ S1 (REDUCE-VAR-SET S1)) (DO ((S NIL)) ((NULL S1) S) (COND ((ASSQ (CAAR S1) S2)) ;;; is the first elem of S1 a member of S2? (T (PUSH (CAR S1) S))) ;;; yes. shove it in. (POP S1))) ;;; N.B. union of var sets is defined classicaly ala G.F. (DEFUN UNION-VAR-SET (SET-OF-VAR-SETS) (REDUCE-VAR-SET (APPLY #'APPEND SET-OF-VAR-SETS))) ;;; SUM-VAR-SETS is the usual convention. (DEFUN SUM-VAR-SETS (&REST L) (REDUCE-VAR-SET (APPLY #'APPEND L))) ; consing up a storm aren't we? (DEFUN MAKE-VAR-SET (VARS) (sloop for v in vars collect (ncons v))) ;;; (LAMBDA . ) (DEFUN-prop (LAMBDA FREE-LISP-VARS) (FORM) (DIFFERENCE-VAR-SETS (FREE-LISP-VARS-OF-ARGL (CDDR FORM)) (COND ((NULL (CADR FORM)) NIL) ((ATOM (CADR FORM)) (MAKE-VAR-SET (LIST (CADR FORM)))) (T (MAKE-VAR-SET (CADR FORM)))))) ;;; (PROG . ) (DEFUN-prop (PROG FREE-LISP-VARS) (FORM) (DIFFERENCE-VAR-SETS (UNION-VAR-SET (MAPCAR #'(LAMBDA (U) (COND ((ATOM U) NIL) ;; go tag. (T (FREE-LISP-VARS U)))) (CDDR FORM))) (MAKE-VAR-SET (CADR FORM)))) ;;; no computed gos please. (DEFUN-prop (GO FREE-LISP-VARS) (IGNOR)IGNOR NIL) ;;; (DO (( ) ...) (() ..) ...) (DEFUN-prop (DO FREE-LISP-VARS) (FORM) (DIFFERENCE-VAR-SETS (SUM-VAR-SETS (FREE-LISP-VARS-OF-ARGL (CDDDR FORM)) (FREE-LISP-VARS-OF-ARGL (CADDR FORM)) (UNION-VAR-SET (MAPCAR #'(LAMBDA (DO-ITER) (FREE-LISP-VARS-OF-ARGL (CDR DO-ITER))) (CADR FORM)))) (MAKE-VAR-SET (MAPCAR #'CAR (CADR FORM))))) ;;; (COND ( ..) ( ..) ...) (DEFUN-prop (COND FREE-LISP-VARS) (FORM) (UNION-VAR-SET (MAPCAR #'FREE-LISP-VARS-OF-ARGL (CDR FORM)))) (DEFUN-prop (QUOTE FREE-LISP-VARS) (IGNOR)IGNOR NIL) (DEFUN-prop (FUNCTION FREE-LISP-VARS) (IGNOR)IGNOR NIL) ;;; (SETQ ... ODD AND EVENS...) (DEFUN-prop (SETQ FREE-LISP-VARS) (FORM) (DO ((FREE-VARS NIL (SUM-VAR-SETS `((,(CAR FORM) . T)) (FREE-LISP-VARS (CADR FORM)) FREE-VARS)) (FORM (CDR FORM) (CDDR FORM))) ((NULL FORM) FREE-VARS))) ;;; uhm. LAMBDA, PROG, GO, DO, COND, QUOTE, SETQ. (DEFUN-prop (AND FREE-LISP-VARS)(FORM)(FREE-LISP-VARS-OF-ARGL (CDR FORM))) (DEFUN-prop (OR FREE-LISP-VARS)(FORM)(FREE-LISP-VARS-OF-ARGL (CDR FORM))) (DEFUN-prop (COMMENT FREE-LISP-VARS) (IGNOR)IGNOR NIL) (DEFUN-prop (DECLARE FREE-LISP-VARS) (IGNOR) IGNOR NIL) ;;; these next forms are generated by TRANSLATE. (DEFPROP $PIECE T SORT-OF-LEXICAL) (defun-prop (trd-msymeval free-lisp-vars) (FORM) (IF (GET (CADR FORM) 'SORT-OF-LEXICAL) ;; acts like a lexical variable because of the $SUBSTPART translator. (LIST (LIST (CADR FORM))) ())) (DEFUN-prop (MFUNCTION-CALL FREE-LISP-VARS) (FORM) ; it is not strictly known if the name of the function being called ; is a variable or not. lets say its not. (FREE-LISP-VARS-OF-ARGL (CDDR FORM))) ;;; (FUNGEN&ENV-FOR-MEVAL () () EXP) (DEFUN-prop (FUNGEN&ENV-FOR-MEVAL FREE-LISP-VARS) (FORM) (FREE-LISP-VARS (CAR (CDDDr form)))) ;;; (FUNGEN&ENV-FOR-MEVALSUMARG () () EXP MACSYMA-EXP) (DEFUN-prop (FUNGEN&ENV-FOR-MEVALSUMARG FREE-LISP-VARS) (FORM) (FREE-LISP-VARS (CAR (CDDR form)))) ;;; the various augmented lambda forms. (DEFUN free-lisp-vars-m-tlambda (FORM) (DIFFERENCE-VAR-SETS (FREE-LISP-VARS-OF-ARGL (CDDR FORM)) (FREE-LISP-VARS-OF-ARGL (CADR FORM)))) (MAPC #'(LAMBDA (U)(PUTPROP U 'FREE-LISP-VARS-m-tLAMBDA 'FREE-LISP-VARS)) '(M-TLAMBDA M-TLAMBDA&)) (defun free-lisp-vars-m-tlambda&env (form) (difference-var-sets (free-lisp-vars-of-argl (cddr form)) (free-lisp-vars-of-argl (car (cadr form))))) (defprop m-tlambda&env free-lisp-vars-m-tlambda&env free-lisp-vars) (defprop m-tlambda&env& free-lisp-vars-m-tlambda&env free-lisp-vars) ; (m-tlambda-i mode env ...) (defun-prop (m-tlambda-i free-lisp-vars-macro) (form) `(lambda ,@(cdddr form))) ;;; Other entry points: (DEFUN TBOUND-FREE-VARS (FREE-VARL) ; Takes a FREE-VAR list and returns a list of two lists. ; the tbound free vars and the tbound free vars that are ; side effected also. (DO ((FREE NIL) (FREE&S NIL)) ((NULL FREE-VARL) (LIST FREE FREE&S)) (LET ((V (POP FREE-VARL))) (COND ((AND (TBOUNDP (CAR V)) (NOT (GET (CAR V) 'SPECIAL))) (PUSH (CAR V) FREE) (COND ((CDR V) (PUSH (CAR V) FREE&S)))))))) (DEFUN SIDE-EFFECT-FREE-CHECK (VARL FORM) (COND ((NULL VARL) T) (T (TR-TELL "This form:" FORM "has side effects on these variables:" `((MLIST) ,@VARL) "which cannot be supported in the translated code." "(at this time)") NIL))) ;;; O.K. here is the translate property for LAMBDA. ;;; given catch and throw we don't know where a funarg lambda ;;; may end up. ;;; Cases: ;;; I. No side effects on free variables. ;;; A. one funarg only, not reconsed. e.g. ;;; F(N,L):=MAP(LAMBDA([U],Q(N,U)),L)$ ;;; (PROGN (SET-ENV <*LINK*> N) ;;; (FUNCTION (LAMBDA (U) (LET ((N (GET-ENV *LINK*))) (f* U N))))) ;;; B. need new instance of the environment each time, ;;; F(N):=LAMBDA([U],N*U); ;;; `(LAMBDA (U) (gen-func U 'N)) without extend loaded. ;;; II. side effects. ;;; A. Those since effects need to be propogated to the environment ;;; where the LAMBDA was made. This is difficult to do in the ;;; present translator. e.g. ;;; F(L):=BLOCK([SUM:0],FULLMAP(LAMBDA([U],SUM:SUM+U),L),SUM); ;;; every function which guarantees the order of argument evalation ;;; (MPROG and MPROGN), must translate and expression and get information ;;; about environment propagation. ;;; (PROGN (FULLMAP (PROGN (SET-ENV) '(LAMBDA ...)) L) ;;; (GET-ENV)), uhm. this is pretty tricky anyway. ;;; B. side effects only have to be maintained inside the LAMBDA. ;;; this is easier, and if you have it, you really don't need II.A. ;;; since you can always ask the LAMBDA for its environment by ;;; calling it on the proper message {If the LAMBDA is written that way}. ;;; LAMBDA-I is used by ROMBERG, PLOT2 and INTERPOLATE, and it could be used ;;; by the mapping functions. We have a single instance of the LAMBDA ;;; and its environment. ;;; ((LAMBDA) ((MLIST) X Y ((MLIST Z))) . ) ;;; must also handle the &REST arguments. N.B. MAPPLY correctly handles ;;; the application of a lisp lambda form. ;;; Some forms know that the lambda is not going to ;;; be an upward funarg, that it is not possible (wanted) ;;; have two different lambda's generated from the same ;;; place. e.g. INTERPOLATE(SIN(X^2)=A,X,0,N) (implied lambda ;;; which is contructed by the translation property for ;;; interpolate. MAP(LAMBDA([U],...),L) is another example) ;;; these forms will be called I-LAMBDA's, and will be generated ;;; from LAMBDA's by the functions that want to. All this ;;; is meaningless in the present macsyma evaluator of course, since ;;; it uses dynamic binding and just hopes for the best. (DEF%TR $LAMBDA_I (FORM) (GEN-TR-LAMBDA FORM)) (def%tr lambda-I (form) (gen-tr-lambda form)) (DEF%TR LAMBDA (FORM) (GEN-TR-LAMBDA FORM)) ;;; we keep a pointer to the original FORM so that we can ;;; generate messages with it if need be. (DEFUN GEN-TR-LAMBDA (FORM &AUX ARG-INFO MODE FREES T-FORM) (SETQ ARG-INFO (MAPCAR #'(LAMBDA (V) (COND ((ATOM V) NIL) ((AND (EQ (CAAR V) 'MLIST) (ATOM (CADR V))) T) (T '*BAD*))) (CDR (CADR FORM)))) (COND ((OR (MEMQ '*BAD* ARG-INFO) (AND (MEMQ T ARG-INFO) (CDR (MEMQ T ARG-INFO)))) ;;; the &REST is not the last one. (TR-TELL (CADR FORM) " bad LAMBDA list. -TRANSLATE") (SETQ TR-ABORT T) NIL) (T (SETQ ARG-INFO (MEMQ T ARG-INFO) ;; &RESTP T-FORM (TR-LAMBDA `((LAMBDA) ((MLIST) ,@(MAPCAR #'(LAMBDA (V) (COND ((ATOM V) V) (T (CADR V)))) (CDR (CADR FORM)))) ,@(CDDR FORM))) MODE (CAR T-FORM) ; not much to do with the mode now, T-FORM (CDR T-FORM) ; could be use by a global optimizer. FREES (TBOUND-FREE-VARS (FREE-LISP-VARS T-FORM))))) ; with this info we now dispatch to the various macros forms. ; (cadr t-form) is a lambda list. (cddr t-form) is a progn body. (COND ((NULL (CAR FREES)) ; woopie. (COND ((NULL ARG-INFO) `($ANY . (M-TLAMBDA ,@(CDR T-FORM)))) (T `($ANY . (M-TLAMBDA& ,@(CDR T-FORM)))))) ((NULL (CADR FREES)) (COND ((EQ (CAAR FORM) 'LAMBDA-I) `($ANY . (M-TLAMBDA-I ,MODE ,(CAR FREES) ,@(CDR T-FORM)))) (T `($ANY . (,(COND ((NULL ARG-INFO) 'M-TLAMBDA&ENV) (T 'M-TLAMBDA&ENV&)) (,(CADR T-FORM) ,(CAR FREES)) ,@(CDDR T-FORM)))))) (T (WARN-MEVAL FORM) (side-EFFECT-FREE-CHECK (CADR FREES) FORM) `($ANY . (MEVAL ',FORM)))))