;;; Written by Yasuaki Honda
;;; yhonda@mac.com
;;; Independent Software Developer
;;; Chiba, Japan
;;; Copyright 2002 Yasuaki Honda
;;;
;;; You are granted to use, copy, modify, or distribute this software without
;;; any form of an explicit permission from the author.

;;; This file implements what is described in the NewPackageProposal.rtf
;;; Usage:
;;; Invoke maxima.
;;; :lisp (load "maxima-user-package.lisp") to load this file.
;;; symbol.lisp will be loaded as well.
;;; 
;;; Regression test is performed on maxima 5.9.0 on clisp 2.30 on cygwin.
;;; April 25th, 2003
;;;
;;; Regression test resuts:
;;; rtest1, rtest1a, and rtest2 are OK.
;;; rtest3 does not pass (probably due to totally unrelated issue.)
;;; rtest4 to rtest13 are OK.
;;; rtest13s does not pass due to some issues related to tellsimp and kill.

(in-package :maxima)
(load "symbol.lisp")

;;; create a maxima-user package.
(defpackage :maxima-user
  ;; First of all, import all the lisp system symbols.
  ;; Immediately some of them will be shadowed.
  ;; Then :maxima package symbols will be imported.
  (:use :lisp))


;;; The function implode1 is taken from file commac.lisp.
;;; This function interns the symbol.
;;; Last line of the function is changed so that it interns
;;; symbol into "MAXIMA-USER" package instead of "MAXIMA" package.

