From: Barton W. <wil...@us...> - 2007-01-28 12:47:53
|
Update of /cvsroot/maxima/maxima/share/contrib In directory sc8-pr-cvs7.sourceforge.net:/tmp/cvs-serv28832/share/contrib Modified Files: tocl.lisp Log Message: o Added support for conditionals, blocks, and Maxima lambda forms. o New function to_cl Index: tocl.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/share/contrib/tocl.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- tocl.lisp 15 Jul 2006 02:44:03 -0000 1.1 +++ tocl.lisp 28 Jan 2007 12:47:49 -0000 1.2 @@ -1,4 +1,4 @@ -#| Copyright 2006 by Barton Willis +#| Copyright 2006, 2007 by Barton Willis This is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License, @@ -12,7 +12,7 @@ 'common_lisp' converts a Maxima expression into a Lisp lambda form. It converts Maxima operators into their closest Common Lisp counterparts. Thus Maxima addition is converted into the Common -Lisp '+' function. So the lambda form that common_lisp generates +Lisp '+' function. Thus the lambda form generated by common_lisp should work OK with numerical inputs, but not symbolic inputs. A few examples might be the easiest way to explain what @@ -25,18 +25,22 @@ (LAMBDA (B X Z) (+ (COS (+ B X)) (- (F Z)))) (%o2) done -The function common_lisp doesn't work correctly for conditionals, -Maxima blocks, assignments, and etc. It does (or at least it -is supposed to) work correctly for expressions that involve -polynomials and trig-like functions. +The function common_lisp should work correctly for polynomials +and trig-like functions, block constructs, conditionals, and compound +statements. It doesn't work for any loop construct. |# (defun $common_lisp (e) - (let (($listconstvars nil)) - (print `(lambda ,(sort (mapcar 'stripdollar (margs ($listofvars e))) 'string<) + (let (($listconstvars nil) (vars nil)) + (setq vars (delete 't (margs ($listofvars e)))) ;; listofvars('if x < 0 then 0 else 1) --> [x, true] + (print `(lambda ,(sort (mapcar 'stripdollar vars) 'string<) ,(expr-to-cl (nformat ($ratdisrep e))))) '$done)) - + +(defun $to_cl (e) + (print (expr-to-cl (nformat ($ratdisrep e)))) + '$done) + (setf (get 'mplus 'cl-function) '+) (setf (get 'mminus 'cl-function) '-) (setf (get 'mtimes 'cl-function) '*) @@ -46,9 +50,40 @@ (setf (get 'mgreaterp 'cl-function) '>) (setf (get 'mgeqp 'cl-function) '>=) (setf (get 'mleqp 'cl-function) '<=) +(setf (get 'mprogn 'cl-function) 'progn) +(setf (get 'mabs 'cl-function) 'abs) +(setf (get 'msetq 'cl-function) 'setq) +(setf (get 'mnot 'cl-function) 'not) +(setf (get 'mand 'cl-function) 'and) +(setf (get 'mor 'cl-function) 'or) + +(setf (get 'lambda 'cl-translation-function) 'lambda-tr) +(setf (get 'mprog 'cl-translation-function) 'block-tr) +(setf (get 'mcond 'cl-translation-function) 'cond-tr) + +(defun lambda-tr (&rest f) + `(lambda (,@(mapcar 'expr-to-cl (margs (first f)))) ,(expr-to-cl (second f)))) + +(defun block-tr (&rest f) + (let ((acc nil) (f1)) + (setq f1 (margs (first f))) + (dolist (ai f1) + (push (if (op-equalp ai 'msetq) (mapcar 'expr-to-cl (margs ai)) (list (expr-to-cl ai))) acc)) + (setq acc (list (reverse acc))) + `(let ,@acc ,(expr-to-cl (second f))))) + +(defun cond-tr (&rest f) + (let ((acc nil) (f1) (f2)) + (while f + (setq f1 (expr-to-cl (pop f))) + (setq f2 (expr-to-cl (pop f))) + (push (list f1 f2) acc)) + `(cond ,@(reverse acc)))) (defun mapatom-expr-to-cl (e) (cond ((eq e '$%i) (complex 0 1)) + ((memq e '($true t)) 't) + ((memq e '($false nil)) 'nil) ((integerp e) e) (($ratnump e) `(/ ,($num e) ,($denom e))) ((eq e '$%pi) pi) @@ -56,8 +91,11 @@ (t (stripdollar e)))) (defun expr-to-cl (e) - (if ($mapatom e) (mapatom-expr-to-cl e) - `(,(or (get (mop e) 'cl-function) (stripdollar (mop e))) ,@(mapcar 'expr-to-cl (margs e)))))) + (cond(($mapatom e) (mapatom-expr-to-cl e)) + ((get (mop e) 'cl-translation-function) + (apply (get (mop e) 'cl-translation-function) (margs e))) + (t + `(,(or (get (mop e) 'cl-function) (stripdollar (mop e))) ,@(mapcar 'expr-to-cl (margs e)))))) |