Function: math-define-exp

math-define-exp is a byte-compiled function defined in calc-prog.el.gz.

Signature

(math-define-exp EXP)

Source Code

;; Defined in /usr/src/emacs/lisp/calc/calc-prog.el.gz
(defun math-define-exp (exp)
  (cond ((consp exp)
	 (let ((func (car exp)))
	   (cond ((memq func '(quote function))
		  (if (and (consp (nth 1 exp))
			   (eq (car (nth 1 exp)) 'lambda))
		      (cons 'quote
			    (math-define-lambda (nth 1 exp) math-exp-env))
		    exp))
                 ((eq func 'let)
                  (let ((bindings (nth 1 exp))
                        (body (cddr exp)))
                    `(let ,(math-define-let bindings)
                       ,@(math-define-body
                          body (append (math-define-let-env bindings)
                                       math-exp-env)))))
                 ((eq func 'let*)
                  ;; Rewrite in terms of `let'.
                  (let ((bindings (nth 1 exp))
                        (body (cddr exp)))
                    (math-define-exp
                     (if (> (length bindings) 1)
                         `(let ,(list (car bindings))
                            (let* ,(cdr bindings) ,@body))
                       `(let ,bindings ,@body)))))
		 ((memq func '(for foreach))
		  (let ((bindings (nth 1 exp))
			(body (cddr exp)))
                    (if (> (length bindings) 1)
                        ;; Rewrite as nested loops.
                        (math-define-exp
                         `(,func ,(list (car bindings))
                                 (,func ,(cdr bindings) ,@body)))
                      (let ((mac (cdr (assq func '((for . math-for)
                                                   (foreach . math-foreach))))))
                        (macroexpand
                         `(,mac ,(math-define-let bindings)
                                ,@(math-define-body
                                   body (append (math-define-let-env bindings)
                                                math-exp-env))))))))
		 ((and (memq func '(setq setf))
		       (math-complicated-lhs (cdr exp)))
		  (if (> (length exp) 3)
		      (cons 'progn (math-define-setf-list (cdr exp)))
		    (math-define-setf (nth 1 exp) (nth 2 exp))))
		 ((eq func 'condition-case)
		  (cons func
			(cons (nth 1 exp)
			      (math-define-body (cdr (cdr exp))
						(cons (nth 1 exp)
						      math-exp-env)))))
		 ((eq func 'cond)
		  (cons func
			(math-define-cond (cdr exp))))
		 ((and (consp func)   ; ('spam a b) == force use of plain spam
		       (eq (car func) 'quote))
		  (cons (cadr func) (math-define-list (cdr exp))))
		 ((symbolp func)
		  (let ((args (math-define-list (cdr exp)))
			(prim (assq func math-prim-funcs)))
		    (cond (prim
			   (cons (cdr prim) args))
			  ((eq func 'floatp)
			   (list 'eq (car args) '(quote float)))
			  ((eq func '+)
			   (math-define-binop 'math-add 0
					      (car args) (cdr args)))
			  ((eq func '-)
			   (if (= (length args) 1)
			       (cons 'math-neg args)
			     (math-define-binop 'math-sub 0
						(car args) (cdr args))))
			  ((eq func '*)
			   (math-define-binop 'math-mul 1
					      (car args) (cdr args)))
			  ((eq func '/)
			   (math-define-binop 'math-div 1
					      (car args) (cdr args)))
			  ((eq func 'min)
			   (math-define-binop 'math-min 0
					      (car args) (cdr args)))
			  ((eq func 'max)
			   (math-define-binop 'math-max 0
					      (car args) (cdr args)))
			  ((eq func '<)
			   (if (and (math-numberp (nth 1 args))
				    (math-zerop (nth 1 args)))
			       (list 'math-negp (car args))
			     (cons 'math-lessp args)))
			  ((eq func '>)
			   (if (and (math-numberp (nth 1 args))
				    (math-zerop (nth 1 args)))
			       (list 'math-posp (car args))
			     (list 'math-lessp (nth 1 args) (nth 0 args))))
			  ((eq func '<=)
			   (list 'not
				 (if (and (math-numberp (nth 1 args))
					  (math-zerop (nth 1 args)))
				     (list 'math-posp (car args))
				   (list 'math-lessp
					 (nth 1 args) (nth 0 args)))))
			  ((eq func '>=)
			   (list 'not
				 (if (and (math-numberp (nth 1 args))
					  (math-zerop (nth 1 args)))
				     (list 'math-negp (car args))
				   (cons 'math-lessp args))))
			  ((eq func '=)
			   (if (and (math-numberp (nth 1 args))
				    (math-zerop (nth 1 args)))
			       (list 'math-zerop (nth 0 args))
			     (if (and (integerp (nth 1 args))
				      (/= (% (nth 1 args) 10) 0))
				 (cons 'math-equal-int args)
			       (cons 'math-equal args))))
			  ((eq func '/=)
			   (list 'not
				 (if (and (math-numberp (nth 1 args))
					  (math-zerop (nth 1 args)))
				     (list 'math-zerop (nth 0 args))
				   (if (and (integerp (nth 1 args))
					    (/= (% (nth 1 args) 10) 0))
				       (cons 'math-equal-int args)
				     (cons 'math-equal args)))))
			  ((eq func '1+)
			   (list 'math-add (car args) 1))
			  ((eq func '1-)
			   (list 'math-add (car args) -1))
			  ((eq func 'not)   ; optimize (not (not x)) => x
			   (if (eq (car-safe args) func)
			       (car (nth 1 args))
			     (cons func args)))
			  ((and (eq func 'elt) (cdr (cdr args)))
			   (math-define-elt (car args) (cdr args)))
			  (t
			   (macroexpand
			    (let* ((name (symbol-name func))
				   (cfunc (intern (concat "calcFunc-" name)))
				   (mfunc (intern (concat "math-" name))))
			      (cond ((fboundp cfunc)
				     (cons cfunc args))
				    ((fboundp mfunc)
				     (cons mfunc args))
				    ((or (fboundp func)
					 (string-match "\\`calcFunc-.*" name))
				     (cons func args))
				    (t
				     (cons cfunc args)))))))))
		 (t (cons func (math-define-list (cdr exp))))))) ;;args
	((symbolp exp)
	 (let ((prim (assq exp math-prim-vars))
	       (name (symbol-name exp)))
	   (cond (prim
		  (cdr prim))
		 ((memq exp math-exp-env)
		  exp)
		 ((string-search "-" name)
		  exp)
		 (t
		  (intern (concat "var-" name))))))
	((integerp exp)
	 (if (or (<= exp -1000000) (>= exp 1000000))
	     (list 'quote (math-normalize exp))
	   exp))
	(t exp)))