[Maxima-commits] CVS: maxima/src defopt.lisp, 1.4, 1.5 transm.lisp, 1.9, 1.10 nparse.lisp, 1.34, 1.35 defcal.lisp, 1.4, 1.5

[Robert D. <rob...@us...>]

Update of /cvsroot/maxima/maxima/src
In directory sc8-pr-cvs7.sourceforge.net:/tmp/cvs-serv4404/src

Modified Files:
	defopt.lisp transm.lisp nparse.lisp defcal.lisp 
Log Message:
Apply code clean-ups submitted by Andreas Eder.
With these revisions, make and make check succeed for GCL 2.6.7,
SBCL 1.0, and Clisp 2.38 (all Linux).

Comments made by Andreas:

 - src/defopt.lisp (patch 1636087)
    "I removed all stale conditionalizations for old lisp version."

 - src/transm.lisp (patch 1636232)
    "removed stale conditionalizations;
    brought eval-when situations to ansi-level;
    corrected calls to maxima-error;
    replaced maclisp-isms by common-lisp idioms;
    did a few style changes"

 - src/nparse.lisp (patch 1636337)
    "removed stale conditionalizations;
    deleted unused functions;
    changed maclispisms to common lisp;
    brought eval-when situations to ansi;
    corrected erroneous calls to maxima-error;
    moved variable definitions up in the file to avoid compiler warnings;
    the file now compiles without warning even on sbcl"

 - src/defcal.lisp (patch 1636355)
    "removed macros/functions that were no longer used;
    removed stale conditionalization"


Index: defopt.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/defopt.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- defopt.lisp	7 Nov 2005 17:37:11 -0000	1.4
+++ defopt.lisp	27 Jan 2007 18:39:28 -0000	1.5
@@ -3,6 +3,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (in-package :maxima)
+
 (macsyma-module defopt macro)
 
 ;; For defining optimizers which run on various systems.
@@ -12,92 +13,5 @@
 ;; ***==> Right now, DEFOPT is used just like you would a DEFMACRO <==***
 ;; (defopt <name> <arlist> <body-boo>)
 