(defun implode1 (lis upcase &aux (ar *string-for-implode*) (leng 0))
  (declare (type string ar) (fixnum leng))
  (or (> (array-total-size ar) (setq leng (length lis)))
      (adjust-array ar (+ leng 20)))
  (setf (fill-pointer ar) leng)
  (sloop for v in lis
	 for i below leng
	 do
	 (cond ((typep v 'character))
	       ((symbolp v) (setq v (aref (symbol-name v) 0)))
	       ((numberp v) (setq v (code-char v))))
	 (setf (aref ar i) (if upcase (char-upcase v) v)))
  (intern ar :maxima-user))

;;;
;;; Original bothcase-implode requires that upcase symbol
;;; needs to be there and actually used (i.e., function
;;; is defined or property list is defined on the symbol)
;;; for the symbol being converted to the upcase symbol.
;;; This is too strong a requirement for symbols such as
;;; $U, $V, $W, $X, $Y, $Z for Poisson series special
;;; functions.
;;; This version does not require such strong condition.
;;; Just upcase symbol needs to be there.
;;;

(defun bothcase-implode (lis  &aux tem )
  (cond ((not (eql (car lis) #\$))
	 (return-from bothcase-implode (implode1 lis nil))))
  (multiple-value-bind
   (sym there)
   (implode1 lis nil)
   (cond (there (if (setq tem (get sym 'upcase)) tem sym))
	 (t
	  ;; if all upper case lets not bother interning...
	  (sloop for v in lis with haslower
		 when (not (eql (char-upcase v) v))
		 do (setq haslower t) (loop-finish)
		 finally (or haslower (return-from bothcase-implode sym)))
	  (multiple-value-bind
	   (symup there)
	   (implode1 lis t)
	   (cond (there		       
		  (setf (get sym 'upcase) symup)
		  symup)
		 (t (or there (unintern symup))
		    sym)))))))

(DEFMFUN GETOPR (X)
  (if (symbolp x)
      (let (tmp)
	(setq tmp (intern (symbol-name X) :maxima))
	(or (get tmp 'opr) x))
    x))

;;;
;;; When REMOVERULE is called, RULE is bound to a symbol
;;; representing a name of a rule, in maxima package.
;;; Since the rule name symbol is effectively defined
;;; in maxima-user package, it needs to be converted first.
;;;

(DEFUN REMOVERULE (OP RULE)
       (SETQ RULE (FIND-SYMBOL (SYMBOL-NAME RULE) :maxima-user))
       (PROG (OLDRULES OLD OTHRULENAME OTHRULE) 
	     (SETQ OLDRULES (MGET OP 'OLDRULES))
	     (COND ((OR (NULL RULE) (NULL (SETQ OLDRULES (zl-MEMBER RULE OLDRULES))))
		    (MERROR "~:M - no such rule." RULE))
		   ((NULL (CAR (SETQ OLDRULES (CDR OLDRULES))))
		    (SETQ OLDRULES (CDR OLDRULES))
		    (SETQ OTHRULENAME 'SIMPARGS1)
		    (SETQ OTHRULE #'(LAMBDA (A B C) (SIMPARGS A C))))
		   (T (SETQ OTHRULENAME (CAR OLDRULES))
		      (SETQ OTHRULE (CADR (GETL (CAR OLDRULES) '(EXPR SUBR))))))
	     (PUTPROP RULE OTHRULE 'EXPR)
	     (SETQ OLD (CDR (zl-MEMBER RULE (REVERSE (MGET OP 'OLDRULES)))))
	     (IF OLD (PUTPROP (CAR OLD)
			      (SUBST OTHRULENAME RULE (GET (CAR OLD) 'EXPR))
			      'EXPR))
	     (IF (BOUNDP RULE) (MAKUNBOUND RULE))
	     (MREMPROP RULE '$RULE)
	     (MREMPROP RULE '$RULETYPE)
	     (MREMPROP RULE 'RULEOF)
	     (REMPROP RULE 'EXPR)
	     (DELQ RULE $RULES 1)
	     (PUTPROP RULE OTHRULENAME 'EXPR)
	     (IF (EQ (GET OP 'OPERATORS) RULE)
		 (PUTPROP OP OTHRULENAME 'OPERATORS))
	     (RETURN (MPUTPROP OP (DELQ RULE (MGET OP 'OLDRULES)) 'OLDRULES))))

;;; Below is copy from maxima-package.lisp. Some modifications were made
;;; so that symbols defined in common lisp are available in maxima-user
;;; as well.

(shadow '(complement continue   tan sinh cosh tanh #+ti file-position ) 'maxima-user)


;;defined in polyrz
(shadow '(signum ) 'maxima-user)

;;lmsup
#+lispm
(shadow '(namestring) 'maxima-user)

;;in transs


#+lispm
(import '(global::array-leader
	  si::arglist
	  global::gc-on
	  global::gc-off
	  global::user-id
	  global::ERROR-RESTART-LOOP
	  global::condition-case 
	  global::compile-flavor-methods
	  global::default-cons-area
	  global::errset
	  global::make-condition
	  si::signal-condition
	  si::set-in-instance
	  si::record-source-file-name
	  #+ti tv::define-user-option-alist
	  #+ti tv::font-char-height ;for plot win
	  #+ti tv::font-char-width ;for plot win
	  #-ti 	  global::define-user-option-alist
	  #-symbolics global::defflavor
	  #-symbolics global::defmethod
	  #-symbolics global::defun-method
	  global::self
	  global::send
	  global::print-herald
	  global::without-interrupts
	  global::current-process
	  global::working-storage-area
	  ) 'maxima-user)
 
(shadow '(copy xor putprop) 'maxima-user)
(shadow '(
 ARRAY       ;;"CL-MAXIMA-SOURCE: MAXIMA; COMMAC" ;not a function in common lisp but symbol in the package
 EXP         ;;various files declare this special which is bad since it is in LISP package.
 LET         ;;"CL-MAXIMA-SOURCE: MAXIMA; LET" ;;like let*
 LET*        ;;"CL-MAXIMA-SOURCE: MAXIMA; LET" ;;maxima:let* does destructuring.  
 LISTEN      ;;"CL-MAXIMA-SOURCE: MAXIMA; SUPRV" ;;has trivial definition in suprv (listen any) ==> 0
 SIGNUM      ;;"CL-MAXIMA-SOURCE: MAXIMA; COMMAC" ;same except (cl:signum 1.3)==1.0 not 1 but I think this is ok for macsyma
 ATAN        ;; (zl:atan y x) == (cl:atan y x) + 2 pi if latter is  negative
 ASIN        ;; different for complex numbers
 ACOS 
 ASINH             
 ACOSH
 ATANH
 TANH        ;;"CL-MAXIMA-SOURCE: MAXIMA; TRIGI" ;same could remove from trigi
 COSH        ;;"CL-MAXIMA-SOURCE: MAXIMA; TRIGI" ;same  ditto
 SINH        ;;"CL-MAXIMA-SOURCE: MAXIMA; TRIGI" ;same  ditto
 TAN         ;;"CL-MAXIMA-SOURCE: MAXIMA; TRIGI" ;;same ditto
 ) 'maxima-user)

;;new definitions in commac to handle narg compat.
(shadow '(arg listify setarg) 'maxima-user)

;;MANY instances are (if a b &rest c).  I changed a bunch but there were 
;;many more
(shadow 'lisp::IF 'maxima-user)

#+kcl
(import '(si::modulus si::cmod si::ctimes si::cdifference si::cplus)
   'maxima-user)

#+(or clisp gcl)
(import '(system::getenv) (find-package "MAXIMA"))
#+gcl
(import '(si::getpid) (find-package "MAXIMA"))

;;get
#+gcl
(import '( si::cleanup si::*info-paths*
	   si::get-instream  si::short-name  si::cleanup
	   si::instream-stream-name si::instream-line si::instream-name
	   si::instream-stream
	   si::stream-name si::complete-prop
	   si::*stream-alist*
	   si::break-call
) "MAXIMA")
#+gcl
(setf (symbol-function 'maxima::newline) (symbol-function 'si::newline))

;; *info-paths* from cl-info.lisp
#+(or clisp cmu)
(import '( si::*info-paths* ) "MAXIMA" )

;; detect which version of clisp REGEXP we have
#+clisp
(if (find-package "REGEXP") 
  (push (cond ((apply (intern "REGEXP-EXEC" "REGEXP") 
                      (list (apply (intern "REGEXP-COMPILE" "REGEXP")
		                   '("AAA" t)) 
		            "aaa"))
                  ':case-fold-search     )
              (t  ':case-fold-search-not ))
	*features* ))
	      
;;redefined in commac  lucid 2.1 does (functionp 'jiljay)-->t
(if (lisp::functionp 'dotimes) (push :shadow-functionp *features*))
(unless (lisp::functionp 'lisp::functionp)
   (pushnew :shadow-functionp *features*))

#+shadow-functionp
(shadow 'lisp::functionp 'maxima-user)

;;;REMOVE The following two forms when the kcl reader can read
;;;the most-negative-double-float again.
#+kcl ;bug fix for float not readable:
(progn
(shadow '( most-positive-single-float most-negative-double-float) 'maxima-user))
#+kcl 
(progn ;bug fix for float not readable:
 (defvar maxima::most-positive-single-float
   (* .1 lisp::most-positive-single-float))
 (defvar maxima::most-negative-double-float
   (* .1 lisp::most-negative-double-float)))

#+(or gcl kcl)
(in-package "SERROR"  :use '( "LISP" "SLOOP"))

(shadow 'lisp::float 'maxima-user)
#+lispm
(shadow 'lisp::loop 'maxima-user)

;;
(use-package :maxima :maxima-user)

(in-package :maxima-user)