-;; PDP-10 Maclisp:
-;; SOURCE-TRANS property is a list of functions (F[1] F[2] ... F[n]).
-;; F[k] is funcalled on the <FORM>, it returns (VALUES <NEW-FORM> <FLAG>).
-;; If <FLAG> = NIL then compiler procedes to F[k+1]
-;; If <FLAG> = T then compiler calls starts again with F[1].
-
-;; LispMachine Lisp:
-;; COMPILER:OPTIMIZERS property is a list of functions as in PDP-10 Maclisp.
-;; F[k] returns <NEW-FORM>. Stop condition is (EQ <FORM> <NEW-FORM>).
-
-;; VAX NIL (with compiler "H"):
-;; SOURCE-CODE-REWRITE property is a function, returns NIL if no rewrite,
-;; else returns NCONS of result to recursively call compiler on.
-
-;; Multics Maclisp:
-;; ???
-;; Franz Lisp:
-;; ???
-
-;; General note:
-;; Having a list of optimizers with stop condition doesn't provide
-;; any increase in power over having a single property. For example,
-;; only two functions in LISPM lisp have more than one optimizer, and
-;; no maclisp functions do. It just isn't very usefull or efficient
-;; to use such a crude mechanism. What one really wants is to be able
-;; to define a set of production rules in a simple pattern match
-;; language. The optimizer for NTH is a case in point:
-;; (NTH 0 X) => (CAR X)
-;; (NTH 1 X) => (CADR X)
-;; ...
-;; This is defined on the LISPM as a single compiler:optimizers with
-;; a hand-compiled pattern matcher.
-
-;;;what's that damn defmacro1 doing here..
-
-;;#+LISPM
-;;(progn 'compile
-;;(defmacro defopt-internal (name . other)
-;;  `(defun (,name opt) . ,other))
-;;(defun opt-driver (form)
-;;  (funcall (get (car form) 'opt) form))
-;;(defmacro defopt (name . other)
-;;  `(progn 'compile
-;;	  ,(si:defmacro1 (cons name other) 'defopt-internal)
-;;	  (defprop ,name (opt-driver) compiler:optimizers)))
-;;
-;;)
-
-
-#+(and cl (not lispm))
 (defmacro defopt (&rest other)
-  `(#-gcl define-compiler-macro #+gcl si::define-compiler-macro ,.other)) 
-
-#+(and lispm cl)
-(progn 'compile
-       (defun opt-driver (form)
-	 (apply (get (car form) 'opt) (cdr form)))
-
-       (defmacro defopt (name . other)
-	 `(progn 'compile
-	   (defun-prop (,name opt) . , other)
-	   (defprop ,name (opt-driver) compiler:optimizers)))
-       )
-
-
-#+pdp10
-(progn 'compile
-       (defun opt-driver (form)
-	 (values (apply (get (car form) 'opt)
-			(cdr form))
-		 t))
-       ;; pdp10 maclisp has argument destructuring available in
-       ;; vanilla defun.
-       (defmacro defopt (name . other)
-	 `(progn 'compile
-	   (defun-prop (,name opt) . ,other)
-	   (defprop ,name (opt-driver) source-trans)))
-       )
-
-#+nil
-(defmacro defopt (name argl &rest other &aux (form (gensym)))
-  `(defun-prop (,name source-code-rewrite) (,form)
-    (compiler:debind-args ,argl ,form (list (progn ,@other)))))
-
-#+(or multics franz)
-(defmacro defopt (name argl . other)
-  `(defmacro ,name ,argl . ,other))
-
-
+  `(#-gcl define-compiler-macro #+gcl si::define-compiler-macro ,@other)) 

Index: transm.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/transm.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- transm.lisp	7 Dec 2005 14:33:25 -0000	1.9
+++ transm.lisp	27 Jan 2007 18:39:28 -0000	1.10
@@ -11,7 +11,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (in-package :maxima)
+
 (macsyma-module transm macro)
+
 (load-macsyma-macros procs)
 (load-macsyma-macros-at-runtime 'procs)
 
@@ -27,7 +29,7 @@
 ;;; [5] Runtime of user-code.
 ;;; [6] "Utilities" or documentation-time of user-code.
 
-;;; -GJC 
+;;; -GJC
 
 ;;; Note: Much of the functionality here was in use before macsyma as
 ;;; a whole got such mechanisms, however we must admit that the macsyma
@@ -36,7 +38,7 @@
 
 (defmacro enterq (thing list)
   ;; should be a DEF-ALTERANT
-  `(or (memq ,thing ,list)
+  `(or (member ,thing ,list :test #'eq)
     (setf ,list (cons ,thing ,list))))
 
 (defmacro def-transl-module (name &rest properties)
@@ -63,12 +65,13 @@
 (def-transl-module mtags ttime-auto)
 (def-transl-module mdefun)
 (def-transl-module transq)
-(def-transl-module fcall  no-load-auto)
+(def-transl-module fcall no-load-auto)
 (def-transl-module acall no-load-auto)
-(def-transl-module trdata   no-load-auto)
+(def-transl-module trdata no-load-auto)
 (def-transl-module mcompi ttime-auto)
 
 (def-transl-module dcl pseudo)		; more data
+
 (defprop dcl maxdoc fasl-dir)
 
 (def-transl-module trmode ttime-auto
@@ -80,416 +83,80 @@
 (def-transl-module trhook hyper)
 (def-transl-module transl-autoload pseudo)
 
-(eval-when (eval compile load)
+(eval-when (:execute :compile-toplevel :load-toplevel)
   (load-macsyma-macros procs))
-#+its
-(defun tr-fasl-file-name (foo)
-  (namestring `((dsk  ,(get! foo 'fasl-dir)) ,foo fasl)))
-
-#+multics
-(defun tr-fasl-file-name (foo)
-  (namestring `,(executable-dir foo)))
-
-#+its
-(defvar transl-autoload-oldio-name "DSK:MACSYM;TRANSL AUTOLO")
-
-#+multics
-(defvar transl-autoload-oldio-name (namestring (executable-dir 'transl/.autoload)))
-
-(defvar module-stack nil)
 
 (defmacro transl-module (name)
-  (if (not (memq name transl-modules))
-      (maxima-error "Not a `transl-module', see LIBMAX;TRANSM >"))
-  #+pdp10
-  (progn (push name module-stack)
-	 (push '(eval-when (compile eval)
-		 (transl-module-do-it)
-		 (pop module-stack))
-	       eof-compile-queue)
-	 (putprop name nil 'functions)
-	 (putprop name nil 'tr-props)
-	 (putprop name nil 'variables)
-	 (do ((l transl-modules (cdr l)))
-	     ((null l))
-	   (if (eq (car l) name) nil
-	       (load-module-info (car l))))
-	 )
-  #+pdp10
-  `(progn 'compile
-    (defprop ,name
-	,(caddr (namelist (truename infile)))
-      version)
-    (progn
-      ,(if (not (get name 'no-load-auto))
-	   `(or (get 'transl-autoload 'version)
-	     ($load ',transl-autoload-oldio-name)))
-      ,@(mapcar #'(lambda (u)
-		    `(or (get ',u 'version)
-		      ($load
-		       ',(tr-fasl-file-name u))))
-		(get name 'first-load))))
-  #-pdp10
-  '(comment there are reasonable things to do here)
-  )
-
-#+pdp10
-
-(defun lambda-type (arglist)
-  (cond ((null arglist)
-	 '(*expr . (nil . 0)))
-	((atom arglist)
-	 '(*lexpr . nil))
-	(t
-	 ;; (FOO BAR &OPTIONAL ... &REST L &AUX)
-	 ;; #O776 is the MAX MAX.
-	 (do ((min 0)
-	      (max 0)
-	      (optional nil)
-	      (l arglist (cdr l)))
-	     ((null l)
-	      (if (= min max)
-		  `(*expr . (nil . ,min))
-		  `(*lexpr . (,min . ,max))))
-	   (case (car l)
-	     ((&rest)
-	      (setq max #o776)
-	      (setq l nil))
-	     ((&optional)
-	      (setq optional t))
-	     ((&aux)
-	      (setq l nil))
-	     (t
-	      (if (and (symbolp (car l))
-		       (= #\& (getcharn (car l) 1)))
-		  (return
-		    (lambda-type
-		     (maxima-error (list "arglist has unknown &keword" (car l))
-				   arglist 'wrng-type-arg))))
-	      (or optional (setq min (f1+ min)))
-	      (setq max (f1+ max))))))))
+  (unless (member name transl-modules :test #'eq)
+    (maxima-error "Not a `transl-module', see TRANSM")))
 
 (def-def-property translate (form))
 
-#+cl
 (defmacro def%tr (name lambda-list &body body &aux definition)
   (setq definition
-	(cond ((and (null body) (symbolp lambda-list))
-	       `(def-same%tr ,name ,lambda-list))
-	      (t
-	       #+pdp10
-	       (enterq name (get (car module-stack) 'tr-props))
-	       `(defun-prop (,name translate) ,lambda-list ,@ body))))
-  `(eval-when (compile eval load)
-    #+lispm(record-source-file-name ',name 'def%tr)
+	(if (and (null body) (symbolp lambda-list))
+	    `(def-same%tr ,name ,lambda-list)
+	    `(defun-prop (,name translate) ,lambda-list ,@body)))
+  `(eval-when (:compile-toplevel :execute :load-toplevel)
     ,definition))
 
-
-#-cl
-(defmacro def%tr (name lambda-list &rest body)
-  (cond ((and (null body) (symbolp lambda-list))
-	 `(def-same%tr ,name ,lambda-list))
-	(t
-	 #+pdp10
-	 (enterq name (get (car module-stack) 'tr-props))
-	 `(def-translate-property ,name
-	   ,lambda-list ,@body))))
-
 (defmacro def-same%tr (name same-as)
   ;; right now MUST be used in the SAME file.
-  #+pdp10
-  (enterq name (get (car module-stack) 'tr-props))
   `(putprop ',name
     (or (get ',same-as 'translate)
-     (maxima-error '|No TRANSLATE property to alias.| ',same-as))
+     (maxima-error "No TRANSLATE property to alias. ~a" ',same-as))
     'translate))
 
 (defmacro def%tr-inherit (from &rest others)
-  #+pdp10
-  (mapc #'(lambda (name)
-	    (enterq name (get (car module-stack) 'tr-props)))
-	others)
   `(let ((tr-prop (or (get ',from 'translate)
-		      (maxima-error '|No TRANSLATE property to alias.| ',from))))
-    (mapc #'(lambda (name) (putprop name tr-prop 'translate))
-     ',others)))
-
-#+pdp10
-(defun put-lambda-type (name argl)
-  (let ((lambda-type (lambda-type argl)))
-    (putprop name t (car lambda-type))
-    (args name (cdr lambda-type))))
-
+		      (maxima-error "No TRANSLATE property to alias. ~a" ',from))))
+    (mapc #'(lambda (name) (putprop name tr-prop 'translate))',others)))
 
 (defmacro deftrfun (name argl &rest body)
-  #+pdp10
-  (progn (enterq name (get (car module-stack) 'functions))
-	 (put-lambda-type name argl))
   `(defun ,name ,argl ,@body))
 
 (defmacro deftrvar (name value &rest ignore-doc) ignore-doc
 	  ;; to be used to put the simple default value in
 	  ;; the autoload file. Should be generalized to include
 	  ;; BINDING methods.
-	  #+pdp10
-	  (progn (enterq name (get (car module-stack) 'variables))
-		 (putprop name (if (fboundp 'macro-expand)
-				   (macro-expand value)
-				   value)
-			  'value))
 	  `(defvar ,name ,value))
 
-;;#+PDP10
-;;(PROGN 'COMPILE
-
-;;(defun get! (a b) (or (get a b) (get! (maxima-error (list "undefined" b "property")
-;;					     a 'wrng-type-arg)
-;;				      b)))
-
-;;(defun print-defprop (symbol prop stream)
-;;       (print `(defprop ,symbol ,(get symbol prop) ,prop) stream))
-
-;;(defun save-module-info (module stream)
-;;  (putprop module `(,(status uname) ,(status dow) ,(status date))
-;;	   'last-compiled)
-;;  (print-defprop module 'last-compiled stream)
-;;  (print-defprop module 'functions stream)
-;;  (print-defprop module 'variables stream)
-;;  (print-defprop module 'tr-props stream)
-;;  (DO ((VARIABLES (get module 'VARIABLES) (CDR VARIABLES)))
-;;      ((NULL VARIABLES))
-;;    (print-defprop (car variables) 'value stream)
-;;    ;; *NB*
-;;    ;; this depends on knowing about the internal workings
-;;    ;; of the maclisp compiler!!!!
-;;    (print `(defprop ,(car variables)
-;;	      (special ,(car variables))
-;;	      special)
-;;	   stream)
-;;    )
-;;  (DO ((FUNCTIONS (GET MODULE 'FUNCTIONS) (CDR FUNCTIONS)))
-;;      ((NULL FUNCTIONS))
-;;    ;; *NB* depends on maclisp compiler.
-;;    (LET ((X (GETL (CAR FUNCTIONS) '(*LEXPR *EXPR))))
-;;      (IF X
-;;	  (PRINT-DEFPROP (CAR FUNCTIONS) (CAR X) STREAM)))
-;;    (LET ((X (ARGS (CAR FUNCTIONS))))
-;;      (IF X
-;;	  (PRINT `(ARGS ',(CAR FUNCTIONS) ',X) STREAM)))))
-
-;;(defun save-enable-module-info (module stream)
-;;  ;; this outputs stuff to be executed in the context
-;;  ;; of RUNTIME of the modules, using information gotten
-;;  ;; by the SAVE done by the above function.
-;;  (print `(defprop ,module ,(tr-fasl-file-name module) fasload) stream)
-;;  ;; FASLOAD property lets us share the TR-FASL-FILE-NAME
-;;  ;; amoung the various autoload properties.
-;;  (print `(map1-put-if-nil ',(get module 'functions)
-;;			   (get ',module 'fasload)
-;;			   'autoload)
-;;	 stream)
-;;  (print `(map1-put-if-nil ',(get module 'tr-props)
-;;			   (get ',module 'fasload)
-;;			   'autoload-translate)
-;;	 stream)
-;;  (print `(map1-put-if-nil ',(get module 'tr-props)
-;;			   (or (get 'autoload-translate 'subr)
-;;			       (maxima-error 'autoload-translate 'subr
-;;				      'fail-act))
-;;			   'translate)
-;;	 stream)
-;;  (do ((variables (get module 'variables) (cdr variables)))
-;;      ((null variables))
-;;    (print `(or (boundp ',(car variables))
-;;		(setq ,(car variables) ,(get (car variables) 'value)))
-;;	   stream)))
-
-;;(eval-when (compile eval)
-;;	   (or (get 'iota 'macro) (load '|liblsp;iota fasl|)))
-
-;;(DEFUN TRANSL-MODULE-DO-IT (&AUX (*print-base* 10.) (*NOPOINT NIL))
-;;       (let ((module (CAR MODULE-STACK)))
-;;	    (cond ((AND (GET module 'ttime-auto)
-;;			(macsyma-compilation-p))
-;;		   (iota ((f `((dsk ,(get! module 'dir))
-;;			       ,module _auto_) 'out))
-;;			 (and ttynotes (format tyo "~&;`module' : ~A~%" `module'))
-;;			 (save-module-info module f)
-;;			 (renamef f "* AUTOLO"))
-;;		   (INSTALL-TRANSL-AUTOLOADS)))))
-
-;;(defun load-module-info (module)
-;;       (IF (AND (GET MODULE 'TTIME-AUTO)
-;;		;; Assume we are the only MCL compiling
-;;		;; a transl module at this time.
-;;		(NOT (GET MODULE 'LAST-COMPILED)))
-;;	   (LET ((FILE `((dsk ,(get! module 'dir))
-;;			 ,module autolo)))
-;;		(COND ((PROBE-FILE FILE)
-;;		       (AND TTYNOTES
-;;			    (FORMAT TYO "~&;Loading ~A info~%"
-;;				    file))
-;;		       (LOAD FILE))
-;;		      (T
-;;		       (AND TTYNOTES
-;;			    (FORMAT TYO "~&; ~A NOT FOUND~%"
-;;				    file)))))))
-
-;;(defvar autoload-install-file "dsk:macsyma;transl autoload")
-
-;;(DEFUN UNAME-TIMEDATE (FORMAT-STREAM)
-;;       (LET (((YEAR MONTH DAY) (STATUS DATE))
-;;	     ((HOUR MINUTE SECOND) (STATUS DAYTIME)))
-;;	    (FORMAT FORMAT-STREAM
-;;		    "by ~A on ~A, ~
-;;	       ~[January~;February~;March~;April~;May~;June~;July~;August~
-;;	       ~;September~;October~;November~;December~] ~
-;;	       ~D, 19~D, at ~D:~2,'0D:~2,'0D"
-;;		    (status uname)
-;;		    (status dow)
-;;		    (f1- month) day year
-;;		    hour minute second)))
-
-;;(defun install-transl-autoloads ()
-;;       (MAPC #'LOAD-MODULE-INFO TRANSL-MODULES)
-;;       (iota ((f (mergef "* _TEMP"
-;;			 autoload-install-file)
-;;		 '(out ascii)))
-;;	     (PRINT `(progn
-;;		      (DEFPROP TRANSL-AUTOLOAD ,(Uname-timedate nil) VERSION)
-;;		      (OR (GET 'TRANSL-AUTOLOAD 'SUBR)
-;;			  (load '((dsk macsym)trhook fasl)))
-;;		      (setq transl-modules
-;;			    ',transl-modules))
-;;		    F)
-;;	     (DO ((MODULES TRANSL-MODULES (CDR MODULES)))
-;;		 ((NULL MODULES)
-;;		  (renamef f autoload-install-file))
-;;		 (and (get (car modules) 'ttime-auto)
-;;		      (save-enable-module-info (car modules) f)))))
-
-;;(defun tr-tagS ()
-;;  ;; trivial convenience utility.
-;;  (iota ((f `((dsk ,(get 'transl 'dir)) transl ntags) 'out))
-;;    (do ((l transl-modules (cdr l)))
-;;	((null l)
-;;	 (close f)
-;;	 (valret
-;;	  (symbolconc '|:TAGS | (NAMESTRING F) '|
-;; |)))
-;;      (or (get (car l) 'pseudo)
-;;	  (format f "DSK:~A;~A >~%,LISP~%~%"
-;;		  (get! (car l) 'dir) (car l))))))
-
-;;;; end of #+PDP10 I/O code.
-
-;;)
-
-;;; in PDP-10 maclisp OP is a subr-pointer.
-;;; system-dependance macro-fied away in PROCS.
-
 (defmacro tprop-call (op form)
   `(subr-call ,op ,form))
 
 (defmacro def-autoload-translate (&rest funs)
-  #+pdp10
-  `(let ((a-subr (or (get 'autoload-translate 'subr)
-		     (maxima-error 'lose 'autoload-translate 'fail-act))))
-    (mapc #'(lambda (u)
-	      (or (get u 'translate)
-		  (putprop u a-subr 'translate)))
-     ',funs))
-  #-pdp10
   `(comment *autoloading?* ,@funs))
 
 
 ;;; declarations for the TRANSL PACKAGE.
 
-(declare-top 
- (special *transl-sources*)
- ;; The warning an error subsystem.
- (special tr-abort		    ; set this T if you want to abort.
-	  *translation-msgs-files*) ; the stream to print messages to.
- (*lexpr warn-undedeclared
-	 tr-nargs-check
-	 warn-meval
-	 warn-mode
-	 warn-fexpr
-	 tell)
-  
- (*lexpr pump-stream			; file hacking
-	 )
-  
- ;; State variables.
-  
- (special pre-transl-forms* ; push onto this, gets output first into the
-					; transl file.
-	  *warned-un-declared-vars*
-	  *warned-fexprs* 
-	  *warned-mode-vars*
-	  *warned-undefined-vars*
-	  warned-undefined-variables
-	  tr-abort
-	  transl-file
-	  *in-compfile*
-	  *in-translate-file*
-	  *in-translate*
-	  *pre-transl-forms* 
-	  *new-autoload-entries*     ; new entries created by TRANSL. 
-	  *untranslated-functions-called*
-	  )
-  
- ;; General entry points.
-  
- (*expr translate
-	;; Takes a macsyma form, returns a form
-	;; such that the CAR is the MODE and the
-	;; CDR is the equivalent lisp form.
-	;; For the meaning of the second argument to TRANSLATE
-	;; see the code. When calling TRANSLATE from outside of
-	;; itself, the second arg is always left out.
-	tr-args		  ; mapcar of translate, strips off the modes.
-	dtranslate			; CDR TRANSLATE
-	call-and-simp		; (MODE F ARGL) generates `(,F ,@ARGL)
-	;; sticks on the mode and a SIMPLIFY if needed.
-	array-mode
-	function-mode
-	value-mode
-	tbind			      ; For META binding of variables.
-	tunbind				; unbind.
-	tunbinds			; a list.
-	tboundp			     ; is the variable lexicaly bound?
-	teval		 ; get the var replacement. Now this is always
-	;; the same as the var itself. BUT it could be use
-	;; to do internal-mode stuff.
-	 
-	push-pre-transl-form
-	 
-	)
- (*lexpr tr-local-exp
-	 ;; conses up a lambda, calls, translate, strips...
-	 tr-lambda
-	 ;; translate only a standard lambda expression
-	 )
-  
- (*expr free-lisp-vars
-	push-defvar
-	tr-trace-exit
-	tr-trace-entry
-	side-effect-free-check
-	tbound-free-vars)
-  
- (*expr translate-function tr-mfun dconvx)
-  
- ;; these special declarations are for before DEFMVAR
- (special $errexp $loadprint $numer $savedef $nolabels $functions $props 
-	  $filename $filenum $direc $device munbound $values $transrun
-	  st oldst  $version
-	  rephrase $packagefile
-	  dskfnp)
-  
- ;; end of COMPLR declarations section.
- )
+(declare-top (special *transl-sources*)
+	     ;; The warning and error subsystem.
+	     (special tr-abort	    ; set this T if you want to abort.
+		      *translation-msgs-files*)	; the stream to print messages to.
+	     ;; State variables.
+	     (special pre-transl-forms*	; push onto this, gets output first into the transl file.
+		      *warned-un-declared-vars*
+		      *warned-fexprs*
+		      *warned-mode-vars*
+		      *warned-undefined-vars*
+		      warned-undefined-variables
+		      tr-abort
+		      transl-file
+		      *in-compfile*
+		      *in-translate-file*
+		      *in-translate*
+		      *pre-transl-forms*
+		      *new-autoload-entries* ; new entries created by TRANSL.
+		      *untranslated-functions-called*)
+
+
+	     ;; these special declarations are for before DEFMVAR
+	     (special $errexp $loadprint $numer $savedef $nolabels $functions $props
+		      $filename $filenum $direc $device munbound $values $transrun
+		      st oldst  $version
+		      rephrase $packagefile
+		      dskfnp))
 
 (defmacro bind-transl-state (&rest forms)
   ;; this binds all transl state variables to NIL.
@@ -499,7 +166,7 @@
   ;; Called in 3 places, for compactness maybe this should be a PROGV
   ;; which references a list of variables?
   `(let (*warned-un-declared-vars*
-	 *warned-fexprs* 
+	 *warned-fexprs*
 	 *warned-mode-vars*
 	 *warned-undefined-vars*
 	 warned-undefined-variables
@@ -508,7 +175,7 @@
 	 *in-compfile*
 	 *in-translate-file*
 	 *in-translate*
-	 *pre-transl-forms* 
+	 *pre-transl-forms*
 	 *new-autoload-entries*
 	 ($tr_semicompile $tr_semicompile)
 	 (arrays nil)
@@ -522,90 +189,56 @@
 	 defined_variables)
     ,@forms))
 
-
-
-#-(or cl multics)
-(defmacro tr-format (string &rest argl)
-  `(mformat *translation-msgs-files*
-    ,string ,@argl))
-
-;;; Is MFORMAT really prepared in general to handle
-;;; the above form. Certainly not on Multics.
-#+(and multics (not cl))
-(defmacro tr-format (string &rest argl)
-  `(cond ((consp *translation-msgs-files*)
-	  (mapcar #'(lambda (file)
-		      (mformat file ,string ,@argl))
-	   *translation-msgs-files*))
-    (t (mformat *translation-msgs-files* ,string ,@argl))))
-
-#+cl
 (defun tr-format (sstring &rest argl &aux strs)
-  (cond ((consp *translation-msgs-files*)(setq strs *translation-msgs-files*))
-	(t (setq strs (list *translation-msgs-files*))))
+  (if (consp *translation-msgs-files*)
+      (setq strs *translation-msgs-files*)
+      (setq strs (list *translation-msgs-files*)))
   (loop for v in strs
-	 do (apply 'mformat v sstring argl)))
-
- 
-;;; for debugging convenience:
-;;(DEFMACRO TR (EXP) `(BIND-TRANSL-STATE (TRANSLATE ,EXP)))
+	do (apply #'mformat v sstring argl)))
 
 ;; to use in mixing maxima and lisp
 ;; (tr #$$f(x):=x+2$)
 (defmacro tr (u)
-  (and (consp u) (eq (car u) 'quote)
-       (bind-transl-state (translate-macexpr-toplevel  (second u)))))
-
+  (and (consp u)
+       (eq (car u) 'quote)
+       (bind-transl-state (translate-macexpr-toplevel (second u)))))
 
 ;;; These are used by MDEFUN and MFUNCTION-CALL.
 ;;; N.B. this has arguments evaluated twice because I am too lazy to
 ;;; use a LET around things.
 
 (defmacro push-info (name info stack)
-  `(let ((*info* (assq ,name ,stack)))
+  `(let ((*info* (assoc ,name ,stack :test #'eq)))
     (cond (*info* ;;; should check for compatibility of INFO here.
 	   )
 	  (t
 	   (push (cons ,name ,info) ,stack)))))
 
 (defmacro get-info (name stack)
-  `(cdr (assq ,name ,stack)))
+  `(cdr (assoc ,name ,stack :test #'eq)))
 
 (defmacro pop-info (name stack)
-  `(let ((*info* (assq ,name ,stack)))
+  `(let ((*info* (assoc ,name ,stack :test #'eq)))
     (cond (*info*
-	   (setq ,stack (zl-delete *info* ,stack))
+	   (setq ,stack (delete *info* ,stack :test #'equal))
 	   (cdr *info*))
 	  (t nil))))
 
 (defmacro top-ind (stack)
   `(cond ((null ,stack) nil)
-    (t
-     (caar ,stack))))
-
-
+    (t (caar ,stack))))
 
-#+cl
-(defmacro maset ( val ar  &rest inds)
+(defmacro maset (val ar &rest inds)
   `(progn
-     (cond ((symbolp ,ar)
-	    (setf ,ar (make-equal-hash-table
-		       ,(if (cdr inds) t nil)))))
-    (maset1 ,val  ,ar ,@  inds)))
-
-
-;;#+lispm  ;;removed the apply from tr-arraycall and &rest.
-;;(defun tr-maref (ar &rest inds)
-;;    `(nil maref ,ar ,@ (copy-list inds)))
-
-
+    (when (symbolp ,ar)
+      (setf ,ar (make-equal-hash-table ,(if (cdr inds) t nil))))
+    (maset1 ,val ,ar ,@inds)))
 
 (defmacro maref (ar &rest inds)
-  (cond ((or (eql ar 'mqapply)(and (consp ar) (memq 'mqapply ar)))
-         `(marrayref ,(first inds) ,@ (cdr inds)))
-	((consp ar)`(marrayref ,ar ,(first inds) ,@ (cdr inds)))
+  (cond ((or (eql ar 'mqapply)(and (consp ar) (member 'mqapply ar :test #'eq)))
+         `(marrayref ,(first inds) ,@(cdr inds)))
+	((consp ar)`(marrayref ,ar ,(first inds) ,@(cdr inds)))
 	(t
-	 `(maref1  ,ar,@ inds))))
-
-
+	 `(maref1 ,ar ,@inds))))
 
+ 	  	 

Index: nparse.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/nparse.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- nparse.lisp	6 Jan 2007 16:21:38 -0000	1.34
+++ nparse.lisp	27 Jan 2007 18:39:28 -0000	1.35
@@ -11,62 +11,48 @@
 (in-package :maxima)
 
 (macsyma-module nparse)
-(load-macsyma-macros defcal mopers)
-
-(proclaim '(optimize (safety 2) (speed 2) (space 2)))
 
-(defmacro imember (x l)
-  `(member ,x ,l))
+(load-macsyma-macros defcal mopers)
 
[...1175 lines suppressed...]
-	;; then record all cons's eg arglist )
-	;;(setq *at-newline*  (if (eql (peek-char nil str nil) #\() :all t))
-	 (values)))
+(defun newline (str ch) ch
+       (let ((in (get-instream str)))
+	 (setf (instream-line in) (the fixnum (+ 1 (instream-line in)))))
+       ;; if the next line begins with '(',
+       ;; then record all cons's eg arglist )
+       ;;(setq *at-newline*  (if (eql (peek-char nil str nil) #\() :all t))
+       (values))
 
 (defun find-stream (stream)
    (dolist (v *stream-alist*)
 	(cond ((eq stream (instream-stream v))
-	       (return v))))
-  )
+	       (return v)))))
 
 
 (defun add-lineinfo (lis)

Index: defcal.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/defcal.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- defcal.lisp	7 Nov 2005 17:37:11 -0000	1.4
+++ defcal.lisp	27 Jan 2007 18:39:28 -0000	1.5
@@ -9,60 +9,12 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (in-package :maxima)
+
 (macsyma-module defcal macro)
+
 ;; Compile-time support for defining things which dispatch
 ;; off the property list. The Macsyma parser uses this.
 
-(defun check-subr-argl (l)
-  (if (or (> (length l) 5.)
-	  (memq '&rest l)
-	  (memq '&optional l)
-	  (memq '&restv l)
-	  (memq '&quote l))
-      (maxima-error "Can't `def-propl-call' with non-subr arglist" l)))
-
-(defvar use-subrcall
-  #+cl nil
-  #+maclisp t
-  #+nil nil)
-
-(defmacro def-propl-call (name (op . l) default-action
-			  &aux
-			  (temp (gensym))
-			  (subr? (if use-subrcall
-				     (list (symbolconc name '-subr))
-				     ())))
-  (if subr? (check-subr-argl l))
-  `(progn 'compile
-    #+lispm   (si:record-source-file-name ',name 'def-propl-call)
-    (defmacro ,(symbolconc 'def- name '-equiv) (op equiv)
-      #+lispm  (declare (si:function-parent ,name 'def-propl-call))
-      `(putprop ',op #',equiv ',',name))
-    (defmacro ,(symbolconc name '-propl) ()
-      #+lispm  (declare (si:function-parent ,name 'def-propl-call))
-
-      ''(,name ,@subr?))
-    (defmacro ,(symbolconc 'def- name '-fun) (op-name op-l . body)
-      ;;	    #+lispm  (declare (si:function-parent ,name 'def-propl-call))
-      ;;	    `(DEFUN (,OP-NAME ,',NAME  ,@',SUBR?)
-      ;;		    ,OP-L . ,BODY))
-      `(defun-prop (,op-name ,',name  ,@',subr?)
-	,op-l
-	#+lispm  (declare (si:function-parent ,op-name 'def-nud-fun))
-	,@ body))
-    (defun ,(symbolconc name '-call) (,op . ,l)
-      #+lispm  (declare (si:function-parent ,name 'def-propl-call))
-      (let ((,temp (and (symbolp ,op)
-			(getl ,op '(,name ,@subr?)))))
-	(if (null ,temp)
-	    ,default-action
-	    ,(if subr?
-		 `(if (eq (car ,temp) ',(car subr?))
-		   (subrcall nil (cadr ,temp) ,op ,@l)
-		   (funcall (cadr ,temp) ,op ,@l))
-		 `(funcall (cadr ,temp) ,op ,@l)))))))
-
-
 (defun make-parser-fun-def (op p bvl body)
   ;; Used by the Parser at compile time.
   (if (not (consp op))
@@ -71,14 +23,12 @@
 	;; so compiler won't warn about
 	;; unused lambda variable.
 	. ,body)
-      `(progn 'compile
+      `(progn
 	,(make-parser-fun-def (car op) p bvl body)
 	,@(mapcar #'(lambda (x)
-		      `(inherit-propl ',x ',(car op)
-			(,(symbolconc p '-propl))))
+		      `(inherit-propl ',x ',(car op) (,(symbolconc p '-propl))))
 		  (cdr op)))))
 
-
 ;;; The tokenizer use the famous CSTR to represent the possible extended token
 ;;; symbols. The derivation of the name and implementation is obscure, but I've
 ;;; heard it has something to do with an early Fortran compiler written in Lisp.
@@ -88,72 +38,62 @@
 ;;;
 ;;;  <description> ::= (<descriptor> <descriptor> ...)
 ;;;  <descriptor>  ::= <name> ! (<name> <translation>)
-;;;  
+;;;
 ;;;  If no translation is supplied, $<name> is the default.
-;;;  
+;;;
 ;;;  Sets up a CSTR [Command STRucture] object which may be used
 ;;;  in conjunction with the CEQ predicate to determine if the
-;;;  LINBUF cursor is currently pointing at any keyword in that 
+;;;  LINBUF cursor is currently pointing at any keyword in that
 ;;;  structure.
-;;;  
+;;;
 ;;;  Note: Names containing shorter names as initial segments
 ;;;        must follow the shorter names in arg to CSTRSETUP.
 
 (defvar symbols-defined () "For safe keeping.")
 (defvar macsyma-operators ())
 
-(eval-when (eval compile load)
+(eval-when (:execute :compile-toplevel :load-toplevel)
   (defun *define-initial-symbols (l)
     (setq symbols-defined
 	  (sort (copy-list l) #'(lambda (x y) (< (flatc x) (flatc y)))))
-    (setq macsyma-operators (cstrsetup symbols-defined)))
-  )
-
+    (setq macsyma-operators (cstrsetup symbols-defined))))
 
 (defmacro define-initial-symbols (&rest l)
   (let ((symbols-defined ())
 	(macsyma-operators ()))
     (*define-initial-symbols l)
-    `(progn 'compile
+    `(progn
       (declare-top (special symbols-defined macsyma-operators))
       (setq symbols-defined (copy-list ',symbols-defined))
       (setq macsyma-operators (subst () () ',macsyma-operators)))))
 
 (defun undefine-symbol (op)
-  (*define-initial-symbols (delq (stripdollar op) symbols-defined)))
+  (*define-initial-symbols (delete (stripdollar op) symbols-defined :test #'eq)))
 
 (defun define-symbol (x)
   (setq x (stripdollar x))
   (*define-initial-symbols (cons x symbols-defined))
-					;(IMPLODE (CONS #/$ (EXPLODEN X)))
   (symbolconc '$ x))
 
 (defun cstrsetup (arg)
-  (do ((arg arg (cdr arg)) (tree nil))
+  (do ((arg arg (cdr arg))
+       (tree nil))
       ((null arg) (list* () '(ans ()) tree))
-    (cond ((atom (car arg))
-	   (setq tree 
-		 (add2cstr (car arg) 
-			   tree 
-					;(IMPLODE (CONS '$ (EXPLODEC (CAR ARG))))
-			   (symbolconc '$ (car arg))
-			   )))
-	  (t
-	   (setq tree 
-		 (add2cstr (caar arg) tree (cadar arg)))))))
-   
+    (if (atom (car arg))
+	(setq tree (add2cstr (car arg) tree (symbolconc '$ (car arg))))
+	(setq tree (add2cstr (caar arg) tree (cadar arg))))))
+
 ;;; (ADD2CSTR <name> <tree> <translation>)
-;;; 
-;;;  Adds the information <name> -> <translation> to a 
+;;;
+;;;  Adds the information <name> -> <translation> to a
 ;;;  CSTR-style <tree>.
 
-(defun add2cstr (x tree ans) 
-  (add2cstr1 (nconc (exploden x) (ncons (list 'ans ans)))
-	     tree))
-   
+(defun add2cstr (x tree ans)
+  (add2cstr1 (nconc (exploden x) (ncons (list 'ans ans))) tree))
+
 ;;; (ADD2CSTR1 <translation-info> <tree>)
 ;;;
-;;;  Helping function for ADD2CSTR. Puts information about a 
+;;;  Helping function for ADD2CSTR. Puts information about a
 ;;;  keyword into the <tree>
 
 (defun add2cstr1 (x tree)