Added files to support building and running Macsyma.

Resolves #284.

Commented out uses of time-origin in maxtul; mcldmp (init) until we
can figure out why it gives arithmetic overflows under the emulators.

Updated the expect script statements in build_macsyma_portion to not
attempt to match expected strings, but simply sleep for some time
since in some cases the matching appears not to work.

src/maxsrc/ar.17

@@ -0,0 +1,165 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;  (c) Copyright 1976, 1983 Massachusetts Institute of Technology      ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module ar)
+
+(DECLARE (SPECIAL EVARRP MUNBOUND FLOUNBOUND FIXUNBOUND))
+
+;;; This code needs to be checked carefully for the 3600.
+(defstruct (mgenarray conc-name array)
+  aref
+  aset
+  type
+  NULL
+  GENERATOR
+  CONTENT)
+
+(DEFUN MARRAY-TYPE (X)
+  (OR (CDR (ASSQ (ARRAY-TYPE X)
+		 '((FLONUM . $FLOAT)
+		   (FIXNUM . $FIXNUM))))
+      (MGENARRAY-TYPE X)))
+
+(DEFMFUN $MAKE_ARRAY (TYPE &REST DIML)
+  (LET ((LTYPE (ASSQ TYPE '(($FLOAT . FLONUM) ($FLONUM . FLONUM)
+					      ($FIXNUM . FIXNUM)))))
+    (COND ((NOT LTYPE)
+	   (COND ((EQ TYPE '$ANY)
+		  (MAKE-MGENARRAY TYPE '$ANY
+				  CONTENT (LEXPR-FUNCALL '*ARRAY NIL T DIML)))
+		 ((EQ TYPE '$HASHED)
+		  (LET ((KLUDGE (GENSYM)))
+		    (OR (FIXP (CAR DIML))
+			(MERROR "non-integer number of dimensions: ~M"
+				(CAR DIML)))
+		    (INSURE-ARRAY-PROPS KLUDGE () (CAR DIML))
+		    (MAKE-MGENARRAY TYPE '$HASHED
+				    CONTENT KLUDGE)))
+		 ((EQ TYPE '$FUNCTIONAL)
+		  ;; MAKE_ARRAY('FUNCTIONAL,LAMBDA(...),'ARRAY_TYPE,...)
+		  (OR (> (LENGTH DIML) 1)
+		      (MERROR "not enough arguments for functional array specification"))
+		  (LET ((AR (APPLY #'$MAKE_ARRAY (CDR DIML)))
+			(THE-NULL))
+		    (CASEQ (MARRAY-TYPE AR)
+		      (($FIXNUM)
+		       (FILLARRAY AR (LIST (SETQ THE-NULL FIXUNBOUND))))
+		      (($FLOAT)
+		       (FILLARRAY AR (LIST (SETQ THE-NULL FLOUNBOUND))))
+		      (($ANY)
+		       (FILLARRAY (MGENARRAY-CONTENT AR) (LIST (SETQ THE-NULL MUNBOUND))))
+		      (T
+		       ;; Nothing to do for hashed arrays. Is FUNCTIONAL here
+		       ;; an error?
+		       (SETQ THE-NULL 'NOTEXIST)))
+		    (MAKE-MGENARRAY TYPE '$FUNCTIONAL
+				    CONTENT AR
+				    GENERATOR (CAR DIML)
+				    NULL THE-NULL)))
+		 ('ELSE
+		  (MERROR "Array type of ~M is not recognized by MAKE_ARRAY" TYPE))))
+	  ('ELSE
+	   (LEXPR-FUNCALL '*ARRAY NIL (CDR LTYPE) DIML)))))
+
+(DEFMFUN DIMENSION-ARRAY-OBJECT (FORM RESULT &AUX (MTYPE (MARRAY-TYPE FORM)))
+  (DIMENSION-STRING
+   (NCONC (EXPLODEN "{Array: ")
+	  (CDR (EXPLODEN MTYPE))
+	  (EXPLODEN " ")
+	  (EXPLODEN (MAKNUM FORM))
+	  (IF (MEMQ MTYPE '($FLOAT $FIXNUM $ANY))
+	      (NCONC (EXPLODEN "[")
+		     (DO ((L (CDR (ARRAYDIMS (IF (MEMQ MTYPE '($FLOAT $FIXNUM))
+						 FORM
+						 (MGENARRAY-CONTENT FORM))))
+			     (CDR L))
+			  (V NIL
+			     (NCONC (NREVERSE (EXPLODEN (CAR L))) V)))
+			 ((NULL L) (NREVERSE V))
+		       (IF V (PUSH #/, V)))
+		     (EXPLODEN "]")))
+	  (EXPLODEN "}"))
+   RESULT))
+
+(DEFUN MARRAY-CHECK (A)
+  (IF (EQ (TYPEP A) 'ARRAY)
+      (CASEQ (MARRAY-TYPE A)
+	(($FIXNUM $FLOAT) A)
+	(($ANY) (MGENARRAY-CONTENT A))
+	(($HASHED $FUNCTIONAL)
+	 ;; BUG: It does have a number of dimensions! Gosh. -GJC
+	 (MERROR "Hashed array has no dimension info: ~M" A))
+	(T
+	 (MARRAY-TYPE-UNKNOWN A)))
+      (MERROR "Not an array: ~M" A)))
+
+(DEFMFUN $ARRAY_NUMBER_OF_DIMENSIONS (A)
+  (ARRAY-/#-DIMS (MARRAY-CHECK A)))
+
+(DEFMFUN $ARRAY_DIMENSION_N (N A)
+  (ARRAY-DIMENSION-N N (MARRAY-CHECK A)))
+
+(DEFUN MARRAY-TYPE-UNKNOWN (X)
+  (MERROR "BUG: Array of unhandled type: ~S" X))
+
+(DEFUN MARRAYREF-GENSUB (ARRAY IND1 INDS)
+  (CASEQ (MARRAY-TYPE ARRAY)
+    ;; We are using a CASEQ on the TYPE instead of a FUNCALL, (or SUBRCALL)
+    ;; because we are losers. All this stuff uses too many functions from
+    ;; the "MLISP" modual, which are not really suitable for the kind of
+    ;; speed and simplicity we want anyway. Ah me. Also, passing the single
+    ;; unconsed index IND1 around is a dubious optimization, which causes
+    ;; extra consing in the case of hashed arrays.
+    (($HASHED)
+     (LEXPR-FUNCALL #'MARRAYREF (MGENARRAY-CONTENT ARRAY) IND1 INDS))
+    (($FLOAT $FIXNUM)
+     (LEXPR-FUNCALL ARRAY IND1 INDS))
+    (($ANY)
+     (LEXPR-FUNCALL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
+    (($FUNCTIONAL)
+     (LET ((VALUE (LET ((EVARRP T))
+		    ;; special variable changes behavior of hashed-array
+		    ;; referencing functions in case of not finding an element.
+		    (*CATCH 'EVARRP (MARRAYREF-GENSUB
+				      (MGENARRAY-CONTENT ARRAY) IND1 INDS)))))
+       (IF (EQUAL VALUE (MGENARRAY-NULL ARRAY))
+	   (MARRAYSET-GENSUB  (LEXPR-FUNCALL #'MFUNCALL
+					     (MGENARRAY-GENERATOR ARRAY)
+					     ;; the first argument we pass the
+					     ;; function is a SELF variable.
+					     ARRAY
+					     ;; extra consing here! LEXPR madness.
+					     IND1
+					     INDS)
+			      (MGENARRAY-CONTENT ARRAY) IND1 INDS)
+	   VALUE)))
+    (T
+     (MARRAY-TYPE-UNKNOWN ARRAY))))
+	  
+
+(DEFUN MARRAYSET-GENSUB (VAL ARRAY IND1 INDS)
+  (CASEQ (MARRAY-TYPE ARRAY)
+    (($HASHED)
+     (LEXPR-FUNCALL #'MARRAYSET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
+    (($ANY)
+     #-3600(STORE (LEXPR-FUNCALL (MGENARRAY-CONTENT ARRAY) IND1 INDS) VAL)
+     #+3600(LEXPR-FUNCALL #'ASET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
+    (($FLOAT $FIXNUM)
+     #-3600(STORE (LEXPR-FUNCALL ARRAY IND1 INDS) VAL)
+     #+3600(LEXPR-FUNCALL #'ASET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
+    (($FUNCTIONAL)
+     (MARRAYSET-GENSUB VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
+    (T
+     (MARRAY-TYPE-UNKNOWN ARRAY))))
+
+
+;; Extensions to MEVAL.
+
+(DEFMFUN MEVAL1-EXTEND (FORM)
+  (LET ((L (MEVALARGS (CDR FORM))))
+    (MARRAYREF-GENSUB (CAAR FORM) (CAR L) (CDR L))))
+
+(DEFMFUN ARRSTORE-EXTEND (A L R)
+  (MARRAYSET-GENSUB R A (CAR L) (CDR L)))
+

src/maxsrc/ards.11

@@ -0,0 +1,145 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module ards)
+
+;; Package for drawing lines on terminals supporting the Advanced Remote
+;; Display Station (ARDS) protocol.  See .INFO.;ARDS > for a description of
+;; this crock.  The screen is addressed as -512. <= X, Y <= 511.  Note that
+;; drawing from (-511, 0) to (512, 0) on plasma consoles will work for some
+;; random reason.  Keep ibase set at 8 since Macsyma has it at 10.
+
+(EVAL-WHEN (EVAL COMPILE) (SETQ OLD-IBASE IBASE IBASE 8))
+
+;; Read-time parameters.  These aren't real TD codes.
+
+#.(SETQ %TDCHR #+ITS 234 #-ITS 34)
+#.(SETQ %TDSET #+ITS 235 #-ITS 35)
+#.(SETQ %TDLNG #+ITS 236 #-ITS 36)
+#.(SETQ %TDSHR #+ITS 237 #-ITS 37)
+
+;; The ARDS-X and ARDS-Y variables are only valid when inside one of the
+;; graphics modes.  When entering a graphics mode, we always move the cursor to
+;; where we want it without looking to see where it is already.  This may want
+;; to be fixed later.
+
+(DEFVAR ARDS-X)
+(DEFVAR ARDS-Y)
+(DEFVAR ARDS-STATE #.%TDCHR)
+
+;; I can think of few things less optimal.
+
+(DEFUN ARDS-SEND-X-Y (S X Y INVISIBLE DOTTED 4-CHARS &AUX (SIGN-X 0) (SIGN-Y 0))
+       (DECLARE (FIXNUM X Y SIGN-X SIGN-Y))
+       (SETQ SIGN-X (IF (< X 0) 1 0))
+       (SETQ SIGN-Y (IF (< Y 0) 1 0))
+       (SETQ X (ABS X) Y (ABS Y))
+       (+TYO (+ (LSH (LOGAND X 37) 1) SIGN-X 100) S)
+       (IF 4-CHARS
+	   (+TYO (+ (LOGAND (LSH X -5) 37) 100 (IF INVISIBLE 40 0)) S))
+       (+TYO (+ (LSH (LOGAND Y 37) 1) SIGN-Y 100) S)
+       (IF 4-CHARS
+	   (+TYO (+ (LOGAND (LSH Y -5) 37) 100 (IF DOTTED 40 0)) S)))
+
+(DEFUN ARDS-SET-POINT (S X Y)
+       (DECLARE (FIXNUM X Y))
+       (COND ((AND (NOT (= ARDS-STATE #.%TDCHR))
+		   (= ARDS-X X)
+		   (= ARDS-Y Y)))
+	     (T (UNLESS (= ARDS-STATE #.%TDSET)
+			(+TYO #.%TDSET S)
+			(SETQ ARDS-STATE #.%TDSET))
+		(SETQ ARDS-X X ARDS-Y Y)
+		(ARDS-SEND-X-Y S X Y NIL NIL T))))
+
+;; Updates global state and figures out if we can draw a short vector.  Even if
+;; in long vector mode already, it still wins to go into short vector mode.  If
+;; only one short vector is drawn, we break even.
+
+(DEFUN ARDS-DRAW-VECTOR (S X Y INVISIBLE DOTTED)
+       (DECLARE (FIXNUM X Y))
+       (PSETQ X (- X ARDS-X) ARDS-X X)
+       (PSETQ Y (- Y ARDS-Y) ARDS-Y Y)
+       (IF (AND (< (ABS X) 40) (< (ABS Y) 40) (NOT INVISIBLE) (NOT DOTTED))
+	   (ARDS-DRAW-SHORT-VECTOR S X Y)
+	   (ARDS-DRAW-LONG-VECTOR S X Y INVISIBLE DOTTED)))
+
+(DEFUN ARDS-DRAW-SHORT-VECTOR (S X Y)
+       (DECLARE (FIXNUM X Y))
+       (UNLESS (= ARDS-STATE #.%TDSHR)
+	       (+TYO #.%TDSHR S)
+	       (SETQ ARDS-STATE #.%TDSHR))
+       (ARDS-SEND-X-Y S X Y NIL NIL NIL))
+
+(DEFUN ARDS-DRAW-LONG-VECTOR (S X Y INVISIBLE DOTTED)
+       (DECLARE (FIXNUM X Y))
+       (UNLESS (= ARDS-STATE #.%TDLNG)
+	       (+TYO #.%TDLNG S)
+	       (SETQ ARDS-STATE #.%TDLNG))
+       (ARDS-SEND-X-Y S X Y INVISIBLE DOTTED T))
+
+(DEFUN ARDS-EXIT-GRAPHICS (S)
+       (UNLESS (= ARDS-STATE #.%TDCHR)
+	       (+TYO #.%TDCHR S)
+	       (SETQ ARDS-STATE #.%TDCHR)))
+
+;; For convenience.  If you are drawing a lot of lines, you
+;; should call the procedures defined above.
+
+#+DEBUG
+(DEFUN ARDS-DRAW-POINT (S X Y)
+       (ARDS-SET-POINT S X Y)
+       (ARDS-DRAW-VECTOR S X Y NIL NIL)
+       (ARDS-EXIT-GRAPHICS S))
+
+(DEFUN ARDS-DRAW-LINE (S X1 Y1 X2 Y2)
+       (ARDS-SET-POINT S X1 Y1)
+       (ARDS-DRAW-VECTOR S X2 Y2 NIL NIL)
+       (ARDS-EXIT-GRAPHICS S))
+
+
+;; This file gets loaded when Macsyma is started up and it is determined
+;; that an ARDS console is being used.  Communication with Macsyma
+;; is through the functions and specials defined after this point.
+;; Everything above this point is independent of Macsyma.
+
+(DECLARE (SPECIAL DISPLAY-FILE))
+
+;; These define the size of the character cell in pixels.
+
+(SETQ LG-CHARACTER-X    6.)
+(SETQ LG-CHARACTER-Y   10.)
+(SETQ LG-CHARACTER-X-2 (// LG-CHARACTER-X 2))
+(SETQ LG-CHARACTER-Y-2 (// LG-CHARACTER-Y 2))
+
+;; Coordinate translation from 0 <= X, Y <= 511 to -512 <= X, Y <= 511.  Also,
+;; exchange directtion of Y coordinates.  Normally, both constants below would
+;; be 512., but there is a one pixel border around the edge of the Plasma TVs.
+
+(DEFMACRO LG-TRANSL-X (X) `(- (LSH ,X 1) 510.))
+(DEFMACRO LG-TRANSL-Y (Y) `(- 510. (LSH ,Y 1)))
+
+(DEFUN LG-DRAW-LINE (X1 Y1 X2 Y2)
+       (DECLARE (FIXNUM X1 Y1 X2 Y2))
+       (LG-SET-POINT X1 Y1)
+       (LG-END-VECTOR X2 Y2))
+
+(DEFUN LG-SET-POINT (X Y)
+       (ARDS-SET-POINT DISPLAY-FILE (LG-TRANSL-X X) (LG-TRANSL-Y Y)))
+
+(DEFUN LG-DRAW-VECTOR (X Y)
+       (ARDS-DRAW-VECTOR DISPLAY-FILE
+			 (LG-TRANSL-X X) (LG-TRANSL-Y Y) NIL NIL))
+
+(DEFUN LG-END-VECTOR (X Y)
+       (LG-DRAW-VECTOR X Y)
+       (ARDS-EXIT-GRAPHICS DISPLAY-FILE))
+
+(EVAL-WHEN (EVAL COMPILE) (SETQ IBASE OLD-IBASE))
+
+;; This should really be set in ALJABR;LOADER and not here, but we're not
+;; always able to recognize the terminal type.  So we want things to turn on
+;; when the file is loaded by hand.
+
+(SETQ LINE-GRAPHICS-TTY T)

src/maxsrc/char.2

@@ -0,0 +1,33 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module char)
+
+
+;;; hacks for character manipulation.
+
+
+(DEFMFUN $GETCHARN (SYMBOL INDEX)
+	 (OR (SYMBOLP SYMBOL)
+	     (MERROR "First arg to GETCHARN: ~A, was not a symbol."
+		     (implode (mstring symbol))))
+	 (OR (AND (FIXP INDEX)
+		  (> INDEX 0))
+	     (MERROR "Second arg to GETCHARN: ~A, was not a positive fixnum."
+		     (implode (mstring index))))
+	 ; what happens next is debateable.
+	 ; one thing I don't want to do call mstring and take nthcdr.
+	 ; what to returns depends on what you would see printed.
+	 ; well, or read in.
+	 ; the main use for this is to check symbol name conventions,
+	 ; so $FOO and &FOO might be the same, same with %FOO I guess,
+	 ; but FOO (i.e. ?FOO is different.) poo, all these things
+	 ; depend on the setting of global switches. screw it.
+	 (LET ((C1 (GETCHARN SYMBOL 1)))
+	      (COND ((OR (= C1 #/$) (= C1 #/%) (= C1 #/&))
+		     (GETCHARN SYMBOL (1+ INDEX)))
+		    ((= INDEX 1) #/?)
+		    (T (GETCHARN SYMBOL (1- INDEX))))))
+
+

src/maxsrc/descri.58

@@ -0,0 +1,226 @@
+;;; -*- Mode:LISP; Package:MACSYMA -*-
+
+;	** (c) Copyright 1981 Massachusetts Institute of Technology **
+
+(macsyma-module descri)
+
+(DECLARE (SPLITFILE DESCR))
+
+;;; Updated for New-I/O by KMP, 5:31pm  Tuesday, 8 August 1978
+;;; Updated for FILEPOSing by RLB, 20 December 1978
+;;; Updated for Multics by putting the index to the doc on the plist of the
+;;; symbol being doc'ed by JIM 25 Oct. 1980.
+
+;;; This version will allow  (control-Q) to quote an & in the
+;;; doc file.  It first reads MANUAL;MACSYM BINDEX (prepared by doing
+;;; :L MANUAL;MANDEX) to find out where in 
+;;; MANUAL;MACSYM DOC to look.  It then reads the latter file
+;;; for the entries found in the index.  The entry is printed by TYI'ing
+;;; chars to the next (non-quoted) "&" in the file. Elements which are
+;;; not Macsyma keywords will not be searched for. Any elements which are 
+;;; not found will be noted explicitly.
+;;; The format of the index file is found in comments in RLB;MANDEX .
+
+;;; This version runs most of the old $DESCRIBE (here named ODESCRIBE)
+;;; as a fallback if the index info is out of date.
+
+(DEFMFUN $DESCRIBE FEXPR (NODES)
+  (DO ((N NODES (CDR N)) (L) (X))
+      ((NULL N) (SETQ NODES (NREVERSE L)))
+      (SETQ X (CAR N))
+      (COND ((SYMBOLP X) (PUSH (prepare-a-node x) L))
+	    (T (MTELL "~&Non-atomic arg being ignored: ~M" X)
+	       )))
+  (COND ((NULL NODES) (SETQ NODES (NCONS 'DESCRIBE))))
+  (CURSORPOS 'A)
+  (LET ((L (LOCATE-INDEX-INFO NODES #+ITS'((DSK MAXOUT) MACSYM BINDEX)
+			            #-ITS ()))
+	(F))
+       (SETQ F (CAR L) L (CDR L))
+       (COND ((NULL F) 
+	      (PRINC
+	       "Description index is out of date, this may take a lot longer.")
+	      (ODESCRIBE NODES))
+	     ('T (DO ((L L (CDR L))) ((NULL L) (CLOSE F))
+		     (COND ((ATOM (CAR L))
+			    (PRINC "No info for ")
+			    (PRINC (fullstrip1 (CAR L))) (TERPRI))
+			   ((DO POS (CAR L) (CDR POS) (NULL POS)
+				(TERPRI)
+				(FILEPOS F (CAR POS))
+				(DO C (TYI F -1) (TYI F -1) ()
+				    (CASEQ C
+					   (#/ (TYO (TYI F)))
+					   ((#/& -1) (RETURN 'T))
+					   (#o14 () )	;^L
+					   (T (TYO C)))))))))))
+  '$DONE)
+
+#-Multics
+(DEFUN UPCASE-FULLSTRIP1 (X)
+  (IMPLODE
+   (MAP #'(LAMBDA (CHS)
+	    (COND ((< (CAR CHS) #/a))
+		  ((> (CAR CHS) #/z))
+		  (T (RPLACA CHS (- (CAR CHS)
+				    #.(- #/a #/A))))))
+	(EXPLODEN (FULLSTRIP1 X)))))
+
+#-Multics
+(DEFUN LH-BITS MACRO (FORM) `(BOOLE 1 #o777777 (LSH ,(CADR FORM) -18.)))
+#-Multics
+(DEFUN RH-BITS MACRO (FORM) `(BOOLE 1 #o777777 ,(CADR FORM)))
+
+#-Multics
+(defun prepare-a-node (x)
+  (COND ((= (GETCHARN X 1) #/&) (UPCASE-FULLSTRIP1 X))
+        (T (FULLSTRIP1 X))))
+
+#+Multics 
+(defun prepare-a-node (x)
+  (setq x (downcase-it (fullstrip1 x)));For strings and to get the alias's.
+  (implode (cons #/$ (explode x))))
+
+#+Multics
+(defun downcase-it (x)
+  (IMPLODE
+   (MAP #'(LAMBDA (CHS)
+	    (COND ((< (CAR CHS) #/A))
+		  ((> (CAR CHS) #/Z))
+		  (T (RPLACA CHS (+ (CAR CHS)
+				    #.(- #/a #/A))))))
+	     (EXPLODEN X))))
+
+;;;Return
+;;; (open-file-obj-or-NIL . (list of (list of starting pos's) or losing-atom))
+#+Multics
+(defun locate-index-info (nodes f)
+  f ;IGNORED
+  (cond ((not (get '$describe 'user-doc))
+	 (mtell "Loading DESCRIBE data-base, please be patient.~%")
+	 (load-documentation-file manual-index)))
+  (setq nodes (sort (append nodes ()) 'alphalessp))
+  (do ((l nodes (cdr l))
+       (locations ()))
+      ((null l) (return (cons (open (find-documentation-file manual)
+				    '(in ascii)) 
+			      locations)))
+    (let ((item-location (and (symbolp (car l))
+			      (get (car l) 'user-doc))))
+      (push (if (not (null item-location)) 
+	      (ncons item-location) 
+	      (car l))
+	    locations))))
+
+#-Multics
+(DEFUN LOCATE-INDEX-INFO (NODES F)
+  (SETQ NODES (SORT (APPEND NODES ()) 'ALPHALESSP) F (OPEN F '(IN FIXNUM)))
+  (LET ((FILE (DO ((I (IN F) (1- I)) (L))	;Grab file name
+		  ((< I 1) (PNPUT (NREVERSE L) 7))
+		(PUSH (IN F) L)))
+	(CDATE (IN F)) (FPINDEX (FILEPOS F)))
+    (DO ((L NODES (CDR L)) (PN) (1STCH 0) (NENT 0) (RET))
+	((NULL L))
+      ;(DECLARE (FIXNUM NENT 1STCH))
+      (SETQ 1STCH (GETCHARN (CAR L) 1) PN (PNGET (CAR L) 7))
+      (FILEPOS F (+ FPINDEX 1STCH))	;Pos to index-to-the-index
+      (SETQ NENT (IN F))
+      (COND ((NOT (= 0 NENT))
+	     (FILEPOS F (RH-BITS NENT))	;Pos to the entries
+	     (SETQ NENT (LH-BITS NENT))
+	     (DO I 1 (1+ I) (> I NENT)	;Check all entries
+		 (LET ((LPNAME (IN F)) (NSTARTS 0) (FOUND 'T))
+		   (SETQ NSTARTS (RH-BITS LPNAME)
+			 LPNAME (LH-BITS LPNAME))
+		   ;;Read in LPNAME file entry pname words,
+		   ;;comparing word-by-word with pname list of the
+		   ;;symbol.  Assume they all match (FOUND=T) unless
+		   ;;(a) a mismatch is found
+		   ;;(b) pname list of symbol ran out before LPNAME
+		   ;;    words were read from the file
+		   ;;(c) any pname list words left when all words
+		   ;;    read from the file
+		   (DO ((I 1 (1+ I)) (PN PN (CDR PN)))
+		       ((> I LPNAME)		;Read pname of entry
+			(AND PN (SETQ FOUND ())))
+		     (COND ((NULL PN) (SETQ FOUND ()) (IN F))
+			   ((NOT (= (CAR PN) (IN F)))
+			    (SETQ FOUND ()))))
+		   ;;If we found the one, read in all the starts and
+		   ;;return a list of them.  If we didn't find it, we
+		   ;;need too read in all the starts anyway (dumb
+		   ;;filepos) but remember that simple DO returns nil.
+		   (COND (FOUND (DO ((I 1 (1+ I)) (L))
+				    ((> I NSTARTS)
+				     (SETQ RET (NREVERSE L)))
+				  (PUSH (IN F) L)))
+			 ((SETQ RET (DO I 1 (1+ I) (> I NSTARTS)
+					(IN F))))))
+		 (COND (RET (RPLACA L RET) (RETURN 'T)))))))
+    (CLOSE F)
+    (SETQ F (OPEN FILE '(IN ASCII)))
+    (COND ((NOT (= CDATE (CAR (SYSCALL 1 'RFDATE F))))
+	   (CLOSE F) (SETQ F ())))
+    (CONS F NODES)))
+
+(DEFMFUN MDESCRIBE (X) (APPLY '$DESCRIBE (NCONS X)))
+
+;;;ODESCRIBE is mostly like the old $DESCRIBE, except the arg checking
+;;; has already been done, and it is a SUBR.
+
+(DEFUN ODESCRIBE (NODES)
+  (TERPRI)
+  (COND ((NOT NODES) (ERROR "Nothing to describe!")))
+  (CURSORPOS 'A)
+  (PRINC "Checking...")
+  (TERPRI)
+  (PROG (STREAM EOF)
+   (SETQ STREAM (OPEN '((DSK MAXOUT) MACSYM DOC) '(IN ASCII)))
+   (SETQ EOF (GENSYM))
+   (*CATCH 'END-OF-FILE
+	   (DO ((FORM (READ STREAM EOF) (READ STREAM EOF)))
+	       ((OR (NULL NODES) (EQ FORM EOF)))
+	     (COND ((MEMQ FORM NODES)
+		    (SETQ NODES (DELETE FORM NODES))
+		    (CURSORPOS 'A)
+		    (PRINC FORM)
+		    (DO ((C (TYI STREAM -1.) (TYI STREAM -1.)))
+			((= C 38.))             ; "&"  = End of entry
+			(COND ((= C -1.)	     ; -1   = EOF
+			       (*THROW 'END-OF-FILE T))
+			      ((= C 17.)	     ; "" = Quote
+			       (SETQ C (TYI STREAM))
+			       (TYO C))
+			      ((NOT (MEMBER C '(3. 12.)))
+			       (TYO C)))))
+		   (T (DO ((C (TYI STREAM -1.) (TYI STREAM -1.)))
+			  ((= C 38.))
+			(COND ((= C -1.)
+			       (*THROW 'END-OF-FILE T))
+			      ((= C 17.)
+			       (SETQ C (TYI STREAM)))))))))
+    (CLOSE STREAM))
+  (COND (NODES 
+	       (MTELL "Information missing: ~%~M"
+		      (CONS '(MLIST) NODES))
+	       ))
+       '$DONE)
+
+(DEFMFUN $HELP FEXPR (X) X (MDESCRIBE '$HELP))
+
+(DECLARE (SPLITFILE EXAMPL))
+
+;In essence,  example(func):=DEMO([manual,demo,dsk,demo],OFF,func,OFF);
+
+(DEFUN $example FEXPR (func)
+ (FEXPRCHK func '$example)
+ (NONSYMCHK (SETQ func (CAR func)) '$example)
+ (let (($change_filedefaults ()))
+   (batch1 `(#-Multics((MLIST) manual demo dsk demo)
+             #+Multics((mlist) ,(string-to-mstring 
+				 (string-append macsyma-dir
+						">demo>manual.demo")))
+	     NIL ,func NIL) 
+	   t nil nil))
+ '$done)
+

src/maxsrc/dover.3

@@ -0,0 +1,62 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module dover)
+
+;;; to make it easy to queue plot files to the DOVER.
+
+(DEFMVAR $DOVARD_VIEWPORT '((MLIST) 1 7 1 7)
+  "[XMIN,XMAX,YMIN,YMAX] in inches on the paper")
+
+(DEFUN ($DOVARD_VIEWPORT ASSIGN) (IGNORE VALUE)
+  (IF ($LISTP VALUE)
+      (DO ((L (CDR VALUE) (CDR L))
+	   (J 0 (1+ J)))
+	  ((= J 4)
+	   (OR (NULL L) (MERROR "DOVARD_VIEWPORT list too long")))
+	(AND (NULL L) (MERROR "DOVARD_VIEWPORT list too short"))
+	(OR (NUMBERP (CAR L))
+	    (MERROR "DOVARD_VIEWPORT list element non-numeric: ~M" (CAR L))))
+      (MERROR "DOVARD_VIEWPORT must be a list")))
+
+(defmfun $dovard_file (&optional (filename "dsk:.temp.;* .plot.") (output "* PRESS"))
+  (setq filename ($filename_merge filename (status uname)))
+  (IF (NOT (PROBEF FILENAME))
+      (MERROR "File for input ~M does not exist" FILENAME))
+  (setq output ($filename_merge output filename))
+  (let ((dovard-command-filename (TO-MACSYMA-NAMESTRING (mergef "* DOVARD" filename)))
+	(dovard-output-filename OUTPUT)
+	(STREAM))
+    (UNWIND-PROTECT
+     (PROGN (SETQ STREAM (OPEN (MERGEF "* _DOVARD" DOVARD-COMMAND-FILENAME) 'OUT))
+	    (MFORMAT STREAM
+		     "DSK:MACSYM;.PLOT PRESS~%~A~%~A~%1~%~S,~S,~S,~S~%~%"
+		     DOVARD-OUTPUT-FILENAME
+		     FILENAME
+		     (NTH 1 $DOVARD_VIEWPORT)
+		     (NTH 2 $DOVARD_VIEWPORT)
+		     (NTH 3 $DOVARD_VIEWPORT)
+		     (NTH 4 $DOVARD_VIEWPORT)
+		     )
+	    (RENAMEF STREAM DOVARD-COMMAND-FILENAME))
+     (IF STREAM (CLOSE STREAM)))
+    (MTELL "~%Calling DOVARD program, reply Y to its question.~%")
+    (IF (PROBEF DOVARD-OUTPUT-FILENAME) (DELETEF DOVARD-OUTPUT-FILENAME))
+    (CALL-JOB "DOVARD" (CONCAT "@" DOVARD-COMMAND-FILENAME))
+    (IF (NOT (PROBEF DOVARD-OUTPUT-FILENAME))
+	(MERROR "Output file ~M not created" DOVARD-OUTPUT-FILENAME)
+	`((MLIST) ,FILENAME ,DOVARD-OUTPUT-FILENAME))))
+
+(DEFMFUN $DOVER_FILE (&OPTIONAL (FILENAME ""))
+  (SETQ FILENAME ($FILENAME_MERGE FILENAME "DSK:.TEMP.;* PRESS" (STATUS UNAME)))
+  (IF (NOT (PROBEF FILENAME))
+      (MERROR "File for input ~M does not exist" FILENAME))
+  (CALL-JOB "DOVER" FILENAME)
+  FILENAME)
+
+(DEFUN CALL-JOB (JOB JCL)
+  (VALRET (CONCAT ": At DDT LEVEL:"
+		  JOB " " JCL
+		  "î:JOB " (STATUS JNAME)
+		  "î:CONTINUE ")))

src/maxsrc/ermsgm.12

@@ -0,0 +1,61 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module ermsgm)
+
+;;; Functions for MACSYMA error messages, run-time stuff.
+;;; Note: This file must be loaded before any files which use error messages.
+;;; -GJC 11:24pm  Saturday, 25 October 1980
+
+;; **NOTE** The definition for STRING-FILE-NAME *MUST* come before any and
+;; all use of out-of-core strings *including* DEFVAR's.
+
+(defun string-file-name (name)
+  name ;ignore
+  ())
+
+; Make sure the LOADER's version will be used.  It is an EXPR version that
+; will latter be flushed.
+
+(eval-when (load)
+  (if (get 'STRING-FILE-NAME 'EXPR)
+      (putprop 'STRING-FILE-NAME (get 'STRING-FILE-NAME 'EXPR) 'EXPR)))
+
+(defvar string-files nil)
+(defvar incore-files nil
+	"set up ONLY during the LOADING of a macsyma for
+	the SUSPEND operation. Then it is an ALIST of (file . offset)")
+(defvar incore-message-file nil
+	"Set up ONLY during the LOADING of a macsyma for
+	the SUSPEND operation.  Then it is the filename of
+	the common message file for all incore files.")
+
+(defvar string-filearray 
+	; name a file I know will be open, so that I can
+	; get a file object. Ah, the NUL device.
+	(open '((NUL)) '(in fixnum dsk block)))
+(close string-filearray)
+
+
+(DEFMFUN ALLOCATE-MESSAGE-INDEX (FILE ERROR-MESSAGE-INDEX)
+  (LET ((TEMP (ASSOC FILE INCORE-FILES)))
+	(IF TEMP
+	    (SETQ FILE INCORE-MESSAGE-FILE
+		  ERROR-MESSAGE-INDEX (+ ERROR-MESSAGE-INDEX (CDR TEMP)))))
+  (CONS (CAR (OR (MEMBER FILE STRING-FILES)  ; For cons-sharing, intern
+		 (PUSH FILE STRING-FILES)))  ; the FILE name list.
+	ERROR-MESSAGE-INDEX))
+
+(DEFMFUN CHECK-OUT-OF-CORE-STRING (STRING &AUX (A STRING-FILEARRAY))
+  (COND ((OR (ATOM STRING) (NOT (MEMBER (CAR STRING) STRING-FILES))) STRING)
+	(T (CNAMEF A (CAR STRING))
+	   (UNWIND-PROTECT
+	    (PROGN
+	     (OPEN A)
+	     (FILEPOS A (CDR STRING))
+	     (FILEPOS A (IN A))
+	     (DO ((L NIL (CONS W L)) (W (IN A) (IN A)))
+		 ((= W 0) (PNPUT (NREVERSE L) NIL))))
+	    (CLOSE A)))))
+

src/maxsrc/h19.4

@@ -0,0 +1,47 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module h19)
+
+;; Package for doing character graphics on H19s.  The Macsyma display package
+;; uses this to draw quotients, matrices, boxes, etc.  with contiguous lines.
+;; This file gets loaded when Macsyma is started up and it is determined that a
+;; H19 is being used.
+
+(DEFUN CG-BEGIN-GRAPHICS () (CG-IMAGE-TYO-N '(#\ALT #/F)))
+(DEFUN CG-END-GRAPHICS	 () (CG-IMAGE-TYO-N '(#\ALT #/G)))
+
+(DEFUN CG-VERTICAL-BAR   () (CG-TYO #/`))
+(DEFUN CG-HORIZONTAL-BAR () (CG-TYO #/a))
+
+(DEFUN CG-UL-CORNER      () (CG-TYO #/f))
+(DEFUN CG-UR-CORNER      () (CG-TYO #/c))
+(DEFUN CG-LL-CORNER      () (CG-TYO #/e))
+(DEFUN CG-LR-CORNER      () (CG-TYO #/d))
+
+;; Again we have to fool ITS.  As far as its concerned, the cursor
+;; has moved forward four character spaces.
+
+(DEFUN CG-D-SUMSIGN ()
+       (CG-IMAGE-TYO-N '(#\ALT #/A #\ALT #/A))
+       (CG-TYO-N '(#/{ #/{ #/{ #/{))
+       (CG-IMAGE-TYO-N '(#\LF #\BS #\BS #\BS #\BS #/y #\SP #\SP #/o
+			 #\LF #\BS #\BS #\BS #/>
+			 #\LF #\BS #\BS #/x #\SP #\SP #/l
+			 #\LF #\BS #\BS #\BS #\BS #/z #/z #/z #/z
+			 #\ALT #/A #\ALT #/A)))
+
+(DEFUN CG-D-PRODSIGN ()
+       (CG-IMAGE-TYO-N '(#\ALT #/A #\ALT #/A))
+       (CG-TYO-N '(#/f #/s #/a #/s #/c))
+       (CG-IMAGE-TYO-N '(#\LF #\BS #\BS #\BS #\BS #/` #\SP #/`
+			 #\LF #\BS #\BS #\BS      #/` #\SP #/`
+			 #\LF #\BS #\BS #\BS      #/u #\SP #/u
+			 #\SP #\ALT #/A)))
+
+;; This should really be set in ALJABR;LOADER and not here, but we're not
+;; always able to recognize the terminal type.  For example, coming in via
+;; supdup.  So we want things to turn on when the file is loaded by hand.
+
+(SETQ CHARACTER-GRAPHICS-TTY T)

src/maxsrc/inmis.98

@@ -0,0 +1,90 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module inmis)
+
+(DEFMVAR $LISTCONSTVARS NIL
+  "Causes LISTOFVARS to include %E, %PI, %I, and any variables declared
+   constant in the list it returns if they appear in exp.  The default is
+   to omit these." BOOLEAN SEE-ALSO $LISTOFVARS)
+
+(DECLARE (SPECIAL LISTOFVARS))
+
+(SETQ $COMBINEFLAG NIL $POLYFACTOR NIL)
+
+(DEFMFUN $UNKNOWN (F) (*CATCH NIL (UNKNOWN (MRATCHECK F))))
+
+(DEFUN UNKNOWN (F)
+ (AND (NOT (MAPATOM F))
+      (COND ((AND (EQ (CAAR F) 'MQAPPLY)
+		  (NOT (GET (CAAADR F) 'SPECSIMP)))
+	     (*THROW NIL T))
+	    ((NOT (GET (CAAR F) 'OPERATORS)) (*THROW NIL T))
+	    (T (MAPC 'UNKNOWN (CDR F)) NIL))))
+
+(DEFMFUN $LISTOFVARS (E) 
+       ((LAMBDA (LISTOFVARS) 
+	 (COND (($RATP E)
+		(AND (MEMQ 'TRUNC (CDDAR E))
+		     (SETQ E ($TAYTORAT E)))
+		(SETQ E
+		      (CONS '(MLIST)
+			    (SUBLIS (MAPCAR 'CONS
+					    (CAR (CDDDAR E))
+					    ;;GENSYMLIST
+					    (CADDAR E))
+				    ;;VARLIST
+				    (UNION* (LISTOVARS (CADR E))
+					    (LISTOVARS (CDDR E))))))))
+	 (ATOMVARS E)
+	 LISTOFVARS)
+	(LIST '(MLIST)))) 
+
+(DEFUN ATOMVARS (E) 
+       (COND ((AND (EQ (TYPEP E) 'SYMBOL)
+		   (OR $LISTCONSTVARS (NOT ($CONSTANTP E))))
+	      (ADD2LNC E LISTOFVARS))
+	     ((ATOM E))
+	     ((EQ (CAAR E) 'MRAT) (ATOMVARS (RATDISREP E)))
+	     ((MEMQ 'ARRAY (CAR E)) (MYADD2LNC E LISTOFVARS))
+	     (T (MAPC 'ATOMVARS (CDR E))))) 
+
+(DEFUN MYADD2LNC (ITEM LIST) 
+       (AND (NOT (MEMALIKE ITEM LIST)) (NCONC LIST (NCONS ITEM)))) 
+
+;; Reset the settings of all Macsyma user-level switches to their initial
+;; values.
+
+#+ITS
+(DEFMFUN $RESET NIL 
+       (load '((DSK MACSYM) RESET FASL))
+       '$DONE)
+
+#+Multics
+(DEFMFUN $RESET ()
+  (LOAD (EXECUTABLE-DIR "RESET"))
+  '$DONE)
+
+#+NIL
+(DEFMFUN $REST ()
+  (LOAD "[MACSYMA]RESET"))
+
+;; Please do not use the following version on MC without consulting with me.
+;; I already fixed several bugs in it, but the +ITS version works fine on MC 
+;; and takes less address space. - JPG
+(DECLARE (SPECIAL MODULUS $FPPREC))
+#-(or ITS Multics NIL) ;This version should be eventually used on Multics.
+(DEFMFUN $RESET ()
+        (SETQ BASE 10. IBASE 10. *NOPOINT T MODULUS NIL ZUNDERFLOW T)
+        ($DEBUGMODE NIL)
+        (COND ((NOT (= $FPPREC 16.)) ($FPPREC 16.) (SETQ $FPPREC 16.))) 
+   #+GC ($DSKGC NIL)
+        (LOAD #+PDP10   '((ALJABR) INIT RESET)
+	      #+Lispm   "MC:ALJABR;INIT RESET"
+	      #+Multics (executable-dir "init_reset")
+	      #+Unix	???)
+	;; *** This can be flushed when all Macsyma user-switches are defined
+	;; *** with DEFMVAR.  This is part of an older mechanism.
+ #+PDP10 (LOAD '((MACSYM) RESET FASL))
+        '$DONE)

src/maxsrc/intpol.13

@@ -0,0 +1,107 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Interpolation routine by CFFK.
+
+(macsyma-module intpol)
+(load-macsyma-macros transm numerm)
+
+(declare (special $intpolrel $intpolabs $intpolerror)
+	 (flonum $intpolrel $intpolabs a b c fa fb fc)
+	 (fixnum lin)
+	 (notype (interpolate-check flonum flonum flonum flonum))) 
+
+(COMMENT  |  For historical information ONLY.  |
+(defun fmeval2 (x) 
+       (cond ((fixp (setq x (meval x))) (float x))
+	     ((floatp x) x)
+	     (t (displa x) (error '|not floating point|))))
+(defun qeval (y x z) (cond (x (fmeval2 (list '($ev) y (list '(mequal) x z) '$numer)))
+			   (t (funcall y z))))
+)
+
+(or (boundp '$intpolabs) (setq $intpolabs 0.0)) 
+(or (boundp '$intpolrel) (setq $intpolrel 0.0))
+(or (boundp '$intpolerror) (setq $intpolerror t))
+
+(Defun $interpolate_SUBR (F LEFT RIGHT)
+  (BIND-TRAMP1$
+   F F
+   (prog (a b c fa fb fc lin)
+     (declare (flonum a b c fa fb fc) (fixnum lin))
+     (setq A (FLOAT LEFT)
+	   B (FLOAT RIGHT))
+     (or (> b a) (setq a (prog2 niL b (setq b a))))
+     (setq fa (FCALL$ f a)
+	   fb (FCALL$ f b))
+     (or (> (abs fa) $intpolabs) (return a))
+     (or (> (abs fb) $intpolabs) (return b))
+     (and (> (*$ fa fb) 0.0)
+	  (cond ((eq $intpolerror t)
+		 (merror "function has same sign at endpoints~%~M"
+			 `((mlist)
+			   ((mequal) ((f) ,a) ,fa)
+			   ((mequal) ((f) ,b) ,fb))))
+		(t (return $intpolerror))))
+     (and (> fa 0.0)
+	  (setq fa (prog2 nil fb (setq fb fa)) a (prog2 nil b (setq b a))))
+     (setq lin 0.)
+    binary
+     (setq c (//$ (+$ a b) 2.0)
+	   fc
+	   (FCALL$ f c))
+     (and (interpolate-check a c b fc) (return c))
+     (cond ((< (abs (-$ fc (//$ (+$ fa fb) 2.0))) (*$ 0.1 (-$ fb fa)))
+	    (setq lin (1+ lin)))
+	   (t (setq lin 0.)))
+     (cond ((> fc 0.0) (setq fb fc b c)) (t (setq fa fc a c)))
+     (or (= lin 3.) (go binary))
+    falsi
+     (setq c (cond ((> (+$ fb fa) 0.0)
+		    (+$ a (*$ (-$ b a) (//$ fa (-$ fa fb)))))
+		   (t (+$ b (*$ (-$ a b) (//$ fb (-$ fb fa)))))) 
+	   fc (FCALL$ f c))
+     (and (interpolate-check a c b fc) (return c))
+     (cond ((> fc 0.0) (setq fb fc b c)) (t (setq fa fc a c)))
+     (go falsi))))
+
+(defun interpolate-check (a c b fc)
+       (not (and (prog2 nil (> (abs fc) $intpolabs) (setq fc (max (abs a) (abs b))))
+		 (> (abs (-$ b c)) (*$ $intpolrel fc))
+		 (> (abs (-$ c a)) (*$ $intpolrel fc)))))
+
+
+
+
+(DEFUN INTERPOLATE-MACRO (FORM TRANSLP)
+       (SETQ FORM (CDR FORM))
+       (COND ((= (LENGTH FORM) 3)
+	      (COND (TRANSLP
+		     `(($INTERPOLATE_SUBR) ,@FORM))
+		    (T
+		     `((MPROG) ((MLIST) ((msetq) $NUMER T))
+			       (($INTERPOLATE_SUBR)  ,@FORM)))))
+	     ((= (LENGTH FORM) 4)
+	      (LET (((EXP VAR . BNDS) FORM))
+		   (SETQ EXP (SUB ($LHS EXP) ($RHS EXP)))
+		   (COND (TRANSLP
+			  `(($INTERPOLATE_SUBR)
+			    ((LAMBDA-I) ((MLIST) ,VAR)
+					(($MODEDECLARE) ,VAR $FLOAT)
+					,EXP)
+			    ,@BNDS))
+			 (T
+			  `((MPROG) ((MLIST) ((msetq) $NUMER T))
+				    (($INTERPOLATE_SUBR)
+				     ((LAMBDA) ((MLIST) ,VAR) ,EXP)
+				     ,@BNDS))))))
+	     (T (merror "wrong number of args to INTERPOLATE"))))
+
+(DEFMSPEC $INTERPOLATE (FORM)
+  (MEVAL (INTERPOLATE-MACRO FORM NIL)))
+
+(def-translate-property $INTERPOLATE (FORM)
+  (let (($tr_numer t))
+    (TRANSLATE (INTERPOLATE-MACRO FORM t))))
+
+

src/maxsrc/laplac.202

@@ -0,0 +1,935 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module laplac)
+
+(DECLARE (SPECIAL DVAR VAR-LIST VAR-PARM-LIST VAR PARM $SAVEFACTORS
+		  CHECKFACTORS $RATFAC $KEEPFLOAT NOUNL NOUNSFLAG)
+	 (*EXPR SUBFUNMAKE)
+	 (*LEXPR $DIFF $EXPAND $MULTTHRU $RATSIMP)
+	 ) 
+
+(DEFUN EXPONENTIATE (POW) 
+       ;;;COMPUTES %E**Z WHERE Z IS AN ARBITRARY EXPRESSION TAKING SOME OF THE WORK AWAY FROM SIMPEXPT
+       (COND ((ZEROP1 POW) 1)
+	     ((EQUAL POW 1) '$%E)
+	     (T (POWER '$%E POW)))) 
+
+(DEFUN FIXUPREST (REST) 
+       ;;;REST IS A PRODUCT WITHOUT THE MTIMES.FIXUPREST PUTS BACK THE MTIMES
+       (COND ((NULL REST) 1)
+	     ((CDR REST) (CONS '(MTIMES SIMP) REST))
+	     (T (CAR REST)))) 
+
+(DEFUN POSINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (> Y 0))))
+
+(DEFUN NEGINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (< Y 0))))
+
+(DEFUN ISQUADRATICP (E X)
+    ((LAMBDA (B)
+	(COND ((ZEROP1 B) (LIST 0 0 E))
+	      ((FREEOF X B) (LIST 0 B (SUBSTITUTE 0 X E)))
+	      ((SETQ B (ISLINEAR B X))
+		(LIST (DIV* (CAR B) 2) (CDR B) (SUBSTITUTE 0 X E)))))
+	(SDIFF E X)))
+ 
+
+;;;INITIALIZES SOME GLOBAL VARIABLES THEN CALLS THE DISPATCHING FUNCTION
+
+(DEFMFUN $LAPLACE (FUN VAR PARM) 
+       (SETQ FUN (MRATCHECK FUN))
+       (COND ((OR NOUNSFLAG (MEMQ '%LAPLACE NOUNL)) (SETQ FUN (REMLAPLACE FUN))))
+       (COND ((AND (NULL (ATOM FUN)) (EQ (CAAR FUN) 'MEQUAL))
+	      (LIST '(MEQUAL SIMP)
+		    (LAPLACE (CADR FUN))
+		    (LAPLACE (CADDR FUN))))
+	     (T (LAPLACE FUN)))) 
+
+;;;LAMBDA BINDS SOME SPECIAL VARIABLES TO NIL AND DISPATCHES
+
+(DEFUN REMLAPLACE (E)
+ (COND ((ATOM E) E)
+       (T (CONS (DELQ 'LAPLACE (APPEND (CAR E) NIL) 1) (MAPCAR 'REMLAPLACE (CDR E))))))
+
+(DEFUN LAPLACE (FUN) 
+       ((LAMBDA (DVAR VAR-LIST VAR-PARM-LIST) 
+	    ;;; Handles easy cases and calls appropriate function on others.
+		(COND ((EQUAL FUN 0) 0)
+		      ((EQUAL FUN 1)
+		       (COND ((ZEROP1 PARM) (SIMPLIFY (LIST '($DELTA) 0)))
+			     (T (POWER PARM -1))))
+		      ((ALIKE1 FUN VAR) (POWER PARM -2))
+		      ((OR (ATOM FUN) (FREEOF VAR FUN))
+		       (COND ((ZEROP1 PARM) (MUL2 FUN (SIMPLIFY (LIST '($DELTA) 0))))
+			     (T (MUL2 FUN (POWER PARM -1)))))
+		      (T ((LAMBDA (OP) 
+				  (COND ((EQ OP 'MPLUS)
+					 (LAPLUS FUN))
+					((EQ OP 'MTIMES)
+					 (LAPTIMES (CDR FUN)))
+					((EQ OP 'MEXPT)
+					 (LAPEXPT FUN NIL))
+					((EQ OP '%SIN)
+					 (LAPSIN FUN NIL NIL))
+					((EQ OP '%COS)
+					 (LAPSIN FUN NIL T))
+					((EQ OP '%SINH)
+					 (LAPSINH FUN NIL NIL))
+					((EQ OP '%COSH)
+					 (LAPSINH FUN NIL T))
+					((EQ OP '%LOG)
+					 (LAPLOG FUN))
+					((EQ OP '%DERIVATIVE)
+					 (LAPDIFF FUN))
+					((EQ OP '%INTEGRATE)
+					 (LAPINT FUN))
+					((EQ OP '%SUM)
+					 (LIST '(%SUM SIMP)
+					       (LAPLACE (CADR FUN))
+					       (CADDR FUN)
+					       (CADDDR FUN)
+					       (CAR (CDDDDR FUN))))
+					((EQ OP '%ERF)
+					 (LAPERF FUN))
+				((AND (EQ OP '%ILT)(EQ (CADDDR FUN) VAR))
+			(COND ((EQ PARM (CADDR FUN))(CADR FUN))
+				(T (SUBST PARM (CADDR FUN)(CADR FUN))))
+)					((EQ OP '$DELTA)
+					 (LAPDELTA FUN NIL))
+					((SETQ OP ($GET OP '$LAPLACE))
+					 (MCALL OP FUN VAR PARM))
+					(T (LAPDEFINT FUN))))
+			  (CAAR FUN)))))
+	NIL
+	NIL
+	NIL)) 
+
+(DEFUN LAPLUS (FUN) 
+       (SIMPLUS (CONS '(MPLUS)
+		      (MAPCAR (FUNCTION LAPLACE) (CDR FUN)))
+		1.
+		T)) 
+
+(DEFUN LAPTIMES (FUN) 
+       ;;;EXPECTS A LIST (PERHAPS EMPTY) OF FUNCTIONS MULTIPLIED TOGETHER WITHOUT THE MTIMES
+       ;;;SEES IF IT CAN APPLY THE FIRST AS A TRANSFORMATION ON THE REST OF THE FUNCTIONS
+       (COND ((NULL FUN) (LIST '(MEXPT SIMP) PARM -1.))
+	     ((NULL (CDR FUN)) (LAPLACE (CAR FUN)))
+	     ((FREEOF VAR (CAR FUN))
+	      (SIMPTIMES (LIST '(MTIMES)
+			       (CAR FUN)
+			       (LAPTIMES (CDR FUN)))
+			 1.
+			 T))
+	     ((EQ (CAR FUN) VAR)
+	      (SIMPTIMES (LIST '(MTIMES)
+			       -1.
+			       (SDIFF (LAPTIMES (CDR FUN)) PARM))
+			 1.
+			 T))
+	     (T ((LAMBDA (OP) 
+			 (COND ((EQ OP 'MEXPT)
+				(LAPEXPT (CAR FUN) (CDR FUN)))
+			       ((EQ OP 'MPLUS)
+				(LAPLUS ($MULTTHRU (FIXUPREST (CDR FUN)) (CAR FUN))))
+			       ((EQ OP '%SIN)
+				(LAPSIN (CAR FUN) (CDR FUN) NIL))
+			       ((EQ OP '%COS)
+				(LAPSIN (CAR FUN) (CDR FUN) T))
+			       ((EQ OP '%SINH)
+				(LAPSINH (CAR FUN) (CDR FUN) NIL))
+			       ((EQ OP '%COSH)
+				(LAPSINH (CAR FUN) (CDR FUN) T))
+			       ((EQ OP '$DELTA)
+				(LAPDELTA (CAR FUN) (CDR FUN)))
+
+			       (T (LAPSHIFT (CAR FUN) (CDR FUN)))))
+		 (CAAAR FUN))))) 
+
+(DEFUN LAPEXPT (FUN REST) 
+       ;;;HANDLES %E**(A*T+B)*REST(T), %E**(A*T**2+B*T+C),
+       ;;; 1/SQRT(A*T+B), OR T**K*REST(T)
+       (PROG (AB BASE-OF-FUN POWER RESULT) 
+	     (SETQ BASE-OF-FUN (CADR FUN) POWER (CADDR FUN))
+	     (COND
+	      ((AND
+		(FREEOF VAR BASE-OF-FUN)
+		(SETQ 
+		 AB
+		 (ISQUADRATICP
+		  (COND ((EQ BASE-OF-FUN '$%E) POWER)
+			(T (SIMPTIMES (LIST '(MTIMES)
+					    POWER
+					    (LIST '(%LOG)
+						  BASE-OF-FUN))
+				      1.
+				      NIL)))
+		  VAR)))
+	       (COND ((EQUAL (CAR AB) 0.) (GO %E-CASE-LIN))
+		     ((NULL REST) (GO %E-CASE-QUAD))
+		     (T (GO NOLUCK))))
+	      ((AND (EQ BASE-OF-FUN VAR) (FREEOF VAR POWER))
+	       (GO VAR-CASE))
+	      ((AND (ALIKE1 '((RAT) -1. 2.) POWER) (NULL REST)
+		    (SETQ AB (ISLINEAR BASE-OF-FUN VAR)))
+	       (SETQ RESULT (DIV* (CDR AB) (CAR AB)))
+	       (RETURN (SIMPTIMES
+		(LIST '(MTIMES)
+		      (LIST '(MEXPT)
+			    (DIV* '$%PI
+				  (LIST '(MTIMES)
+					(CAR AB)
+					PARM))
+			    '((RAT) 1. 2.))
+		      (EXPONENTIATE (LIST '(MTIMES) RESULT PARM))
+		      (LIST '(MPLUS)
+			    1.
+			    (LIST '(MTIMES)
+				  -1.
+				   (LIST '(%ERF)
+						 (LIST '(MEXPT)
+						       (LIST '(MTIMES)
+							     RESULT
+							     PARM)
+						       '((RAT)
+							 1.
+							 2.)))
+					   ))) 1 NIL)))
+	      (T (GO NOLUCK)))
+	%E-CASE-LIN
+	     (SETQ 
+	      RESULT
+	      (COND
+	       (REST ($RATSIMP ($AT (LAPTIMES REST)
+				    (LIST '(MEQUAL SIMP)
+					  PARM
+					  (LIST '(MPLUS SIMP)
+						PARM
+						(AFIXSIGN (CADR AB)
+							  NIL))))))
+	       (T (LIST '(MEXPT)
+			(LIST '(MPLUS)
+			      PARM
+			      (AFIXSIGN (CADR AB) NIL))
+			-1.))))
+	     (RETURN (SIMPTIMES (LIST '(MTIMES)
+				      (EXPONENTIATE (CADDR AB))
+				      RESULT)
+				1.
+				NIL))
+	%E-CASE-QUAD
+	     (SETQ RESULT (AFIXSIGN (CAR AB) NIL))
+	     (SETQ 
+	      RESULT
+	       (LIST
+		'(MTIMES)
+		(DIV* (LIST '(MEXPT)
+			    (DIV* '$%PI RESULT)
+			    '((RAT) 1. 2.))
+		      2.)
+		(EXPONENTIATE (DIV* (LIST '(MEXPT) PARM 2.)
+				    (LIST '(MTIMES)
+					  4.
+					  RESULT)))
+		(LIST '(MPLUS)
+		      1.
+		      (LIST '(MTIMES)
+			    -1.
+			     (LIST '(%ERF)
+					   (DIV* PARM
+						 (LIST '(MTIMES)
+						       2.
+						       (LIST '(MEXPT)
+							     RESULT
+							     '((RAT)
+							       1.
+							       2.)))))
+				))))
+	     (AND (NULL (EQUAL (CADR AB) 0.))
+		  (SETQ RESULT
+			(SUBSTITUTE (LIST '(MPLUS)
+					  PARM
+					  (LIST '(MTIMES)
+						-1.
+						(CADR AB)))
+				    PARM
+				    RESULT)))
+	     (RETURN (SIMPTIMES  (LIST '(MTIMES)
+			   (EXPONENTIATE (CADDR AB))
+			   RESULT) 1 NIL))
+	VAR-CASE
+	     (COND ((OR (NULL REST) (FREEOF VAR (FIXUPREST REST)))
+		    (GO VAR-EASY-CASE)))
+	     (COND ((POSINT POWER)
+		    (RETURN (AFIXSIGN (APPLY '$DIFF
+					     (LIST (LAPTIMES REST)
+						   PARM
+						   POWER))
+				      (EVEN POWER))))
+		   ((NEGINT POWER)
+		    (RETURN (MYDEFINT (HACKIT POWER REST)
+				      (CREATENAME PARM (MINUS POWER))
+				      PARM)))
+		   (T (GO NOLUCK)))
+	VAR-EASY-CASE
+	     (SETQ POWER
+		   (SIMPLUS (LIST '(MPLUS) 1. POWER) 1. T))
+	     (OR (EQ (ASKSIGN POWER) '$POSITIVE) (GO NOLUCK))
+	     (SETQ RESULT (LIST (LIST '(%GAMMA) POWER)
+				(LIST '(MEXPT)
+				      PARM
+				      (AFIXSIGN POWER NIL))))
+	     (AND REST (SETQ RESULT (NCONC RESULT REST)))
+	     (RETURN (SIMPTIMES (CONS '(MTIMES) RESULT)
+				1.
+				NIL))
+	NOLUCK
+	     (RETURN
+	      (COND
+	       ((AND (POSINT POWER)
+		     (MEMQ (CAAR BASE-OF-FUN)
+			   '(MPLUS %SIN %COS %SINH %COSH)))
+		(LAPTIMES (CONS BASE-OF-FUN
+				(CONS (COND ((= POWER 2.) BASE-OF-FUN)
+					    (T (LIST '(MEXPT SIMP)
+						     BASE-OF-FUN
+						     (SUB1 POWER))))
+				      REST))))
+	       (T (LAPSHIFT FUN REST)))))) 
+
+(DEFUN MYDEFINT (F X A) 
+       ;;;INTEGRAL FROM A TO INFINITY OF F(X)
+       ((LAMBDA (TRYINT) (COND (TRYINT (CAR TRYINT))
+			       (T (LIST '(%INTEGRATE SIMP)
+					F
+					X
+					A
+					'$INF))))
+	(AND (NOT ($UNKNOWN F))
+	     (ERRSET ($DEFINT F X A '$INF))))) 
+
+(DEFUN CREATENAME 
+ ;;;CREATES HOPEFULLY UNIQUE NAMES FOR VARIABLE OF INTEGRATION
+ (HEAD TAIL) 
+ (implode (NCONC (EXPLODEC HEAD) (EXPLODEC TAIL))))
+
+(DECLARE (FIXNUM EXPONENT)) 
+
+(DEFUN HACKIT (EXPONENT REST) 
+       ;;;REDUCES LAPLACE(F(T)/T**N,T,S) CASE TO LAPLACE(F(T)/T**(N-1),T,S) CASE
+       (COND ((EQUAL EXPONENT -1.)
+	      ((LAMBDA (PARM) (LAPTIMES REST)) (CREATENAME PARM 1.)))
+	     (T (MYDEFINT (HACKIT (1+ EXPONENT) REST)
+			  (CREATENAME PARM (DIFFERENCE -1. EXPONENT))
+			  (CREATENAME PARM (MINUS EXPONENT)))))) 
+
+(DECLARE (NOTYPE EXPONENT)) 
+
+(DEFUN AFIXSIGN (FUNCT SIGNSWITCH) 
+       ;;;MULTIPLIES FUNCT BY -1 IF SIGNSWITCH IS NIL
+       (COND (SIGNSWITCH FUNCT)
+	     (T (SIMPTIMES (LIST '(MTIMES) -1. FUNCT) 1. T)))) 
+
+ 
+
+(DEFUN LAPSHIFT (FUN REST) 
+       (COND ((ATOM FUN) (merror "INTERNAL ERROR"))
+	     ((OR (MEMQ 'LAPLACE (CAR FUN)) (NULL REST))
+	      (LAPDEFINT (COND (REST (SIMPTIMES (CONS '(MTIMES)
+					   (CONS FUN REST)) 1 T))
+			       (T FUN))))
+	     (T (LAPTIMES (APPEND REST
+				  (NCONS (CONS (APPEND (CAR FUN)
+						       '(LAPLACE))
+					       (CDR FUN)))))))) 
+
+(DEFUN MOSTPART (F PARM SIGN A B) 
+       ;;;COMPUTES %E**(W*B*%I)*F(S-W*A*%I) WHERE W=-1 IF SIGN IS T ELSE W=1
+       ((LAMBDA (SUBSTINFUN) 
+		(COND ((ZEROP1 B) SUBSTINFUN)
+		      (T (LIST '(MTIMES)
+			       (EXPONENTIATE (AFIXSIGN (LIST '(MTIMES)
+							     B
+							     '$%I)
+						       (NULL SIGN)))
+			       SUBSTINFUN))))
+	($AT F
+	     (LIST '(MEQUAL SIMP)
+		   PARM
+		   (LIST '(MPLUS SIMP)
+			 PARM
+			 (AFIXSIGN (LIST '(MTIMES)
+					 A
+					 '$%I)
+				   SIGN)))))) 
+
+(DEFUN COMPOSE 
+ ;;;IF WHICHSIGN IS NIL THEN SIN TRANSFORM ELSE COS TRANSFORM
+ (FUN PARM WHICHSIGN A B) 
+       ((LAMBDA (RESULT) 
+		($RATSIMP (SIMPTIMES (CONS '(MTIMES)
+					   (COND (WHICHSIGN RESULT)
+						 (T (CONS '$%I
+							  RESULT))))
+				     1 NIL)))
+	(LIST '((RAT) 1. 2.)
+	      (LIST '(MPLUS)
+		    (MOSTPART FUN PARM T A B)
+		    (AFIXSIGN (MOSTPART FUN PARM NIL A B)
+			      WHICHSIGN))))) 
+
+(DEFUN LAPSIN 
+ ;;;FUN IS OF THE FORM SIN(A*T+B)*REST(T) OR COS
+ (FUN REST TRIGSWITCH) 
+       ((LAMBDA (AB) 
+	 (COND
+	  (AB
+	    (COND
+	     (REST (COMPOSE (LAPTIMES REST)
+			    PARM
+			    TRIGSWITCH
+			    (CAR AB)
+			    (CDR AB)))
+	     (T (SIMPTIMES
+	      (LIST
+	       '(MTIMES)
+	       (COND
+		((ZEROP1 (CDR AB))
+		 (COND (TRIGSWITCH PARM) (T (CAR AB))))
+		(T (COND (TRIGSWITCH (LIST '(MPLUS)
+					   (LIST '(MTIMES)
+						 PARM
+						 (LIST '(%COS)
+						       (CDR AB)))
+					   (LIST '(MTIMES)
+						 -1.
+						 (CAR AB)
+						 (LIST '(%SIN)
+						       (CDR AB)))))
+			 (T (LIST '(MPLUS)
+				  (LIST '(MTIMES)
+					PARM
+					(LIST '(%SIN)
+					      (CDR AB)))
+				  (LIST '(MTIMES)
+					(CAR AB)
+					(LIST '(%COS)
+					      (CDR AB))))))))
+	       (LIST '(MEXPT)
+		     (LIST '(MPLUS)
+			   (LIST '(MEXPT) PARM 2.)
+			   (LIST '(MEXPT) (CAR AB) 2.))
+		     -1.))
+	    1 NIL))))
+	  (T (LAPSHIFT FUN REST))))
+	(ISLINEAR (CADR FUN) VAR))) 
+
+(DEFUN LAPSINH 
+ ;;;FUN IS OF THE FORM SINH(A*T+B)*REST(T) OR IS COSH
+ (FUN REST SWITCH) 
+	(COND ((ISLINEAR (CADR FUN) VAR)
+       ($RATSIMP
+	(LAPLUS
+	 (SIMPLUS
+	  (LIST '(MPLUS)
+		(NCONC (LIST '(MTIMES)
+			     (LIST '(MEXPT)
+				   '$%E
+				   (CADR FUN))
+			     '((RAT) 1. 2.))
+		       REST)
+		(AFIXSIGN (NCONC (LIST '(MTIMES)
+				       (LIST '(MEXPT)
+					     '$%E
+					     (AFIXSIGN (CADR FUN)
+						       NIL))
+				       '((RAT) 1. 2.))
+				 REST)
+			  SWITCH))
+	  1.
+	  NIL)))) 
+	(T (LAPSHIFT FUN REST))))
+
+(DEFUN LAPLOG 
+ ;;;FUN IS OF THE FORM LOG(A*T)
+ (FUN) ((LAMBDA (AB) 
+		(COND ((AND AB (ZEROP1 (CDR AB)))
+		       (SIMPTIMES (LIST '(MTIMES)
+					(LIST '(MPLUS)
+					      (subfunmake '$PSI
+							  '(0)
+							  (NCONS 1.))
+					      (LIST '(%LOG)
+						    (CAR AB))
+					      (LIST '(MTIMES)
+						    -1.
+						    (LIST '(%LOG)
+							  PARM)))
+					(LIST '(MEXPT)
+					      PARM
+					      -1.))
+				  1 NIL))
+		      (T (LAPDEFINT FUN))))
+	(ISLINEAR (CADR FUN) VAR))) 
+
+(DEFUN RAISEUP (FBASE EXPONENT) 
+       (COND ((EQUAL EXPONENT 1.) FBASE)
+	     (T (LIST '(MEXPT) FBASE EXPONENT)))) 
+
+(DEFUN LAPDELTA (FUN REST) 
+       ;;TAKES TRANSFORM OF DELTA(A*T+B)*F(T)
+       ((LAMBDA (AB SIGN RECIPA) 
+	 (COND
+	  (AB
+	   (SETQ RECIPA (POWER (CAR AB) -1) AB (DIV (CDR AB) (CAR AB)))
+	   (SETQ SIGN (ASKSIGN AB) RECIPA (SIMPLIFYA (LIST '(MABS) RECIPA) NIL))
+	   (SIMPLIFYA (COND ((EQ SIGN '$POSITIVE) 0)
+			    ((EQ SIGN '$ZERO)
+			     (LIST '(MTIMES)
+				   (SUBSTITUTE 0 VAR (FIXUPREST REST))
+				   RECIPA))
+			    (T (LIST '(MTIMES)
+				     (SUBSTITUTE (NEG AB)
+						 VAR
+						 (FIXUPREST REST))
+				     (LIST '(MEXPT)
+					   '$%E
+					   (CONS '(MTIMES)
+						 (CONS PARM (NCONS AB))))
+				     RECIPA)))
+		      NIL))
+	  (T (LAPSHIFT FUN REST))))
+	(ISLINEAR (CADR FUN) VAR) NIL NIL)) 
+
+(DEFUN LAPERF (FUN  )
+       ((LAMBDA (AB) 
+	 (COND
+	  ((AND AB (EQUAL (CDR AB) 0.))
+	   (SIMPTIMES (LIST '(MTIMES)
+		 (DIV* (EXPONENTIATE (DIV* (LIST '(MEXPT)
+						 PARM
+						 2.)
+					   (LIST '(MTIMES)
+						 4.
+						 (LIST '(MEXPT)
+						       (CAR AB)
+						       2.))))
+		       PARM)
+		 (LIST '(MPLUS)
+		       1.
+		       (LIST '(MTIMES)
+			     -1.
+			      (LIST '(%ERF)
+					    (DIV* PARM
+						  (LIST '(MTIMES)
+							2.
+							(CAR AB))))
+				      ))) 1 NIL))
+	  (T (LAPDEFINT FUN))))
+	(ISLINEAR (CADR FUN) VAR)))
+(DEFUN LAPDEFINT (FUN)
+  (PROG (TRYINT MULT)
+    (AND ($UNKNOWN FUN)(GO SKIP))
+    (SETQ MULT (SIMPTIMES (LIST '(MTIMES) (EXPONENTIATE
+					   (LIST '(MTIMES SIMP) -1 VAR PARM)) FUN) 1 NIL))
+    (MEVAL `(($ASSUME) ,@(LIST (LIST '(MGREATERP) PARM 0))))
+    (SETQ TRYINT (ERRSET ($DEFINT MULT VAR 0 '$INF)))
+    (MEVAL `(($FORGET) ,@(LIST (LIST '(MGREATERP) PARM 0))))
+    (AND TRYINT (NOT (EQ (CAAAR TRYINT) '%INTEGRATE))  (RETURN (CAR TRYINT)))
+   SKIP (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))))
+ 
+
+(DECLARE (FIXNUM ORDER)) 
+
+(DEFUN LAPDIFF 
+ ;;;FUN IS OF THE FORM DIFF(F(T),T,N) WHERE N IS A POSITIVE INTEGER
+ (FUN) (PROG (DIFFLIST DEGREE FRONTEND RESULTLIST NEWDLIST ORDER
+	      ARG2) 
+	     (SETQ NEWDLIST (SETQ DIFFLIST (COPY (CDDR FUN))))
+	     (SETQ ARG2 (LIST '(MEQUAL SIMP) VAR 0.))
+	A    (COND ((NULL DIFFLIST)
+		    (RETURN (CONS '(%DERIVATIVE SIMP)
+				  (CONS (LIST '(%LAPLACE SIMP)
+					      (CADR FUN)
+					      VAR
+					      PARM)
+					NEWDLIST))))
+		   ((EQ (CAR DIFFLIST) VAR)
+		    (SETQ DEGREE (CADR DIFFLIST) 
+			  DIFFLIST (CDDR DIFFLIST))
+		    (GO OUT)))
+	     (SETQ DIFFLIST (CDR (SETQ FRONTEND (CDR DIFFLIST))))
+	     (GO A)
+	OUT  (COND ((NULL (POSINT DEGREE))
+		    (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))))
+	     (COND (FRONTEND (RPLACD FRONTEND DIFFLIST))
+		   (T (SETQ NEWDLIST DIFFLIST)))
+	     (COND (NEWDLIST (SETQ FUN (CONS '(%DERIVATIVE SIMP)
+					     (CONS (CADR FUN)
+						   NEWDLIST))))
+		   (T (SETQ FUN (CADR FUN))))
+	     (SETQ ORDER 0.)
+	LOOP (SETQ DEGREE (1- DEGREE))
+	     (SETQ RESULTLIST
+		   (CONS (LIST '(MTIMES)
+			       (RAISEUP PARM DEGREE)
+			       ($AT ($DIFF FUN VAR ORDER) ARG2))
+			 RESULTLIST))
+	     (SETQ ORDER (1+ ORDER))
+	     (AND (> DEGREE 0.) (GO LOOP))
+	     (SETQ RESULTLIST (COND ((CDR RESULTLIST)
+				     (CONS '(MPLUS)
+					   RESULTLIST))
+				    (T (CAR RESULTLIST))))
+	     (RETURN (SIMPLUS (LIST '(MPLUS)
+				      (LIST '(MTIMES)
+					    (RAISEUP PARM ORDER)
+					    (LAPLACE FUN))
+				      (LIST '(MTIMES)
+					    -1.
+					    RESULTLIST))
+				1 NIL)))) 
+
+(DECLARE (NOTYPE ORDER)) 
+
+(DEFUN LAPINT 
+ ;;;FUN IS OF THE FORM INTEGRATE(F(X)*G(T)*H(T-X),X,0,T)
+ (FUN) (PROG (NEWFUN PARM-LIST F) 
+	     (AND DVAR (GO CONVOLUTION))
+	     (SETQ DVAR (CADR (SETQ NEWFUN (CDR FUN))))
+	     (AND (CDDR NEWFUN)
+		  (ZEROP1 (CADDR NEWFUN))
+		  (EQ (CADDDR NEWFUN) VAR)
+		  (GO CONVOLUTIONTEST))
+	NOTCON
+	     (SETQ NEWFUN (CDR FUN))
+	     (COND ((CDDR NEWFUN)
+		    (COND ((AND (FREEOF VAR (CADDR NEWFUN))
+				(FREEOF VAR (CADDDR NEWFUN)))
+			   (RETURN (LIST '(%INTEGRATE SIMP)
+					 (LAPLACE (CAR NEWFUN))
+					 DVAR
+					 (CADDR NEWFUN)
+					 (CADDDR NEWFUN))))
+			  (T (GO GIVEUP))))
+		   (T (RETURN (LIST '(%INTEGRATE SIMP)
+				    (LAPLACE (CAR NEWFUN))
+				    DVAR))))
+	GIVEUP
+	     (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))
+	CONVOLUTIONTEST
+	     (SETQ NEWFUN ($FACTOR (CAR NEWFUN)))
+	     (COND ((EQ (CAAR NEWFUN) 'MTIMES)
+		    (SETQ F (CADR NEWFUN) NEWFUN (CDDR NEWFUN)))
+		   (T (SETQ F NEWFUN NEWFUN NIL)))
+	GOTHRULIST
+	     (COND ((FREEOF DVAR F)
+		    (SETQ PARM-LIST (CONS F PARM-LIST)))
+		   ((FREEOF VAR F) (SETQ VAR-LIST (CONS F VAR-LIST)))
+		   ((FREEOF DVAR
+			    ($RATSIMP (SUBSTITUTE (LIST '(MPLUS)
+							VAR
+							DVAR)
+						  VAR
+						  F)))
+		    (SETQ VAR-PARM-LIST (CONS F VAR-PARM-LIST)))
+		   (T (GO NOTCON)))
+	     (COND (NEWFUN (SETQ F (CAR NEWFUN) NEWFUN (CDR NEWFUN))
+			   (GO GOTHRULIST)))
+	     (AND
+	      PARM-LIST
+	      (RETURN
+	       (LAPLACE
+		(CONS
+		 '(MTIMES)
+		 (NCONC PARM-LIST
+			(NCONS (LIST '(%INTEGRATE)
+				     (CONS '(MTIMES)
+					   (APPEND VAR-LIST
+						   VAR-PARM-LIST))
+				     DVAR
+				     0.
+				     VAR)))))))
+	CONVOLUTION
+	     (RETURN
+	      (SIMPTIMES
+	       (LIST
+		'(MTIMES)
+		(LAPLACE ($EXPAND (SUBSTITUTE VAR
+					      DVAR
+					      (FIXUPREST VAR-LIST))))
+		(LAPLACE
+		 ($EXPAND (SUBSTITUTE 0.
+				      DVAR
+				      (FIXUPREST VAR-PARM-LIST)))))
+	       1.
+	       T)))) 
+
+(DECLARE (SPECIAL VARLIST RATFORM ILS ILT)) 
+
+(DEFMFUN $ILT (EXP ILS ILT) 
+ ;;;EXP IS F(S)/G(S) WHERE F AND G ARE POLYNOMIALS IN S AND DEGR(F) < DEGR(G)
+	 (LET (VARLIST ($SAVEFACTORS T) CHECKFACTORS $RATFAC $KEEPFLOAT) 
+		;;; MAKES ILS THE MAIN VARIABLE
+		(SETQ VARLIST (LIST ILS))
+		(NEWVAR EXP)
+		(ORDERPOINTER VARLIST)
+		(SETQ VAR (CAADR (RATREP* ILS)))
+		(COND ((AND (NULL (ATOM EXP))
+			    (EQ (CAAR EXP) 'MEQUAL))
+		       (LIST '(MEQUAL)
+			     ($ILT (CADR EXP) ILS ILT)
+			     ($ILT (CADDR EXP) ILS ILT)))
+		      ((ZEROP1 EXP) 0.)
+		      ((FREEOF ILS EXP)
+		       (LIST '(%ILT SIMP) EXP ILS ILT))
+		      (T (ILT0 EXP))))) 
+
+(DEFUN RATIONALP (LE V) 
+       (COND ((NULL LE))
+	     ((AND (NULL (ATOM (CAR LE))) (NULL (FREEOF V (CAR LE))))
+	      NIL)
+	     (T (RATIONALP (CDR LE) V)))) 
+
+(DEFUN ILT0 
+ ;;;THIS FUNCTION DOES THE PARTIAL FRACTION DECOMPOSITION
+ (EXP) (PROG (WHOLEPART FRPART NUM DENOM Y CONTENT REAL FACTOR
+	      APART BPART PARNUMER RATARG RATFORM) 
+	     (AND (MPLUSP EXP)
+		  (RETURN (SIMPLUS  (CONS '(MPLUS)
+				(MAPCAR (FUNCTION (LAMBDA(F)($ILT F ILS ILT))) (CDR EXP))) 1 T)))
+	     (AND (NULL (ATOM EXP))
+		  (EQ (CAAR EXP) '%LAPLACE)
+		  (EQ (CADDDR EXP) ILS)
+		  (RETURN (COND ((EQ (CADDR EXP) ILT) (CADR EXP))
+				(T (SUBST ILT
+					       (CADDR EXP)
+					       (CADR EXP))))))
+	     (SETQ RATARG (RATREP* EXP))
+	     (OR (RATIONALP VARLIST ILS)
+		 (RETURN (LIST '(%ILT SIMP) EXP ILS ILT)))
+	     (SETQ RATFORM (CAR RATARG))
+	     (SETQ DENOM (RATDENOMINATOR (CDR RATARG)))
+	     (SETQ FRPART (PDIVIDE (RATNUMERATOR (CDR RATARG)) DENOM))
+	     (SETQ WHOLEPART (CAR FRPART))
+	     (SETQ FRPART (RATQU (CADR FRPART) DENOM))
+	     (COND ((NOT (ZEROP1 (CAR WHOLEPART)))
+		    (RETURN (LIST '(%ILT SIMP) EXP ILS ILT)))
+		   ((ZEROP1 (CAR FRPART)) (RETURN 0)))
+	     (SETQ NUM (CAR FRPART) DENOM (CDR FRPART))
+	     (SETQ Y (OLDCONTENT DENOM))
+	     (SETQ CONTENT (CAR Y))
+	     (SETQ REAL (CADR Y))
+	     (SETQ FACTOR (PFACTOR REAL))
+	LOOP (COND ((NULL (CDDR FACTOR))
+		    (SETQ APART REAL 
+			  BPART 1 
+			  Y '((0 . 1) 1 . 1))
+		    (GO SKIP)))
+	     (SETQ APART (PEXPT (CAR FACTOR) (CADR FACTOR)))
+	     (SETQ BPART (CAR (RATQU REAL APART)))
+	     (SETQ Y (BPROG APART BPART))
+	SKIP (SETQ FRPART
+		   (CDR (RATDIVIDE (RATTI (RATNUMERATOR NUM)
+					  (CDR Y)
+					  T)
+				   (RATTI (RATDENOMINATOR NUM)
+					  (RATTI CONTENT APART T)
+					  T))))
+	     (SETQ 
+	      PARNUMER
+	      (CONS (ILT1 (RATQU (RATNUMERATOR FRPART)
+				 (RATTI (RATDENOMINATOR FRPART)
+					(RATTI (RATDENOMINATOR NUM)
+					       CONTENT
+					       T)
+					T))
+			  (CAR FACTOR)
+			  (CADR FACTOR))
+		    PARNUMER))
+	     (SETQ FACTOR (CDDR FACTOR))
+	     (COND ((NULL FACTOR)
+		    (RETURN (SIMPLUS (CONS '(MPLUS) PARNUMER)
+				     1.
+				     T))))
+	     (SETQ NUM (CDR (RATDIVIDE (RATTI NUM (CAR Y) T)
+				       (RATTI CONTENT BPART T))))
+	     (SETQ REAL BPART)
+	     (GO LOOP))) 
+
+(DECLARE (FIXNUM K) (SPECIAL Q Z)) 
+
+(DEFUN ILT1 (P Q K)
+  ((LAMBDA (Z)
+  (COND (( ONEP1 K)(ILT3 P ))
+	(T (SETQ Z (BPROG Q (PDERIVATIVE Q VAR)))(ILT2 P K)))) NIL))
+
+
+(DEFUN ILT2 
+ ;;;INVERTS P(S)/Q(S)**K WHERE Q(S)  IS IRREDUCIBLE
+ ;;;DOESN'T CALL ILT3 IF Q(S) IS LINEAR
+  (P K)
+       (PROG (Y A B) 
+		(AND (ONEP1 K)(RETURN (ILT3 P)))
+		(SETQ K (1- K))
+	     (SETQ A (RATTI P (CAR Z) T))
+	     (SETQ B (RATTI P (CDR Z) T))
+	     (SETQ Y (PEXPT Q K))
+	     (COND
+	      ((OR (NULL (EQUAL (PDEGREE Q VAR) 1.))
+		   (> (PDEGREE (CAR P) VAR) 0.))
+	       (RETURN
+		(SIMPLUS
+		 (LIST
+		  '(MPLUS)
+		  (ILT2
+		   (CDR (RATDIVIDE (RATPLUS A
+					    (RATQU (RATDERIVATIVE B
+								  VAR)
+						   K))
+				   Y))
+		   K)
+		  ($MULTTHRU (SIMPTIMES (LIST '(MTIMES)
+				   ILT
+				   (POWER K -1)
+				   (ILT2 (CDR (RATDIVIDE B Y)) K))
+			     1.
+			     T)))
+		 1.
+		 T))))
+	     (SETQ A (DISREP (POLCOEF Q 1.)) 
+		   B (DISREP (POLCOEF Q 0.)))
+	     (RETURN
+	      (SIMPTIMES (LIST '(MTIMES)
+			       (DISREP P)
+			       (RAISEUP ILT K)
+			       (SIMPEXPT (LIST '(MEXPT)
+					       '$%E
+					       (LIST '(MTIMES)
+						     -1.
+						     ILT
+						     B
+						     (LIST '(MEXPT)
+							   A
+							   -1.)))
+					 1.
+					 NIL)
+			       (LIST '(MEXPT)
+				     A
+				     (DIFFERENCE -1. K))
+			       (LIST '(MEXPT)
+				     (FACTORIAL K)
+				     -1.))
+			 1.
+			 NIL)))) 
+
+(DECLARE (NOTYPE K)) 
+
+(DEFUN COEF MACRO (POL) (SUBST (CADR POL) (QUOTE DEG)
+  '(DISREP (RATQU (POLCOEF (CAR P) DEG) (CDR P)))))
+
+(DEFUN LAPSUM N (CONS '(MPLUS)(LISTIFY N)))
+(DEFUN LAPPROD N (CONS '(MTIMES)(LISTIFY N)))
+(DEFUN EXPO N (CONS '(MEXPT)(LISTIFY N)))
+(DEFUN ILT3 
+ ;;;INVERTS P(S)/Q(S) WHERE Q(S) IS IRREDUCIBLE
+ (P ) (PROG (DISCRIM SIGN A C D E B1 B0 R TERM1 TERM2 DEGR) 
+	     (SETQ E (DISREP (POLCOEF Q 0.)) 
+		   D (DISREP (POLCOEF Q 1.)) 
+		   DEGR (PDEGREE Q VAR))
+	      (AND (EQUAL DEGR 1.)
+	       (RETURN
+		(SIMPTIMES (LAPPROD
+				 (DISREP P)
+				 (EXPO D -1.)
+				 (EXPO
+				       '$%E
+				       (LAPPROD
+					     -1.
+					     ILT
+					     E
+					     (EXPO
+						   D
+						   -1.))))
+			   1.
+			   NIL)))
+		(SETQ C (DISREP (POLCOEF Q 2)))
+	      (AND (EQUAL DEGR 2.) (GO QUADRATIC))
+	      (AND (EQUAL DEGR 3.) (ZEROP1 C) (ZEROP1 D)
+	       (GO CUBIC))
+	(RETURN (LIST '(%ILT SIMP) (DIV* (DISREP P)(DISREP Q)) ILS ILT))
+	CUBIC (SETQ  A (DISREP (POLCOEF Q 3))
+		R (SIMPNRT (DIV* E A) 3))
+		(SETQ D (DIV* (DISREP P)(LAPPROD A (LAPSUM
+			(EXPO ILS 3)(EXPO '%R 3)))))
+		(RETURN (ILT0 (SUBSTITUTE R '%R ($PARTFRAC D ILS))))
+	QUADRATIC (SETQ B0 (COEF 0) B1 (COEF 1))
+
+	     (SETQ DISCRIM
+		   (SIMPLUS (LAPSUM
+				  (LAPPROD
+					4.
+					E
+					C)
+				  (LAPPROD -1. D D))
+			    1.
+			    NIL))
+	     (SETQ SIGN (COND ((FREE DISCRIM '$%I) (ASKSIGN DISCRIM)) (T '$POSITIVE)) 
+		   TERM1 '(%COS) 
+		   TERM2 '(%SIN))
+	(SETQ DEGR (EXPO '$%E (LAPPROD ILT D (POWER C -1) '((RAT SIMP) -1 2))))
+	     (COND ((EQ SIGN '$ZERO)
+		    (RETURN (SIMPTIMES (LAPPROD DEGR (LAPSUM (DIV* B1 C)(LAPPROD
+		(DIV* (LAPSUM (LAPPROD 2 B0 C)(LAPPROD -1 B1 D))
+		(LAPPROD 2 C C)) ILT))) 1 NIL))
+)		   ((EQ SIGN '$NEGATIVE)
+		    (SETQ TERM1 '(%COSH) 
+			  TERM2 '(%SINH) 
+			  DISCRIM (SIMPTIMES (LAPPROD
+						   -1.
+						   DISCRIM)
+					     1.
+					     T))))
+	     (SETQ DISCRIM (SIMPNRT DISCRIM 2))
+	     (SETQ 
+	      SIGN
+	      (SIMPTIMES
+	       (LAPPROD
+		     (LAPSUM
+			   (LAPPROD
+				 2.
+				 B0
+				 C)
+			   (LAPPROD
+				 -1.
+				 B1
+				 D))
+		     (EXPO DISCRIM -1.))
+	       1.
+	       NIL))
+	     (SETQ C (POWER C -1))
+	     (SETQ DISCRIM (SIMPTIMES (LAPPROD
+					    DISCRIM
+					    ILT
+					    '((RAT SIMP) 1. 2.)
+					    C)
+				      1.
+				      T))
+	     (RETURN
+	      (SIMPTIMES
+	       (LAPPROD
+		     C
+		     DEGR
+		     (LAPSUM
+			   (LAPPROD
+				 B1
+				 (LIST TERM1 DISCRIM))
+			   (LAPPROD
+				 SIGN
+				 (LIST TERM2 DISCRIM))))
+	       1.
+	       NIL)))) 
+
+(DECLARE (UNSPECIAL DVAR ILS ILT NOUNL PARM Q RATFORM VAR VARLIST
+		    VAR-LIST VAR-PARM-LIST Z))

src/maxsrc/laplac.205

@@ -0,0 +1,918 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;
+;;;  (c) Copyright 1976, 1983 Massachusetts Institute of Technology     ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module laplac)
+
+(DECLARE (SPECIAL DVAR VAR-LIST VAR-PARM-LIST VAR PARM $SAVEFACTORS
+		  CHECKFACTORS $RATFAC $KEEPFLOAT NOUNL NOUNSFLAG)
+	 (*EXPR SUBFUNMAKE)
+	 (*LEXPR $DIFF $EXPAND $MULTTHRU $RATSIMP)) 
+
+(DEFUN EXPONENTIATE (POW) 
+       ;;;COMPUTES %E**Z WHERE Z IS AN ARBITRARY EXPRESSION TAKING SOME OF THE WORK AWAY FROM SIMPEXPT
+       (COND ((ZEROP1 POW) 1)
+	     ((EQUAL POW 1) '$%E)
+	     (T (POWER '$%E POW)))) 
+
+(DEFUN FIXUPREST (REST) 
+       ;;;REST IS A PRODUCT WITHOUT THE MTIMES.FIXUPREST PUTS BACK THE MTIMES
+       (COND ((NULL REST) 1)
+	     ((CDR REST) (CONS '(MTIMES SIMP) REST))
+	     (T (CAR REST)))) 
+
+(DEFUN POSINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (> Y 0))))
+
+(DEFUN NEGINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (< Y 0))))
+
+(DEFUN ISQUADRATICP (E X)
+    ((LAMBDA (B)
+	(COND ((ZEROP1 B) (LIST 0 0 E))
+	      ((FREEOF X B) (LIST 0 B (SUBSTITUTE 0 X E)))
+	      ((SETQ B (ISLINEAR B X))
+		(LIST (DIV* (CAR B) 2) (CDR B) (SUBSTITUTE 0 X E)))))
+	(SDIFF E X)))
+ 
+
+;;;INITIALIZES SOME GLOBAL VARIABLES THEN CALLS THE DISPATCHING FUNCTION
+
+(DEFMFUN $LAPLACE (E VAR PARM) 
+  (IF (OR NOUNSFLAG (MEMQ '%LAPLACE NOUNL))
+      (SETQ E (REMLAPLACE (SPECREPCHECK E))))
+  (LAPLACE E)) 
+
+(DEFUN REMLAPLACE (E)
+  (IF (ATOM E) E (CONS (DELQ 'LAPLACE (APPEND (CAR E) NIL) 1)
+		       (MAPCAR #'REMLAPLACE (CDR E)))))
+
+(DEFUN LAPLACE (FUN) 
+       ((LAMBDA (DVAR VAR-LIST VAR-PARM-LIST) 
+	    ;;; Handles easy cases and calls appropriate function on others.
+	  (COND ((EQUAL FUN 0) 0)
+	        ((EQUAL FUN 1)
+	         (COND ((ZEROP1 PARM) (SIMPLIFY (LIST '($DELTA) 0)))
+		       (T (POWER PARM -1))))
+		((MBAGP FUN) (CONS (CAR FUN) (MAPCAR #'LAPLACE (CDR FUN))))
+		((SPECREPP FUN) (LAPLACE (SPECDISREP FUN)))
+		      ((ALIKE1 FUN VAR) (POWER PARM -2))
+		      ((OR (ATOM FUN) (FREEOF VAR FUN))
+		       (COND ((ZEROP1 PARM) (MUL2 FUN (SIMPLIFY (LIST '($DELTA) 0))))
+			     (T (MUL2 FUN (POWER PARM -1)))))
+		      (T ((LAMBDA (OP) 
+				  (COND ((EQ OP 'MPLUS)
+					 (ADDN (MAPCAR #'LAPLACE (CDR FUN)) T))
+					((EQ OP 'MTIMES)
+					 (LAPTIMES (CDR FUN)))
+					((EQ OP 'MEXPT)
+					 (LAPEXPT FUN NIL))
+					((EQ OP '%SIN)
+					 (LAPSIN FUN NIL NIL))
+					((EQ OP '%COS)
+					 (LAPSIN FUN NIL T))
+					((EQ OP '%SINH)
+					 (LAPSINH FUN NIL NIL))
+					((EQ OP '%COSH)
+					 (LAPSINH FUN NIL T))
+					((EQ OP '%LOG)
+					 (LAPLOG FUN))
+					((EQ OP '%DERIVATIVE)
+					 (LAPDIFF FUN))
+					((EQ OP '%INTEGRATE)
+					 (LAPINT FUN))
+					((EQ OP '%SUM)
+					 (LIST '(%SUM SIMP)
+					       (LAPLACE (CADR FUN))
+					       (CADDR FUN)
+					       (CADDDR FUN)
+					       (CAR (CDDDDR FUN))))
+					((EQ OP '%ERF)
+					 (LAPERF FUN))
+				((AND (EQ OP '%ILT)(EQ (CADDDR FUN) VAR))
+			(COND ((EQ PARM (CADDR FUN))(CADR FUN))
+				(T (SUBST PARM (CADDR FUN)(CADR FUN))))
+)					((EQ OP '$DELTA)
+					 (LAPDELTA FUN NIL))
+					((SETQ OP ($GET OP '$LAPLACE))
+					 (MCALL OP FUN VAR PARM))
+					(T (LAPDEFINT FUN))))
+			  (CAAR FUN)))))
+	NIL
+	NIL
+	NIL)) 
+
+(DEFUN LAPLUS (FUN) (ADDN (MAPCAR #'LAPLACE (CDR FUN)) T))
+
+(DEFUN LAPTIMES (FUN)
+       ;;;EXPECTS A LIST (PERHAPS EMPTY) OF FUNCTIONS MULTIPLIED TOGETHER WITHOUT THE MTIMES
+       ;;;SEES IF IT CAN APPLY THE FIRST AS A TRANSFORMATION ON THE REST OF THE FUNCTIONS
+       (COND ((NULL FUN) (LIST '(MEXPT SIMP) PARM -1))
+	     ((NULL (CDR FUN)) (LAPLACE (CAR FUN)))
+	     ((FREEOF VAR (CAR FUN))
+	      (SIMPTIMES (LIST '(MTIMES)
+			       (CAR FUN)
+			       (LAPTIMES (CDR FUN)))
+			 1 T))
+	     ((EQ (CAR FUN) VAR)
+	      (SIMPTIMES (LIST '(MTIMES)
+			       -1
+			       (SDIFF (LAPTIMES (CDR FUN)) PARM))
+			 1 T))
+	     (T ((LAMBDA (OP) 
+			 (COND ((EQ OP 'MEXPT)
+				(LAPEXPT (CAR FUN) (CDR FUN)))
+			       ((EQ OP 'MPLUS)
+				(LAPLUS ($MULTTHRU (FIXUPREST (CDR FUN)) (CAR FUN))))
+			       ((EQ OP '%SIN)
+				(LAPSIN (CAR FUN) (CDR FUN) NIL))
+			       ((EQ OP '%COS)
+				(LAPSIN (CAR FUN) (CDR FUN) T))
+			       ((EQ OP '%SINH)
+				(LAPSINH (CAR FUN) (CDR FUN) NIL))
+			       ((EQ OP '%COSH)
+				(LAPSINH (CAR FUN) (CDR FUN) T))
+			       ((EQ OP '$DELTA)
+				(LAPDELTA (CAR FUN) (CDR FUN)))
+
+			       (T (LAPSHIFT (CAR FUN) (CDR FUN)))))
+		 (CAAAR FUN))))) 
+
+(DEFUN LAPEXPT (FUN REST) 
+       ;;;HANDLES %E**(A*T+B)*REST(T), %E**(A*T**2+B*T+C),
+       ;;; 1/SQRT(A*T+B), OR T**K*REST(T)
+       (PROG (AB BASE-OF-FUN POWER RESULT) 
+	     (SETQ BASE-OF-FUN (CADR FUN) POWER (CADDR FUN))
+	     (COND
+	      ((AND
+		(FREEOF VAR BASE-OF-FUN)
+		(SETQ 
+		 AB
+		 (ISQUADRATICP
+		  (COND ((EQ BASE-OF-FUN '$%E) POWER)
+			(T (SIMPTIMES (LIST '(MTIMES)
+					    POWER
+					    (LIST '(%LOG)
+						  BASE-OF-FUN))
+				      1.
+				      NIL)))
+		  VAR)))
+	       (COND ((EQUAL (CAR AB) 0.) (GO %E-CASE-LIN))
+		     ((NULL REST) (GO %E-CASE-QUAD))
+		     (T (GO NOLUCK))))
+	      ((AND (EQ BASE-OF-FUN VAR) (FREEOF VAR POWER))
+	       (GO VAR-CASE))
+	      ((AND (ALIKE1 '((RAT) -1. 2.) POWER) (NULL REST)
+		    (SETQ AB (ISLINEAR BASE-OF-FUN VAR)))
+	       (SETQ RESULT (DIV* (CDR AB) (CAR AB)))
+	       (RETURN (SIMPTIMES
+		(LIST '(MTIMES)
+		      (LIST '(MEXPT)
+			    (DIV* '$%PI
+				  (LIST '(MTIMES)
+					(CAR AB)
+					PARM))
+			    '((RAT) 1. 2.))
+		      (EXPONENTIATE (LIST '(MTIMES) RESULT PARM))
+		      (LIST '(MPLUS)
+			    1.
+			    (LIST '(MTIMES)
+				  -1.
+				   (LIST '(%ERF)
+						 (LIST '(MEXPT)
+						       (LIST '(MTIMES)
+							     RESULT
+							     PARM)
+						       '((RAT)
+							 1.
+							 2.)))
+					   ))) 1 NIL)))
+	      (T (GO NOLUCK)))
+	%E-CASE-LIN
+	     (SETQ 
+	      RESULT
+	      (COND
+	       (REST ($RATSIMP ($AT (LAPTIMES REST)
+				    (LIST '(MEQUAL SIMP)
+					  PARM
+					  (LIST '(MPLUS SIMP)
+						PARM
+						(AFIXSIGN (CADR AB)
+							  NIL))))))
+	       (T (LIST '(MEXPT)
+			(LIST '(MPLUS)
+			      PARM
+			      (AFIXSIGN (CADR AB) NIL))
+			-1.))))
+	     (RETURN (SIMPTIMES (LIST '(MTIMES)
+				      (EXPONENTIATE (CADDR AB))
+				      RESULT)
+				1.
+				NIL))
+	%E-CASE-QUAD
+	     (SETQ RESULT (AFIXSIGN (CAR AB) NIL))
+	     (SETQ 
+	      RESULT
+	       (LIST
+		'(MTIMES)
+		(DIV* (LIST '(MEXPT)
+			    (DIV* '$%PI RESULT)
+			    '((RAT) 1. 2.))
+		      2.)
+		(EXPONENTIATE (DIV* (LIST '(MEXPT) PARM 2.)
+				    (LIST '(MTIMES)
+					  4.
+					  RESULT)))
+		(LIST '(MPLUS)
+		      1.
+		      (LIST '(MTIMES)
+			    -1.
+			     (LIST '(%ERF)
+					   (DIV* PARM
+						 (LIST '(MTIMES)
+						       2.
+						       (LIST '(MEXPT)
+							     RESULT
+							     '((RAT)
+							       1.
+							       2.)))))
+				))))
+	     (AND (NULL (EQUAL (CADR AB) 0.))
+		  (SETQ RESULT
+			(SUBSTITUTE (LIST '(MPLUS)
+					  PARM
+					  (LIST '(MTIMES)
+						-1.
+						(CADR AB)))
+				    PARM
+				    RESULT)))
+	     (RETURN (SIMPTIMES  (LIST '(MTIMES)
+			   (EXPONENTIATE (CADDR AB))
+			   RESULT) 1 NIL))
+	VAR-CASE
+	     (COND ((OR (NULL REST) (FREEOF VAR (FIXUPREST REST)))
+		    (GO VAR-EASY-CASE)))
+	     (COND ((POSINT POWER)
+		    (RETURN (AFIXSIGN (APPLY '$DIFF
+					     (LIST (LAPTIMES REST)
+						   PARM
+						   POWER))
+				      (EVEN POWER))))
+		   ((NEGINT POWER)
+		    (RETURN (MYDEFINT (HACKIT POWER REST)
+				      (CREATENAME PARM (MINUS POWER))
+				      PARM)))
+		   (T (GO NOLUCK)))
+	VAR-EASY-CASE
+	     (SETQ POWER
+		   (SIMPLUS (LIST '(MPLUS) 1 POWER) 1 T))
+	     (OR (EQ (ASKSIGN POWER) '$POSITIVE) (GO NOLUCK))
+	     (SETQ RESULT (LIST (LIST '(%GAMMA) POWER)
+				(LIST '(MEXPT)
+				      PARM
+				      (AFIXSIGN POWER NIL))))
+	     (AND REST (SETQ RESULT (NCONC RESULT REST)))
+	     (RETURN (SIMPTIMES (CONS '(MTIMES) RESULT)
+				1
+				NIL))
+	NOLUCK
+	     (RETURN
+	      (COND
+	       ((AND (POSINT POWER)
+		     (MEMQ (CAAR BASE-OF-FUN)
+			   '(MPLUS %SIN %COS %SINH %COSH)))
+		(LAPTIMES (CONS BASE-OF-FUN
+				(CONS (COND ((= POWER 2.) BASE-OF-FUN)
+					    (T (LIST '(MEXPT SIMP)
+						     BASE-OF-FUN
+						     (SUB1 POWER))))
+				      REST))))
+	       (T (LAPSHIFT FUN REST)))))) 
+
+(DEFUN MYDEFINT (F X A) 
+       ;;;INTEGRAL FROM A TO INFINITY OF F(X)
+       ((LAMBDA (TRYINT) (COND (TRYINT (CAR TRYINT))
+			       (T (LIST '(%INTEGRATE SIMP)
+					F
+					X
+					A
+					'$INF))))
+	(AND (NOT ($UNKNOWN F))
+	     (ERRSET ($DEFINT F X A '$INF))))) 
+
+(DEFUN CREATENAME 
+ ;;;CREATES HOPEFULLY UNIQUE NAMES FOR VARIABLE OF INTEGRATION
+ (HEAD TAIL) 
+ (implode (NCONC (EXPLODEC HEAD) (EXPLODEC TAIL))))
+
+(DECLARE (FIXNUM EXPONENT)) 
+
+(DEFUN HACKIT (EXPONENT REST) 
+       ;;;REDUCES LAPLACE(F(T)/T**N,T,S) CASE TO LAPLACE(F(T)/T**(N-1),T,S) CASE
+       (COND ((EQUAL EXPONENT -1.)
+	      ((LAMBDA (PARM) (LAPTIMES REST)) (CREATENAME PARM 1.)))
+	     (T (MYDEFINT (HACKIT (1+ EXPONENT) REST)
+			  (CREATENAME PARM (DIFFERENCE -1. EXPONENT))
+			  (CREATENAME PARM (MINUS EXPONENT)))))) 
+
+(DECLARE (NOTYPE EXPONENT)) 
+
+(DEFUN AFIXSIGN (FUNCT SIGNSWITCH) 
+       ;;;MULTIPLIES FUNCT BY -1 IF SIGNSWITCH IS NIL
+       (COND (SIGNSWITCH FUNCT)
+	     (T (SIMPTIMES (LIST '(MTIMES) -1. FUNCT) 1. T)))) 
+
+ 
+
+(DEFUN LAPSHIFT (FUN REST) 
+       (COND ((ATOM FUN) (merror "INTERNAL ERROR"))
+	     ((OR (MEMQ 'LAPLACE (CAR FUN)) (NULL REST))
+	      (LAPDEFINT (COND (REST (SIMPTIMES (CONS '(MTIMES)
+					   (CONS FUN REST)) 1 T))
+			       (T FUN))))
+	     (T (LAPTIMES (APPEND REST
+				  (NCONS (CONS (APPEND (CAR FUN)
+						       '(LAPLACE))
+					       (CDR FUN)))))))) 
+
+(DEFUN MOSTPART (F PARM SIGN A B) 
+       ;;;COMPUTES %E**(W*B*%I)*F(S-W*A*%I) WHERE W=-1 IF SIGN IS T ELSE W=1
+       ((LAMBDA (SUBSTINFUN) 
+		(COND ((ZEROP1 B) SUBSTINFUN)
+		      (T (LIST '(MTIMES)
+			       (EXPONENTIATE (AFIXSIGN (LIST '(MTIMES)
+							     B
+							     '$%I)
+						       (NULL SIGN)))
+			       SUBSTINFUN))))
+	($AT F
+	     (LIST '(MEQUAL SIMP)
+		   PARM
+		   (LIST '(MPLUS SIMP)
+			 PARM
+			 (AFIXSIGN (LIST '(MTIMES)
+					 A
+					 '$%I)
+				   SIGN)))))) 
+
+(DEFUN COMPOSE 
+ ;;;IF WHICHSIGN IS NIL THEN SIN TRANSFORM ELSE COS TRANSFORM
+ (FUN PARM WHICHSIGN A B) 
+       ((LAMBDA (RESULT) 
+		($RATSIMP (SIMPTIMES (CONS '(MTIMES)
+					   (COND (WHICHSIGN RESULT)
+						 (T (CONS '$%I
+							  RESULT))))
+				     1 NIL)))
+	(LIST '((RAT) 1. 2.)
+	      (LIST '(MPLUS)
+		    (MOSTPART FUN PARM T A B)
+		    (AFIXSIGN (MOSTPART FUN PARM NIL A B)
+			      WHICHSIGN))))) 
+
+(DEFUN LAPSIN 
+ ;;;FUN IS OF THE FORM SIN(A*T+B)*REST(T) OR COS
+ (FUN REST TRIGSWITCH) 
+       ((LAMBDA (AB) 
+	 (COND
+	  (AB
+	    (COND
+	     (REST (COMPOSE (LAPTIMES REST)
+			    PARM
+			    TRIGSWITCH
+			    (CAR AB)
+			    (CDR AB)))
+	     (T (SIMPTIMES
+	      (LIST
+	       '(MTIMES)
+	       (COND
+		((ZEROP1 (CDR AB))
+		 (COND (TRIGSWITCH PARM) (T (CAR AB))))
+		(T (COND (TRIGSWITCH (LIST '(MPLUS)
+					   (LIST '(MTIMES)
+						 PARM
+						 (LIST '(%COS)
+						       (CDR AB)))
+					   (LIST '(MTIMES)
+						 -1.
+						 (CAR AB)
+						 (LIST '(%SIN)
+						       (CDR AB)))))
+			 (T (LIST '(MPLUS)
+				  (LIST '(MTIMES)
+					PARM
+					(LIST '(%SIN)
+					      (CDR AB)))
+				  (LIST '(MTIMES)
+					(CAR AB)
+					(LIST '(%COS)
+					      (CDR AB))))))))
+	       (LIST '(MEXPT)
+		     (LIST '(MPLUS)
+			   (LIST '(MEXPT) PARM 2.)
+			   (LIST '(MEXPT) (CAR AB) 2.))
+		     -1.))
+	    1 NIL))))
+	  (T (LAPSHIFT FUN REST))))
+	(ISLINEAR (CADR FUN) VAR))) 
+
+(DEFUN LAPSINH 
+ ;;;FUN IS OF THE FORM SINH(A*T+B)*REST(T) OR IS COSH
+ (FUN REST SWITCH) 
+	(COND ((ISLINEAR (CADR FUN) VAR)
+       ($RATSIMP
+	(LAPLUS
+	 (SIMPLUS
+	  (LIST '(MPLUS)
+		(NCONC (LIST '(MTIMES)
+			     (LIST '(MEXPT)
+				   '$%E
+				   (CADR FUN))
+			     '((RAT) 1. 2.))
+		       REST)
+		(AFIXSIGN (NCONC (LIST '(MTIMES)
+				       (LIST '(MEXPT)
+					     '$%E
+					     (AFIXSIGN (CADR FUN)
+						       NIL))
+				       '((RAT) 1. 2.))
+				 REST)
+			  SWITCH))
+	  1.
+	  NIL)))) 
+	(T (LAPSHIFT FUN REST))))
+
+(DEFUN LAPLOG 
+ ;;;FUN IS OF THE FORM LOG(A*T)
+ (FUN) ((LAMBDA (AB) 
+		(COND ((AND AB (ZEROP1 (CDR AB)))
+		       (SIMPTIMES (LIST '(MTIMES)
+					(LIST '(MPLUS)
+					      (subfunmake '$PSI
+							  '(0)
+							  (NCONS 1.))
+					      (LIST '(%LOG)
+						    (CAR AB))
+					      (LIST '(MTIMES)
+						    -1.
+						    (LIST '(%LOG)
+							  PARM)))
+					(LIST '(MEXPT)
+					      PARM
+					      -1.))
+				  1 NIL))
+		      (T (LAPDEFINT FUN))))
+	(ISLINEAR (CADR FUN) VAR))) 
+
+(DEFUN RAISEUP (FBASE EXPONENT) 
+       (COND ((EQUAL EXPONENT 1.) FBASE)
+	     (T (LIST '(MEXPT) FBASE EXPONENT)))) 
+
+(DEFUN LAPDELTA (FUN REST) 
+       ;;TAKES TRANSFORM OF DELTA(A*T+B)*F(T)
+       ((LAMBDA (AB SIGN RECIPA) 
+	 (COND
+	  (AB
+	   (SETQ RECIPA (POWER (CAR AB) -1) AB (DIV (CDR AB) (CAR AB)))
+	   (SETQ SIGN (ASKSIGN AB) RECIPA (SIMPLIFYA (LIST '(MABS) RECIPA) NIL))
+	   (SIMPLIFYA (COND ((EQ SIGN '$POSITIVE) 0)
+			    ((EQ SIGN '$ZERO)
+			     (LIST '(MTIMES)
+				   (SUBSTITUTE 0 VAR (FIXUPREST REST))
+				   RECIPA))
+			    (T (LIST '(MTIMES)
+				     (SUBSTITUTE (NEG AB)
+						 VAR
+						 (FIXUPREST REST))
+				     (LIST '(MEXPT)
+					   '$%E
+					   (CONS '(MTIMES)
+						 (CONS PARM (NCONS AB))))
+				     RECIPA)))
+		      NIL))
+	  (T (LAPSHIFT FUN REST))))
+	(ISLINEAR (CADR FUN) VAR) NIL NIL)) 
+
+(DEFUN LAPERF (FUN  )
+       ((LAMBDA (AB) 
+	 (COND
+	  ((AND AB (EQUAL (CDR AB) 0.))
+	   (SIMPTIMES (LIST '(MTIMES)
+		 (DIV* (EXPONENTIATE (DIV* (LIST '(MEXPT)
+						 PARM
+						 2.)
+					   (LIST '(MTIMES)
+						 4.
+						 (LIST '(MEXPT)
+						       (CAR AB)
+						       2.))))
+		       PARM)
+		 (LIST '(MPLUS)
+		       1.
+		       (LIST '(MTIMES)
+			     -1.
+			      (LIST '(%ERF)
+					    (DIV* PARM
+						  (LIST '(MTIMES)
+							2.
+							(CAR AB))))
+				      ))) 1 NIL))
+	  (T (LAPDEFINT FUN))))
+	(ISLINEAR (CADR FUN) VAR)))
+(DEFUN LAPDEFINT (FUN)
+  (PROG (TRYINT MULT)
+    (AND ($UNKNOWN FUN)(GO SKIP))
+    (SETQ MULT (SIMPTIMES (LIST '(MTIMES) (EXPONENTIATE
+					   (LIST '(MTIMES SIMP) -1 VAR PARM)) FUN) 1 NIL))
+    (MEVAL `(($ASSUME) ,@(LIST (LIST '(MGREATERP) PARM 0))))
+    (SETQ TRYINT (ERRSET ($DEFINT MULT VAR 0 '$INF)))
+    (MEVAL `(($FORGET) ,@(LIST (LIST '(MGREATERP) PARM 0))))
+    (AND TRYINT (NOT (EQ (CAAAR TRYINT) '%INTEGRATE))  (RETURN (CAR TRYINT)))
+   SKIP (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))))
+ 
+
+(DECLARE (FIXNUM ORDER)) 
+
+(DEFUN LAPDIFF 
+ ;;;FUN IS OF THE FORM DIFF(F(T),T,N) WHERE N IS A POSITIVE INTEGER
+ (FUN) (PROG (DIFFLIST DEGREE FRONTEND RESULTLIST NEWDLIST ORDER
+	      ARG2) 
+	     (SETQ NEWDLIST (SETQ DIFFLIST (COPY (CDDR FUN))))
+	     (SETQ ARG2 (LIST '(MEQUAL SIMP) VAR 0.))
+	A    (COND ((NULL DIFFLIST)
+		    (RETURN (CONS '(%DERIVATIVE SIMP)
+				  (CONS (LIST '(%LAPLACE SIMP)
+					      (CADR FUN)
+					      VAR
+					      PARM)
+					NEWDLIST))))
+		   ((EQ (CAR DIFFLIST) VAR)
+		    (SETQ DEGREE (CADR DIFFLIST) 
+			  DIFFLIST (CDDR DIFFLIST))
+		    (GO OUT)))
+	     (SETQ DIFFLIST (CDR (SETQ FRONTEND (CDR DIFFLIST))))
+	     (GO A)
+	OUT  (COND ((NULL (POSINT DEGREE))
+		    (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))))
+	     (COND (FRONTEND (RPLACD FRONTEND DIFFLIST))
+		   (T (SETQ NEWDLIST DIFFLIST)))
+	     (COND (NEWDLIST (SETQ FUN (CONS '(%DERIVATIVE SIMP)
+					     (CONS (CADR FUN)
+						   NEWDLIST))))
+		   (T (SETQ FUN (CADR FUN))))
+	     (SETQ ORDER 0.)
+	LOOP (SETQ DEGREE (1- DEGREE))
+	     (SETQ RESULTLIST
+		   (CONS (LIST '(MTIMES)
+			       (RAISEUP PARM DEGREE)
+			       ($AT ($DIFF FUN VAR ORDER) ARG2))
+			 RESULTLIST))
+	     (SETQ ORDER (1+ ORDER))
+	     (AND (> DEGREE 0.) (GO LOOP))
+	     (SETQ RESULTLIST (COND ((CDR RESULTLIST)
+				     (CONS '(MPLUS)
+					   RESULTLIST))
+				    (T (CAR RESULTLIST))))
+	     (RETURN (SIMPLUS (LIST '(MPLUS)
+				      (LIST '(MTIMES)
+					    (RAISEUP PARM ORDER)
+					    (LAPLACE FUN))
+				      (LIST '(MTIMES)
+					    -1.
+					    RESULTLIST))
+				1 NIL)))) 
+
+(DECLARE (NOTYPE ORDER)) 
+
+(DEFUN LAPINT 
+ ;;;FUN IS OF THE FORM INTEGRATE(F(X)*G(T)*H(T-X),X,0,T)
+ (FUN) (PROG (NEWFUN PARM-LIST F) 
+	     (AND DVAR (GO CONVOLUTION))
+	     (SETQ DVAR (CADR (SETQ NEWFUN (CDR FUN))))
+	     (AND (CDDR NEWFUN)
+		  (ZEROP1 (CADDR NEWFUN))
+		  (EQ (CADDDR NEWFUN) VAR)
+		  (GO CONVOLUTIONTEST))
+	NOTCON
+	     (SETQ NEWFUN (CDR FUN))
+	     (COND ((CDDR NEWFUN)
+		    (COND ((AND (FREEOF VAR (CADDR NEWFUN))
+				(FREEOF VAR (CADDDR NEWFUN)))
+			   (RETURN (LIST '(%INTEGRATE SIMP)
+					 (LAPLACE (CAR NEWFUN))
+					 DVAR
+					 (CADDR NEWFUN)
+					 (CADDDR NEWFUN))))
+			  (T (GO GIVEUP))))
+		   (T (RETURN (LIST '(%INTEGRATE SIMP)
+				    (LAPLACE (CAR NEWFUN))
+				    DVAR))))
+	GIVEUP
+	     (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))
+	CONVOLUTIONTEST
+	     (SETQ NEWFUN ($FACTOR (CAR NEWFUN)))
+	     (COND ((EQ (CAAR NEWFUN) 'MTIMES)
+		    (SETQ F (CADR NEWFUN) NEWFUN (CDDR NEWFUN)))
+		   (T (SETQ F NEWFUN NEWFUN NIL)))
+	GOTHRULIST
+	     (COND ((FREEOF DVAR F)
+		    (SETQ PARM-LIST (CONS F PARM-LIST)))
+		   ((FREEOF VAR F) (SETQ VAR-LIST (CONS F VAR-LIST)))
+		   ((FREEOF DVAR
+			    ($RATSIMP (SUBSTITUTE (LIST '(MPLUS)
+							VAR
+							DVAR)
+						  VAR
+						  F)))
+		    (SETQ VAR-PARM-LIST (CONS F VAR-PARM-LIST)))
+		   (T (GO NOTCON)))
+	     (COND (NEWFUN (SETQ F (CAR NEWFUN) NEWFUN (CDR NEWFUN))
+			   (GO GOTHRULIST)))
+	     (AND
+	      PARM-LIST
+	      (RETURN
+	       (LAPLACE
+		(CONS
+		 '(MTIMES)
+		 (NCONC PARM-LIST
+			(NCONS (LIST '(%INTEGRATE)
+				     (CONS '(MTIMES)
+					   (APPEND VAR-LIST
+						   VAR-PARM-LIST))
+				     DVAR
+				     0
+				     VAR)))))))
+	CONVOLUTION
+	     (RETURN
+	      (SIMPTIMES
+	       (LIST
+		'(MTIMES)
+		(LAPLACE ($EXPAND (SUBSTITUTE VAR
+					      DVAR
+					      (FIXUPREST VAR-LIST))))
+		(LAPLACE
+		 ($EXPAND (SUBSTITUTE 0
+				      DVAR
+				      (FIXUPREST VAR-PARM-LIST)))))
+	       1
+	       T)))) 
+
+(DECLARE (SPECIAL VARLIST RATFORM ILS ILT)) 
+
+(DEFMFUN $ILT (EXP ILS ILT) 
+ ;;;EXP IS F(S)/G(S) WHERE F AND G ARE POLYNOMIALS IN S AND DEGR(F) < DEGR(G)
+	 (LET (VARLIST ($SAVEFACTORS T) CHECKFACTORS $RATFAC $KEEPFLOAT) 
+		;;; MAKES ILS THE MAIN VARIABLE
+		(SETQ VARLIST (LIST ILS))
+		(NEWVAR EXP)
+		(ORDERPOINTER VARLIST)
+		(SETQ VAR (CAADR (RATREP* ILS)))
+		(COND ((MBAGP EXP)
+		       (CONS (CAR EXP)
+		             (MAPCAR #'(LAMBDA (E) ($ILT E ILS ILT)) (CDR EXP))))
+		      ((ZEROP1 EXP) 0)
+		      ((FREEOF ILS EXP) (LIST '(%ILT SIMP) EXP ILS ILT))
+		      (T (ILT0 EXP))))) 
+
+(DEFUN RATIONALP (LE V) 
+       (COND ((NULL LE))
+	     ((AND (NULL (ATOM (CAR LE))) (NULL (FREEOF V (CAR LE))))
+	      NIL)
+	     (T (RATIONALP (CDR LE) V)))) 
+
+(DEFUN ILT0 (EXP) ;; This function does the partial fraction decomposition.
+  (PROG (WHOLEPART FRPART NUM DENOM Y CONTENT REAL FACTOR
+	 APART BPART PARNUMER RATARG RATFORM) 
+	     (IF (MPLUSP EXP)
+		 (RETURN
+		  (ADDN (MAPCAR #'(LAMBDA (E) ($ILT E ILS ILT)) (CDR EXP)) T)))
+	     (AND (NULL (ATOM EXP))
+		  (EQ (CAAR EXP) '%LAPLACE)
+		  (EQ (CADDDR EXP) ILS)
+		  (RETURN (COND ((EQ (CADDR EXP) ILT) (CADR EXP))
+				(T (SUBST ILT (CADDR EXP) (CADR EXP))))))
+	     (SETQ RATARG (RATREP* EXP))
+	     (OR (RATIONALP VARLIST ILS)
+		 (RETURN (LIST '(%ILT SIMP) EXP ILS ILT)))
+	     (SETQ RATFORM (CAR RATARG))
+	     (SETQ DENOM (RATDENOMINATOR (CDR RATARG)))
+	     (SETQ FRPART (PDIVIDE (RATNUMERATOR (CDR RATARG)) DENOM))
+	     (SETQ WHOLEPART (CAR FRPART))
+	     (SETQ FRPART (RATQU (CADR FRPART) DENOM))
+	     (COND ((NOT (ZEROP1 (CAR WHOLEPART)))
+		    (RETURN (LIST '(%ILT SIMP) EXP ILS ILT)))
+		   ((ZEROP1 (CAR FRPART)) (RETURN 0)))
+	     (SETQ NUM (CAR FRPART) DENOM (CDR FRPART))
+	     (SETQ Y (OLDCONTENT DENOM))
+	     (SETQ CONTENT (CAR Y))
+	     (SETQ REAL (CADR Y))
+	     (SETQ FACTOR (PFACTOR REAL))
+	LOOP (COND ((NULL (CDDR FACTOR))
+		    (SETQ APART REAL 
+			  BPART 1 
+			  Y '((0 . 1) 1 . 1))
+		    (GO SKIP)))
+	     (SETQ APART (PEXPT (CAR FACTOR) (CADR FACTOR)))
+	     (SETQ BPART (CAR (RATQU REAL APART)))
+	     (SETQ Y (BPROG APART BPART))
+	SKIP (SETQ FRPART
+		   (CDR (RATDIVIDE (RATTI (RATNUMERATOR NUM)
+					  (CDR Y)
+					  T)
+				   (RATTI (RATDENOMINATOR NUM)
+					  (RATTI CONTENT APART T)
+					  T))))
+	     (SETQ 
+	      PARNUMER
+	      (CONS (ILT1 (RATQU (RATNUMERATOR FRPART)
+				 (RATTI (RATDENOMINATOR FRPART)
+					(RATTI (RATDENOMINATOR NUM)
+					       CONTENT
+					       T)
+					T))
+			  (CAR FACTOR)
+			  (CADR FACTOR))
+		    PARNUMER))
+	     (SETQ FACTOR (CDDR FACTOR))
+	     (COND ((NULL FACTOR)
+		    (RETURN (SIMPLUS (CONS '(MPLUS) PARNUMER)
+				     1
+				     T))))
+	     (SETQ NUM (CDR (RATDIVIDE (RATTI NUM (CAR Y) T)
+				       (RATTI CONTENT BPART T))))
+	     (SETQ REAL BPART)
+	     (GO LOOP))) 
+
+(DECLARE (FIXNUM K) (SPECIAL Q Z)) 
+
+(DEFUN ILT1 (P Q K)
+  ((LAMBDA (Z)
+  (COND ((ONEP1 K) (ILT3 P))
+	(T (SETQ Z (BPROG Q (PDERIVATIVE Q VAR)))(ILT2 P K)))) NIL))
+
+(DEFUN ILT2 
+ ;;;INVERTS P(S)/Q(S)**K WHERE Q(S)  IS IRREDUCIBLE
+ ;;;DOESN'T CALL ILT3 IF Q(S) IS LINEAR
+  (P K)
+       (PROG (Y A B) 
+		(AND (ONEP1 K)(RETURN (ILT3 P)))
+		(SETQ K (1- K))
+	     (SETQ A (RATTI P (CAR Z) T))
+	     (SETQ B (RATTI P (CDR Z) T))
+	     (SETQ Y (PEXPT Q K))
+	     (COND
+	      ((OR (NULL (EQUAL (PDEGREE Q VAR) 1.))
+		   (> (PDEGREE (CAR P) VAR) 0.))
+	       (RETURN
+		(SIMPLUS
+		 (LIST
+		  '(MPLUS)
+		  (ILT2
+		   (CDR (RATDIVIDE (RATPLUS A
+					    (RATQU (RATDERIVATIVE B
+								  VAR)
+						   K))
+				   Y))
+		   K)
+		  ($MULTTHRU (SIMPTIMES (LIST '(MTIMES)
+				   ILT
+				   (POWER K -1)
+				   (ILT2 (CDR (RATDIVIDE B Y)) K))
+			     1.
+			     T)))
+		 1.
+		 T))))
+	     (SETQ A (DISREP (POLCOEF Q 1.)) 
+		   B (DISREP (POLCOEF Q 0.)))
+	     (RETURN
+	      (SIMPTIMES (LIST '(MTIMES)
+			       (DISREP P)
+			       (RAISEUP ILT K)
+			       (SIMPEXPT (LIST '(MEXPT)
+					       '$%E
+					       (LIST '(MTIMES)
+						     -1.
+						     ILT
+						     B
+						     (LIST '(MEXPT)
+							   A
+							   -1.)))
+					 1.
+					 NIL)
+			       (LIST '(MEXPT)
+				     A
+				     (DIFFERENCE -1. K))
+			       (LIST '(MEXPT)
+				     (FACTORIAL K)
+				     -1.))
+			 1.
+			 NIL)))) 
+
+(DECLARE (NOTYPE K)) 
+
+(DEFUN COEF MACRO (POL) (SUBST (CADR POL) (QUOTE DEG)
+  '(DISREP (RATQU (POLCOEF (CAR P) DEG) (CDR P)))))
+
+(DEFUN LAPSUM N (CONS '(MPLUS)(LISTIFY N)))
+(DEFUN LAPPROD N (CONS '(MTIMES)(LISTIFY N)))
+(DEFUN EXPO N (CONS '(MEXPT)(LISTIFY N)))
+(DEFUN ILT3 
+ ;;;INVERTS P(S)/Q(S) WHERE Q(S) IS IRREDUCIBLE
+ (P ) (PROG (DISCRIM SIGN A C D E B1 B0 R TERM1 TERM2 DEGR) 
+	     (SETQ E (DISREP (POLCOEF Q 0.)) 
+		   D (DISREP (POLCOEF Q 1.)) 
+		   DEGR (PDEGREE Q VAR))
+	      (AND (EQUAL DEGR 1.)
+	       (RETURN
+		(SIMPTIMES (LAPPROD
+				 (DISREP P)
+				 (EXPO D -1.)
+				 (EXPO
+				       '$%E
+				       (LAPPROD
+					     -1.
+					     ILT
+					     E
+					     (EXPO
+						   D
+						   -1.))))
+			   1.
+			   NIL)))
+		(SETQ C (DISREP (POLCOEF Q 2)))
+	      (AND (EQUAL DEGR 2.) (GO QUADRATIC))
+	      (AND (EQUAL DEGR 3.) (ZEROP1 C) (ZEROP1 D)
+	       (GO CUBIC))
+	(RETURN (LIST '(%ILT SIMP) (DIV* (DISREP P)(DISREP Q)) ILS ILT))
+	CUBIC (SETQ  A (DISREP (POLCOEF Q 3))
+		R (SIMPNRT (DIV* E A) 3))
+		(SETQ D (DIV* (DISREP P)(LAPPROD A (LAPSUM
+			(EXPO ILS 3)(EXPO '%R 3)))))
+		(RETURN (ILT0 (SUBSTITUTE R '%R ($PARTFRAC D ILS))))
+	QUADRATIC (SETQ B0 (COEF 0) B1 (COEF 1))
+
+	     (SETQ DISCRIM
+		   (SIMPLUS (LAPSUM
+				  (LAPPROD
+					4.
+					E
+					C)
+				  (LAPPROD -1. D D))
+			    1.
+			    NIL))
+	     (SETQ SIGN (COND ((FREE DISCRIM '$%I) (ASKSIGN DISCRIM)) (T '$POSITIVE)) 
+		   TERM1 '(%COS) 
+		   TERM2 '(%SIN))
+	(SETQ DEGR (EXPO '$%E (LAPPROD ILT D (POWER C -1) '((RAT SIMP) -1 2))))
+	     (COND ((EQ SIGN '$ZERO)
+		    (RETURN (SIMPTIMES (LAPPROD DEGR (LAPSUM (DIV* B1 C)(LAPPROD
+		(DIV* (LAPSUM (LAPPROD 2 B0 C)(LAPPROD -1 B1 D))
+		(LAPPROD 2 C C)) ILT))) 1 NIL))
+)		   ((EQ SIGN '$NEGATIVE)
+		    (SETQ TERM1 '(%COSH) 
+			  TERM2 '(%SINH) 
+			  DISCRIM (SIMPTIMES (LAPPROD
+						   -1.
+						   DISCRIM)
+					     1.
+					     T))))
+	     (SETQ DISCRIM (SIMPNRT DISCRIM 2))
+	     (SETQ 
+	      SIGN
+	      (SIMPTIMES
+	       (LAPPROD
+		     (LAPSUM
+			   (LAPPROD
+				 2.
+				 B0
+				 C)
+			   (LAPPROD
+				 -1.
+				 B1
+				 D))
+		     (EXPO DISCRIM -1.))
+	       1.
+	       NIL))
+	     (SETQ C (POWER C -1))
+	     (SETQ DISCRIM (SIMPTIMES (LAPPROD
+					    DISCRIM
+					    ILT
+					    '((RAT SIMP) 1. 2.)
+					    C)
+				      1.
+				      T))
+	     (RETURN
+	      (SIMPTIMES
+	       (LAPPROD
+		     C
+		     DEGR
+		     (LAPSUM
+			   (LAPPROD
+				 B1
+				 (LIST TERM1 DISCRIM))
+			   (LAPPROD
+				 SIGN
+				 (LIST TERM2 DISCRIM))))
+	       1.
+	       NIL)))) 
+
+(DECLARE (UNSPECIAL DVAR ILS ILT NOUNL PARM Q RATFORM VAR VARLIST
+		    VAR-LIST VAR-PARM-LIST Z))
+

src/maxsrc/ldisp.43

@@ -0,0 +1,100 @@
+;;; -*- LISP -*-
+;;; Auxiliary DISPLA package for doing 1-D display
+;;;
+;;; (c) 1979 Massachusetts Institute of Technology
+;;;
+;;; See KMP for details
+
+(DECLARE (*EXPR MSTRING STRIPDOLLAR)
+	 (SPECIAL LINEAR-DISPLAY-BREAK-TABLE FORTRANP))
+
+#-LISPM
+(EVAL-WHEN (EVAL COMPILE)
+	   (SSTATUS MACRO /# '+INTERNAL-/#-MACRO SPLICING))
+
+;;; (LINEAR-DISPLA <thing-to-display>)
+;;;
+;;; Display text linearly. This function should be usable in any case
+;;;  DISPLA is usable and will attempt to do something reasonable with
+;;;  its input.
+
+(DEFUN LINEAR-DISPLA (X)
+       (TERPRI)
+       (COND ((NOT (ATOM X))
+	      (COND ((EQ (CAAR X) 'MLABLE)
+		     (COND ((CADR X)
+			    (PRIN1 (LIST (STRIPDOLLAR (CADR X))))
+			    (TYO 32.)))
+		     (LINEAR-DISPLA1 (CADDR X) (CHARPOS T)))
+		    ((EQ (CAAR X) 'MTEXT)
+		     (DO ((X (CDR X) (CDR X))
+			  (FORTRANP))			; Atoms in MTEXT
+			 ((NULL X))			;  should omit ?'s
+			 (SETQ FORTRANP (ATOM (CAR X)))
+			 (LINEAR-DISPLA1 (CAR X) 0.)
+			 (TYO 32.)))
+		    (T
+		     (LINEAR-DISPLA1 X 0.))))
+	     (T
+	      (LINEAR-DISPLA1 X 0.)))
+        (TERPRI))
+
+;;; LINEAR-DISPLAY-BREAK-TABLE
+;;;  Table entries have the form (<char> . <illegal-predecessors>)
+;;;
+;;;  The linear display thing will feel free to break BEFORE any
+;;;  of these <char>'s unless they are preceded by one of the
+;;;  <illegal-predecessor> characters.
+
+(SETQ LINEAR-DISPLAY-BREAK-TABLE
+      '((#/= #/: #/=)
+	(#/( #/( #/[)
+	(#/) #/) #/])
+	(#/[ #/( #/[)
+	(#/] #/) #/])
+	(#/: #/:)
+	(#/+ #/E #/B)
+	(#/- #/E #/B)
+	(#/* #/*)
+	(#/^)))
+	
+;;; (FIND-NEXT-BREAK <list-of-fixnums>)
+;;;   Tells how long it will be before the next allowable
+;;;   text break in a list of chars.
+
+(DEFUN FIND-NEXT-BREAK (L)
+       (DO ((I 0. (1+ I))
+	    (TEMP)
+	    (L L (CDR L)))
+	   ((NULL L) I)
+	   (COND ((MEMBER (CAR L) '(#\SPACE #/,)) (RETURN I))
+		 ((AND (SETQ TEMP (ASSQ (CADR L) LINEAR-DISPLAY-BREAK-TABLE))
+		       (NOT (MEMQ (CAR L) (CDR TEMP))))
+		  (RETURN I)))))
+
+;;; (LINEAR-DISPLA1 <object> <indent-level>)
+;;;  Displays <object> as best it can on this line.
+;;;  If atom is too long to go on line, types # and a carriage return.
+;;;  If end of line is found and an elegant break is seen 
+;;;   (see FIND-NEXT-BREAK), it will type a carriage return and indent
+;;;   <indent-level> spaces.
+
+(DEFUN LINEAR-DISPLA1 (X INDENT)
+       (LET ((CHARS (MSTRING X)))
+	    (DO ((END-COLUMN  (- (LINEL T) 3.))
+		 (CHARS CHARS (CDR CHARS))
+		 (I (CHARPOS T) (1+ I))
+		 (J (FIND-NEXT-BREAK CHARS) (1- J)))
+		((NULL CHARS) T)
+		(TYO (CAR CHARS))
+		(COND ((< J 1)
+		       (SETQ J (FIND-NEXT-BREAK (CDR CHARS)))
+		       (COND ((> (+ I J) END-COLUMN)
+			      (TERPRI)
+			      (DO ((I 0. (1+ I))) ((= I INDENT)) (TYO 32.))
+			      (SETQ I INDENT))))
+		      ((= I END-COLUMN)
+		       (PRINC '/#)
+		       (TERPRI)
+		       (SETQ I -1.))))))
+

src/maxsrc/mdot.94

@@ -0,0 +1,379 @@
+;; -*- Mode: Lisp; Package: Macsyma -*-
+;; (c) Copyright 1982 Massachusetts Institute of Technology 
+
+;; Non-commutative product and exponentiation simplifier
+;; Written:	July 1978 by CWH
+
+;; Flags to control simplification:
+
+(macsyma-module mdot)
+
+(DEFMVAR $DOTCONSTRULES T
+	 "Causes a non-commutative product of a constant and
+another term to be simplified to a commutative product.  Turning on this
+flag effectively turns on DOT0SIMP, DOT0NSCSIMP, and DOT1SIMP as well.")
+
+(DEFMVAR $DOT0SIMP T
+	 "Causes a non-commutative product of zero and a scalar term to
+be simplified to a commutative product.")
+
+(DEFMVAR $DOT0NSCSIMP T
+	 "Causes a non-commutative product of zero and a nonscalar term
+to be simplified to a commutative product.")
+
+(DEFMVAR $DOT1SIMP T
+	"Causes a non-commutative product of one and another term to be
+simplified to  a commutative product.")
+
+(DEFMVAR $DOTSCRULES NIL
+	 "Causes a non-commutative product of a scalar and another term to
+be simplified to a commutative product.  Scalars and constants are carried
+to the front of the expression.")
+
+(DEFMVAR $DOTDISTRIB NIL
+	 "Causes every non-commutative product to be expanded each time it
+is simplified, i.e.  A . (B + C) will simplify to A . B + A . C.")
+
+(DEFMVAR $DOTEXPTSIMP T "Causes A . A to be simplified to A ^^ 2.")
+
+(DEFMVAR $DOTASSOC T
+	 "Causes a non-commutative product to be considered associative, so
+that A . (B . C) is simplified to A . B . C.  If this flag is off, dot is
+taken to be right associative, i.e.  A . B . C is simplified to A . (B . C).")
+
+(DEFMVAR $DOALLMXOPS T
+	 "Causes all operations relating to matrices (and lists) to be
+carried out.  For example, the product of two matrices will actually be
+computed rather than simply being returned.  Turning on this switch
+effectively turns on the following three.")
+
+(DEFMVAR $DOMXMXOPS T "Causes matrix-matrix operations to be carried out.")
+
+(DEFMVAR $DOSCMXOPS NIL "Causes scalar-matrix operations to be carried out.")
+
+(DEFMVAR $DOMXNCTIMES NIL
+	 "Causes non-commutative products of matrices to be carried out.")
+
+(DEFMVAR $SCALARMATRIXP T
+	 "Causes a square matrix of dimension one to be converted to a
+scalar, i.e. its only element.")
+
+(DEFMVAR $DOTIDENT 1 "The value to be returned by X^^0.")
+
+(DEFMVAR $ASSUMESCALAR T
+	 "This governs whether unknown expressions 'exp' are assumed to behave
+like scalars for combinations of the form 'exp op matrix' where op is one of
+{+, *, ^, .}.  It has three settings:
+
+FALSE -- such expressions behave like non-scalars.
+TRUE  -- such expressions behave like scalars only for the commutative
+	 operators but not for non-commutative multiplication.
+ALL   -- such expressions will behave like scalars for all operators
+	 listed above.
+
+Note:  This switch is primarily for the benefit of old code.  If possible,
+you should declare your variables to be SCALAR or NONSCALAR so that there
+is no need to rely on the setting of this switch.")
+
+;; Specials defined elsewhere.
+
+(DECLARE (SPECIAL $EXPOP $EXPON ; Controls behavior of EXPAND
+		  SIGN		; Something to do with BBSORT1
+		  )
+	 (FIXNUM $EXPOP $EXPON)
+	 (*EXPR FIRSTN $IDENT POWERX MXORLISTP1 ONEP1
+		SCALAR-OR-CONSTANT-P EQTEST BBSORT1 OUTERMAP1 TIMEX))
+
+(defun simpnct (exp vestigial simp-flag) 
+ vestigial ;ignored
+ (let ((check exp)
+       (first-factor (simpcheck (cadr exp) simp-flag))
+       (remainder (if (cdddr exp)
+		      (ncmuln (cddr exp) simp-flag)
+		      (simpcheck (caddr exp) simp-flag))))
+      (cond ((null (cdr exp)) $dotident)
+	    ((null (cddr exp)) first-factor)
+
+;  This does (. sc m) --> (* sc m)  and  (. (* sc m1) m2) --> (* sc (. m1 m2))
+;  and (. m1 (* sc m2)) --> (* sc (. m1 m2)) where sc can be a scalar
+;  or constant, and m1 and m2 are non-constant, non-scalar expressions.
+
+	    ((commutative-productp first-factor remainder)
+	     (mul2 first-factor remainder))
+	    ((product-with-inner-scalarp first-factor)
+	     (let ((p-p (partition-product first-factor)))
+		  (outer-constant (car p-p) (cdr p-p) remainder)))
+	    ((product-with-inner-scalarp remainder)
+	     (let ((p-p (partition-product remainder)))
+		  (outer-constant (car p-p) first-factor (cdr p-p))))
+
+;  This code does distribution when flags are set and when called by
+;  $EXPAND.  The way we recognize if we are called by $EXPAND is to look at
+;  the value of $EXPOP, but this is a kludge since $EXPOP has nothing to do
+;  with expanding (. A (+ B C)) --> (+ (. A B) (. A C)).  I think that
+;  $EXPAND wants to have two flags:  one which says to convert
+;  exponentiations to repeated products, and another which says to
+;  distribute products over sums.
+
+	    ((and (mplusp first-factor) (or $dotdistrib (not (zerop $expop))))
+	     (addn (mapcar #'(lambda (x) (ncmul x remainder))
+			   (cdr first-factor))
+		   t))
+	    ((and (mplusp remainder) (or $dotdistrib (not (zerop $expop))))
+	     (addn (mapcar #'(lambda (x) (ncmul first-factor x))
+			   (cdr remainder))
+		   t))
+
+;  This code carries out matrix operations when flags are set.
+
+	    ((matrix-matrix-productp first-factor remainder)
+	     (timex first-factor remainder))
+	    ((or (scalar-matrix-productp first-factor remainder)
+		 (scalar-matrix-productp remainder first-factor))
+	     (simplifya (outermap1 'mnctimes first-factor remainder) t))
+
+;  (. (^^ x n) (^^ x m)) --> (^^ x (+ n m))
+
+	    ((and (simpnct-alike first-factor remainder) $dotexptsimp)
+	     (simpnct-merge-factors first-factor remainder))
+
+;  (. (. x y) z) --> (. x y z)
+
+	    ((and (mnctimesp first-factor) $dotassoc)
+	     (ncmuln (append (cdr first-factor)
+			     (if (mnctimesp remainder)
+				 (cdr remainder)
+				 (ncons remainder)))
+		     t))
+
+;  (. (^^ (. x y) m) (^^ (. x y) n) z) --> (. (^^ (. x y) m+n) z)
+;  (. (^^ (. x y) m) x y z) --> (. (^^ (. x y) m+1) z)
+;  (. x y (^^ (. x y) m) z) --> (. (^^ (. x y) m+1) z)
+;  (. x y x y z) --> (. (^^ (. x y) 2) z)
+
+	    ((and (mnctimesp remainder) $dotassoc $dotexptsimp)
+	     (setq exp (simpnct-merge-product first-factor (cdr remainder)))
+	     (if (and (mnctimesp exp) $dotassoc)
+		 (simpnct-antisym-check (cdr exp) check)
+		 (eqtest exp check)))
+
+;  (. x (. y z)) --> (. x y z)
+
+	    ((and (mnctimesp remainder) $dotassoc)
+	     (simpnct-antisym-check (cons first-factor (cdr remainder)) check))
+
+	    (t (eqtest (list '(mnctimes) first-factor remainder) check)))))
+
+;  Predicate functions for simplifying a non-commutative product to a
+;  commutative one.  SIMPNCT-CONSTANTP actually determines if a term is a
+;  constant and is not a nonscalar, i.e. not declared nonscalar and not a
+;  constant list or matrix.  The function CONSTANTP determines if its argument
+;  is a number or a variable declared constant.
+
+(defun commutative-productp (first-factor remainder)
+       (or (simpnct-sc-or-const-p first-factor)
+	   (simpnct-sc-or-const-p remainder)
+	   (simpnct-onep first-factor)
+	   (simpnct-onep remainder)
+	   (zero-productp first-factor remainder)
+	   (zero-productp remainder first-factor)))
+
+(defun simpnct-sc-or-const-p (term)
+  (or (simpnct-constantp term) (simpnct-assumescalarp term)))
+
+(defun simpnct-constantp (term)
+       (and $dotconstrules
+	    (or (mnump term)
+		(and ($constantp term) (not ($nonscalarp term))))))
+
+(defun simpnct-assumescalarp (term)
+       (and $dotscrules (scalar-or-constant-p term (eq $assumescalar '$all))))
+
+(defun simpnct-onep (term) (and $dot1simp (onep1 term)))
+	
+(defun zero-productp (one-term other-term)
+       (and (zerop1 one-term)
+	    $dot0simp
+	    (or $dot0nscsimp (not ($nonscalarp other-term)))))
+
+;  This function takes a form and determines if it is a product 
+;  containing a constant or a declared scalar.  Note that in the
+;  next three functions, the word "scalar" is used to refer to a constant
+;  or a declared scalar.  This is a bad way of doing things since we have
+;  to cdr down an expression twice: once to determine if a scalar is there
+;  and once again to pull it out.
+
+(defun product-with-inner-scalarp (product)
+       (and (mtimesp product)
+	    (or $dotconstrules $dotscrules)
+	    (do ((factor-list (cdr product) (cdr factor-list)))
+		((null factor-list) nil)
+		(if (simpnct-sc-or-const-p (car factor-list))
+		    (return t)))))
+
+;  This function takes a commutative product and separates it into a scalar
+;  part and a non-scalar part.
+
+(defun partition-product (product)
+       (do ((factor-list (cdr product) (cdr factor-list))
+	    (scalar-list nil)
+	    (nonscalar-list nil))
+	   ((null factor-list) (cons (nreverse scalar-list)
+				     (muln (nreverse nonscalar-list) t)))
+	   (if (simpnct-sc-or-const-p (car factor-list))
+	       (push (car factor-list) scalar-list)
+	       (push (car factor-list) nonscalar-list))))
+
+;  This function takes a list of constants and scalars, and two nonscalar
+;  expressions and forms a non-commutative product of the nonscalar
+;  expressions, and a commutative product of the constants and scalars and
+;  the non-commutative product.
+
+(defun outer-constant (constant nonscalar1 nonscalar2)
+       (muln (nconc constant (ncons (ncmul nonscalar1 nonscalar2))) t))
+
+(defun simpnct-base (term) (if (mncexptp term) (cadr term) term))
+
+(defun simpnct-power (term) (if (mncexptp term) (caddr term) 1))
+
+(defun simpnct-alike (term1 term2)
+       (alike1 (simpnct-base term1) (simpnct-base term2)))
+
+(defun simpnct-merge-factors (term1 term2)
+       (ncpower (simpnct-base term1)
+		(add2 (simpnct-power term1) (simpnct-power term2))))
+
+(defun matrix-matrix-productp (term1 term2)
+       (and (or $doallmxops $domxmxops $domxnctimes)
+	    (mxorlistp1 term1)
+	    (mxorlistp1 term2)))
+
+(defun scalar-matrix-productp (term1 term2)
+       (and (or $doallmxops $doscmxops)
+	    (mxorlistp1 term1)
+	    (scalar-or-constant-p term2 (eq $assumescalar '$all))))
+
+(declare (muzzled t))
+
+(defun simpncexpt (exp vestigial simp-flag)
+  vestigial ;ignored
+  (let ((factor (simpcheck (cadr exp) simp-flag))
+	(power (simpcheck (caddr exp) simp-flag))
+	(check exp))
+       (twoargcheck exp)
+       (cond ((zerop1 power)
+	      (if (mxorlistp1 factor) (identitymx factor) $dotident))
+	     ((onep1 power) factor)
+	     ((simpnct-sc-or-const-p factor) (power factor power))
+	     ((and (zerop1 factor) $dot0simp) factor)
+	     ((and (onep1 factor) $dot1simp) factor)
+	     ((and (or $doallmxops $domxmxops) (mxorlistp1 factor))
+	      (let (($scalarmatrixp (or ($listp factor) $scalarmatrixp)))
+		   (simplify (powerx factor power))))
+
+	     ;; This does (A+B)^^2 --> A^^2 + A.B + B.A + B^^2
+	     ;; and (A.B)^^2 --> A.B.A.B
+
+	     ((and (or (mplusp factor)
+		       (and (not $dotexptsimp) (mnctimesp factor)))
+		   (fixp power)
+		   (not (greaterp power $expop))
+		   (plusp power))
+	      (ncmul factor (ncpower factor (1- power))))
+
+	     ;; This does the same thing as above for (A+B)^^(-2)
+	     ;; and (A.B)^^(-2).  Here the "-" operator does the trick
+	     ;; for us.
+
+	     ((and (or (mplusp factor)
+		       (and (not $dotexptsimp) (mnctimesp factor)))
+		   (fixp power)
+		   (not (greaterp (minus power) $expon))
+		   (minusp power))
+	      (ncmul (simpnct-invert factor) (ncpower factor (1+ power))))
+	     ((product-with-inner-scalarp factor)
+	      (let ((p-p (partition-product factor)))
+		   (mul2 (power (muln (car p-p) t) power)
+			 (ncpower (cdr p-p) power))))
+	     ((and $dotassoc (mncexptp factor))
+	      (ncpower (cadr factor) (mul2 (caddr factor) power)))
+	     (t (eqtest (list '(mncexpt) factor power) check)))))
+
+(declare (muzzled nil))
+
+(defun simpnct-invert (exp)
+       (cond ((mnctimesp exp)
+	      (ncmuln (nreverse (mapcar #'simpnct-invert (cdr exp))) t))
+	     ((and (mncexptp exp) (fixp (caddr exp)))
+	      (ncpower (cadr exp) (minus (caddr exp))))
+	     (t (list '(mncexpt simp) exp -1))))
+
+(defun identitymx (x)
+ (if (and ($listp (cadr x)) (= (length (cdr x)) (length (cdadr x))))
+     (simplifya (cons (car x) (cdr ($ident (length (cdr x))))) t)
+     $dotident))
+
+;  This function incorporates the hairy search which enables such
+;  simplifications as (. a b a b) --> (^^ (. a b) 2).  It assumes
+;  that FIRST-FACTOR is not a dot product and that REMAINDER is.
+;  For the product (. a b c d e), three basic types of comparisons
+;  are done:
+;   
+;  1)  a <---> b		first-factor <---> inner-product
+;      a <---> (. b c)
+;      a <---> (. b c d)
+;      a <---> (. b c d e)	(this case handled in SIMPNCT)
+;   
+;  2) (. a b) <---> c		outer-product <---> (car rest)
+;     (. a b c) <---> d
+;     (. a b c d) <---> e
+;   
+;  3) (. a b) <---> (. c d)	outer-product <---> (firstn rest)
+;   
+;  Note that INNER-PRODUCT and OUTER-PRODUCT share list structure which
+;  is clobbered as new terms are added.
+
+(defun simpnct-merge-product (first-factor remainder)
+  (let ((half-product-length (// (1+ (length remainder)) 2))
+	(inner-product (car remainder))
+	(outer-product (list '(mnctimes) first-factor (car remainder))))
+       (do ((merge-length 2 (1+ merge-length))
+	    (rest (cdr remainder) (cdr rest)))
+	   ((null rest) outer-product)
+	   (cond ((simpnct-alike first-factor inner-product)
+		  (return
+		   (ncmuln
+		    (cons (simpnct-merge-factors first-factor inner-product)
+			  rest)
+		    t)))
+		 ((simpnct-alike outer-product (car rest))
+		  (return
+		   (ncmuln
+		    (cons (simpnct-merge-factors outer-product (car rest))
+			  (cdr rest))
+		    t)))
+		 ((and (not (> merge-length half-product-length))
+		       (alike1 outer-product
+			       (cons '(mnctimes)
+				     (firstn merge-length rest))))
+		  (return
+		   (ncmuln (cons (ncpower outer-product 2)
+				 (nthcdr merge-length rest))
+			   t)))
+		 ((= merge-length 2)
+		  (setq inner-product
+			(cons '(mnctimes) (cddr outer-product)))))
+	   (rplacd (last inner-product) (ncons (car rest))))))
+
+(defun simpnct-antisym-check (l check)
+  (let (sign)
+       (cond ((and (get 'mnctimes '$antisymmetric) (cddr l))
+	      (setq l (bbsort1 l))
+	      (cond ((equal l 0) 0)
+		    ((prog1 (null sign)
+			    (setq l (eqtest (cons '(mnctimes) l) check)))
+		     l)
+		    (t (neg l))))
+	     (t (eqtest (cons '(mnctimes) l) check)))))
+
+(declare (unspecial sign))

src/maxsrc/merror.47

@@ -0,0 +1,252 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module merror)
+
+;;; Macsyma error signalling. 
+;;; 2:08pm  Tuesday, 30 June 1981 George Carrette.
+
+(DEFMVAR $ERROR '((MLIST SIMP) |&No error.|)
+  "During an error break this is bound to a list
+  of the arguments to the call to ERROR, with the message
+  text in a compact format.")
+
+(DEFMVAR $ERRORMSG 'T
+  "If FALSE then NO error message is printed!")
+
+(DEFMFUN $ERROR (&REST L)
+  "Signals a Macsyma user error."
+  (apply #'merror (fstringc L)))
+
+(DEFMVAR $ERROR_SIZE 10.
+  "Expressions greater in some size measure over this value
+  are replaced by symbols {ERREXP1, ERREXP2,...} in the error
+  display, the symbols being set to the expressions, so that one can
+  look at them with expression editing tools. The default value of
+  this variable may be determined by factors of terminal speed and type.")
+
+(DECLARE (FIXNUM (ERROR-SIZE NIL)))
+
+(DEFUN ERROR-SIZE (EXP)
+  (IF (ATOM EXP) 0
+      (DO ((L (CDR EXP) (CDR L))
+	   (N 1 (1+ (+ N (ERROR-SIZE (CAR L))))))
+	  ((OR (NULL L)
+	       ;; no need to go any further, and this will save us
+	       ;; from circular structures. (Which they display
+	       ;; package would have a hell of a time with too.)
+	       (> N $ERROR_SIZE))
+	   N)
+	(DECLARE (FIXNUM N)))))
+
+;;; Problem: Most macsyma users do not take advantage of break-points
+;;; for debugging. Therefore they need to have the error variables
+;;; SET (as the old ERREXP was), and not PROGV bound. The problem with
+;;; this is that recursive errors will bash the old value of the
+;;; error variables. However, since we do bind the value of the
+;;; variable $ERROR, calling the function $ERRORMSG will always
+;;; set things back. It would be better to bind these variables,
+;;; for, amoung other things, then the values could get garbage 
+;;; collected.
+
+(DEFMFUN MERROR (STRING &REST L)
+  (SETQ STRING (CHECK-OUT-OF-CORE-STRING STRING))
+  (LET (($ERROR `((MLIST) ,STRING ,@L)))
+    (AND $ERRORMSG ($ERRORMSG))
+    (ERROR #+(OR LISPM NIL) STRING)))
+
+#+LISPM
+;; This tells the error handler to report the context of
+;; the error as the function that called MERROR, instead of
+;; saying that the error was in MERROR.
+(DEFPROP MERROR T :ERROR-REPORTER)
+
+(DEFMVAR $ERROR_SYMS '((MLIST) $ERREXP1 $ERREXP2 $ERREXP3)
+  "Symbols to bind the too-large error expresssions to")
+
+(DEFUN ($ERROR_SYMS ASSIGN) (VAR VAL)
+  (IF (NOT (AND ($LISTP VAL)
+		(DO ((L (CDR VAL) (CDR L)))
+		    ((NULL L) (RETURN T))
+		  (IF (NOT (SYMBOLP (CAR L))) (RETURN NIL)))))
+      (MERROR "The variable ~M being set to ~M which is not a list of symbols."
+	      VAR VAL)))
+
+(DEFUN PROCESS-ERROR-ARGL (L)
+  ;; This returns things so that we could set or bind.
+  (DO ((ERROR-SYMBOLS NIL)
+       (ERROR-VALUES NIL)
+       (NEW-ARGL NIL)
+       (SYMBOL-NUMBER 0))
+      ((NULL L)
+       (LIST (NREVERSE ERROR-SYMBOLS)
+	     (NREVERSE ERROR-VALUES)
+	     (NREVERSE NEW-ARGL)))
+    (LET ((FORM (POP L)))
+      (COND ((> (ERROR-SIZE FORM) $ERROR_SIZE)
+	     (SETQ SYMBOL-NUMBER (1+ SYMBOL-NUMBER))
+	     (LET ((SYM (NTHCDR SYMBOL-NUMBER $ERROR_SYMS)))
+	       (COND (SYM
+		      (SETQ SYM (CAR SYM)))
+		     ('ELSE
+		      (SETQ SYM (CONCAT '$ERREXP SYMBOL-NUMBER))
+		      (SETQ $ERROR_SYMS (APPEND $ERROR_SYMS (LIST SYM)))))
+	       (PUSH SYM ERROR-SYMBOLS)
+	       (PUSH FORM ERROR-VALUES)
+	       (PUSH SYM NEW-ARGL)))
+	    ('ELSE
+	     (PUSH FORM NEW-ARGL))))))
+
+(DEFMFUN $ERRORMSG ()
+  "ERRORMSG() redisplays the error message while in an error break."
+  ;; Don't optimize out call to PROCESS-ERROR-ARGL in case of
+  ;; multiple calls to $ERRORMSG, because the user may have changed
+  ;; the values of the special variables controling its behavior.
+  ;; The real expense here is when MFORMAT calls the DISPLA package.
+  (LET ((THE-JIG (PROCESS-ERROR-ARGL (CDDR $ERROR))))
+    (MAPC #'SET (CAR THE-JIG) (CADR THE-JIG))
+    (CURSORPOS 'A #-LISPM NIL)
+    (LET ((ERRSET NIL))
+      (IF (NULL (ERRSET
+		 (LEXPR-FUNCALL #'MFORMAT NIL (CADR $ERROR) (CADDR THE-JIG))))
+	  (MTELL "~%** Error while printing error message **~%~A~%"
+		 (CADR $ERROR)
+		 )))
+    (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI)))
+  '$DONE)
+
+(DEFMFUN READ-ONLY-ASSIGN (VAR VAL)
+  (IF MUNBINDP
+      'MUNBINDP
+      (MERROR "Attempting to assign read-only variable ~:M the value:~%~M"
+	      VAR VAL)))
+
+(DEFPROP $ERROR READ-ONLY-ASSIGN ASSIGN)
+
+
+;; THIS THROWS TO  (*CATCH 'RATERR ...), WHEN A PROGRAM ANTICIPATES
+;; AN ERROR (E.G. ZERO-DIVIDE) BY SETTING UP A CATCH  AND SETTING
+;; ERRRJFFLAG TO T.  Someday this will be replaced with SIGNAL.
+;; Such skill with procedure names!  I'd love to see how he'd do with
+;; city streets.
+
+;;; N.B. I think the above comment is by CWH, this function used
+;;; to be in RAT;RAT3A. Its not a bad try really, one of the better
+;;; in macsyma. Once all functions of this type are rounded up
+;;; I'll see about implementing signaling. -GJC
+
+(DEFMFUN ERRRJF N
+  (IF ERRRJFFLAG (*THROW 'RATERR NIL) (APPLY #'MERROR (LISTIFY N))))
+
+;;; The user-error function is called on |&foo| "strings" and expressions.
+;;; Cons up a format string so that $ERROR can be bound.
+;;; This might also be done at code translation time.
+;;; This is a bit crude.
+
+(defmfun fstringc (L)
+  (do ((sl nil) (s) (sb)
+		(se nil))
+      ((null l)
+       (setq sl (maknam sl))
+       #+PDP10
+       (putprop sl t '+INTERNAL-STRING-MARKER)
+       (cons sl (nreverse se)))
+    (setq s (pop l))
+    (cond ((and (symbolp s) (= (getcharn s 1) #/&))
+	   (setq sb (cdr (exploden s))))
+	  (t
+	   (push s se)
+	   (setq sb (list #/~ #/M))))
+    (setq sl (nconc sl sb (if (null l) nil (list #\SP))))))
+
+
+
+#+PDP10
+(PROGN 'COMPILE
+       ;; Fun and games with the pdp-10. The calling sequence for
+       ;; subr, (arguments passed through registers), is much smaller
+       ;; than that for lsubrs. If we really where going to do a lot
+       ;; of this hackery then we would define some kind of macro
+       ;; for it.
+       (LET ((X (GETL 'MERROR '(EXPR LSUBR))))
+	 (REMPROP '*MERROR (CAR X))
+	 (PUTPROP '*MERROR (CADR X) (CAR X)))
+       (DECLARE (*LEXPR *MERROR))
+       (DEFMFUN *MERROR-1 (A)         (*MERROR A))
+       (DEFMFUN *MERROR-2 (A B)       (*MERROR A B))
+       (DEFMFUN *MERROR-3 (A B C)     (*MERROR A B C))
+       (DEFMFUN *MERROR-4 (A B C D)   (*MERROR A B C D))
+       (DEFMFUN *MERROR-5 (A B C D E) (*MERROR A B C D E))
+
+
+       (LET ((X (GETL 'ERRRJF '(EXPR LSUBR))))
+	 (REMPROP '*ERRRJF (CAR X))
+	 (PUTPROP '*ERRRJF (CADR X) (CAR X)))
+       (DECLARE (*LEXPR *ERRRJF))
+       (DEFMFUN *ERRRJF-1 (A) (*ERRRJF A))
+
+       )
+#+Maclisp
+(progn 'compile
+(defun m-wna-eh (((f . actual-args) args-info))
+  ;; generate a nice user-readable message about this lisp error.
+  ;; F may be a symbol or a lambda expression.
+  ;; args-info may be nil, an args-info form, or a formal argument list.
+  (merror "~M ~A to function ~A"
+	  `((mlist) ,@actual-args)
+	  ;; get the error messages passed as first arg to lisp ERROR.
+	  (caaddr (errframe ()))
+	  (if (symbolp f)
+	      (if (or (equal (args f) args-info)
+		      (symbolp args-info))
+		  f
+		  `((,f),@args-info))
+	      `((lambda)((mlist),@(cadr f))))))
+
+(defun m-wta-eh ((object))
+  (merror "~A: ~A" (caaddr (errframe ())) object))
+
+(defun m-ubv-eh ((variable))
+  (merror "Unbound variable: ~A" variable))
+
+;; TRANSL generates regular LISP function calls for functions which
+;; are lisp defined at translation time, and in compiled code.
+;; MEXPRs can be handled by the UUF (Undefined User Function) handler.
+
+(DEFVAR UUF-FEXPR-ALIST ())
+
+(DEFUN UUF-HANDLER (X)
+  (LET ((FUNP (OR (MGETL (CAR X) '(MEXPR MMACRO))
+		  (GETL (CAR X) '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S)))))
+    (CASEQ (CAR FUNP)
+      ((MEXPR)
+       ;; The return value of the UUF-HANDLER is put back into
+       ;; the "CAR EVALUATION LOOP" of the S-EXP. It is evaluated,
+       ;; checked for "functionality" and applied if a function,
+       ;; otherwise it is evaluated again, unless it's atomic,
+       ;; in which case it will call the UNDF-FNCTN handler again,
+       ;; unless (STATUS PUNT) is NIL in which case it is
+       ;; evaluated (I think). One might honestly ask
+       ;; why the maclisp evaluator behaves like this. -GJC
+       `((QUOTE (LAMBDA *N*
+		  (MAPPLY ',(CAR X) (LISTIFY *N*) ',(CAR X))))))
+      ((MMACRO TRANSLATED-MMACRO)
+       (MERROR
+	"Call to a macro '~:@M' which was undefined during translation."
+	(CAR X)))
+      ((MFEXPR* MFEXPR*S)
+       ;; An call in old translated code to what was a FEXPR.
+       (LET ((CELL (ASSQ (CAR X) UUF-FEXPR-ALIST)))
+	 (OR CELL
+	     (LET ((NAME (GENSYM)))
+	       (PUTPROP NAME
+			`(LAMBDA (,NAME) (MEVAL (CONS '(,(CAR X)) ,NAME)))
+			'FEXPR)
+	       (SETQ CELL (LIST (CAR X) NAME))
+	       (PUSH CELL UUF-FEXPR-ALIST)))
+	 (CDR CELL)))
+      (T
+       (MERROR "Call to an undefined function '~A' at Lisp level."
+	       (CAR X))))))
+)

src/maxsrc/mformt.27

@@ -0,0 +1,145 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module mformt)
+(load-macsyma-macros mforma)
+
+(EVAL-WHEN (EVAL)
+	   (SETQ MACRO-EXPANSION-USE 'DISPLACE))
+
+(DEF-MFORMAT)
+
+(DEF-MFORMAT-VAR /:-FLAG     NIL T)
+(DEF-MFORMAT-VAR /@-FLAG     NIL T)
+(DEF-MFORMAT-VAR PARAMETER   0  T) ; Who can read "~33,34,87A" ?
+(DEF-MFORMAT-VAR PARAMETER-P NIL T)
+(DEF-MFORMAT-VAR TEXT       NIL NIL)
+(DEF-MFORMAT-VAR TEXT-TEMP NIL NIL)
+(DEF-MFORMAT-VAR DISPLA-P NIL NIL)
+(DEF-MFORMAT-VAR PRE-%-P NIL NIL)
+(DEF-MFORMAT-VAR POST-%-P NIL NIL)
+
+#-PDP10
+(DEFMFUN CHECK-OUT-OF-CORE-STRING (string) string)
+
+(DEFMACRO PUSH-TEXT-TEMP ()
+	  '(IF TEXT-TEMP (SETQ TEXT (CONS (CONS '(TEXT-STRING) (NREVERSE TEXT-TEMP))
+					  TEXT)
+			       TEXT-TEMP NIL)))
+
+(DEFMACRO OUTPUT-TEXT ()
+	  '(PROGN (PUSH-TEXT-TEMP)
+		  (OUTPUT-TEXT* STREAM TEXT DISPLA-P PRE-%-P POST-%-P)
+		  (SETQ TEXT NIL DISPLA-P NIL PRE-%-P NIL POST-%-P NIL)))
+
+(DEF-MFORMAT-OP (#/% #/&)
+		(COND ((OR TEXT TEXT-TEMP)
+		       (SETQ POST-%-P T)
+		       ;; there is text to output.
+		       (OUTPUT-TEXT))
+		      (T
+		       (SETQ PRE-%-P T))))
+
+(DEF-MFORMAT-OP #/M
+		(PUSH-TEXT-TEMP)
+		(LET ((ARG (POP-MFORMAT-ARG)))
+		     (AND @-FLAG (ATOM ARG) 
+			  (SETQ ARG (OR (GET ARG 'OP) ARG)))
+		     (COND (/:-FLAG
+			    (PUSH (CONS '(TEXT-STRING) (MSTRING ARG)) TEXT))
+			   (T
+			    (SETQ DISPLA-P T)
+			    (PUSH ARG TEXT)))))
+
+(DEF-MFORMAT-OP #/A
+		(PUSH-TEXT-TEMP)
+		(PUSH (CONS '(TEXT-STRING) (EXPLODEN (POP-MFORMAT-ARG))) TEXT))
+
+(DEF-MFORMAT-OP #/S
+		(PUSH-TEXT-TEMP)
+		(PUSH (CONS '(TEXT-STRING)
+			    (MAP #'(LAMBDA (C)
+					   (RPLACA C (GETCHARN (CAR C) 1)))
+				 (EXPLODE (POP-MFORMAT-ARG))))
+		      TEXT))
+
+(DEFMFUN MFORMAT N
+  (OR (> N 1)
+      ;; make error message without new symbols.
+      ;; This error should not happen in compiled code because
+      ;; this check is done at compile time too.
+      (ERROR 'WRNG-NO-ARGS 'MFORMAT))
+  (LET ((STREAM (ARG 1))
+	(STRING (exploden (check-out-of-core-string (ARG 2))))
+	(arg-index 2))
+    #+NIL
+    (AND (OR (NULL STREAM)
+	     (EQ T STREAM))
+	 (SETQ STREAM STANDARD-OUTPUT))
+    ;; This is all done via macros to save space,
+    ;; (No functions, no special variable symbols.)
+    ;; If the lack of flexibilty becomes an issue then
+    ;; it can be changed easily.
+    (MFORMAT-LOOP (OUTPUT-TEXT))
+    ;; On Multics keep from getting bitten by line buffering.
+    #+Multics
+    (FORCE-OUTPUT STREAM)
+    ))
+
+(DEFUN OUTPUT-TEXT* (STREAM TEXT DISPLA-P PRE-%-P POST-%-P)
+  (SETQ TEXT (NREVERSE TEXT))
+  ;; outputs a META-LINE of text.
+  (COND (DISPLA-P (DISPLAF (CONS '(MTEXT) TEXT) STREAM))
+	(T
+	 (IF PRE-%-P (TERPRI STREAM))
+	 (DO ()
+	     ((NULL TEXT))
+	   (DO ((L (CDR (POP TEXT)) (CDR L)))
+	       ((NULL L))
+	     (TYO (CAR L) STREAM)))
+	 (IF POST-%-P (TERPRI STREAM)))))
+
+(DEFUN (TEXT-STRING DIMENSION) (FORM RESULT)
+  ;; come up with something more efficient later.
+  (DIMENSION-ATOM (MAKNAM (CDR FORM)) RESULT))
+
+(DEFMFUN DISPLAF (OBJECT STREAM)
+  ;; for DISPLA to a file. actually this works for SFA's and
+  ;; other streams in maclisp.
+  (IF (EQ STREAM NIL)
+      (DISPLA OBJECT)
+      (LET ((/^R T)
+	    (/^W T)
+	    (OUTFILES (NCONS STREAM)))
+	(DISPLA OBJECT))))
+
+
+(DEFMFUN MTELL (&REST L)
+  (LEXPR-FUNCALL #'MFORMAT NIL L))
+
+
+;; Calling-sequence optimizations.
+#+PDP10
+(PROGN 'COMPILE
+       (LET ((X (GETL 'MFORMAT '(EXPR LSUBR))))
+	 (REMPROP '*MFORMAT (CAR X))
+	 (PUTPROP '*MFORMAT (CADR X) (CAR X)))
+       (DECLARE (*LEXPR *MFORMAT))
+       (DEFMFUN *MFORMAT-2 (A B) (*MFORMAT A B))
+       (DEFMFUN *MFORMAT-3 (A B C) (*MFORMAT A B C))
+       (DEFMFUN *MFORMAT-4 (A B C D) (*MFORMAT A B C D))
+       (DEFMFUN *MFORMAT-5 (A B C D E) (*MFORMAT A B C D E))
+
+       (LET ((X (GETL 'MTELL '(EXPR LSUBR))))
+	 (REMPROP '*MTELL (CAR X))
+	 (PUTPROP '*MTELL (CADR X) (CAR X)))
+       (DECLARE (*LEXPR *MTELL))
+       (DEFMFUN MTELL1 (A)         (*MTELL A))
+       (DEFMFUN MTELL2 (A B)       (*MTELL A B))
+       (DEFMFUN MTELL3 (A B C)     (*MTELL A B C))
+       (DEFMFUN MTELL4 (A B C D)   (*MTELL A B C D))
+       (DEFMFUN MTELL5 (A B C D E) (*MTELL A B C D E))
+       )
+
+

src/maxsrc/mload.121

@@ -0,0 +1,479 @@
+;;; -*- Mode: Lisp; Package: Macsyma -*-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;       (c) Copyright 1982 Massachusetts Institute of Technology       ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module mload)
+
+;; I decided to move most of the file hacking utilities I used in TRANSL to
+;; this file. -GJC
+
+;; Concepts:
+;; Lisp_level_filename. Anything taken by the built-in lisp I/O primitives.
+;;
+;; User_level_filename. Comes through the macsyma reader, so it has an extra "&"
+;;   in the pname in the case of "filename" or has extra "$" and has undergone
+;;   ALIAS transformation in the case of 'FOOBAR or '[FOO,BAR,BAZ].
+;;
+;; Canonical_filename. Can be passed to built-in lisp I/O primitives, and
+;;   can also be passed back to the user, is specially handled by the DISPLAY.
+;;
+;; Functions:
+;; $FILENAME_MERGE. Takes User_level_filename(s) and Canonical_filename(s) and
+;;   merges them together, returning a Canonical_filename.
+;;
+;; TO-MACSYMA-NAMESTRING. Converts a Lisp_level_filename to a Canonical_filename
+;;
+;; $FILE_SEARCH ............ Takes a user or canonical filename and a list of types of
+;;                           applicable files to look for.
+;; $FILE_TYPE   ............. Takes a user or canonical filename and returns
+;;                            NIL, $MACSYMA, $LISP, or $FASL.
+;; CALL-BATCH1 ............. takes a canonical filename and a no-echop flag.
+
+;; Note: This needs to be generalized some more to take into account
+;; the lispmachine situation of access to many different file systems
+;; at the same time without, and also take into account the way it presently
+;; deals with that situation. The main thing wrong now is that the file-default
+;; strings are constants.
+
+;; What a cannonical filename is on the different systems:
+;; This is for informational purposes only, as the Macsyma-Namestringp
+;; predicate is provided.
+;; [PDP-10 Maclisp] An uninterned symbol with various properties.
+;; [Franz Lisp] a string or a symbol (whose print name is used).
+;; [Multics Maclisp] A STRING.
+;; [LispMachine] A generic pathname object, which is a system-provided FLAVOR.
+;; [NIL] Not decided yet, but a STRING should do ok, since in NIL files are
+;; a low-level primitive, and programs, modules, and environments are the
+;; practical abstraction used. No attempt is made to come up with ad-hoc generalizations
+;; of the ITS'ish and DEC'ish filenames, as such attempts fail miserably to provide
+;; the functionality of filesystems such as on Multics.
+
+(DECLARE (SPECIAL $FILE_SEARCH $FILE_TYPES))
+
+(DEFMFUN $LISTP_CHECK (VAR VAL)
+  "Gives an error message including its first argument if its second
+  argument is not a LIST"
+  (OR ($LISTP VAL)
+      (MERROR "The variable ~:M being set to a non-LISTP object:~%~M"
+	      VAR VAL)))
+
+(DEFPROP $FILE_SEARCH $LISTP_CHECK ASSIGN)
+
+(DEFPROP $FILE_TYPES $LISTP_CHECK ASSIGN)
+
+#-Franz
+(DEFMFUN $FILE_SEARCH (X &OPTIONAL
+			 (LISTP NIL)
+			 (L $FILE_TYPES))
+  (SETQ X ($FILENAME_MERGE X))
+  (IF ($LISTP L) (SETQ L (CDR L))
+      (MERROR "3'rd arg to FILE_SEARCH not a list.~%~M" L))
+  (DO ((MERGE-SPECS (CONS ($filename_merge)
+			  ;; Get a complete "star filename"
+			  (CDR $FILE_SEARCH))
+		    (CDR MERGE-SPECS))
+       (PROBED)
+       (FOUND))
+      ((NULL MERGE-SPECS)
+       (IF LISTP
+	   `((MLIST) ,@(NREVERSE FOUND))
+	   (MERROR "Could not find file which matches ~M" X)))
+    (IF (DO ((L L (CDR L))
+	     (U ($FILENAME_MERGE (CAR MERGE-SPECS))))
+	    ((NULL L) NIL)
+	  (IF (SETQ PROBED (PROBEF ($FILENAME_MERGE X U (CAR L))))
+	      (IF LISTP
+		  (PUSH (TO-MACSYMA-NAMESTRING PROBED) FOUND)
+		  (RETURN T))))
+	(RETURN (TO-MACSYMA-NAMESTRING PROBED)))))
+
+;; filename merging is unheard of on Unix.
+;; If the user doesn't supply a file extension, we look for .o, .l and .v
+;; and finally the file itself.  If the user supplies one of the standard
+;; extensions, we just use that.
+#+Franz
+(defmfun $file_search (x &optional (listp nil) (l $file_types))
+   (let ((filelist (cond ((cdr $file_search))
+			 (t '("."))))
+	 (extlist (cond ((member (substring x -2) '(".o" ".l" ".v"))
+			 '(nil))
+			(t '(".o" ".l" ".v" nil)))))
+      (do ((dir filelist (cdr dir))
+	   (ret))
+	  ((null dir)
+	   (cond (listp '((mlist)))
+		     (t (MERROR "Could not find file ~M" X))))
+	  (cond ((setq ret
+		       (do ((try extlist (cdr try))
+			    (this))
+			   ((null try))
+			   (setq this (cond ((null (car try)) x)
+					    (t (concat x (car try)))))
+			   (cond ((not (equal "." (car dir)))
+				  (setq this (concat (car dir) "//" this))))
+			   (cond ((probef this)
+				  (return
+				     (cond (listp `((mlist)
+						    ,(to-macsyma-namestring x)))
+						(t (to-macsyma-namestring this))))))))
+		 (return ret))))))
+
+			
+(DECLARE (SPECIAL $LOADPRINT))
+
+(DEFMFUN LOAD-AND-TELL (FILENAME)
+  (LOADFILE FILENAME
+	    T ;; means this is a lisp-level call, not user-level.
+	    $LOADPRINT))
+
+#+PDP10
+(PROGN 'COMPILE
+;; on the PDP10 cannonical filenames are represented as symbols
+;; with a DIMENSION-LIST property of DISPLAY-FILENAME.
+
+(DEFUN DIMENSION-FILENAME (FORM RESULT)
+  (DIMENSION-STRING (CONS #/" (NCONC (EXPLODEN FORM) (LIST #/"))) RESULT))
+
+(DEFUN TO-MACSYMA-NAMESTRING (X)
+  ;; create an uninterned symbol, uninterned so that
+  ;; it will be GC'd.
+  (SETQ X (PNPUT (PNGET (NAMESTRING X) 7) NIL))
+  (PUTPROP X 'DIMENSION-FILENAME 'DIMENSION-LIST)
+  X)
+
+(DEFUN MACSYMA-NAMESTRINGP (X)
+  (AND (SYMBOLP X) (EQ (GET X 'DIMENSION-LIST) 'DIMENSION-FILENAME)))
+
+(DEFMACRO ERRSET-NAMESTRING (X)
+  `(LET ((ERRSET NIL))
+     (ERRSET (NAMESTRING ,X) NIL)))
+
+(DEFMFUN $FILENAME_MERGE N
+  (DO ((F "" (MERGEF (MACSYMA-NAMESTRING-SUB (ARG J)) F))
+       (J N (1- J)))
+      ((ZEROP J)
+       (TO-MACSYMA-NAMESTRING F))))
+)
+
+#+Franz
+(progn 'compile
+
+;; a first crack at these functions
+
+(defun to-macsyma-namestring (x)
+   (cond ((macsyma-namestringp x) x)
+	 ((symbolp x)
+	  (cond ((memq (getcharn x 1) '(#/& #/$))
+		 (substring (get_pname x) 2))
+		(t (get_pname x))))
+	 (t (merror "to-macsyma-namestring: non symbol arg ~M~%" x))))
+
+(defun macsyma-namestringp (x)
+   (stringp x))
+
+;;--- $filename_merge
+; may not need this ask filename merging is not done on Unix systems.
+;
+(defmfun $filename_merge (&rest files)
+   (cond (files (filestrip (ncons (car files))))))
+)
+
+#+MULTICS
+(PROGN 'COMPILE
+(DEFUN TO-MACSYMA-NAMESTRING (X) 
+  (cond ((macsyma-namestringp x) x)
+	((symbolp x) (substring (string x) 1))
+	((listp x) (namestring x))
+	(t x)))
+
+(DEFUN MACSYMA-NAMESTRINGP (X) (STRINGP X))
+(DEFUN ERRSET-NAMESTRING (X)
+  (IF (ATOM X) (NCONS (STRING X)) (ERRSET (NAMESTRING X) NIL)))
+
+(DEFMFUN $FILENAME_MERGE (&REST FILE-SPECS)
+  (SETQ FILE-SPECS (cond (file-specs 
+			  (MAPCAR #'MACSYMA-NAMESTRING-SUB FILE-SPECS))
+			 (t '("**"))))
+  (TO-MACSYMA-NAMESTRING (IF (NULL (CDR FILE-SPECS))
+			     (CAR FILE-SPECS)
+			     (APPLY #'MERGEF FILE-SPECS))))
+
+)
+
+#+LISPM
+(PROGN 'COMPILE
+(DEFUN TO-MACSYMA-NAMESTRING (X)
+  (FS:PARSE-PATHNAME X))
+(DEFUN MACSYMA-NAMESTRINGP (X)
+  (TYPEP X 'FS:PATHNAME))
+(DEFUN ERRSET-NAMESTRING (X)
+  (LET ((ERRSET NIL))
+    (ERRSET (FS:PARSE-PATHNAME X) NIL)))
+
+(DEFMFUN $FILENAME_MERGE (&REST FILE-SPECS)
+  (DO ((F "" (FS:MERGE-PATHNAME-DEFAULTS (MACSYMA-NAMESTRING-SUB
+					   (NTH (1- J) FILE-SPECS))
+					 F))
+       (J (LENGTH FILE-SPECS) (1- J)))
+      ((ZEROP J)
+       (TO-MACSYMA-NAMESTRING F))))
+)
+
+(DEFUN MACSYMA-NAMESTRING-SUB (USER-OBJECT)
+  (IF (MACSYMA-NAMESTRINGP USER-OBJECT) USER-OBJECT
+      (LET* ((SYSTEM-OBJECT
+	      (COND ((ATOM USER-OBJECT)
+		     (FULLSTRIP1 USER-OBJECT))
+		    (($LISTP USER-OBJECT)
+		     (FULLSTRIP (CDR USER-OBJECT)))
+		    (T
+		     (MERROR "Bad file spec:~%~M" USER-OBJECT))))
+	     (NAMESTRING-TRY (ERRSET-NAMESTRING SYSTEM-OBJECT)))
+	(IF NAMESTRING-TRY (CAR NAMESTRING-TRY)
+	    ;; know its small now, so print on same line.
+	    (MERROR "Bad file spec: ~:M" USER-OBJECT)))))
+
+(DEFMFUN open-out-dsk (x)
+  (open x #-LISPM '(out dsk ascii block)
+	  #+LISPM '(:out :ascii)))
+(DEFMFUN open-in-dsk (x)
+  (open x #-LISPM '(in dsk ascii block)
+	  #+LISPM '(:in :ascii)))
+
+#-MAXII
+(PROGN 'COMPILE
+
+(DECLARE (SPECIAL DSKFNP OLDST ST $NOLABELS REPHRASE))
+
+(DEFMFUN CALL-BATCH1 (FILENAME ^W)
+  (LET ((^R (AND ^R (NOT ^W)))
+	($NOLABELS T)
+	($CHANGE_FILEDEFAULTS)
+	(DSKFNP T)
+	(OLDST)
+	(ST))
+    ;; cons #/& to avoid the double-stripdollar problem.
+    (BATCH1 (LIST (MAKNAM (CONS #/& (EXPLODEN FILENAME))))
+	    NIL
+	    NIL
+	    #-Franz T
+	    #+Franz nil)
+    (SETQ REPHRASE T)))
+
+
+(DEFMVAR *IN-$BATCHLOAD* NIL
+  "I should have a single state variable with a bit-vector or even a list
+  of symbols for describing the state of file translation.")
+(DEFMVAR *IN-TRANSLATE-FILE* NIL "")
+(DEFMVAR *IN-MACSYMA-INDEXER* NIL)
+
+(DEFUN TRANSLATE-MACEXPR (FORM &optional FILEPOS)
+       (COND (*IN-TRANSLATE-FILE*
+	      (TRANSLATE-MACEXPR-ACTUAL FORM FILEPOS))
+	     (*in-macsyma-indexer*
+	      (outex-hook-exp form))
+	     (T
+	      (LET ((R (ERRSET (MEVAL* FORM))))
+		   (COND ((NULL R)
+			  (LET ((^W NIL))
+			       (MERROR "~%This form caused an error in evaluation:~
+				       ~%~:M" FORM))))))))
+
+
+(DEFMFUN $BATCHLOAD (FILENAME)
+  (LET ((WINP NIL)
+	(NAME ($FILENAME_MERGE FILENAME))
+	(*IN-$BATCHLOAD* T))
+    (IF $LOADPRINT
+	(MTELL "~%Batching the file ~M~%" NAME))
+    (UNWIND-PROTECT
+     (PROGN (CALL-BATCH1 NAME T)
+	    (SETQ WINP T)
+	    NAME)
+     ;; unwind protected.
+     (IF WINP
+	 (IF $LOADPRINT (MTELL "Batching done."))
+	 (MTELL "Some error in loading this file: ~M" NAME)))))
+
+;; end of moby & crufty #-MAXII
+)
+
+#+MAXII
+(DEFMFUN $BATCHLOAD (FILENAME)
+  (LET ((EOF (LIST NIL))
+	(NAME ($FILENAME_MERGE FILENAME))
+	(*MREAD-PROMPT* "(Batching) "))
+    (IF $LOADPRINT
+	(MTELL "~%Batching the file ~M~%" NAME))
+    (WITH-OPEN-FILE (STREAM NAME '(:IN :ASCII))
+      (DO ((FORM NIL (MREAD STREAM EOF)))
+	  ((EQ FORM EOF)
+	   (IF $LOADPRINT (MTELL "Batching done."))
+	   '$DONE)
+	(MEVAL* (CADDR FORM))))))
+
+
+(DEFMFUN $LOAD (MACSYMA-USER-FILENAME
+		&AUX
+		(FILENAME ($FILENAME_MERGE MACSYMA-USER-FILENAME)))
+  "This is the generic file loading function.
+  LOAD(/"filename/") will either BATCHLOAD or LOADFILE the file,
+  depending on wether the file contains Macsyma, Lisp, or Compiled
+  code. The file specifications default such that a compiled file
+  is searched for first, then a lisp file, and finally a macsyma batch
+  file. This command is designed to provide maximum utility and
+  convenience for writers of packages and users of the macsyma->lisp
+  translator."
+  (LET* ((SEARCHED-FOR ($FILE_SEARCH FILENAME))
+	 (TYPE ($FILE_TYPE SEARCHED-FOR)))
+    (CASEQ TYPE
+      (($MACSYMA)
+       ($BATCHLOAD SEARCHED-FOR))
+      (($LISP $FASL)
+       ;; do something about handling errors
+       ;; during loading. Foobar fail act errors.
+       (LOAD-AND-TELL SEARCHED-FOR))
+      (T
+       (MERROR "MACSYMA BUG: Unknown file type ~M" TYPE)))
+    SEARCHED-FOR
+    ))
+
+#+Multics
+(DEFMFUN $FILE_TYPE (FILE)
+  (SETQ FILE ($FILENAME_MERGE FILE))
+  (IF (NULL (PROBEF FILE)) NIL
+      (CASEQ (CAR (LAST (NAMELIST FILE)))
+	((MACSYMA) '$MACSYMA)
+	((LISP) '$LISP)
+	(T '$FASL))))
+
+#-MULTICS
+(DEFMFUN $FILE_TYPE (FILENAME &AUX STREAM)
+  (SETQ FILENAME ($FILENAME_MERGE FILENAME))
+  (COND ((NULL (PROBEF FILENAME))
+	 NIL)
+#-Franz ((FASLP FILENAME)
+	 '$FASL)
+#+Franz ((cdr (assoc (substring filename -2)
+		     '((".l" . $lisp) (".o" . $fasl) (".v" . $macsyma)))))
+	('ELSE
+	 ;; This has to be simple and small for greatest utility
+	 ;; as an in-core pdp10 function.
+	 (UNWIND-PROTECT
+	  (DO ((C (PROGN (SETQ STREAM (OPEN-IN-DSK FILENAME))
+			 #\SP)
+		  (TYI STREAM -1)))
+	      ((NOT (MEMBER C '(#\SP #\TAB #\CR #\LF #\FF)))
+	       ;; heuristic number one,
+	       ;; check for cannonical language "comment." as first thing
+	       ;; in file after whitespace.
+	       (COND ((MEMBER C '(-1 #/;))
+		      '$LISP)
+		     ((AND (= C #//)
+			   (= (TYI STREAM -1) #/*))
+		      '$MACSYMA)
+	   #+Franz   ((eq c 7)		;; fasl files begin with bytes 7,1
+		      '$fasl)		;; but just seeing 7 is good enough
+		     ('ELSE
+		      ;; the above will win with all Lisp files written by
+		      ;; the macsyma system, e.g. the $SAVE and
+		      ;; $TRANSLATE_FILE commands, all lisp files written
+		      ;; by macsyma system programmers, and anybody else
+		      ;; who starts his files with a "comment," lisp or
+		      ;; macsyma.
+		      (FILEPOS STREAM 0)
+		      ;; heuristic number two, see if READ returns something
+		      ;; evaluable.
+		      (LET ((FORM (LET ((ERRSET NIL))
+				    ;; this is really bad to do since
+				    ;; it can screw the lisp programmer out
+				    ;; of a chance to identify read errors
+				    ;; as they happen.
+				    (ERRSET (READ STREAM NIL) NIL))))
+			(IF (OR (NULL FORM)
+				(ATOM (CAR FORM)))
+			    '$MACSYMA
+			    '$LISP))))))
+	  ;; Unwind protected.
+	  (IF STREAM (CLOSE STREAM))))))
+
+#+LISPM
+(defun faslp (filename)
+  ;; wasteful to be opening file objects so many times, one for
+  ;; each predicate and then again to actually load. Fix that perhaps
+  ;; by having the predicates return "failure-objects," which can be
+  ;; passed on to other predicates and on to FS:FASLOAD-INTERNAL and
+  ;; FS:READFILE-INTERNAL.
+  (with-open-file (stream filename '(:read :fixnum))
+    (funcall stream ':qfaslp)))
+
+(DEFMVAR $FILE_SEARCH
+  #+ITS
+  `((MLIST)
+    ,@(MAPCAR #'TO-MACSYMA-NAMESTRING
+	      '("DSK:SHARE;" "DSK:SHARE1;" "DSK:SHARE2;" "DSK:SHAREM;")))
+  #+Franz
+  `((mlist)
+    ,@(mapcar #'to-macsyma-namestring
+	       `("."
+		 ,(concat vaxima-main-dir "//share")
+		 ,(concat vaxima-main-dir "//demo"))))
+    
+  #+LISPM
+  `((MLIST)
+    ,@(MAPCAR #'TO-MACSYMA-NAMESTRING
+	      '("MC:LMMAXR;" "MC:LMMAXQ;")))
+  #+Multics
+  '((MLIST))
+  "During startup initialized to a list of places the LOAD function
+  should search for files."
+  )
+
+#+Multics
+(PROGN 'COMPILE
+;; We need an abstract entry in this list to indicate "working_dir".
+(DEFMFUN INITIATE-FILE-SEARCH-LIST ()
+  (LET ((WHERE-AM-I (CAR (NAMELIST EXECUTABLE-DIR))))
+    (SETQ 
+     $FILE_SEARCH 
+     `((MLIST) 
+       ,@(mapcar #'to-macsyma-namestring
+	   `(,(string-append (PATHNAME-UTIL "hd") ">**")
+	     ,(string-append (NAMESTRING `(,WHERE-AM-I "share")) ">**")
+	     ,(string-append (NAMESTRING `(,WHERE-AM-I "executable"))
+			     ">**")))))))
+
+;; These forms getting evaluated at macsyma start-up time.
+(if (boundp 'macsyma-startup-queue)
+    (PUSH '(INITIATE-FILE-SEARCH-LIST) MACSYMA-STARTUP-QUEUE)
+    (setq macsyma-startup-queue '((initiate-file-search-list))))
+
+;; Done for debuggings sake.
+(eval-when (eval load)
+  (initiate-file-search-list))
+
+)
+
+#-LISPM
+(DEFMVAR $FILE_TYPES
+  `((MLIST)
+    ,@(MAPCAR #'TO-MACSYMA-NAMESTRING
+	      #+ITS
+	      ;; ITS filesystem. Sigh. This should be runtime conditionalization.
+	      '("* FASL" "* TRLISP" "* LISP" "* >")
+	      #+MULTICS
+	      '("**" "**.lisp" "**.macsyma")))
+  "The types of files that can be loaded into a macsyma automatically")
+#+LISPM
+(DEFMVAR $FILE_TYPES '((MLIST) "* FASL" "* TRLISP" "* LISP" "* >"))
+
+(defmfun mfilename-onlyp (x)
+  "Returns T iff the argument could only be reasonably taken as a filename."
+  (cond ((macsyma-namestringp x) t)
+	(($listp x) t)
+	((symbolp x)
+	 (= #/& (getcharn x 1)))
+	('else
+	 nil)))
+

src/maxsrc/mtrace.41

@@ -0,0 +1,654 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module mtrace)
+
+(declare (*lexpr trace-mprint) ;; forward references
+	 (genprefix mtrace-))
+
+;;; a reasonable trace capability for macsyma users.
+;;; 8:10pm  Saturday, 10 January 1981 -GJC.
+
+;; TRACE(F1,F2,...)   /* traces the functions */
+;; TRACE()            /* returns a list of functions under trace */
+;; UNTRACE(F1,F2,...) /* untraces the functions */
+;; UNTRACE()          /* untraces all functions. */
+;; TRACE_MAX_INDENT   /* The maximum indentation of trace printing. */
+;;
+;; TRACE_OPTIONS(F,option1,option2,...)  /* gives F options */
+;;
+;; TRACE_BREAK_ARG    /* Bound to list of argument during BREAK ENTER,
+;;                      and the return value during BREAK EXIT.
+;;                      This lets you change the arguments to a function,
+;;                      or make a function return a different value,
+;;                      which are both usefull debugging hacks.
+;;
+;;                      You probably want to give this a short alias
+;;                      for typing convenience. 
+;;                    */
+;;
+;; An option is either a keyword, FOO.
+;; or an expression  FOO(PREDICATE_FUNCTION);
+;;
+;; A keyword means that the option is in effect, an keyword
+;; expression means to apply the predicate function to some arguments
+;; to determine if the option is in effect. The argument list is always
+;; [LEVEL,DIRECTION, FUNCTION, ITEM] where
+;; LEVEL      is the recursion level for the function.
+;; DIRECTION  is either ENTER or EXIT.
+;; FUNCTION   is the name of the function.
+;; ITEM       is either the argument list or the return value.
+;;
+;; ----------------------------------------------
+;; | Keyword    | Meaning of return value       |
+;; ----------------------------------------------
+;; | NOPRINT    | If TRUE do no printing.       |
+;; | BREAK      | If TRUE give a breakpoint.    |
+;; | LISP_PRINT | If TRUE use lisp printing.    |
+;; | INFO       | Extra info to print           |
+;; | ERRORCATCH | If TRUE errors are caught.    |
+;; ----------------------------------------------
+;;
+;; General interface functions. These would be called by user debugging utilities.
+;;
+;; TRACE_IT('F)             /* Trace the function named F */
+;; TRACE                    /* list of functions presently traced. */
+;; UNTRACE_IT('F)           /* Untrace the function named F */
+;; GET('F,'TRACE_OPTIONS)  /* Access the trace options of F */
+;;
+;; Sophisticated feature:
+;; TRACE_SAFETY a variable with default value TRUE.
+;; Example: F(X):=X; BREAKP([L]):=(PRINT("Hi!",L),FALSE),
+;; TRACE(F,BREAKP); TRACE_OPTIONS(F,BREAK(BREAKP));
+;; F(X); Note that even though BREAKP is traced, and it is called,
+;; it does not print out as if it were traced. If you set
+;; TRACE_SAFETY:FALSE; then F(X); will cause a normal trace-printing
+;; for BREAKP. However, then consider TRACE_OPTIONS(BREAKP,BREAK(BREAKP));
+;; When TRACE_SAFETY:FALSE; F(X); will give an infinite recursion,
+;; which it would not if safety were turned on.
+;; [Just thinking about this gives me a headache.]
+
+;;; Structures.
+
+(defmacro trace-p (x) `(mget ,x 'trace))
+(defmacro trace-type (x) `(mget ,x 'trace-type))
+(defmacro trace-level (x) `(mget ,x 'trace-level))
+(defmacro trace-options (x) `($get ,x '$trace_options))
+
+;;; User interface functions.
+
+(defmvar $trace (list '(mlist)) "List of functions actively traced")
+(putprop '$trace #'read-only-assign 'assign)
+
+(defun mlistcan-$all (fun list default)
+  "totally random utility function"
+  (if (null list) default
+      `((mlist) ,@(mapcan fun
+			  (if (memq (car list) '($all $functions))
+			      (mapcar #'caar (cdr $functions))
+			      list)))))
+
+(defmspec $trace (form)
+  (mlistcan-$all #'macsyma-trace (cdr form) $trace))
+  
+(defmfun $trace_it (function) `((mlist),@(macsyma-trace function)))
+
+
+(defmspec $untrace (form)
+  `((mlist) ,@(mapcan #'macsyma-untrace (or (cdr form)
+					    (cdr $trace)))))
+
+(defmfun $untrace_it (function) `((mlist) ,@(macsyma-untrace function)))
+
+(defmspec $trace_options (form)
+  (setf (trace-options (cadr form))
+	`((mlist) ,@(cddr form))))
+
+
+
+;;; System interface functions.
+
+(defvar hard-to-trace '(trace-handler listify args setplist
+				     trace-apply
+				     *apply mapply))
+
+
+;; A list of functions called by the TRACE-HANDLEr at times when
+;; it cannot possibly shield itself from a continuation which would
+;; cause infinite recursion. We are assuming the best-case of
+;; compile code.
+
+(defun macsyma-trace (fun) (macsyma-trace-sub fun 'trace-handler $trace))
+
+(defun macsyma-trace-sub (fun handler ilist &aux temp)
+  (cond ((not (symbolp fun))
+	 (mtell "~%Bad arg to TRACE: ~M" fun)
+	 nil)
+	((trace-p fun)
+	 ;; Things which redefine should be expected to reset this
+	 ;; to NIL.
+	 (mtell "~%~@:M is already traced." fun)
+	 nil)
+	((memq fun hard-to-trace)
+	 (mtell
+	  "~%The function ~:@M cannot be traced because: ASK GJC~%"
+	  fun)
+	 nil)
+	((null (setq temp (macsyma-fsymeval fun)))
+	 (mtell "~%~@:M has no functional properties." fun)
+	 nil)
+	((memq (car temp) '(mmacro translated-mmacro))
+	 (mtell "~%~@:M is a macro, won't trace well, so use ~
+		     the MACROEXPAND function to debug it." fun)
+	 nil)
+	((get (car temp) 'shadow)
+	 (put-trace-info fun (car temp) ilist)
+	 (trace-fshadow fun (car temp)
+			(make-trace-hook fun (car temp) handler))
+	 (list fun))
+	(t
+	 (mtell "~%~@:M has functional properties not understood by TRACE"
+		fun)
+	 nil)))
+
+(defvar trace-handling-stack ())
+
+(defun macsyma-untrace (fun) (macsyma-untrace-sub fun 'trace-handler $trace))
+
+(defun macsyma-untrace-sub (fun handler ilist)
+  (prog1
+   (cond ((not (symbolp fun))
+	  (mtell "~%Bad arg to UNTRACE: ~M" fun)
+	  nil)
+	 ((not (trace-p fun))
+	  (mtell "~%~:@M is not traced." fun)
+	  nil)
+	 (t
+	  (trace-unfshadow fun (trace-type fun))
+	  (rem-trace-info fun ilist)
+	  (list fun)))
+   (if (memq fun trace-handling-stack)
+       ;; yes, he has re-defined or untraced the function
+       ;; during the trace-handling application.
+       ;; This is not strange, in fact it happens all the
+       ;; time when the user is using the $ERRORCATCH option!
+       (macsyma-trace-sub fun handler ilist))))
+
+(defun put-trace-info (fun type ilist)
+       (setf (trace-p fun) fun) ; needed for MEVAL at this time also.
+       (setf (trace-type fun) type)
+       (LET ((SYM (GENSYM)))
+	    (SET SYM 0)
+	    (setf (trace-level fun) SYM))
+       (push fun (cdr ilist))
+       (list fun))
+
+(defun rem-trace-info (fun ilist)
+       (setf (trace-p fun) nil)
+       (or (memq fun trace-handling-stack)
+	   (setf (trace-level fun) nil))
+       (setf (trace-type fun) nil)
+       (delq fun ilist)
+       (list fun))
+
+
+;; Placing the TRACE functional hook.
+;; Because the function properties in macsyma are used by the EDITOR, SAVE,
+;; and GRIND commands it is not possible to simply replace the function
+;; being traced with a hook and to store the old definition someplace.
+;; [We do know how to cons up machine-code hooks on the fly, so that
+;;  is not stopping us].
+
+
+;; This data should be formalized somehow at the time of
+;; definition of the DEFining form.
+
+(defprop subr expr shadow)
+(defprop lsubr expr shadow)
+(defprop expr expr shadow)
+(defprop mfexpr*s mfexpr* shadow)
+(defprop mfexpr* mfexpr* shadow)
+(defprop fsubr fexpr shadow)
+(defprop fexpr fexpr shadow)
+
+#-Multics
+(progn
+;; too slow to snap links on multics.
+(defprop subr t uuolinks)
+(defprop lsubr t uuolinks)
+(defprop fsubr t uuolinks) ; believe it or not. 
+)
+
+(defprop mexpr t mget)
+(defprop mexpr expr shadow)
+
+(defun get! (x y)
+       (or (get x y)
+	   (get! (error (list "Undefined" y "property") x 'wrng-type-arg)
+		 y)))
+
+(defun trace-fshadow (fun type value)
+       ;; the value is defined to be a lisp functional object, which
+       ;; might have to be compiled to be placed in certain locations.
+       (if (get type 'uuolinks)
+	   (sstatus uuolinks))
+       (let ((shadow (get! type 'shadow)))
+	    (setplist fun (list* shadow value (plist fun)))))
+
+(defun trace-unfshadow (fun type)
+       ;; what a hack.
+       (remprop fun (get! type 'shadow)))
+
+(defun trace-fsymeval (fun)
+       (or
+	(let ((type-of (trace-type fun)))
+	     (if (get type-of 'mget)
+		 (if (eq (get! type-of 'shadow) type-of)
+		     (mget (cdr (mgetl fun (list type-of))) type-of)
+		     (mget fun type-of))
+		 (if (eq (get! type-of 'shadow) type-of)
+		     (get (cdr (getl fun (list type-of))) type-of)
+		     (get fun type-of))))
+	(trace-fsymeval
+	 (merror "Macsyma BUG: Trace property for ~:@M went away without hook."
+		 fun))))
+
+
+;;; The handling of a traced call.
+
+(defvar trace-indent-level -1)
+
+(defmacro bind-sym (symbol value . body)
+	  #-Multics
+	   ;; is by far the best dynamic binding generally available.
+	  `(progv (list ,symbol)
+		  (list ,value)
+		  ,@body)
+	  #+Multics ; PROGV is wedged on multics.
+	  `(let ((the-symbol ,symbol)
+		 (the-value ,value))
+		(let ((old-value (symeval the-symbol)))
+		     (unwind-protect
+		      (progn (set the-symbol the-value)
+			     ,@body)
+		      (set the-symbol old-value)))))
+
+;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (TRACE-LEVEL FUN)) ...)
+;; (Think about PROGV and SETF and BINDF. If the trace object where
+;; a closure, then we want to fluid bind instance variables.)
+
+;; From JPG;SUPRV
+;;(DEFMFUN $ERRCATCH FEXPR (L)
+;; (LET ((ERRCATCH (CONS BINDLIST LOCLIST)) RET)
+;;      (IF (NULL (SETQ RET (ERRSET (MEVALN L) LISPERRPRINT)))
+;;	  (ERRLFUN1 ERRCATCH))
+;;      (CONS '(MLIST) RET)))
+;; ERRLFUN1 does the UNBINDING.
+;; As soon as error handlers are written and signalling is
+;; implemented, use the correct thing and get rid of this macro.
+
+(declare (special errcatch lisperrprint bindlist loclist)
+	 (*expr errlfun1))
+
+(defmacro macsyma-errset (form &aux (ret (gensym)))
+	  `(let ((errcatch (cons bindlist loclist)) ,ret)
+		(setq ,ret (errset ,form lisperrprint))
+		(or ,ret (errlfun1 errcatch))
+		,ret))
+
+(defvar predicate-arglist nil)
+
+(defvar return-to-trace-handle nil)
+
+(defun trace-handler (fun largs)
+       (If return-to-trace-handle
+	   ;; we were called by the trace-handler.
+	   (trace-apply fun largs)
+	   (let ((trace-indent-level (1+ trace-indent-level))
+		 (return-to-trace-handle t)
+		 (trace-handling-stack (cons fun trace-handling-stack))
+		 (LEVEL-SYM (TRACE-LEVEL fun))(LEVEL))
+		(SETQ LEVEL (1+ (SYMEVAL LEVEL-SYM)))
+		(BIND-SYM
+		 LEVEL-SYM
+		 LEVEL
+		 (do ((ret-val)(continuation)(predicate-arglist))(nil)
+		     (setq predicate-arglist `(,level $enter ,fun ((mlist) ,@largs)))
+		     (setq largs (trace-enter-break fun level largs))
+		     (trace-enter-print fun level largs)
+		     (cond ((trace-option-p fun '$errorcatch)
+			    (setq ret-val (macsyma-errset (trace-apply fun largs)))
+			    (cond ((null ret-val)
+				   (setq ret-val (trace-error-break fun level largs))
+				   (setq continuation (car ret-val)
+					 ret-val (cdr ret-val)))
+				  (t
+				   (setq continuation 'exit
+					 ret-val (car ret-val)))))
+			   (t
+			    (setq continuation 'exit
+				  ret-val (trace-apply fun largs))))
+		     (caseq continuation
+			    ((exit)
+			     (setq predicate-arglist `(,level $exit ,fun ,ret-val))
+			     (setq ret-val (trace-exit-break fun level ret-val))
+			     (trace-exit-print fun level ret-val)
+			     (return ret-val))
+			    ((retry)
+			     (setq largs ret-val)
+			     (MTELL "~%Re applying the function ~:@M~%" fun))
+			    ((error)
+			     (MERROR "~%Signaling error for function ~:@M~%" fun))))))))
+
+
+;; The (Trace-options function) access is not optimized to take place
+;; only once per trace-handle call. This is so that the user may change
+;; options during his break loops.
+;; Question: Should we bind return-to-trace-handle to NIL when we
+;; call the user's predicate? He has control over his own lossage.
+
+(defmvar $trace_safety t "This is subtle")
+
+(defun trace-option-p (function KEYWORD)
+  (do ((options					
+	(LET ((OPTIONS (TRACE-OPTIONS FUNCTION)))
+	  (COND ((NULL OPTIONS) NIL)
+		(($LISTP OPTIONS) (CDR OPTIONS))
+		(T
+		 (mtell "Trace options for ~:@M not a list, so ignored."
+			function)
+		 NIL)))
+	(CDR OPTIONS))
+       (OPTION))
+      ((null options) nil)
+    (setq OPTION (CAR OPTIONS))
+    (cond ((atom option)
+	   (if (eq option keyword) (return t)))
+	  ((eq (caar option) keyword)
+	   (let ((return-to-trace-handle $trace_safety))
+	     (return (mapply (cadr option) predicate-arglist
+			     "&A trace option predicate")))))))
+			
+
+(defun trace-enter-print (fun lev largs &aux (mlargs `((mlist) ,@largs)))
+  (if (not (trace-option-p fun '$noprint))
+      (let ((info (trace-option-p fun '$info)))
+	(cond ((trace-option-p fun '$lisp_print)
+	       (trace-print `(,lev enter ,fun ,largs ,@info)))
+	      (t
+	       (trace-mprint lev " Enter " (mopstringnam fun) " " mlargs
+			     (if info " -> " "")
+			     (if info info "")))))))
+
+(defun mopstringnam (x) (maknam (mstring (getop x))))
+
+(defun trace-exit-print (fun lev ret-val)
+       (if (not (trace-option-p fun '$noprint))
+	   (let ((info (trace-option-p fun '$info)))
+		(cond ((trace-option-p fun '$lisp_print)
+		       (trace-print `(,lev exit ,fun ,ret-val ,@info)))
+		      (t
+		       (trace-mprint lev " Exit  " (mopstringnam fun) " " ret-val
+				     (if info " -> " "")
+				     (if info info "")))))))
+
+(defmvar $trace_break_arg '$TRACE_BREAK_ARG 
+	 "During trace Breakpoints bound to the argument list or return value")
+
+(defun trace-enter-break (fun lev largs)
+       (if (trace-option-p fun '$break)
+	   (do ((return-to-trace-handle nil)
+		($trace_break_arg `((mlist) ,@largs)))(nil)
+	       ($break '|&Trace entering| fun '|&level| lev)
+	       (cond (($listp $trace_break_arg)
+		      (return (cdr $trace_break_arg)))
+		     (t
+		       (mtell "~%Trace_break_arg set to nonlist, ~
+			      please try again"))))
+	   largs))
+
+(defun trace-exit-break (fun lev ret-val)
+       (if (trace-option-p fun '$break)
+	   (let (($trace_break_arg ret-val)
+		 (return-to-trace-handle nil))
+		($break '|&Trace exiting| fun '|&level| lev)
+		$trace_break_arg)
+	   ret-val))
+
+(defun pred-$read (predicate argl bad-message)
+       (do ((ans))(nil)
+	   (setq ans (apply #'$read argl))
+	   (if (funcall predicate ans) (return ans))
+	   (mtell "~%Unacceptable input, ~A~%" bad-message)))
+
+(declare (special upper))
+
+(defun ask-choicep (list &rest header-message)
+       (do ((j 0 (1+ j))
+	    (dlist nil
+		   (list* "î" `((marrow) ,j ,(car ilist)) dlist))
+	    (ilist list (cdr ilist)))
+	   ((null ilist)
+	    (setq dlist (nconc header-message (cons "î" (nreverse dlist))))
+	    (let ((upper (1- j)))
+		 (pred-$read #'(lambda (val)
+				      (and (fixp val)
+					   (>= val 0)
+					   (<= val upper)))
+			    dlist
+			    "please reply with an integer from the menue.")))))
+
+(declare (unspecial upper))
+
+(defun trace-error-break (fun level largs)
+       (caseq (ask-choicep '("Signal an error, i.e. PUNT?"
+			     "Retry with same arguments?"
+			     "Retry with new arguments?"
+			     "Exit with user supplied value")
+			   "Error during application of" (mopstringnam fun)
+			   "at level" level
+			   "î" "Do you want to:")
+	      ((0)
+	       '(error))
+	      ((1)
+	       (cons 'retry largs))
+	      ((2)
+	       (cons 'retry (let (($trace_break_arg `((mlist) ,largs)))
+				 (cdr (pred-$read '$listp
+						 (list
+						  "Enter new argument list for"
+						  (mopstringnam fun))
+						 "please enter a list.")))))
+					   
+	      ((3)
+	       (cons 'exit ($read "Enter value to return")))))
+
+
+;;; application dispatch, and the consing up of the trace hook.
+
+(defun macsyma-fsymeval (fun)
+       (let ((try (macsyma-fsymeval-sub fun)))
+	    (cond (try try)
+		  ((get fun 'autoload)
+		   (load-and-tell (get fun 'autoload))
+		   (setq try (macsyma-fsymeval-sub fun))
+		   (or try
+		       (mtell "~%~:@M has no functional~
+			      properties after autoloading.~%"
+			      fun))
+		   try)
+		  (t try))))
+
+(defun macsyma-fsymeval-sub (fun)
+       ;; The semantics of $TRANSRUN are herein taken from DESCRIBE,
+       ;; a carefull reading of MEVAL1 reveals, well... I've promised to watch
+       ;; my language in these comments.
+
+       (let ((mprops (mgetl fun '(mexpr mmacro)))
+	     (lprops (getl fun '(subr lsubr expr fexpr macro fsubr
+				      translated-mmacro mfexpr* mfexpr*s))))
+	    (cond ($TRANSRUN
+		   ;; the default, so its really a waste to have looked for
+		   ;; those mprops. Its better to fix the crock than to
+		   ;; optimize this though!
+		   (or lprops mprops))
+		  (t
+		   (or mprops lprops)))))
+
+(Defprop EXPR EXPR HOOK-TYPE)
+(DEFPROP MEXPR EXPR HOOK-TYPE)
+(Defprop SUBR EXPR HOOK-TYPE)
+(Defprop LSUBR EXPR HOOK-TYPE)
+(Defprop FEXPR FEXPR HOOK-TYPE)
+(Defprop FSUBR FEXPR HOOK-TYPE)
+(Defprop MFEXPR* MACRO HOOK-TYPE)
+(Defprop MFEXPR*S MACRO HOOK-TYPE)
+
+(defun make-trace-hook (fun type handler)
+  (CASEQ (GET! TYPE 'HOOK-TYPE)
+    ((EXPR)
+     `(lambda trace-nargs
+	(,handler ',fun (listify trace-nargs))))
+    ((FEXPR)
+     `(LAMBDA (TRACE-ARGL)
+	(,HANDLER ',FUN TRACE-ARGL)))
+    ((MACRO)
+     `(lambda (TRACE-FORM)
+	(,HANDLER (CAAR TRACE-FORM) (LIST TRACE-FORM))))))
+       
+
+(defun trace-apply (fun largs)
+       (let ((prop (trace-fsymeval fun))
+	     (type (trace-type fun))
+	     (return-to-trace-handle nil))
+	    (caseq type
+		   ((mexpr)
+		    (mapply prop largs "&A traced function"))
+		   ((expr)
+		    (apply prop largs))
+		   ((subr lsubr)
+		    ;; no need to be fast here.
+		    (args 'the-trace-apply-hack (args fun))
+		    (setplist 'the-trace-apply-hack (list type prop))
+		    (apply 'the-trace-apply-hack largs))
+		   ((MFEXPR*)
+		    (FUNCALL PROP (CAR LARGS)))
+		   ((MFEXPR*S)
+		    (SUBRCALL NIL PROP (CAR LARGS)))
+		   ((FEXPR)
+		    (FUNCALL PROP LARGS))
+		   ((FSUBR)
+		    (SUBRCALL NIL PROP LARGS)))))
+
+;;; I/O cruft
+
+(defmvar $trace_max_indent 15. "max number of spaces it will go right"
+	 FIXNUM)
+(putprop '$trace_max_indent #'assign-mode-check 'assign)
+(putprop '$trace_max_indent '$fixnum 'mode)
+
+(defun (spaceout dimension) (form result)
+       (dimension-string (*make-list (cadr form) #\sp) result))
+
+(defun trace-mprint (&rest l)
+       (mtell-open "~M"
+		   `((mtext)
+		     ((spaceout) ,(min $trace_max_indent trace-indent-level))
+		     ,@l)))
+
+(defun trace-print (form)
+       (terpri)
+       (do ((j (min $trace_max_indent trace-indent-level)
+	       (1- j)))
+	   ((not (> j 0)))
+	   (tyo #\sp))
+       (if prin1 (funcall prin1 form)
+	   (prin1 form))
+       (tyo #\sp))
+
+
+;; 9:02pm  Monday, 18 May 1981 -GJC
+;; A function benchmark facility using trace utilities.
+;; This provides medium accuracy, enough for most user needs.
+
+(DEFMVAR $TIMER '((MLIST)) "List of functions under active timetrace")
+(PUTPROP '$TIMER #'READ-ONLY-ASSIGN 'ASSIGN)
+
+(DEFMSPEC $TIMER (FORM)
+  (MLISTCAN-$ALL #'macsyma-timer (cdr form) $timer))
+
+(DEFMSPEC $UNTIMER (FORM)
+  `((MLIST) ,@(MAPCAN #'MACSYMA-UNTIMER (OR (CDR FORM)
+					    (CDR $TIMER)))))
+
+(DEFUN MICRO-TO-SEC (RUNTIME)
+  (MUL RUNTIME 1.0E-6 '$SEC))
+(DEFUN MICRO-PER-CALL-TO-SEC (RUNTIME CALLS)
+  (DIV (MICRO-TO-SEC RUNTIME)
+       (IF (ZEROP CALLS) 1 CALLS)))
+
+(DEFUN TIMER-MLIST (FUNCTION CALLS RUNTIME GCTIME)
+  `((MLIST SIMP) ,FUNCTION
+		 ,(MICRO-PER-CALL-TO-SEC (PLUS RUNTIME GCTIME) CALLS)
+		 ,CALLS
+		 ,(MICRO-TO-SEC RUNTIME)
+		 ,(MICRO-TO-SEC GCTIME)))
+
+(DEFMSPEC $TIMER_INFO (FORM)
+  (DO ((L (OR (CDR FORM) (CDR $TIMER))
+	  (CDR L))
+       (V NIL)
+       (TOTAL-RUNTIME 0)
+       (TOTAL-GCTIME 0)
+       (TOTAL-CALLS 0))
+      ((NULL L)
+       `(($matrix simp)
+	 ((MLIST SIMP) $FUNCTION $TIME//CALL $CALLS $RUNTIME $GCTIME)
+	 ,.(NREVERSE V)
+	 ,(TIMER-MLIST '$TOTAL TOTAL-CALLS TOTAL-RUNTIME TOTAL-GCTIME)))
+      (LET ((RUNTIME ($GET (CAR L) '$RUNTIME))
+	    (GCTIME  ($GET (CAR L) '$GCTIME))
+	    (CALLS   ($GET (CAR L) '$CALLS)))
+	(WHEN RUNTIME
+	      (SETQ TOTAL-CALLS (PLUS CALLS TOTAL-CALLS))
+	      (SETQ TOTAL-RUNTIME (PLUS RUNTIME TOTAL-RUNTIME))
+	      (SETQ TOTAL-GCTIME (PLUS GCTIME TOTAL-GCTIME))
+	      (PUSH (TIMER-MLIST (CAR L) CALLS RUNTIME GCTIME) V)))))
+
+(DEFUN macsyma-timer (fun)
+  (PROG1 (macsyma-trace-sub fun 'timer-handler $timer)
+	 ($PUT FUN 0 '$RUNTIME)
+	 ($PUT FUN 0 '$GCTIME)
+	 ($PUT FUN 0 '$CALLS)
+	 ))
+
+(defun macsyma-untimer (fun) (macsyma-untrace-sub fun 'timer-handler $timer))
+
+(DEFVAR RUNTIME-DEVALUE 0)
+(DEFVAR GCTIME-DEVALUE 0)
+
+(DEFMVAR $TIMER_DEVALUE NIL
+  "If true, then time spent inside calls to other timed functions is
+  subtracted from the timing figure for a function.")
+
+(DEFUN TIMER-HANDLER (FUN LARGS)
+  ;; N.B. Doesn't even try to account for use of DYNAMIC CONTROL
+  ;; such as ERRSET ERROR and CATCH and THROW, as these are
+  ;; rare and the overhead for the unwind-protect is high.
+  (LET ((RUNTIME (RUNTIME))
+	(GCTIME (STATUS GCTIME))
+	(OLD-RUNTIME-DEVALUE RUNTIME-DEVALUE)
+	(OLD-GCTIME-DEVALUE GCTIME-DEVALUE))
+    (PROG1 (TRACE-APPLY FUN LARGS)
+	   (SETQ OLD-RUNTIME-DEVALUE (- RUNTIME-DEVALUE OLD-RUNTIME-DEVALUE))
+	   (SETQ OLD-GCTIME-DEVALUE (- GCTIME-DEVALUE OLD-GCTIME-DEVALUE))
+	   (SETQ RUNTIME (- (RUNTIME) RUNTIME OLD-RUNTIME-DEVALUE))
+	   (SETQ GCTIME (- (STATUS GCTIME) GCTIME OLD-GCTIME-DEVALUE))
+	   (WHEN $TIMER_DEVALUE
+		 (SETQ RUNTIME-DEVALUE (+ RUNTIME-DEVALUE RUNTIME))
+		 (SETQ GCTIME-DEVALUE (+ GCTIME-DEVALUE GCTIME)))
+	   ($PUT FUN (+ ($GET FUN '$RUNTIME) RUNTIME) '$RUNTIME)
+	   ($PUT FUN (+ ($GET FUN '$GCTIME) GCTIME) '$GCTIME)
+	   ($PUT FUN (1+ ($GET FUN '$CALLS)) '$CALLS))))
+

src/maxsrc/mtree.1

@@ -0,0 +1,86 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module mtree)
+
+
+;;; A general macsyma tree walker.
+
+;;; It is cleaner to have the flags and handlers passed as arguments
+;;; to the function instead of having them be special variables.
+;;; In maclisp this also happens to win big, because the arguments
+;;; merely stay in registers.
+
+
+(DEFMFUN MTREE-SUBST (FORM CAR-FLAG MOP-FLAG SUBST-ER)
+	 (COND ((ATOM FORM)
+		(SUBRCALL NIL SUBST-ER FORM MOP-FLAG))
+	       (CAR-FLAG
+		(COND (($RATP FORM)
+		       (LET* ((DISREP ($RATDISREP FORM))
+			      (SUB    (MTREE-SUBST DISREP T MOP-FLAG SUBST-ER)))
+			     (COND ((EQ DISREP SUB) FORM)
+				   (T ($RAT SUB)))))
+		      ((ATOM (CAR FORM))
+		       (MERROR "Illegal expression being walked."))
+		      (T
+		       (LET ((CDR-VALUE (MTREE-SUBST (CDR FORM)
+						     NIL MOP-FLAG SUBST-ER))
+			     (CAAR-VALUE (MTREE-SUBST (CAAR FORM)
+						      T T SUBST-ER)))
+			    (COND ((AND (EQ CDR-VALUE (CDR FORM))
+					(EQ (CAAR FORM) CAAR-VALUE))
+				   FORM)
+				  ; cannonicalize the operator.
+				  ((AND (LEGAL-LAMBDA CAAR-VALUE)
+					$SUBLIS_APPLY_LAMBDA)
+				   `((,CAAR-VALUE
+				      ,@(COND ((MEMQ 'ARRAY (CAR FORM)) '(ARRAY))
+					      (T NIL)))
+				     ,@CDR-VALUE))
+				  (T
+				   `((MQAPPLY
+				      ,@(COND ((MEMQ 'ARRAY (CAR FORM)) '(ARRAY))
+					      (T NIL)))
+				     ,CAAR-VALUE
+				     ,@CDR-VALUE)))))))
+	       (T
+		(LET ((CAR-VALUE (MTREE-SUBST (CAR FORM) T MOP-FLAG SUBST-ER))
+		      (CDR-VALUE (MTREE-SUBST (CDR FORM) NIL MOP-FLAG SUBST-ER)))
+		   (COND ((AND (EQ (CAR FORM) CAR-VALUE)
+			       (EQ (CDR FORM) CDR-VALUE))
+			  FORM)
+			 (T
+			  (CONS CAR-VALUE CDR-VALUE)))))))
+
+(DEFUN LEGAL-LAMBDA (X)
+       (COND ((ATOM X) NIL)
+	     ((ATOM (CAR X))
+	      (EQ (CAR X) 'LAMBDA))
+	     (T
+	      (EQ (CAAR X) 'LAMBDA))))
+
+(DEF-PROCEDURE-PROPERTY
+ $APPLY_NOUNS
+ (LAMBDA (ATOM MOP-FLAG)
+	 (COND (MOP-FLAG
+		(LET ((TEMP (GET ATOM '$APPLY_NOUNS)))
+		     (COND (TEMP TEMP)
+			   ((SETQ TEMP (GET ATOM 'NOUN))
+			    ; the reason I do this instead of
+			    ; applying it now is that the simplifier
+			    ; has to walk the tree anyway, and this
+			    ; way we avoid funargiez.
+			    (PUTPROP ATOM
+				     `((LAMBDA) ((MLIST) ((MLIST) L))
+						(($APPLY) ((MQUOTE) ,TEMP)
+							  L))
+				     '$APPLY_NOUNS))
+			   (T ATOM))))
+	       (T ATOM)))
+ FOOBAR)
+
+(DEFMFUN $APPLY_NOUNS (EXP)
+	 (LET (($SUBLIS_APPLY_LAMBDA T))
+	      (MTREE-SUBST EXP T NIL (GET '$APPLY_NOUNS 'FOOBAR))))

src/maxsrc/mutils.11

@@ -0,0 +1,57 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module mutils)
+
+;;; General purpose Macsyma utilities.  This file contains runtime functions 
+;;; which perform operations on Macsyma functions or data, but which are
+;;; too general for placement in a particular file.
+;;;
+;;; Every function in this file is known about externally.
+
+
+
+;;; (ASSOL item A-list)
+;;;
+;;;  Like ASSOC, but uses ALIKE1 as the comparison predicate rather
+;;;  than EQUAL.
+;;;
+;;;  Meta-Synonym:	(ASS #'ALIKE1 ITEM ALIST)
+
+(DEFMFUN ASSOL (ITEM ALIST)
+  (DOLIST (PAIR ALIST)
+	  (IF (ALIKE1 ITEM (CAR PAIR)) (RETURN PAIR))))
+;;; 
+
+(DEFMFUN ASSOLIKE (ITEM ALIST) 
+  (CDR (ASSOL ITEM ALIST)))
+
+; Old ASSOLIKE definition:
+;
+; (defun assolike (e l) 
+;	 (prog nil 
+;	  loop (cond ((null l) (return nil))
+;		     ((alike1 e (caar l)) (return (cdar l))))
+;	       (setq l (cdr l))
+;	       (go loop)))
+
+;;; (MEM #'ALIKE1 X L)
+
+(DEFMFUN MEMALIKE (X L)
+  (DO L L (CDR L) (NULL L)
+      (COND ((ALIKE1 X (CAR L)) (RETURN L)))))
+
+;;;Do we want MACROS for these on MC and on Multics?? -Jim 1/29/81
+#+Multics
+(PROGN 'COMPILE
+  (DEFMFUN MSTRINGP (X)
+    (AND (SYMBOLP X)
+	 (EQUAL (GETCHARN X 1) #/&)))
+
+  (DEFMFUN MSTRING-TO-STRING (X)
+    (SUBSTRING (STRING X) 1))
+
+  (DEFMFUN STRING-TO-MSTRING (X)
+    (MAKE-SYMBOL (STRING-APPEND "&" X)))
+)

src/maxsrc/ndiffq.5

@@ -0,0 +1,199 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module ndiffq)
+
+(load-macsyma-macros numerm)
+
+;;; Some numerical differential equation routines.
+
+(defmfun $init_float_array (array x0 x1 &aux
+				     (a (get-array array '(flonum) 1)))
+  (setq x0 (float x0)
+	x1 (float x1))
+  (let ((n (array-dimension-n 1 a)))
+    (do ((j 0 (1+ j))
+	 (h (//$ (-$ x1 x0) (float (1- n))))
+	 (x x0 (+$ x h)))
+	((= j n) array)
+      (setf (aref$ a j) x))))
+
+(defmfun $map_float_array (ya f xa)
+  (let* ((y (get-array ya '(flonum) 1))
+	 (n (array-dimension-n 1 y))
+	 (x (get-array xa '(flonum) 1 n)))
+    (bind-tramp1$
+     f f
+     (do ((j 0 (1+ j)))
+	 ((= j n) ya)
+       (setf (aref$ y j) (fcall$ f (aref$ x j)))))))
+  
+;;; Runge-Kutta method for getting starting values.
+
+(defvar runge-^]-int nil)
+(defun runge-^]-int () (setq runge-^]-int t))
+
+(defun $runge_kutta (f x y &rest higher-order)
+  (let  ((runge-^]-int nil)
+	 (USER-TIMESOFAR (CONS #'runge-^]-int USER-TIMESOFAR)))
+    (if ($listp f)
+	(if higher-order
+	    (merror "Runge_Kutta handles systems of order 1 only.")
+	    (let* ((fl (mapcar #'(lambda (f) (make-gtramp$ f 2)) (cdr f)))
+		   (xa (get-array x '(flonum) 1))
+		   (n (array-dimension-n 1 xa)))
+	      (if (and ($listp y)
+		       (= (length fl) (length (cdr y))))
+		  (runge-kutta-1-n fl xa
+				   (mapcar #'(lambda (y)
+					       (get-array y '(flonum) 1 n))
+					   (cdr y)))
+		  (merror "Not a list of length ~M~%~M" (length fl) y))))
+	(let* ((xa (get-array x '(flonum) 1))
+	       (n (array-dimension-n 1 xa))
+	       (ya (get-array y '(flonum) 1 n)))
+	  (caseq (length higher-order)
+	    ((0)
+	     (bind-tramp2$
+	      f f
+	      (runge-kutta-1 f xa ya)))
+	    ((1)
+	     (bind-tramp3$
+	      f f
+	      (runge-kutta-2 f xa ya
+			     (get-array (car higher-order) '(flonum) 1 n))))
+	    (t
+	     (merror "Runge_Kutta of order greater than 2 is unimplemented"))))))
+  ;; return value to user.
+  y)
+
+(defvar one-half$   (//$ 1.0 2.0))
+(defvar one-third$  (//$ 1.0 3.0))
+(defvar one-sixth$  (//$ 1.0 6.0))
+(defvar one-eighth$ (//$ 1.0 8.0))
+
+(DEFVAR RUNGE-KUTTA-1 NIL)
+
+(defun runge-kutta-1 (f x y)
+  (do ((m-1 (1- (array-dimension-n 1 x)))
+       (n 0 (1+ n))
+       (x_n)(y_n)(h)(k1)(k2)(k3)(k4))
+      ((= n m-1))
+    (declare (fixnum n-1 n)
+	     (flonum x_n y_n h k1 k2 k3 k4))
+    (setq x_n (aref$ x n))
+    (setq y_n (aref$ y n))
+    (WHEN RUNGE-^]-INT
+	  (SETQ RUNGE-^]-INT NIL)
+	  (MTELL "~A steps, calculating F(~A,~A)" N X_N Y_N))
+    (setq h (-$ (aref$ x (1+ n)) x_n))
+    ;; Formula 25.5.10 pp 896 of Abramowitz & Stegun.
+    (setq k1 (*$ h (fcall$ f x_n y_n)))
+    (setq k2 (*$ h (fcall$ f
+			   (+$ x_n (*$ one-half$ h))
+			   (+$ y_n (*$ one-half$ k1)))))
+    (setq k3 (*$ h (fcall$ f
+			   (+$ x_n (*$ one-half$ h))
+			   (+$ y_n (*$ one-half$ k2)))))
+    (setq k4 (*$ h (fcall$ f
+			   (+$ x_n h)
+			   (+$ y_n k3))))
+    (setf (aref$ y (1+ n))
+	  (+$ y_n (*$ one-sixth$ (+$ k1 k4))
+	          (*$ one-third$ (+$ k2 k3))))))
+
+(defun runge-kutta-2 (f x y y-p)
+  (do ((m-1 (1- (array-dimension-n 1 x)))
+       (n 0 (1+ n))
+       (x_n)(y_n)(y-p_n)(h)(k1)(k2)(k3)(k4))
+      ((= n m-1))
+    (declare (fixnum m-1 n)
+	     (flonum x_n y_n y-p_n h k1 k2 k3 k4))
+    (setq x_n (aref$ x n))
+    (setq y_n (aref$ y n))
+    (setq y-p_n (aref$ y-p n))
+    (WHEN RUNGE-^]-INT
+	  (SETQ RUNGE-^]-INT NIL)
+	  (MTELL "~A steps, calculating F(~A,~A,~A)" N X_N Y_N Y-P_N))
+    (setq h (-$ (aref$ x (1+ n)) x_n))
+    ;; Formula 25.5.20 pp 897 of Abramowitz & Stegun.
+    (setq k1 (*$ h (fcall$ f x_n y_n y-p_n)))
+    (setq k2 (*$ h (fcall$ f
+			   (+$ x_n (*$ one-half$ h))
+			   (+$ y_n (*$ one-half$ h y-p_n)
+			           (*$ one-eighth$ h k1))
+			   (+$ y-p_n (*$ one-half$ k1)))))
+    (setq k3 (*$ h (fcall$ f
+			   (+$ x_n (*$ one-half$ h))
+			   (+$ y_n (*$ one-half$ h y-p_n)
+			           (*$ one-eighth$ h k1))
+			   (+$ y-p_n (*$ one-half$ k2)))))
+    (setq k4 (*$ h (fcall$ f
+			   (+$ x_n h)
+			   (+$ y_n (*$ h y-p_n)
+			           (*$ one-half$ h k3))
+			   (+$ y-p_n k3))))
+    (setf (aref$ y (1+ n))
+	  (+$ y_n (*$ h (+$ y-p_n (*$ one-sixth$ (+$ k1 k2 k3))))))
+    (setf (aref$ y-p (1+ n))
+	  (+$ y-p_n (+$ (*$ one-third$ (+$ k2 k3))
+			(*$ one-sixth$ (+$ k1 k4)))))))
+
+(defun runge-kutta-1-n (fl x yl
+			   &aux
+			   (m (array-dimension-n 1 x))
+			   (d (length fl)))
+  (do ((m-1 (1- m))
+       (n 0 (1+ n))
+       (h)
+       (x_n)
+       (y_n (make-array$ d))
+       (K1 (make-array$ d))
+       (K2 (make-array$ d))
+       (K3 (make-array$ d))
+       (K4 (make-array$ d))
+       (ACC (make-array$ d)))
+      ((= n m-1)
+       (free-array$ y_n)
+       (free-array$ k1)
+       (free-array$ k2)
+       (free-array$ k3)
+       (free-array$ k4)
+       (free-array$ acc)
+       nil)
+    (declare (fixnum m-1 n) (flonum x_n h))
+    (setq x_n (aref$ x n))
+    (when (= n 0)
+	  (do ((l yl (cdr l))
+	       (j 0 (1+ j)))
+	      ((null l))
+	    (setf (aref$ y_n j) (aref$ (car l) n))))
+    (WHEN RUNGE-^]-INT
+	  (SETQ RUNGE-^]-INT NIL)
+	  (MTELL "~A steps, calculating ~M" n
+		 `(($F) ,x_n ,@(listarray y_n))))
+    (setq h (-$ (aref$ x (1+ n)) x_n))
+    (gvapply$-x-ar$ k1 fl x_n y_n)
+    (ar$*s k1 k1 h)					
+    (ar$*s acc k1 one-half$)
+    (ar$+ar$ acc acc y_n)
+    (gvapply$-x-ar$ k2 fl (+$ x_n (*$ h one-half$)) acc)
+    (ar$*s k2 k2 h)
+    (ar$*s acc k2 one-half$)
+    (ar$+ar$ acc acc y_n)
+    (gvapply$-x-ar$ k3 fl (+$ x_n (*$ h one-half$)) acc)
+    (ar$*s k3 k3 h)
+    (ar$+ar$ acc k3 y_n)
+    (gvapply$-x-ar$ k4 fl (+$ x_n h) acc)
+    (ar$*s k4 k4 h)
+    (ar$+ar$ k1 k1 k4)
+    (ar$*s k1 k1 one-sixth$)
+    (ar$+ar$ k2 k2 k3)
+    (ar$*s k2 k2 one-third$)
+    (ar$+ar$ y_n y_n k1)
+    (ar$+ar$ y_n y_n k2)
+    (do ((l yl (cdr l))
+	 (j 0 (1+ j)))
+	((null l))
+      (setf (aref$ (car l) (1+ n)) (aref$ y_n j)))))

src/maxsrc/numer.17

@@ -0,0 +1,276 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module numer)
+(load-macsyma-macros numerm)
+
+;;; Interface of lisp numerical routines to macsyma.
+;;; 4:34pm  Thursday, 28 May 1981 - George Carrette.
+
+(DEFMACRO COMPATIBLE-ARRAY-TYPE? (TYPE TYPE-LIST)
+  #+MACLISP
+  `(MEMQ ,TYPE ,TYPE-LIST)
+  #+LISPM
+  (PROGN TYPE-LIST
+	 `(EQ ,TYPE 'ART-Q))
+  )
+
+(DEFMFUN GET-ARRAY (X &OPTIONAL (KINDS NIL) (/#-DIMS) &REST DIMENSIONS)
+  "Get-Array is fairly general.
+  Examples:
+  (get-array ar '(flonum) 2 3 5) makes sure ar is a flonum array
+  with 2 dimensions, of 3 and 5.
+  (get-array ar '(fixnum) 1) gets a 1 dimensional fixnum array."
+  (COND ((NULL KINDS)
+	 (CASEQ (TYPEP X)
+	   ((ARRAY) X)
+	   ((SYMBOL)
+	    (OR (GET X 'ARRAY)
+		(AND (FBOUNDP X)
+		     (EQ 'ARRAY (TYPEP (FSYMEVAL X)))
+		     (FSYMEVAL X))
+		(MERROR "Not a lisp array:~%~M" X)))
+	   (T
+	    (MERROR "Not a lisp array:~%~M" X))))
+	((NULL /#-DIMS)
+	 (LET ((A (GET-ARRAY X)))
+	   (COND ((COMPATIBLE-ARRAY-TYPE? (ARRAY-TYPE A) KINDS) A)
+		 (T
+		  (MERROR "~:M is not an array of type: ~:M"
+			  X
+			  `((mlist) ,@kinds))))))
+	((NULL DIMENSIONS)
+	 (LET ((A (GET-ARRAY X KINDS)))
+	   (COND ((= (ARRAY-/#-DIMS A) /#-DIMS) A)
+		 (T
+		  (MERROR "~:M does not have ~:M dimensions." X /#-DIMS)))))
+	('ELSE
+	 (LET ((A (GET-ARRAY X KINDS /#-DIMS)))
+	   (DO ((J 1 (1+ J))
+		(L DIMENSIONS (CDR L)))
+	       ((NULL L)
+		A)
+	     (OR (OR (EQ (CAR L) '*)
+		     (= (CAR L) (ARRAY-DIMENSION-N J A)))
+		 (MERROR "~:M does not have dimension ~:M equal to ~:M"
+			 X
+			 J
+			 (CAR L))))))))
+
+(DECLARE (SPECIAL %E-VAL))
+
+(DEFUN MTO-FLOAT (X)
+  (FLOAT (IF (NUMBERP X)
+	     X
+	     (LET (($NUMER T) ($FLOAT T))
+	       (RESIMPLIFY (SUBST %E-VAL '$%E X))))))
+
+;;; Trampolines for calling with numerical efficiency.
+
+(DEFVAR TRAMP$-ALIST ())
+
+(DEFMACRO DEFTRAMP$ (NARGS)
+  (LET ((TRAMP$ (SYMBOLCONC 'TRAMP NARGS '$))
+	#+MACLISP
+	(TRAMP$-S (SYMBOLCONC 'TRAMP NARGS '$-S))
+	(TRAMP$-F (SYMBOLCONC 'TRAMP NARGS '$-F))
+	(TRAMP$-M (SYMBOLCONC 'TRAMP NARGS '$-M))
+	(L (MAKE-LIST NARGS)))
+    (LET ((ARG-LIST (MAPCAR #'(LAMBDA (IGNORE)(GENSYM)) L))
+	  #+MACLISP
+	  (ARG-TYPE-LIST (MAPCAR #'(LAMBDA (IGNORE) 'FLONUM) L)))
+    `(PROGN 'COMPILE
+	    (PUSH '(,NARGS ,TRAMP$
+		    #+MACLISP ,TRAMP$-S
+		    ,TRAMP$-F ,TRAMP$-M)
+		  TRAMP$-ALIST)
+	    (DEFMVAR ,TRAMP$ "Contains the object to jump to if needed")
+	    #+MACLISP
+	    (DECLARE (FLONUM (,TRAMP$-S ,@ARG-TYPE-LIST)
+			     (,TRAMP$-F ,@ARG-TYPE-LIST)
+			     (,TRAMP$-M ,@ARG-TYPE-LIST)))
+	    #+MACLISP
+	    (DEFUN ,TRAMP$-S ,ARG-LIST
+	      (FLOAT (SUBRCALL NIL ,TRAMP$ ,@ARG-LIST)))
+	    (DEFUN ,TRAMP$-F ,ARG-LIST
+	      (FLOAT (FUNCALL ,TRAMP$ ,@ARG-LIST)))
+	    (DEFUN ,TRAMP$-M ,ARG-LIST
+	      (FLOAT (MAPPLY ,TRAMP$ (LIST ,@ARG-LIST) ',TRAMP$)))))))
+
+(DEFTRAMP$ 1)
+(DEFTRAMP$ 2)
+(DEFTRAMP$ 3)
+
+(DEFMFUN MAKE-TRAMP$ (F N)
+  (LET ((L (ASSOC N TRAMP$-ALIST)))
+    (IF (NULL L)
+	(MERROR "BUG: No trampoline of argument length ~M" N))
+    (POP L)
+    (LET ((TRAMP$ (POP L))
+	  #+MACLISP
+	  (TRAMP$-S (POP L))
+	  (TRAMP$-F (POP L))
+	  (TRAMP$-M (POP L)))
+      (LET ((WHATNOT (FUNTYPEP F)))
+	(CASEQ (CAR WHATNOT)
+	  ((OPERATORS)
+	   (SET TRAMP$ F)
+	   (GETSUBR! TRAMP$-M))
+   	  ((MEXPR)
+	   (SET TRAMP$ (CADR WHATNOT))
+	   (GETSUBR! TRAMP$-M))
+	  #+MACLISP
+	  ((SUBR)
+	   (COND ((SHIT-EQ (CADR WHATNOT) (GETSUBR! TRAMP$-S))
+		  ;; This depends on the fact that the lisp compiler
+		  ;; always outputs the same first instruction for
+		  ;; "flonum compiled" subrs.
+		  (CADR WHATNOT))
+		 ('ELSE
+		  (SET TRAMP$ (CADR WHATNOT))
+		  (GETSUBR! TRAMP$-S))))
+	  ((EXPR LSUBR)
+	   (SET TRAMP$ (CADR WHATNOT))
+	   (GETSUBR! TRAMP$-F))
+	  (T
+	   (MERROR "Undefined or inscrutable function~%~M" F)))))))
+
+
+(DEFUN GETSUBR! (X)
+  (OR #+MACLISP(GET X 'SUBR)
+      #+LISPM (AND (FBOUNDP X) (FSYMEVAL X))
+      (GETSUBR! (ERROR "No subr property for it!" X 'WRNG-TYPE-ARG))))
+
+(DEFUN FUNTYPEP (F)
+  (COND ((SYMBOLP F)
+	 (LET ((MPROPS (MGETL F '(MEXPR)))
+	       (LPROPS #+MACLISP (GETL F '(SUBR LSUBR EXPR))
+		       #+LISPM (AND (FBOUNDP F)
+				    (LIST 'EXPR (FSYMEVAL F)))))
+	   (OR (IF $TRANSRUN
+		   (OR LPROPS MPROPS)
+		   (OR MPROPS LPROPS))
+	       (GETL F '(OPERATORS)))))
+	((EQ (TYPEP F) 'LIST)
+	 (LIST (IF (MEMQ (CAR F) '(FUNCTION LAMBDA NAMED-LAMBDA))
+		   'EXPR
+		   'MEXPR)
+	       F))
+	('ELSE
+	 NIL)))
+
+#+MACLISP
+(DEFUN SHIT-EQ (X Y) (= (EXAMINE (MAKNUM X)) (EXAMINE (MAKNUM Y))))
+
+;; For some purposes we need a more general trampoline mechanism,
+;; not limited by the need to use a special variable and a
+;; BIND-TRAMP$ mechanism.
+
+;; For now, we just need the special cases F(X), and F(X,Y) for plotting,
+;; and the hackish GAPPLY$-AR$ for systems of equations.
+
+(DEFUN MAKE-GTRAMP$ (F NARGS)
+  NARGS
+  ;; for now, ignoring the number of arguments, but we really should
+  ;; do this error checking.
+  (LET ((K (FUNTYPEP F)))
+    (CASEQ (CAR K)
+      ((OPERATORS)
+       (CONS 'OPERATORS F))
+      #+MACLISP
+      ((SUBR)
+       (IF (SHIT-EQ (CADR K) (GETSUBR! 'TRAMP1$-S))
+	   (CONS 'SUBR$ (CADR K))
+	   (CONS 'SUBR (CADR K))))
+      ((MEXPR EXPR LSUBR)
+       (CONS (CAR K) (CADR K)))
+      (T
+       (MERROR "Undefined or inscrutable function~%~M" F)))))
+
+(DEFUN GCALL1$ (F X)
+  (CASEQ (CAR F)
+    #+MACLISP
+    ((SUBR$)
+     (SUBRCALL FLONUM (CDR F) X))
+    #+MACLISP
+    ((SUBR)
+     (FLOAT (SUBRCALL NIL (CDR F) X)))
+    #+MACLISP
+    ((LSUBR)
+     (FLOAT (LSUBRCALL NIL (CDR F) X)))
+    ((EXPR)
+     (FLOAT (FUNCALL (CDR F) X)))
+    ((MEXPR OPERATORS)
+     (FLOAT (MAPPLY (CDR F) (LIST X) NIL)))
+    (T
+     (MERROR "BUG: GCALL1$"))))
+
+(DEFUN GCALL2$ (F X Y)
+  (CASEQ (CAR F)
+    #+MACLISP
+    ((SUBR$)
+     (SUBRCALL FLONUM (CDR F) X Y))
+    #+MACLISP
+    ((SUBR)
+     (FLOAT (SUBRCALL NIL (CDR F) X Y)))
+    #+MACLISP
+    ((LSUBR)
+     (FLOAT (LSUBRCALL NIL (CDR F) X Y)))
+    ((EXPR)
+     (FLOAT (FUNCALL (CDR F) X Y)))
+    ((MEXPR OPERATORS)
+     (FLOAT (MAPPLY (CDR F) (LIST X Y) NIL)))
+    (T
+     (MERROR "BUG: GCALL2$"))))
+
+(DEFUN AR$+AR$ (A$ B$ C$)
+  (DO ((N (ARRAY-DIMENSION-N 1 A$))
+       (J 0 (1+ J)))
+      ((= J N))
+    (DECLARE (FIXNUM N J))
+    (SETF (AREF$ A$ J) (+$ (AREF$ B$ J) (AREF$ C$ J)))))
+
+(DEFUN AR$*S (A$ B$ S)
+  (DO ((N (ARRAY-DIMENSION-N 1 A$))
+       (J 0 (1+ J)))
+      ((= J N))
+    (DECLARE (FIXNUM N J))
+    (SETF (AREF$ A$ J) (*$ (AREF$ B$ J) S))))
+
+(DEFUN AR$GCALL2$ (AR FL X Y)
+  (DO ((J 0 (1+ J))
+       (L FL (CDR L)))
+      ((NULL L))
+    (SETF (AREF$ AR J) (GCALL2$ (CAR L) X Y))))
+
+(DEFUN MAKE-GTRAMP (F NARGS)
+  NARGS
+  ;; for now, ignoring the number of arguments, but we really should
+  ;; do this error checking.
+  (LET ((K (FUNTYPEP F)))
+    (CASEQ (CAR K)
+      ((OPERATORS)
+       (CONS 'OPERATORS F))
+      #+MACLISP
+      ((SUBR)
+       (CONS 'SUBR (CADR K)))
+      ((MEXPR EXPR LSUBR)
+       (CONS (CAR K) (CADR K)))
+      (T
+       (MERROR "Undefined or inscrutable function~%~M" F)))))
+
+(DEFUN GCALL3 (F A1 A2 A3)
+  (CASEQ (CAR F)
+    #+MACLISP
+    ((SUBR)
+     (SUBRCALL T (CDR F) A1 A2 A3))
+    #+MACLISP
+    ((LSUBR)
+     (LSUBRCALL T (CDR F) A1 A2 A3))
+    ((EXPR)
+     (FUNCALL (CDR F)  A1 A2 A3))
+    ((MEXPR OPERATORS)
+     (MAPPLY (CDR F) (LIST A1 A2 A3) 'GCALL3))
+    (T
+     (MERROR "BUG: GCALL3"))))

src/maxsrc/opers.75

@@ -0,0 +1,142 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module opers)
+
+;; This file is the run-time half of the OPERS package, an interface to the
+;; Macsyma general representation simplifier.  When new expressions are being
+;; created, the functions in this file or the macros in MOPERS should be called
+;; rather than the entrypoints in SIMP such as SIMPLIFYA or SIMPLUS.  Many of
+;; the functions in this file will do a pre-simplification to prevent
+;; unnecessary consing. [Of course, this is really the "wrong" thing, since
+;; knowledge about 0 being the additive identity of the reals is now
+;; kept in two different places.]
+
+;; The basic functions in the virtual interface are ADD, SUB, MUL, DIV, POWER,
+;; NCMUL, NCPOWER, NEG, INV.  Each of these functions assume that their
+;; arguments are simplified.  Some functions will have a "*" adjoined to the
+;; end of the name (as in ADD*).  These do not assume that their arguments are
+;; simplified.  In addition, there are a few entrypoints such as ADDN, MULN
+;; which take a list of terms as a first argument, and a simplification flag as
+;; the second argument.  The above functions are the only entrypoints to this
+;; package.
+
+;; The functions ADD2, ADD2*, MUL2, MUL2*, and MUL3 are for use internal to
+;; this package and should not be called externally.  Note that MOPERS is
+;; needed to compile this file.
+
+;; Addition primitives.
+
+(defmfun add2 (x y)
+  (cond ((=0 x) y)
+	((=0 y) x)
+	(t (simplifya `((mplus) ,x ,y) t))))
+
+(defmfun add2* (x y)
+  (cond ((=0 x) (simplifya y nil))
+	((=0 y) (simplifya x nil))
+	(t (simplifya `((mplus) ,x ,y) nil))))
+
+;; The first two cases in this cond shouldn't be needed, but exist
+;; for compatibility with the old OPERS package.  The old ADDLIS
+;; deleted zeros ahead of time.  Is this worth it?
+
+(defmfun addn (terms simp-flag)
+  (cond ((null terms) 0)
+	(t (simplifya `((mplus) . ,terms) simp-flag))))
+
+(declare (special $negdistrib) (muzzled t))
+
+(defmfun neg (x)
+  (cond ((numberp x) (minus x))
+	(t (let (($negdistrib t))
+		(simplifya `((mtimes) -1 ,x) t)))))
+
+(declare (muzzled nil))
+
+(defmfun sub (x y)
+  (cond ((=0 y) x)
+	((=0 x) (neg y))
+	(t (add x (neg y)))))
+
+(defmfun sub* (x y)
+  (add (simplifya x nil) (mul -1 (simplifya y nil))))
+
+;; Multiplication primitives -- is it worthwhile to handle the 3-arg
+;; case specially?  Don't simplify x*0 --> 0 since x could be non-scalar.
+
+(defmfun mul2 (x y)
+  (cond ((=1 x) y)
+	((=1 y) x)
+	(t (simplifya `((mtimes) ,x ,y) t))))
+
+(defmfun mul2* (x y)
+  (cond ((=1 x) (simplifya y nil))
+	((=1 y) (simplifya x nil))
+	(t (simplifya `((mtimes) ,x ,y) nil))))
+
+(defmfun mul3 (x y z)
+  (cond ((=1 x) (mul2 y z))
+	((=1 y) (mul2 x z))
+	((=1 z) (mul2 x y))
+	(t (simplifya `((mtimes) ,x ,y ,z) t))))
+
+;; The first two cases in this cond shouldn't be needed, but exist
+;; for compatibility with the old OPERS package.  The old MULSLIS
+;; deleted ones ahead of time.  Is this worth it?
+
+(defmfun muln (factors simp-flag)
+  (cond ((null factors) 1)
+	((atom factors) factors)
+	(t (simplifya `((mtimes) . ,factors) simp-flag))))
+
+(defmfun div (x y) (if (=1 x) (inv y) (mul x (inv y))))
+
+(defmfun div* (x y) (if (=1 x) (inv* y) (mul (simplifya x nil) (inv* y))))
+
+(defmfun ncmul2 (x y) (simplifya `((mnctimes) ,x ,y) t))
+(defmfun ncmuln (factors flag) (simplifya `((mnctimes) . ,factors) flag))
+
+;; Exponentiation
+
+;; Don't use BASE as a parameter name since it is special in MacLisp.
+
+(defmfun power (*base power)
+  (cond ((=1 power) *base)
+	(t (simplifya `((mexpt) ,*base ,power) t))))
+
+(defmfun power* (*base power)
+  (cond ((=1 power) (simplifya *base nil))
+	(t (simplifya `((mexpt) ,*base ,power) nil))))
+
+(defmfun ncpower (x y)
+  (cond ((=0 y) 1)
+	((=1 y) x)
+	(t (simplifya `((mncexpt) ,x ,y) t))))
+
+;; [Add something for constructing equations here at some point.]
+
+;; (ROOT X N) takes the Nth root of X.
+;; Warning! Simplifier may give a complex expression back, starting from a
+;; positive (evidently) real expression, viz. sqrt[(sinh-sin) / (sin-sinh)] or
+;; something.
+
+(defmfun root (x n)
+  (cond ((=0 x) 0)
+	((=1 x) 1)
+	(t (simplifya `((mexpt) ,x ((rat) 1 ,n)) t))))
+
+;; (Porm flag expr) is +expr if flag is true, and -expr
+;; otherwise.  Morp is the opposite.  Names stand for "plus or minus"
+;; and vice versa.
+
+(defmfun porm (s x) (if s x (neg x)))
+(defmfun morp (s x) (if s (neg x) x))
+
+;; On PDP-10s, this is a function so as to save address space.  A one argument
+;; call is shorter than a two argument call, and this function is called
+;; several places.  In Franz, Multics, and the LISPM, this macros out on the
+;; assumption that calls are more expensive than the additional memory.
+
+(defmfun simplify (x) (simplifya x nil))

src/maxsrc/ops.1

@@ -0,0 +1,47 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module ops)
+
+
+;;; mathematical ops to call from translated code.
+;;; this is to replace maxsrc;opers, thus simplifying things,
+;;; and removing extra symbols from the environment.
+;;; With the OPEXPRP switch set these will also speed up
+;;; macsyma arithmetic.
+
+(DEFMACRO DEF-MARITH-NARY (MPLUS ZERO ZEROP PLUS)
+	  `(DEFUN ,MPLUS N
+		  (LET ((SUM ,ZERO)
+			(PUNT ())
+			(ARG))
+		       (DO ((J 1 (1+ J)))
+			   ((> J N)
+			    (IF (NULL PUNT) SUM
+				(SIMPLIFY
+				 `((,',MPLUS) ,.(IF (,ZEROP SUM) NIL (LIST SUM))
+					      ,.PUNT))))
+			   (SETQ ARG (ARG J))
+			   (IF (NUMBERP ARG)
+			       (SETQ SUM (,PLUS SUM ARG))
+			       (PUSH ARG PUNT))))))
+
+(DEF-MARITH-NARY MPLUS  0 ZEROP PLUS)
+(DEF-MARITH-NARY MTIMES 1 ONEP  TIMES)
+
+(DEFMACRO DEF-MARITH-BINARY (MEXPT EXPT)
+	  `(DEFUN ,MEXPT (X Y)
+		  (IF (AND (NUMBERP X) (NUMBERP Y))
+		      (,EXPT X Y)
+		      (SIMPLIFY `((,',MEXPT) ,X ,Y)))))
+
+(DEF-MARITH-BINARY MEXPT EXPT)
+(DEF-MARITH-BINARY MQUOTIENT QUOTIENT)
+
+(DEFMACRO DEF-MARITH-UNARY (MMINUS MINUS)
+	  `(DEFUN ,MMINUS (X)
+		  (IF (NUMBERP X) (,MINUS X) (SIMPLIFY `((,',MMINUS) ,X)))))
+
+(DEF-MARITH-UNARY MMINUS MINUS)
+

src/maxsrc/outex.37

@@ -0,0 +1,209 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 1:42am  Thursday, 26 June 1980 -gjc
+
+(macsyma-module outex)
+
+;;; To PARSE a file of macsyma expressions, and make them quickly
+;;; and randomly accesable. Made for used by ELL's ODE package.
+;;; -GJC
+
+(defvar *parsed-output-file*) ;; written to during psuedo batching.
+(defvar *filepos-table* nil)  ;; pushed on during psuedo batching.
+
+;;; Format of file.
+;;; <pointer-to-index>.......<number-of-objects><index1><index2><index3>
+;;; File is ascii to avoid hair of fixnum=>ascii conversion for read.
+
+#.(PROGN (SETQ FP-LENGTH 10.) NIL)
+
+(DEFUN WRITE-FP (X &AUX (BASE 10.) (*NOPOINT T))
+       (DO ((N (LET ((TN (- #.FP-LENGTH (FLATSIZE X))))
+		    (IF (MINUSP TN) (MERROR "OUTEX internal BUG") TN))
+		    (1- N)))
+	   ((= N 0)
+	    (PRIN1 X *PARSED-OUTPUT-FILE*))
+	   (TYO #/0  *PARSED-OUTPUT-FILE*)))
+
+(defmfun $make_index_file (filename
+			   &AUX
+			   (lfilename ($filename_merge filename))
+			   (temp (probef lfilename))
+			   (*filepos-table* nil))
+	 (or temp
+	     (merror "File does not exist. ~M" lfilename))
+	 (setq lfilename (to-macsyma-namestring temp))
+	 (iota ((*parsed-output-file*
+		 (mergef "* _PARS_" lfilename)
+		 '(out dsk ascii block)))
+	       (WRITE-FP 0)
+	       (let ((*in-macsyma-indexer* t))
+		    (call-batch1 lfilename t))
+	       ;; o.k. the work is done, lets write the index file.
+	       (LET ((IPOINTER (FILEPOS *PARSED-OUTPUT-FILE*)))
+		    (FILEPOS *PARSED-OUTPUT-FILE* 0)
+		    (WRITE-FP IPOINTER)
+		    (FILEPOS *PARSED-OUTPUT-FILE* IPOINTER))
+	       (WRITE-FP (LENGTH *FILEPOS-TABLE*))
+	       (DO ((L (NREVERSE *FILEPOS-TABLE*) (CDR L)))
+		   ((NULL L))
+		   (WRITE-FP (CAR L)))
+	       (renamef *parsed-output-file* "* PARSED")
+	       `((mlist)
+		 ,lfilename
+		 ,(to-macsyma-namestring (truename *parsed-output-file*)))))
+
+
+(defmfun outex-hook-exp (form)
+	 ;; the function is called in MLOAD on expressions
+	 ;; in the BATCH file.
+	 (push (filepos *parsed-output-file*) *filepos-table*)
+	 (outex-print form))
+
+(defun outex-print (form)
+       (terpri *parsed-output-file*)
+       (outex-prin1 form)
+       (tyo #\SP *parsed-output-file*))
+
+(defun outex-prin1 (form)
+       ;; this wants to check for (MPLUS SIMP) and various other
+       ;; headers, and output #.(GET 'MPLUS 'SIMPIND)
+       ;; and other hacks. maybe.
+       (prin1 form *parsed-output-file*))
+
+;;; these functions are for accessing the index file once
+;;; produced.
+
+(declare (splitfile OUTEY))
+
+(eval-when (eval compile)
+(DEFSTRUCT (INDEX-FILE ARRAY CONC-NAME)
+	   ARRAY
+	   INDEX-POINTER
+	   N-ELEMENTS))
+
+(defmfun $open_index_file (filename
+			   &AUX OB
+			   (lfilename ($filename_merge filename))
+			   (pfilen (mergef "* parsed" lfilename))
+			   (sym
+			    (concat (namestring (probef pfilen))
+				    '|-index-file-object|)))
+	 (iota ((fi Pfilen '(in dsK ASCII BLOCK)))
+	       (SETQ OB (MAKE-INDEX-FILE ARRAY FI
+					 INDEX-POINTER (READ-FP FI)))
+	       (FILEPOS FI (INDEX-FILE-INDEX-POINTER OB))
+	       (SETF (INDEX-FILE-N-ELEMENTS OB)
+		     (READ-FP FI)))
+	 (putprop sym OB 'index-file)
+	 sym)
+
+(defmacro get-index-file (x)
+	  (if (atom x)
+	      `(and (symbolp ,x) (get ,x 'index-file))
+	      `(let ((temp ,x)) (get-index-file temp))))
+
+(defmfun $index_file_DIM (sym &aux
+			      (index-file (get-index-file sym)))
+	 (or index-file
+	     (merror "not an index file: ~%~M" SYM))
+	 (index-file-n-ELEMENTS INDEX-FILE))
+
+(defmfun $read_nth_object (n sym)
+	 (or (and (fixp n) (plusp n))
+	     (merror
+	      "The first arg was not a positive integer index.~%~M" n))
+	 (let ((if (get-index-file sym)))
+	      (or if (merror "2nd arg not an index file~%~M" sym))
+	      (and (> n (index-file-n-ELEMENTS if))
+		   (merror "Not that many objects in the file. ~:M ~:M"
+			   n sym))
+	      (let ((index)
+		    (STREAM (index-file-ARRAY IF)))
+		   (unwind-protect
+		    (progn
+		     (OPEN STREAM)
+		     (FILEPOS STREAM (+ (* N #.FP-LENGTH)
+					(INDEX-FILE-INDEX-POINTER IF)))
+		     (SETQ INDEX (READ-FP STREAM))
+		     (FILEPOS STREAM INDEX)
+		     (READ STREAM))
+		    (CLOSE STREAM)))))
+
+(DEFUN READ-FP (S)
+       (DO ((N 0 (+ (- (TYI S) #/0) (* N 10.)))
+	    (J #.FP-LENGTH (1- J)))
+	   ((= J 0) N)))
+
+(defmfun $map_over_index_file (func file
+				    &aux 
+				    (index-file (get-index-file file)))
+	 (or INDEX-FILE
+	     (merror "2nd argument not an indexed file object.~%~M" file))
+	 (let ((fp (index-file-ARRAY INDEX-FILE)))
+	      (unwind-protect
+	       (do ((j (progn (open fp)(READ-FP FP) 1) (1+ j))
+		    (l nil (CONS (mcall func (simplify (READ FP)) j) L)))
+		   ((> J (INDEX-FILE-N-ELEMENTS INDEX-FILE))
+		    `((mlist) ,@(nreverse l))))
+	       (close fp))))
+
+
+
+;;; Additional comments about implementation:
+
+;;; An indexed file object is represented at macsyma level by a symbol
+;;; with an indexed-file property. When array-objects are put into
+;;; macsyma, it will be an array-function of some kind.
+
+;;; This makes for very fast random accessing of
+;;; expressions in a file, incredibly faster than using BATCH,
+;;; very important for files of test cases. 
+
+;;; These are not FEXPR's because the major use of these guys is
+;;; in programs which test files of equations. Normal argument evaluation
+;;; is certainly desired.
+
+
+
+;;; at first I was interning an symbol table for the file,
+;;; this lost incredibly for files with lots of "Strings..." i.e.
+;;; |&Strings...|
+;;; Now: The INDEX file expects to be a FIXNUM mode file.
+;;; i.e. We should be able to do FILEPOSE and IN and OUT on it
+;;; and it should act like a FIXNUM ARRAY.
+;;; Any system should have a FIXNUM mode file, if not, it can
+;;; be simulated by ascii files. The exact number of BITs in a FIXNUM
+;;; doesn't really matter either. The FIXNUMs are just the FILEPOS
+;;; of expressions in the PARSED file. 
+
+;;; Things to add: Support for Symbolic reference to the
+;;; expressions through the FOO&& type labels. This seemed to
+;;; be slightly kludgy to put into the present BATCH1, so I'm waiting
+;;; for KMP's new reader to be installed. Once the labels
+;;; associated with an expression can be read we can work out
+;;; a way to have the possibly out-of-core symbol-table of
+;;; index numbers.
+;;; Maybe use some kind format which is FIXNUM-IO, and bumbed
+;;; for the kind of expressions which the macsyma parser makes.
+;;; That is, TYPEP of SYMBOL, LIST, FIXNUM, BIGNUM, FLONUM.
+;;; Very reasonable to have an out-of-core symbol table,
+;;; but with an in-core cache of the List's which are args to PNPUT.
+;;; That would cut down on the amount of FILEPOSing needed to
+;;; read-in a given expression. Uhm, maybe each entry
+;;; should be <FILEPOS><SYMBOL-SUBSET-VECTOR> where the subset
+;;; vector tells which symbol's (numbered 0..N for that file),
+;;; must be interned to "read" a given expression, which is 
+;;; located at <FILEPOS>.
+;;; Everything at FILEPOS is then a vector of 36-bit-lisp-pointers
+;;; Representation is <typecode><datum>.
+;;; Symbol: <datum> is the symbol-number.
+;;; Cons: <datum> is the filepos of the CAR? CDR follows?
+;;; Fixnum/Bignum: <datum> gives number of words (following) to
+;;; read to get the bits.
+;;; Flonum: next word is it.
+;;; () : is special maybe? well it is a symbol (sigh...)
+;;; Anyway, this could make for some DAMN fast reading of
+;;; expressions.
+

src/maxsrc/rombrg.43

@@ -0,0 +1,143 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
+;;; Original code by CFFK.  Modified to interface correctly with TRANSL  ;;;
+;;; and the rest of macsyma by GJC                                       ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module rombrg)
+(load-macsyma-macros transm numerm)
+
+(declare (special user-timesofar))
+
+;;; the following code if for historical frame of reference.
+;;;(defun fmeval3 (x1) 
+;;;       (cond ((fixp (setq x1 (meval x1))) (float x1))
+;;;	     ((floatp x1) x1)
+;;;	     (t (displa x1) (error '|not floating point|))))
+;;;
+;;;(defun qeval3 (y1 x1 z)
+;;;       (cond (x1 (fmeval3 (list '($ev) y1 (list '(mequal) x1 z) '$numer)))
+;;;	     (t (funcall y1 z))))
+
+(DEFMVAR  $ROMBERGIT 11. "the maximum number of iterations" FIXNUM)
+(DEFMVAR  $ROMBERGMIN 0. "the minimum number of iterations" FIXNUM)
+(DEFMVAR  $ROMBERGTOL 1.e-4 "the relative tolerance of error" FLONUM)	
+(DEFMVAR  $ROMBERGABS 0.0 "the absolute tolerance of error"  FLONUM)
+(DEFMVAR  $ROMBERGIT_USED 0 "the number of iterations actually used." FIXNUM)
+
+(DEFVAR ROMB-PRINT NIL ); " For ^]"
+
+
+(defun $ROMBERG_SUBR (FUNCTION LEFT RIGHT
+			       &aux (st "&the first arg to ROMBERG"))
+  (BIND-TRAMP1$
+   F FUNCTION
+   (LET ((A (FLOAT LEFT))
+	 (B (FLOAT RIGHT))
+	 (X 0.0)
+	 (TT (*array nil 'flonum $rombergit))
+	 (RR (*array nil 'flonum $rombergit))
+	 (USER-TIMESOFAR (cons 'romb-timesofar user-timesofar))
+	 (ROMB-PRINT NIL))
+     (setq X (-$ B A))
+     (SETF (AREF$ TT 0)
+	   (*$ x (+$ (FCALL$ F b st) (FCALL$ F a st)) 0.5))
+     (SETF	(AREF$ RR 0.)
+		(*$ x (FCALL$ F (*$ (+$ b a) 0.5) st)))
+     (do ((l 1. (1+ l)) (m 4. (* m 2.)) (y 0.0) (z 0.0) (cerr 0.0))
+	 ((= l $rombergit)
+	  (MERROR "ROMBERG failed to converge"))
+       (DECLARE (FLONUM Y Z CERR)
+		(FIXNUM L M))
+       (setq y (float m) z (//$ x y))
+       (SETF (AREF$ TT L) (*$ (+$ (AREF$ tt (1- l))
+				  (AREF$ rr (1- l))) 0.5))
+       (SETF (AREF$ RR L) 0.0)
+       (do ((i 1. (+ i 2.)))
+	   ((> i m))
+	 (COND (ROMB-PRINT
+		(SETQ ROMB-PRINT NIL)			;^] magic.
+		(MTELL "Romberg: ~A iterations; last error =~A;~
+			    calculating F(~A)."
+		       I
+		       CERR
+		       (+$ (*$ z (float i)) a))))
+	 (SETF (AREF$ RR L) (+$ (FCALL$ F (+$ (*$ z (float i)) a) st)
+				(AREF$ rr l))))
+       (SETF (AREF$ RR L) (*$ z (AREF$ rr l) 2.0))
+       (setq y 0.0)
+       (do ((k l (1- k))) ((= k 0.))
+	 (DECLARE (FIXNUM K))
+	 (setq y (+$ (*$ y 4.0) 3.0))
+	 (SETF (AREF$  TT (1- K))
+	       (+$ (//$ (-$ (AREF$ tt k)
+			    (AREF$ tt (1- k))) y)
+		   (AREF$ tt k)))
+	 (SETF (AREF$ RR (1- K))
+	       (+$ (//$ (-$ (AREF$ rr k)
+			    (AREF$ rr (1- k))) y)
+		   (AREF$ rr k))))
+       (setq y (*$ (+$ (AREF$ tt 0.)
+		       (AREF$ rr 0.)) 0.5))
+       ;;; this is the WIN condition test.
+       (cond ((and
+	       (or (not
+		    (< $rombergabs
+		       (setq cerr
+			     (abs (-$ (AREF$ tt 0.)
+				      (AREF$ rr 0.))))))
+		   (not (< $rombergtol
+			   ;; cerr = "calculated error"; used for ^]
+			   (setq cerr (//$ cerr
+					   (cond ((= y 0.0) 1.0)
+						 (t (abs y))))))))
+	       (> l $rombergmin))
+	      (SETQ $ROMBERGIT_USED L)
+	      #+maclisp
+	      (progn (*rearray tt) (*rearray rr))
+	      (return y)))))))
+
+
+
+(defun romb-timesofar () (setq romb-print t))  ;^] function.
+;;; Making the ^] scheme work through this special variable makes
+;;; it possible to avoid various timing screws and having to have
+;;; special variables for communication between the interrupt and MP
+;;; function.  On the other hand, it may make it more difficult to
+;;; have multiple reports (double integrals etc.).
+
+
+;;; TRANSL SUPPORT.
+
+(DEFPROP $ROMBERG_SUBR $FLOAT FUNCTION-MODE)
+
+(DEFUN ROMBERG-MACRO (FORM TRANSLATEP)
+  (SETQ FORM (CDR FORM))
+  (COND ((= (LENGTH FORM) 3)
+	 (COND (TRANSLATEP
+		`(($ROMBERG_SUBR) ,@FORM))
+	       (T
+		`((MPROG) ((MLIST) ((MSETQ) $NUMER T) ((MSETQ) $%ENUMER T))
+			  (($ROMBERG_SUBR) ,@FORM)))))
+	((= (LENGTH FORM) 4)
+	 (LET (((EXP VAR . BNDS) FORM))
+	   (COND (TRANSLATEP
+		  `(($ROMBERG_SUBR)
+		    ((LAMBDA-I) ((MLIST) ,VAR)
+				(($MODEDECLARE) ,VAR $FLOAT)
+				,EXP)
+		    ,@BNDS))
+		 (T
+		  `((MPROG) ((MLIST) ((MSETQ) $NUMER T) ((MSETQ) $%ENUMER T))
+			    (($ROMBERG_SUBR)
+			     ((LAMBDA) ((MLIST) ,VAR) ,EXP)
+			     ,@BNDS))))))
+	(T
+	 (WNA-ERR '$ROMBERG))))
+
+(DEFMSPEC $ROMBERG (FORM)
+  (MEVAL (ROMBERG-MACRO FORM NIL)))
+
+(def-translate-property $ROMBERG (FORM)
+  (LET (($TR_NUMER T))
+    (TRANSLATE (ROMBERG-MACRO FORM T))))

src/maxsrc/runtim.19

@@ -0,0 +1,104 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module runtim)
+
+;; This file contains functions which are also defined as macros in the
+;; standard Macsyma environment.  They are defined here for the benefit
+;; interpreted code in the fix file.  This file is used only in the ITS
+;; implementation, as the Macsyma macros are present at runtime in large
+;; address space systems.
+
+;; The above comment is idiotic. These functions are open-codeable,
+;; and defined as macros only for efficiency. However, the correct
+;; way to hack efficiency is through compiler:optimizers, which is
+;; what we use now. This file is no longer its-only.
+
+;; Defined in LIBMAX;MAXMAC.
+
+;(DEFUN COPY (L) (SUBST NIL NIL L))  
+;(DEFUN COPY1 (X) (APPEND X NIL))
+
+;; Defined in RAT;RATMAC.
+
+;(DEFUN EQN (X Y) (EQUAL X Y))
+;(DEFUN PCOEFP (X) (ATOM X))
+;(DEFUN PZEROP (L) (SIGNP E L))
+;(DEFUN RCINV (X) (RATINVERT X))
+
+;; Defined in RAT;LESFAC.
+
+;(DEFUN GETDIS (X) (GET X 'DISREP))
+;(DEFUN CONS1 (X) (CONS X 1))
+
+;; Defined in LIBMAX;MAXMAC.
+
+;(DEFPROP ERLIST ERLIST1 EXPR)
+
+;; Subr definitions of ADD* and MUL* needed at runtime for functions generated
+;; by TRANSL.  If a function is defined as both a macro and a function, the
+;; compiler expands the macro, but still puts the function definitions in the
+;; fasl.  We don't need these on the Lisp Machine or Multics since macros are
+;; around at run time. 
+
+;; ADD and MUL to be flushed shortly.  Around for compatibility only.
+;; (another CWH comment????) -gjc
+
+#+PDP10
+(PROGN 'COMPILE
+       (DEFUN ADD (&REST L) (SIMPLIFYA (CONS '(MPLUS) L) t))
+       (DEFUN MUL (&REST L) (SIMPLIFYA (CONS '(MTIMES) L) t))
+       (DEFUN ADD* (&REST L) (SIMPLIFYA (CONS '(MPLUS) L) nil))
+       (DEFUN MUL* (&REST L) (SIMPLIFYA (CONS '(MTIMES) L) nil)))
+
+#+NIL
+(PROGN 'COMPILE
+       (DEFUN ADD (&RESTL L) (SIMPLIFYA (CONS '(MPLUS) L) t))
+       (DEFUN MUL (&RESTL L) (SIMPLIFYA (CONS '(MTIMES) L) t))
+       (DEFUN ADD* (&RESTL L) (SIMPLIFYA (CONS '(MPLUS) L) nil))
+       (DEFUN MUL* (&RESTL L) (SIMPLIFYA (CONS '(MTIMES) L) nil))
+
+(DEFUN SETF-MGET (A B VALUE) (MPUTPROP A VALUE B))
+
+(DEFUN SETF-$GET (A B VALUE) ($PUT A VALUE B))
+)
+
+#+LISPM
+(PROGN 'COMPILE
+
+;; on the LISPM the &REST list is a stack-allocated cdr-coded list.
+;; We have to copy it, so might as well try out some optimizations.
+
+(DEFUN ADD (&REST V)
+  (DO ((L NIL)(R)
+	      (ACC 0))
+      ((NULL V)
+       (IF (NULL L)
+	   ACC
+	   (IF (ZEROP ACC)
+	       (SIMPLIFYA (CONS '(MPLUS) L) T)
+	       (SIMPLIFYA (LIST* '(MPLUS) ACC L) T))))
+    (SETQ R (POP V))
+    (IF (NUMBERP R)
+	(SETQ ACC (PLUS R ACC))
+	(PUSH R L))))
+
+(DEFUN MUL (&REST V)
+  (DO ((L NIL)(R)
+	      (ACC 1))
+      ((NULL V)
+       (IF (NULL L)
+	   ACC
+	   (IF (EQUAL ACC 1)
+	       (SIMPLIFYA (CONS '(MTIMES) L) T)
+	       (SIMPLIFYA (LIST* '(MTIMES) ACC L) T))))
+    (SETQ R (POP V))
+    (IF (NUMBERP R)
+	(SETQ ACC (TIMES R ACC))
+	(PUSH R L))))
+
+(DEFUN ADD* (&REST L) (SIMPLIFYA (CONS '(MPLUS) (copylist L)) nil))
+(DEFUN MUL* (&REST L) (SIMPLIFYA (CONS '(MTIMES)(copylist L)) nil))
+
+)

src/maxsrc/sets.11

@@ -0,0 +1,439 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module sets)
+
+;;; 3:09am  Tuesday, 7 October 1980 -George Carrette.
+
+(eval-when (eval)
+	   (setq macro-expansion-use 'displace
+		 punt-in-set-carefully t))
+
+;;; Finite sets, which are subsets of a finite UNIVERSE set,
+;;; represented as bit vectors. 0 in the J'th position says
+;;; that the J'th universe element is not a member of the set
+;;; 1 in that position says it is an element.
+;;; (After Pratt).
+
+
+;;; Interface functions to the macsyma system.
+
+(DEFMVAR $DISPLAYSET '$SORTED
+	 "If set to SORTED then the sets are displayed using ORDERGREAT.
+	 Otherwise they are displayed in reverse Goedel order.")
+
+(declare (special LOP ROP RIGHT))
+
+(DEFUN (M-SET DIMENSION) (FORM RESULT)
+       ; interface the the macsyma DISPLA function.
+       (SETQ FORM (CDR ($ELEMENTS FORM)))
+       (IF (EQ $DISPLAYSET '$SORTED)
+	   (SETQ FORM (SORTGREAT FORM)))
+       (DIMENSION (CONS '(|${|) FORM)
+		  RESULT LOP ROP 0 RIGHT))
+
+(declare (unspecial LOP ROP RIGHT))
+
+(WHEN
+ (STATUS FEATURE MACSYMA)
+ ; interface to the macsyma parser. MATCHFIX("{","}")
+ (DEFPROP ${ %{ VERB) 
+ (DEFPROP ${ &{ OP) 
+ (DEFPROP &{ ${ OPR) 
+ (DEFINE-SYMBOL (QUOTE &{)) 
+ (DEFPROP ${ DIMENSION-MATCH DIMENSION) 
+ (DEFPROP ${ ((123.) 125.) DISSYM) 
+ (DEFPROP ${ MSIZE-MATCHFIX GRIND) 
+ (DEFPROP ${ PARSE-MATCHFIX NUD) 
+ (DEFPROP %{ DIMENSION-MATCH DIMENSION) 
+ (DEFPROP %{ ((123.) 125.) DISSYM) 
+ (DEFPROP ${ $} MATCH) 
+ (DEFPROP $} &} OP) 
+ (DEFPROP &} $} OPR) 
+ (DEFINE-SYMBOL (QUOTE &})) 
+ (DEFPROP $} 5. LBP) 
+ (DEFPROP %{ ${ NOUN)
+ )
+
+(DEFUN (M-SET OPERATORS) (X IGNORE-VESTIGIAL IGNORE-SIMP-FLAG)
+       ; interface to the simplifier.
+       ; If SIMP-FLAG is T I think I should $MAPSET SIMPLIFY.
+       (LIST* '(M-SET SIMP) (CDR X)))
+
+;;; A hook for meval. If somebody wants to do 
+;;; X:{A,B,C}; and then  EV(X,A=33) might as well support it.
+;;; Too bad it is not that easy to support SUBST(X,Y,{A,B,Y})
+;;; or any other of a sundry tree-walking beasts.
+
+(DEFUN (M-SET MFEXPR*) (ME)
+       ($MAPSET 'MEVAL ME))
+
+(eval-when (load) ; can't afford to have all the macros loaded while debugging.
+(DEF-PROCEDURE-PROPERTY
+ M-SET
+ ; interface to the macsyma to lisp translator.
+ (LAMBDA (FORM) (TRANSLATE `((${) ,@(CDR ($ELEMENTS FORM)))))
+ ; just in case an M-SET gets macro-expanded into user code.
+ TRANSLATE))
+
+;;; TO DO: Interface to SAVE/GRIND
+
+;;; hashed array, UNIVERSE primitives.
+
+(EVAL-WHEN (EVAL COMPILE)
+
+(DEFSTRUCT (UNIVERSE ARRAY CONC-NAME)
+	   (HASH-ARRAY (*ARRAY NIL T 100.))
+	   (HASH-ARRAY-SIZE 100.)
+	   (HASH-ARRAY-OPTIMAL-ELEMENTS 150.)
+	   (HASH-ARRAY-SIZE-INC 100.)
+	   (OBJECT-ARRAY (*ARRAY NIL T 100.))
+	   (OBJECT-ARRAY-SIZE 100.)
+	   (OBJECT-ARRAY-SIZE-INC 100.)
+	   (CARDINALITY 0))  )
+
+
+(DEFMFUN $MAKE_UNIVERSE ()
+	 (LET ((SYM (IMPLODE (NCONC (EXPLODEN '|$UNIVERSE-|) (EXPLODEN (GENSYM))))))
+	      ; a SYMBOL is the only compound object which is safe from
+	      ; being messed up by all the macsyma code, given that
+	      ; you can't add new data types very easily.
+	      ; I can't just return a type T array to the macsyma user.
+	      (PUTPROP SYM (MAKE-UNIVERSE) 'UNIVERSE)
+	      SYM))
+
+(DEFMVAR $UNIVERSE NIL
+	 "The default universe for the set functions.")
+
+(IF (NULL $UNIVERSE) (SETQ $UNIVERSE ($MAKE_UNIVERSE)))
+
+(PROGN 'COMPILE
+       ; avoid consing to call the macsyma hashing function.
+       (DEFVAR HASH-CELL (LIST NIL))
+       (DEFUN HASH (X) (SETF (CAR HASH-CELL) X) (HASHER HASH-CELL)))
+
+       
+(DEFUN INTERN-ELEM (E UNIVERSE)
+       ; I.E. Goedelize E, return the Goedel number it will have
+       ; for the rest of its lifetime.
+       ; Do something about garbage collecting objects and Goedel numbers
+       ; at some later date.
+       (LET* ((H (HASH E))
+	      (ADDRESS   (\ H (UNIVERSE-HASH-ARRAY-SIZE UNIVERSE)))
+	      (HAR (UNIVERSE-HASH-ARRAY UNIVERSE))
+	      (CELL (AREF HAR ADDRESS)))
+	     (OR (CDR (ASSOL E CELL)) ; (ASS #'ALIKE1 E CELL)
+		 (LET ((CARD (1+ (UNIVERSE-CARDINALITY UNIVERSE))))
+		      (SETF (UNIVERSE-CARDINALITY UNIVERSE) CARD)
+		      (COND ((> CARD (UNIVERSE-HASH-ARRAY-OPTIMAL-ELEMENTS UNIVERSE))
+			     (HASH-RESIZE-UNIVERSE UNIVERSE)
+			     (SETQ ADDRESS (\ H (UNIVERSE-HASH-ARRAY-SIZE UNIVERSE))
+				   CELL (AREF HAR ADDRESS))))
+		      (COND ((= CARD (UNIVERSE-OBJECT-ARRAY-SIZE UNIVERSE))
+			     (LET ((N (+ CARD
+					 (UNIVERSE-OBJECT-ARRAY-SIZE-INC UNIVERSE))))
+				  (SETF (UNIVERSE-OBJECT-ARRAY-SIZE UNIVERSE) N)
+				  (*REARRAY (UNIVERSE-OBJECT-ARRAY UNIVERSE)
+					    T N))))
+		      (SETF (AREF HAR ADDRESS)
+			    (CONS (CONS E (1- CARD)) CELL))
+		      (SETF (AREF (UNIVERSE-OBJECT-ARRAY UNIVERSE) (1- CARD))
+			    E)
+		      (1- CARD)))))
+
+(DEFUN HASH-RESIZE-UNIVERSE (IGNORE-FOR-NOW)
+       NIL)
+
+(DEFUN OBJECT-P (E UNIVERSE)
+       (CDR (ASSOL E (AREF (UNIVERSE-HASH-ARRAY UNIVERSE)
+			   (\ (HASH E) (UNIVERSE-HASH-ARRAY-SIZE UNIVERSE))))))
+
+;;; The macsyma set datatype.
+
+;;; ((M-SET) universe . <list of fixnums or vector>)
+;;; accessor functions, some with error checking.
+
+(DEFMACRO M-SET-$UNIVERSE (X) `(CADR ,X))
+(DEFMACRO M-SET-VECTOR-1 (X) `(CDDR ,X))
+(DEFUN M-SETP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'M-SET)))
+(DEFUN M-SET-VECTOR (X USER-LEVEL-UNIVERSE)
+       (COND ((M-SETP X)
+	      (COND ((EQ (M-SET-$UNIVERSE X) USER-LEVEL-UNIVERSE)
+		     (M-SET-VECTOR-1 X))
+		    (t
+		     (MERROR "Set in wrong universe:~%~M" X))))
+	     (t
+	      (MERROR "Not a set:~%~M" X))))
+
+(DEFMFUN $UNIVERSE (X)
+	 (COND ((M-SETP X)
+		(OR (GET (M-SET-$UNIVERSE X) 'UNIVERSE)
+		    (MERROR "Set in dead universe: ~:M" (M-SET-$UNIVERSE X)))
+		(M-SET-$UNIVERSE X))
+	       (T
+		(MERROR "Not a set:~%~M" X))))
+
+;;; some macros. these might be usefull in other files too.
+
+(DEFMACRO PARAM (PARAM-EVAL-FORM &AUX FORM)
+	  (DECLARE (SPECIAL PARAM-EVAL-FORM))
+	  (LET ((ERRSET
+		 #'(LAMBDA (VAL)
+			   (FORMAT MSGFILES
+				   "~&; Some error in PARAM macro eval of:~%~S"
+				   PARAM-EVAL-FORM)
+			   (*BREAK T VAL))))
+	       (SETQ FORM (ERRSET (EVAL PARAM-EVAL-FORM))))
+	  (IF FORM (CAR FORM)
+	      (ERROR "PARAM evaluation got error."
+		     PARAM-EVAL-FORM)))
+
+(DEFMACRO BIT-MASK (N) `(1- (LSH 1 ,N)))
+
+(DEFMACRO USEABLE-FIXNUM-SIZE ()
+	  (cond ((status feature pdp10)
+		 35.)
+		((status feature lispm) 23.)
+		(t
+		 ; actually this works for the above two machines.
+		 ; but why be obscure? It assumes TWOs complement.
+		 (haulong (lsh -1 -1)))))
+
+(DEFMACRO LOGDIFF (&REST L) `(BOOLE 4 ,@L))
+
+
+;;; Functions for hacking the bit vector.
+
+(DEFUN M-SET-CONS (UNIVERSE VECTOR)
+       ; remove trailing zeros so that EQUAL will work.
+       ; This function is supposed to bash its argument.
+       ; it is only to be called on a vector produced by the
+       ; vector making functions. MAKE-M-SET-VECTOR and
+       ; MAKE-M-SET-UVECTOR.
+
+       ; Also, if this is a CDR-CODED list do something else.
+       ; Uhm, or does NREVERSE do a good thing to CDR-coded lists?
+       (SETQ VECTOR (NREVERSE VECTOR))
+       (DO ()
+	   ((OR (NULL VECTOR)
+		(NOT (ZEROP (CAR VECTOR))))
+	    (LIST* '(M-SET SIMP) UNIVERSE (NREVERSE VECTOR)))
+	   (SETQ VECTOR (CDR VECTOR))))
+
+(defun MAKE-M-SET-VECTOR (UNIVERSE)
+       ; make a fresh vector representing zero in the universe.
+       ;i.e. this vector is big enough to accept any accumulations.
+       (do ((l nil (cons 0 l))
+	    (j (// (UNIVERSE-CARDINALITY UNIVERSE)
+		   (useable-fixnum-size))
+	       (1- j)))
+	   ((< j 0) l)))
+
+(DEFUN MAKE-M-SET-UVECTOR (UNIVERSE)
+       ; make a vector representing everything in the universe.
+       (DO ((L (LIST (BIT-MASK (\ (UNIVERSE-CARDINALITY UNIVERSE)
+				  (USEABLE-FIXNUM-SIZE))))
+	       (CONS (PARAM (BIT-MASK (USEABLE-FIXNUM-SIZE))) L))
+	    (J (// (UNIVERSE-CARDINALITY UNIVERSE)
+		   (USEABLE-FIXNUM-SIZE))
+	       (1- J)))
+	   ((ZEROP J) L)))
+
+(defmacro copy-m-set-vector (x) `(append ,x nil))
+
+;;; accesor functions for the bit vector. On most machines I am using
+;;; a list of FIXNUMS. On the lisp machine it should be trivial to use
+;;; arrays, with the bit-blit. 
+
+(defun set-vbit (V n)
+       (setq v (nthcdr (// n (useable-fixnum-size)) v))
+       (if v
+	   (setf (car v) (logior (car v) (lsh 1 (\ n (useable-fixnum-size)))))
+	   (error 'BARF n 'wrng-type-arg)))
+
+(defun ref-vbitp (v n)
+       (setq v (nthcdr (// n (useable-fixnum-size)) v))
+       (if v
+	   (oddp (lsh (car v) (minus (\ n (useable-fixnum-size)))))
+	   nil))
+
+(defmacro do-vbit (v j code-if-set &OPTIONAL END-CODE
+		     &aux (temp-v (GENSYM)) (temp-f (GENSYM))
+		     (k (GENSYM)))
+	  ; can't use two do loops because then RETURN won't work
+	  ; in the IF-SET-CODE I'll punt and use a prog.
+	  `(PROG (,TEMP-V ,J ,TEMP-F ,K)
+		 (DECLARE (FIXNUM ,TEMP-F ,K))
+		 (SETQ ,TEMP-V ,V ,J 0)
+		 LOOP-V
+		 (IF (NULL ,TEMP-V) (RETURN ,END-CODE))
+		 (SETQ ,TEMP-F (CAR ,TEMP-V) ,K (USEABLE-FIXNUM-SIZE))
+		 LOOP-K
+		 (WHEN (ZEROP ,K)
+		       (SETQ ,TEMP-V (CDR ,TEMP-V))
+		       (GO LOOP-V))
+		 (IF (ODDP ,TEMP-F) ,CODE-IF-SET)
+		 (SETQ ,TEMP-F (LSH ,TEMP-F -1) ,K (1- ,K) ,J (1+ ,J))
+		 (GO LOOP-K)))
+
+(DEFMACRO ACCUMULATE-VECTOR
+	  (OP BASH L
+	      &AUX
+	      (TEMP-BASH (GENSYM))
+	      (TEMP-L (GENSYM)))
+	  `(DO ((,TEMP-BASH ,BASH (CDR ,TEMP-BASH))
+		(,TEMP-L ,L (CDR ,TEMP-L)))
+	       ((NULL ,TEMP-L)
+		(DO ()
+		    ((NULL ,TEMP-BASH))
+		    (SETF (CAR ,TEMP-BASH) (,OP (CAR ,TEMP-BASH) 0))
+		    (SETQ ,TEMP-BASH (CDR ,TEMP-BASH))))
+	       (SETF (CAR ,TEMP-BASH) (,OP (CAR ,TEMP-BASH) (CAR ,TEMP-L)))))
+
+
+;;; The user primitives
+
+
+(DEFMFUN $EMPTYP (X)
+	 ($UNIVERSE X)
+	 (NULL (M-SET-VECTOR-1 X)))
+
+(DEFMFUN |${| N
+	 (DO ((U (OR (GET $UNIVERSE 'UNIVERSE)
+		     (MERROR "The universe is dead!~%~:M" $UNIVERSE)))
+	      (J 1 (1+ J)))
+	     ((> J N)
+	      (SETQ J 1)
+	      (DO ((V (MAKE-M-SET-VECTOR U)))
+		  ((> J N) (M-SET-CONS $UNIVERSE V))
+		  (SET-VBIT V (ARG J))
+		  (SETQ J (1+ J))))
+	     (SETF (ARG J) (INTERN-ELEM (ARG J) U))))
+
+
+(DEFMFUN $ELEMENTS (X)
+	 (LET ((A (UNIVERSE-OBJECT-ARRAY (GET ($UNIVERSE X) 'UNIVERSE)))
+	       (L NIL))
+	      (DO-VBIT (M-SET-VECTOR-1 X) J
+		       (PUSH (AREF A J) L))
+	      (CONS '(MLIST) L)))
+
+(DEFUN MTRAMP (F WHERE)
+       ; this function should be in MLISP.
+       (IF (IF (SYMBOLP F) (FBOUNDP F) (EQ (CAR F) 'LAMBDA))
+	   F
+	   `(LAMBDA N (MAPPLY ',F (LISTIFY N)
+			      ',(CONCAT "The argument to " (STRIPDOLLAR WHERE))))))
+
+(DEFMFUN $PREDSET (F X &AUX (U (UNIVERSE-CHECK ($UNIVERSE X))))
+	 (SETQ F (MTRAMP F '$PREDSET))
+	 ; When the hair is implemented we must make sure that
+	 ; Goedel numbering compactification garbage collections
+	 ; communicate with use here if they go off.
+	 (LET ((A (UNIVERSE-OBJECT-ARRAY U))
+	       (NV (make-m-set-vector u)))
+	      (do-VBIT (M-SET-VECTOR-1 X) J
+		       (IF (EQ T (FUNCALL F (AREF A J)))
+			   ; the primitives I have defined aren't efficient
+			   ; enough for list-representation.
+			   ; however, this is swamped out by the MAPPLY.
+			   (SET-VBIT NV J)))
+	      (M-SET-CONS ($UNIVERSE X) NV)))
+
+(DEFMFUN $MAPSET (F X &AUX (U (UNIVERSE-CHECK ($UNIVERSE X))))
+	 (SETQ F (MTRAMP F '$MAPSET))
+	 (LET ((A (UNIVERSE-OBJECT-ARRAY U))
+	       (STACK NIL))
+	      (DO-VBIT (M-SET-VECTOR-1 X) J
+		       (PUSH (INTERN-ELEM (FUNCALL F (AREF A J)) U) STACK))
+	      (DO ((V (MAKE-M-SET-VECTOR U))
+		   (L STACK (CDR L)))
+		  ((NULL L)
+		   (RECLAIM STACK NIL) ; maclisp sucks!
+		   (M-SET-CONS ($UNIVERSE X) V))
+		  (SET-VBIT V (CAR L)))))
+
+(DEFMFUN $CARDINAL (X)
+	 ($UNIVERSE X) ; error check.
+	 (LET ((C 0))
+	      (DO-VBIT (M-SET-VECTOR-1 X) IGNORE-J
+		       (SETQ C (1+ C)))
+	      C))
+
+(DEFUN UNIVERSE-CHECK (X)
+       (COND ((ATOM X)
+	      (OR (GET X 'UNIVERSE)
+		  (MERROR "Dead universe: ~:M" X)))
+	     (T
+	      (MERROR "Not a universe~%~M" X))))
+
+(DEFMFUN $ORDINAL (OBJECT &OPTIONAL (UNIVERSE $UNIVERSE))
+	 ; users may have an application for the fact that this
+	 ; interns objects in a hash table.
+	 (OBJECT-P OBJECT (UNIVERSE-CHECK UNIVERSE)))
+
+(DEFMFUN $ELEMENTP (E X &AUX (I (OBJECT-P E (GET ($UNIVERSE X) 'UNIVERSE))))
+	 (IF I (REF-VBITP (M-SET-VECTOR-1 X) I) NIL))
+
+(DEFMFUN $ELEMENTOF (X)
+	 (LET ((A (UNIVERSE-OBJECT-ARRAY (GET ($UNIVERSE X) 'UNIVERSE))))
+	      (DO-VBIT (M-SET-VECTOR-1 X) J
+		       (RETURN (AREF A J))
+		       (MERROR "ELEMENTOF called on empty set.~M" X))))
+
+;;; below: functions defined only on sets. These only operate
+;;; on the bit vector, and are fast.
+
+			
+(DEFMACRO DEFSETOP (NAME LOGICAL &OPTIONAL (MAKER 'MAKE-M-SET-VECTOR)
+			 (JS 1))
+	  `(DEFMFUN ,NAME N
+		    (LET* ((UU (IF (ZEROP N) $UNIVERSE ($UNIVERSE (ARG 1))))
+			   (V (,MAKER (UNIVERSE-CHECK UU))))
+			  (DO ((J ,JS (1+ J)))
+			      ((> J N)
+			       (M-SET-CONS UU V))
+			      (ACCUMULATE-VECTOR
+			       ,LOGICAL V (M-SET-VECTOR (ARG J) UU))))))
+
+(DEFSETOP $UNION LOGIOR)
+
+(DEFSETOP $INTERSECTION LOGAND MAKE-M-SET-UVECTOR)
+
+(DEFSETOP $SYMDIFF LOGXOR)
+
+;;; why do I want to cludge COMPLEMENT as part of SETDIFF?
+;;; it sure makes this look ugly.
+
+(DEFSETOP $SETDIFF LOGDIFF
+  (LAMBDA (Q)
+    (IF (> N 1)
+	(COPY-M-SET-VECTOR (M-SET-VECTOR-1 (ARG 1)))
+	(MAKE-M-SET-UVECTOR Q)))
+  (IF (> N 1) 2 1))
+
+(DEFMFUN $SUBSETP (A B)
+	 ; Try to arrange the vector macros so that I don't violate
+	 ; data abstraction here in order to make SUBSETP fast and
+	 ; cons-free.
+	 (DO ((VA (M-SET-VECTOR A ($UNIVERSE B)) (CDR VA))
+	      ; error check on A and B.
+	      (VB (M-SET-VECTOR-1 B)))
+	     ((NULL VA)
+	      ; SUBSETP({A},{A}) is true.
+	      T)
+	     (IF (NOT (ZEROP (LOGDIFF (CAR VA) (CAR VB))))
+		 (RETURN NIL))))
+
+
+;;; Little interface to run this outside of macsyma.
+
+(WHEN (NOT (STATUS FEATURE MACSYMA))
+      (PUTPROP 'HASH (GET 'SXHASH 'SUBR) 'SUBR)
+      (ARGS 'HASH (ARGS 'SXHASH))
+      (PUTPROP 'ASSOL (GET 'ASSOC 'SUBR) 'SUBR)
+      (ARGS 'ASSOL (ARGS 'ASSOC))
+      (DEFUN DISPLA (X)(PRINT X))
+      (DEFUN MGRIND (X Y)(PRINT X Y))
+      )

src/maxsrc/sublis.11

@@ -0,0 +1,117 @@
+;;; -*- Mode: LISP; Package: Macsyma; Ibase: 10. -*-
+;;; SUBLIS: A Macsyma flavor of Lisp's SUBLIS...
+;;;
+;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+(macsyma-module sublis)
+
+(DEFMVAR $SUBLIS_APPLY_LAMBDA T 
+  "a flag which controls whether LAMBDA's substituted are applied in
+   simplification after the SUBLIS or whether you have to do an
+   EV to get things to apply. A value of TRUE means perform the application.")
+
+    ; The EXPR stuff here should eventually be flushed.
+(DECLARE (*EXPR $LISTP $RAT $RATP $RATDISREP GETOPR) 
+	 (SPECIAL *MSUBLIS-MARKER*))
+
+;;; SUBLIS([sym1=form1,sym2=form2,...],expression)$
+;;;
+;;;  This should change all occurrences of sym1 in expression to form1,
+;;;  all occurrences of sym2 to form2, etc. The replacement is done in
+;;;  parallel, so having occurrences of sym1 in form2, etc. will have
+;;;  the `desired' (non-interfering) effect.
+
+(DEFMFUN $SUBLIS (SUBSTITUTIONS FORM)
+  (COND
+   (($LISTP SUBSTITUTIONS)
+    (DO ((L  (CDR SUBSTITUTIONS) (CDR L))
+	 (NL ())
+	 (TEMP))
+	((NULL L) (SETQ SUBSTITUTIONS NL))
+      (SETQ TEMP (CAR L))
+      (COND ((AND (NOT (ATOM TEMP))
+		  (NOT (ATOM (CAR TEMP)))
+		  (EQ (CAAR TEMP) 'MEQUAL)
+		  (SYMBOLP (CAR (POP TEMP))))
+	     (PUSH (CONS (POP TEMP) (POP TEMP)) NL))
+	    (T (MERROR "Usage is SUBLIS([sym1=form1,...],expression)")))))
+   (T
+    (MERROR "Usage is SUBLIS([sym1=form1,...],expression)")))
+  (MSUBLIS SUBSTITUTIONS FORM))
+
+(DECLARE (SPECIAL S))
+(DEFUN MSUBLIS (S Y)
+       (LET ((*MSUBLIS-MARKER* (COPYSYMBOL '*MSUBLIS-MARKER* NIL)))
+	    (MSUBLIS-SETUP)
+	    (UNWIND-PROTECT (MSUBLIS-SUBST Y T) (MSUBLIS-UNSETUP))))
+
+(DEFUN MSUBLIS-SETUP ()
+       (DO ((X S (CDR X)) (TEMP) (TEMP1)) ((NULL X))
+	(COND ((NOT (SYMBOLP (SETQ TEMP (CAAR X))))
+	       (MERROR "SUBLIS: Bad 1st arg")))
+	(SETPLIST TEMP (LIST* *MSUBLIS-MARKER* (CDAR X) (PLIST TEMP)))
+	(COND ((NOT (EQ TEMP (SETQ TEMP1 (GETOPR TEMP))))
+	       (SETPLIST TEMP1 (LIST* *MSUBLIS-MARKER* (CDAR X) (PLIST TEMP1)))
+	       (PUSH (NCONS TEMP1) S))))) ; Remember extra cleanup
+
+(DEFUN MSUBLIS-UNSETUP ()
+       (DO ((X S (CDR X))) ((NULL X)) (REMPROP (CAAR X) *MSUBLIS-MARKER*)))
+(DECLARE (UNSPECIAL S))
+
+(DEFUN MSUBLIS-SUBST (FORM FLAG)
+       (COND ((ATOM FORM)
+	      (COND ((SYMBOLP FORM)
+		     (COND ((EQ (CAR (PLIST FORM)) *MSUBLIS-MARKER*)
+			    (CADR (PLIST FORM)))
+			   (T FORM)))
+		    (T FORM)))
+	     (FLAG
+	      (COND (($RATP FORM)
+		     (LET* ((DISREP ($RATDISREP FORM))
+			    (SUB    (MSUBLIS-SUBST DISREP T)))
+			   (COND ((EQ DISREP SUB) FORM)
+				 (T ($RAT SUB)))))
+		    ((ATOM (CAR FORM))
+		     (MERROR
+		       "SUBLIS: Illegal object in expression being substituted for."))
+		    (T
+		     (LET ((CDR-VALUE (MSUBLIS-SUBST (CDR FORM) NIL))
+			   (CAAR-VALUE (MSUBLIS-SUBST (CAAR FORM) T)))
+			  (COND ((AND (EQ CDR-VALUE (CDR FORM))
+				      (EQ (CAAR FORM) CAAR-VALUE))
+				 FORM)
+				((AND $SUBLIS_APPLY_LAMBDA
+				      (EQ (CAAR FORM) 'MQAPPLY)
+				      (EQ CAAR-VALUE 'MQAPPLY)
+				      (ATOM (CADR FORM))
+				      (NOT (ATOM (CAR CDR-VALUE)))
+				      (EQ (CAAR (CAR CDR-VALUE)) 'LAMBDA))
+				 (CONS (CONS (CAR CDR-VALUE)
+					     (COND ((MEMQ 'ARRAY (CAR FORM))
+						    '(ARRAY))
+						   (T NIL)))
+				       (CDR CDR-VALUE)))
+				((AND (NOT (ATOM CAAR-VALUE))
+				      (OR (NOT (OR (EQ (CAR CAAR-VALUE) 'LAMBDA)
+						   (EQ (CAAR CAAR-VALUE) 'LAMBDA)))
+					  (NOT $SUBLIS_APPLY_LAMBDA)))
+				 (LIST* (CONS 'MQAPPLY
+					      (COND ((MEMQ 'ARRAY (CAR FORM))
+						     '(ARRAY))
+						    (T NIL)))
+					CAAR-VALUE
+					CDR-VALUE))
+				(T (CONS (CONS CAAR-VALUE
+					       (COND ((MEMQ 'ARRAY (CAR FORM))
+						      '(ARRAY))
+						     (T NIL)))
+					 CDR-VALUE)))))))
+	     (T
+	      (LET ((CAR-VALUE (MSUBLIS-SUBST (CAR FORM) T))
+		    (CDR-VALUE (MSUBLIS-SUBST (CDR FORM) NIL)))
+		   (COND ((AND (EQ (CAR FORM) CAR-VALUE)
+			       (EQ (CDR FORM) CDR-VALUE))
+			  FORM)
+			 (T
+			  (CONS CAR-VALUE CDR-VALUE)))))))
+

src/maxsrc/sumcon.18

@@ -0,0 +1,147 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module sumcon)
+
+(declare (special $genindex $niceindicespref $sumexpand)
+	 (*lexpr $min $max))
+
+(defmfun $sumcontract (e)  ; e is assumed to be simplified
+       (cond ((atom e) e)
+	     ((eq (caar e) 'mplus)
+	      (do ((x (cdr e) (cdr x)) (sums) (notsums) (car-x))
+		  ((null x) (cond ((null sums)
+				   (subst0 (cons '(mplus)
+						 (nreverse notsums))
+					   e))
+				  (t (setq sums (sumcontract1 sums))
+				     (addn (cons sums notsums) t))))
+		  (setq car-x (car x))
+		  (cond ((atom car-x)
+			 (setq notsums (cons car-x notsums)))
+			((eq (caar car-x) '%sum)
+			 (setq sums (cons (cons ($sumcontract (cadr car-x))
+						(cddr car-x))
+					  sums)))
+			(t (setq notsums (cons car-x notsums))))))
+	     (t (recur-apply #'$sumcontract e))))
+
+(defmfun $intosum (e)  ; e is assumed to be simplified
+  (let (($sumexpand t))
+       (cond ((atom e) e)
+	     ((eq (caar e) 'mtimes)	;puts outside product inside
+	      (do ((x (cdr e) (cdr x)) (sum) (notsum))
+		  ((null x) (cond ((null sum)
+				   (subst0 (cons '(mtimes)
+						 (nreverse notsum))
+					   e))
+				  (t (simpsum
+				      (let ((new-index
+					     (cond ((free (cons nil notsum)
+							  (caddr sum))
+						    (caddr sum))
+						   (t (get-free-index
+						       (cons nil (cons sum notsum)))))))
+					   (setq sum (subst new-index (caddr sum) sum))
+					   (rplaca (cdr sum) (muln (cons (cadr sum) notsum) t))
+					   (rplacd (car sum) nil)
+					   sum)
+				      1 t))))
+		  (cond ((atom (car x))
+			 (setq notsum (cons (car x) notsum)))
+			((eq (caaar x) '%sum)
+			 (setq sum (if (null sum)
+				       (car x)
+				       (muln (list sum (car x)) t))))
+			(t (setq notsum (cons ($sumcontract (car x))
+					      notsum))))))
+	     (t (recur-apply #'$intosum e)))))
+
+(defun sumcontract1 (sums) (addn (sumcontract2 nil sums) t))
+
+(defun sumcontract2 (result left)
+       (cond ((null left) result)
+	     (t ((lambda (x) (sumcontract2 (append (car x) result)
+					   (cdr x)))
+		 (sumcombine1 (car left) (cdr left))))))
+
+(defun sumcombine1 (pattern list)
+       (do ((sum pattern) (non-sums nil)
+	    (un-matched-sums nil) (try-this-one)
+	    (list list (cdr list)))
+	   ((null list) (cons (cons (simpsum (cons '(%sum) sum) 1 t)
+				    non-sums)
+			      un-matched-sums))
+	   (setq try-this-one (car list))
+	   (cond ((and (numberp (sub* (caddr sum) (caddr try-this-one)))
+		       (numberp (sub* (cadddr sum) (cadddr try-this-one))))
+		  ((lambda (x) (setq sum (cdar x)
+				     non-sums (cons (cdr x) non-sums)))
+		   (sumcombine2 try-this-one sum)))
+		 (t (setq un-matched-sums (cons try-this-one un-matched-sums))))))
+
+(defun sumcombine2 (sum1 sum2)
+       ((lambda (e1 e2 i1 i2 l1 l2 h1 h2)
+		((lambda (newl newh newi extracted new-sum)
+			 (setq e1 (subst newi i1 e1))
+			 (setq e2 (subst newi i2 e2))
+			 (setq new-sum (list '(%sum)
+					     (add2 e1 e2)
+					     newi
+					     newl
+					     newh))
+			 (setq extracted
+			       (addn
+				(mapcar (function dosum)
+					(list e1 e1 e2 e2)
+					(list newi newi newi newi)
+					(list l1 (add2 newh 1)
+					      l2 (add2 newh 1))
+					(list (sub* newl 1) h1
+					      (sub* newl 1) h2)
+					'(t t t t))
+				t))
+			 (cons new-sum extracted))
+		 ($max l1 l2) ($min h1 h2) (cond ((eq i1 i2) i1)
+						 ((free e1 i2) i2)
+						 ((free e2 i1) i1)
+						 (t (get-free-index (list nil
+									  i1 i2
+									  e1 e2
+									  l1 l2
+									  h1 h2))))
+		 nil nil))
+	(car sum1) (car sum2)
+	(cadr sum1) (cadr sum2)
+	(caddr sum1) (caddr sum2)
+	(cadddr sum1) (cadddr sum2)))
+
+(progn 'compile
+       (or (boundp '$niceindicespref)
+	   (setq $niceindicespref '((mlist simp) $i $j $k $l $m $n))))
+
+(defun get-free-index (list)
+       (or (do ((try-list (cdr $niceindicespref) (cdr try-list)))
+	       ((null try-list))
+	       (and (free list (car try-list))
+		    (return (car try-list))))
+	   (do ((n 0 (1+ n)) (try))
+	       (nil)
+	       (setq try (implode (append (exploden (cadr $niceindicespref))
+					  (exploden n))))
+	       (and (free list try) (return try)))))
+
+(defmfun $bashindices (e)  ; e is assumed to be simplified
+       (let (($genindex '$j))
+	    (cond ((atom e) e)
+		  ((memq (caar e) '(%sum %product))
+		   (subst (gensumindex) (caddr e) e))
+		  (t (recur-apply #'$bashindices e)))))
+
+(defmfun $niceindices (e)
+  (if (atom e) e
+	       (let ((e (recur-apply #'$niceindices e)))
+		    (if (memq (caar e) '(%sum %product))
+			(subst (get-free-index e) (caddr e) e)
+			e))))

src/maxsrc/suspen.13

@@ -0,0 +1,99 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module suspen)
+
+;;; For ASB so that he can suspend macsyma at the point of
+;;; a BUG. 12:53am  Wednesday, 4 February 1981 -gjc
+
+;;; I've changed this so that SUSPEND should be able to be
+;;; used in the middle of a BATCH/WRITEFILE and save the correct
+;;; state for a re-start. 4:35pm  Sunday, 15 March 1981
+
+;;; This still needs a lot of work in the way of systemic design if
+;;; it is going to really win. (Reseting of terminal types etc).
+
+(defmvar $suspend nil
+	"If not FALSE then this is the name of the file to which the
+	macsyma in question was last SUSPEND'ed. SUSPEND(); will
+	then suspend the macsyma back into that file again.")
+
+(defmfun $suspend (&optional
+		   (filename (or $suspend
+				 (merror "No filename given to suspend to."))))
+	 (or (symbolp filename)
+	     (merror "filename must be string~%~M" filename))
+	 (setq filename (namestring
+			 (mergef (stripdollar filename)
+				 `((DSK ,(STATUS UDIR)) TS ,(STATUS UNAME)))))
+	 (setq $suspend (concat '|&| filename))
+	 (let ((file-object-state (close-files))
+	       (TTY-RETURN NIL))
+	      (print file-object-state t)
+	      (terpri t)
+	      (suspend (concat '|: Suspended to "|
+			     filename
+			     '|" î:KILLî|)
+		       filename)
+	      (open-files file-object-state)
+	      $suspend))
+
+(eval-when (eval compile)
+	   (defstruct (filestate conc-name list default-pointer)
+		      object
+		      mode
+		      operations
+		      alist))
+
+(defun close-files ()
+       ;; "files" should include all state connected with the
+       ;; outside world. When we re-open the TTY stream for example
+       ;; it would be nice if all the state-variables associated with
+       ;; it got reset. Fat chance though without restructuring all
+       ;; macsyma I/O.
+       (do ((gcmkl (munkam (examine (getddtsym 'GCMKL)))
+		   ;; a list kept by the garbage collector.
+		   ;; we really want a list kept by the macsyma system.
+		   (cddr gcmkl))
+	    (dedsar (getddtsym 'DEDSAR))
+	    (filestates))
+	   ((null gcmkl) filestates)
+	   (if (and (not (eq (car gcmkl) dedsar))            ; not dead.
+		    (memq (car (arraydims (car gcmkl)))
+			  '(file sfa))                       ; is a file.
+		    (status filemode (car gcmkl)))           ; is open.
+	       (let ((filestate
+		      (make-filestate
+		       mode (car (status filemode (car gcmkl)))
+		       operations (cdr (status filemode (car gcmkl)))
+		       object (car gcmkl))))
+		    (if (memq 'filepos (filestate-operations))
+			(push `(filepos . ,(filepos (filestate-object)))
+			      (filestate-alist)))
+		    (close (filestate-object))
+		    (push filestate filestates)))))
+
+(defun open-files (l &aux
+		     (io-lossage
+		      #'(lambda (args)
+				(declare (special args))
+				(mformat-open
+				 t
+				 "~%Error in trying to ~A the object ~A.~
+				 ~%~A. Cannot restore state without help.~%"
+				 (car args) (cadr args)
+				 (caaddr (errframe nil)))
+				(*break t 'io-lossage))))
+       (mapc #'(lambda (filestate)
+		       (cond ((memq 'out (filestate-mode))
+			      (open (filestate-object) 'append))
+			     ((memq 'in (filestate-mode))
+			      (open (filestate-object))
+			      (if (memq 'filepos (filestate-operations))
+				  (filepos (filestate-object)
+					   (cdr (assq 'filepos
+						      (filestate-alist))))))
+			     (t
+			      (open (filestate-object)))))
+	     l))

src/maxsrc/synex.10

@@ -0,0 +1,187 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module synex)
+
+(LOAD-MACSYMA-MACROS MRGMAC)
+
+(DECLARE (GENPREFIX SYN)
+	 (SPECIAL ST1 STRING MOPL $PROPS)
+	 (*EXPR LBP RBP NFORMAT MEVAL MEVAL1 GETOP ADD2LNC REMCHK ASSOL
+		FULLSTRIP1 STRING* DISPLA WNA-ERR GETOPR REMPROPCHK
+		$VERBIFY $NOUNIFY $LISTP))
+
+;  If an appropriate wrng-no-args handler were set up in maclisp, this
+;  stuff could be written like this:
+;  (declare (setq defun&-check-args t))
+;  (DEFMFUN $prefix (operator &optional (rbp 180.) (rpos '$any) (lpos '$any))
+;         (or (fixp rbp) (bp-err rbp))
+;         (if (eq '& (getchar operator 1))
+;  	   (setq operator (define-symbol operator)))
+;         (define-prefix operator rbp rpos lpos))
+
+(DEFMFUN $PREFIX N
+  "Sets up a prefix operator, takes a bunch of optional arguments."
+  (IF (> N 4) (WNA-ERR '$PREFIX))
+  (DEFINE-PREFIX 
+    (COND ((< N 1) (WNA-ERR '$PREFIX))
+	  ((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
+	  (T (ARG 1)))
+    (COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
+    (COND ((< N 3) '$ANY) (T (ARG 3)))
+    (COND ((< N 4) '$ANY) (T (ARG 4)))))
+
+(DEFUN DEFINE-PREFIX (OP RBP RPOS POS)
+  (PROG (NOUN)
+    (SETQ NOUN ($NOUNIFY OP))
+    (OP-SETUP OP)
+    (PUT OP RBP 'RBP) (PUT NOUN RBP 'RBP)
+    (PUT OP RPOS 'RPOS) (PUT OP POS 'POS)
+    (PUT OP 'PARSE-PREFIX 'NUD)
+    (PUT OP 'MSIZE-PREFIX 'GRIND)
+    (PUT OP 'DIMENSION-PREFIX 'DIMENSION)
+    (PUT NOUN 'DIMENSION-PREFIX 'DIMENSION)
+    (PUT OP (NCONC (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
+    (PUT NOUN (NCONC (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
+    (RETURN (GETOPR OP))))
+
+
+(DEFMFUN $POSTFIX N 
+  (IF (> N 4) (WNA-ERR '$POSTFIX))
+  (DEFINE-POSTFIX 
+    (COND ((< N 1) (WNA-ERR '$POSTFIX))
+	  ((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
+	  (T (ARG 1)))
+    (COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
+    (COND ((< N 3) '$ANY) (T (ARG 3)))
+    (COND ((< N 4) '$ANY) (T (ARG 4)))))
+
+(DEFUN DEFINE-POSTFIX (OP LBP LPOS POS)
+  (PROG (NOUN)
+    (SETQ NOUN ($NOUNIFY OP))
+    (OP-SETUP OP)
+    (PUT OP LBP 'LBP) (PUT NOUN LBP 'LBP)
+    (PUT OP LPOS 'LPOS) (PUT OP POS 'POS)
+    (PUT OP 'PARSE-POSTFIX 'LED)
+    (PUT OP 'MSIZE-POSTFIX 'GRIND)
+    (PUT OP 'DIMENSION-POSTFIX 'DIMENSION)
+    (PUT NOUN 'DIMENSION-POSTFIX 'DIMENION)
+    (PUT OP (CONS #\SP (CDR (EXPLODEN OP))) 'DISSYM)
+    (PUT NOUN (CONS #\SP (CDR (EXPLODEN OP))) 'DISSYM)
+    (RETURN (GETOPR OP))))
+
+(DEFMFUN $INFIX N 
+  (IF (> N 6) (WNA-ERR '$INFIX))
+  (DEFINE-INFIX 
+    (COND ((< N 1) (WNA-ERR '$INFIX))
+	  ((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
+	  (T (ARG 1)))
+    (COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
+    (COND ((< N 3) 180.) ((FIXP (ARG 3)) (ARG 3)) (T (BP-ERR (ARG 3))))
+    (COND ((< N 4) '$ANY) (T (ARG 4)))
+    (COND ((< N 5) '$ANY) (T (ARG 5)))
+    (COND ((< N 6) '$ANY) (T (ARG 6)))))
+
+(DEFUN DEFINE-INFIX (OP LBP RBP LPOS RPOS POS)
+  (PROG (NOUN)
+    (SETQ NOUN ($NOUNIFY OP))
+    (OP-SETUP OP)
+    (PUT OP LBP 'LBP) (PUT OP RBP 'RBP)
+    (PUT OP LPOS 'LPOS) (PUT OP RPOS 'RPOS) (PUT OP POS 'POS)
+    (PUT NOUN LBP 'LBP) (PUT NOUN RBP 'RBP)
+    (PUT OP 'PARSE-INFIX 'LED)
+    (PUT OP 'MSIZE-INFIX 'GRIND)
+    (PUT OP 'DIMENSION-INFIX 'DIMENSION)
+    (PUT NOUN 'DIMENSION-INFIX 'DIMENSION)
+    (PUT OP (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
+    (PUT NOUN (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
+    (RETURN (GETOPR OP))))
+
+(DEFMFUN $NARY N 
+  (IF (> N 4) (WNA-ERR '$NARY))
+  (DEFINE-NARY
+    (COND ((< N 1) (WNA-ERR '$INFIX))
+	  ((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
+	  (T (ARG 1)))
+    (COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
+    (COND ((< N 3) '$ANY) (T (ARG 3)))
+    (COND ((< N 4) '$ANY) (T (ARG 4)))))
+
+(DEFUN DEFINE-NARY (OP BP ARGPOS POS)
+  (PROG (NOUN)
+    (SETQ NOUN ($NOUNIFY OP))
+    (OP-SETUP OP)
+    (PUT OP BP 'LBP) (PUT OP BP 'RBP)
+    (PUT OP ARGPOS 'LPOS) (PUT OP POS 'POS)
+    (PUT NOUN BP 'LBP) (PUT NOUN BP 'RBP)
+    (PUT OP 'PARSE-NARY 'LED)
+    (PUT OP 'MSIZE-NARY 'GRIND)
+    (PUT OP 'DIMENSION-NARY 'DIMENSION)
+    (PUT NOUN 'DIMENSION-NARY 'DIMENSION)
+    (PUT OP (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
+    (PUT NOUN (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
+    (RETURN (GETOPR OP))))
+
+(DEFMFUN $MATCHFIX N 
+  (IF (> N 4) (WNA-ERR '$MATCHFIX))
+  (DEFINE-MATCHFIX 
+    (COND ((< N 1) (WNA-ERR '$MATCHFIX))
+	  ((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
+	  (T (ARG 1)))
+    (COND ((< N 2) (WNA-ERR '$MATCHFIX))
+	  ((EQ '& (GETCHAR (ARG 2) 1)) (DEFINE-SYMBOL (ARG 2)))
+	  (T (ARG 2)))
+    (COND ((< N 3) '$ANY) (T (ARG 3)))
+    (COND ((< N 4) '$ANY) (T (ARG 4)))))
+
+(DEFUN DEFINE-MATCHFIX (OP MATCH ARGPOS POS)
+  (PROG (NOUN)
+    (PUT OP MATCH 'MATCH)
+    (SETQ NOUN ($NOUNIFY OP))
+    (OP-SETUP OP) (OP-SETUP MATCH)
+    (PUT OP ARGPOS 'LPOS) (PUT OP POS 'POS)
+    (PUT MATCH 5. 'LBP)
+    (PUT OP 'PARSE-MATCHFIX 'NUD)
+    (PUT OP 'MSIZE-MATCHFIX 'GRIND)
+    (PUT OP 'DIMENSION-MATCH 'DIMENSION)
+    (PUT NOUN 'DIMENSION-MATCH 'DIMENSION)
+    (PUT OP (CONS (CDR (EXPLODEN OP)) (CDR (EXPLODEN MATCH))) 'DISSYM)
+    (PUT NOUN (CONS (CDR (EXPLODEN OP)) (CDR (EXPLODEN MATCH))) 'DISSYM)
+    (RETURN (GETOPR OP))))
+
+(DEFMFUN $NOFIX N 
+  (IF (> N 2) (WNA-ERR '$NOFIX))
+  (DEFINE-NOFIX 
+    (COND ((< N 1) (WNA-ERR '$NOFIX))
+	  ((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
+	  (T (ARG 1)))
+    (COND ((< N 2) '$ANY) (T (ARG 2)))))
+
+(DEFUN DEFINE-NOFIX (OP POS)
+  (PROG (NOUN)
+    (SETQ NOUN ($NOUNIFY OP))
+    (OP-SETUP OP)
+    (PUT OP POS 'POS)
+    (PUT OP 'PARSE-NOFIX 'NUD)
+    (PUT OP 'MSIZE-NOFIX 'GRIND)
+    (PUT OP 'DIMENSION-NOFIX 'DIMENSION)
+    (PUT NOUN 'DIMENSION-NOFIX 'DIMENSION)
+    (PUT OP (CDR (EXPLODEN OP)) 'DISSYM)
+    (PUT NOUN (CDR (EXPLODEN OP)) 'DISSYM)
+    (RETURN (GETOPR OP))))
+
+(DEFUN OP-SETUP (OP)
+  (PROG (DUMMY)
+    (SETQ DUMMY (OR (GET OP 'OP) (IMPLODE (CONS '& (STRING* OP)))))
+    (PUT OP DUMMY 'OP)
+    (PUT DUMMY OP 'OPR)
+    (IF (AND (OPERATORP1 OP) (NOT (MEMQ DUMMY (CDR $PROPS))))
+	(SETQ MOPL (CONS DUMMY MOPL)))
+    (ADD2LNC DUMMY $PROPS)))
+
+(DEFUN BP-ERR (X)
+  (MERROR "Non-integer given as binding power: ~M" X))
+
+
+

src/maxsrc/utils.26

@@ -0,0 +1,182 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module utils)
+
+;;; General purpose Lisp utilities.  This file contains runtime functions which
+;;; are simple extensions to Lisp.  The functions here are not very general, 
+;;; but generalized forms would be useful in future Lisp implementations.
+;;;
+;;; No knowledge of the Macsyma system is kept here.  
+;;;
+;;; Every function in this file is known about externally.
+
+
+
+;;; N.B. this function is different than the lisp machine
+;;; and maclisp standard one. (for now).
+
+;;; temporary until the new lispm make-list is installed
+
+(DEFMFUN *MAKE-LIST (SIZE &OPTIONAL (VAL NIL) )
+	 (DO ((L NIL (CONS VAL L)))
+	     ((< (SETQ SIZE (1- SIZE)) 0) L)))
+
+;;; F is assumed to be a function of two arguments.  It is mapped down L
+;;; and applied to consequtive pairs of elements of the list.
+;;; Useful for iterating over property lists.
+
+(DEFMFUN MAP2C (F L)
+  (DO ((LLT L (CDDR LLT)) (LANS))
+      ((NULL LLT) LANS)
+      (SETQ LANS (CONS (FUNCALL F (CAR LLT) (CADR LLT)) LANS))))
+
+;;; (ANDMAPC #'FIXP '(1 2 3)) --> T
+;;; (ANDMAPC #'FIXP '(1 2 A)) --> NIL
+;;; (ORMAPC  #'FIXP '(1 2 A)) --> T
+;;; (ORMAPC  #'FIXP '(A B C)) --> NIL
+
+;;; If you want the do loop generated inline rather than doing a function call,
+;;; use the macros SOME and EVERY.  See LMLisp manual for more information.
+;;; Note that the value returned by ORMAPC is slightly different from that
+;;; returned by SOME.
+
+(DEFMFUN ANDMAPC (F L)
+  (DO ((L L (CDR L)))
+      ((NULL L) T)
+      (IF (NOT (FUNCALL F (CAR L))) (RETURN NIL))))
+
+(DEFMFUN ORMAPC (F L &AUX ANSWER)
+  (DO ((L L (CDR L)))
+      ((NULL L) NIL)
+      (SETQ ANSWER (FUNCALL F (CAR L)))
+      (IF ANSWER (RETURN ANSWER))))
+
+;;; Like MAPCAR, except if an application of F to any of the elements of L
+;;; returns NIL, then the function returns NIL immediately.
+
+(DEFMFUN ANDMAPCAR (F L &AUX D ANSWER)
+  (DO ((L L (CDR L)))
+      ((NULL L) (NREVERSE ANSWER))
+      (SETQ D (FUNCALL F (CAR L)))
+      (IF D (PUSH D ANSWER) (RETURN NIL))))
+
+;;; Returns T if either A or B is NIL, but not both.
+
+(DEFMFUN XOR (A B) (OR (AND (NOT A) B) (AND (NOT B) A)))
+  
+;;; A MEMQ which works at all levels of a piece of list structure.
+;;;
+;;; Note that (AMONG NIL '(A B C)) is T, however.  This could cause bugs.
+;;; > This is false. (AMONG NIL anything) returns NIL always. -kmp
+
+(DEFMFUN AMONG (X L) 
+  (COND ((NULL L) NIL)
+	((ATOM L) (EQ X L))
+	(T (OR (AMONG X (CAR L)) (AMONG X (CDR L)))))) 
+
+;;; Similar to AMONG, but takes a list of objects to look for.  If any
+;;; are found in L, returns T.
+
+(DEFMFUN AMONGL (X L) 
+  (COND ((NULL L) NIL)
+	((ATOM L) (MEMQ L X))
+	(T (OR (AMONGL X (CAR L)) (AMONGL X (CDR L)))))) 
+
+;;; (RECONC '(A B C) '(D E F)) --> (C B A D E F)
+;;; Like NRECONC, but not destructive.
+;;;
+;;; Is this really faster than macroing into (NCONC (REVERSE L1) L2)?
+;;; > Yes, it is. -kmp
+
+(DEFMFUN RECONC (L1 L2)
+  (DO () ((NULL L1) L2)
+      (SETQ L2 (CONS (CAR L1) L2) L1 (CDR L1))))
+
+
+;;; (FIRSTN 3 '(A B C D E)) --> (A B C)
+;;;
+;;; *NOTE* Given a negative first arg will work fine with this definition
+;;;	   but on LispM where the operation is primitive and defined 
+;;;	   differently, bad things will happen. Make SURE it gets a 
+;;;	   non-negative arg! -kmp
+
+#+(OR PDP10 Franz)
+(DEFMFUN FIRSTN (N L)
+  (LOOP FOR I FROM 1 TO N
+	FOR X IN L
+	COLLECT X))
+
+;;; Reverse ASSQ -- like ASSQ but tries to find an element of the alist whose
+;;; cdr (not car) is EQ to the object.  To be renamed to RASSQ in the near
+;;; future.
+
+(DEFMFUN ASSQR (OBJECT ALIST)
+  (DOLIST (PAIR ALIST)
+	  (IF (EQ OBJECT (CDR PAIR)) (RETURN PAIR))))
+
+;;; Should be open-coded at some point.  (Moved here from RAT;FACTOR)
+(DEFMFUN LOG2 (N) (1- (HAULONG N)))
+
+;;; Tries to emulate Lispm/NIL FSET.  Won't work for LSUBRS, FEXPRS, or
+;;; FSUBRS.
+
+#+PDP10
+(DEFMFUN FSET (SYMBOL DEFINITION)
+  (COND ((SYMBOLP DEFINITION)
+	 (PUTPROP SYMBOL DEFINITION 'EXPR))
+	((EQ (TYPEP DEFINITION) 'RANDOM)
+	 (PUTPROP SYMBOL DEFINITION 'SUBR))
+	((LISTP DEFINITION)
+	 (PUTPROP SYMBOL DEFINITION 'EXPR))
+	(T (ERROR "Invalid symbol definition - FSET"
+		  DEFINITION 'WRNG-TYPE-ARG))))
+
+;;; Takes a list in "alist" form and converts it to one in
+;;; "property list" form, i.e. ((A . B) (C . D)) --> (A B C D).
+;;; All elements of the list better be conses.
+
+(DEFMFUN DOT2L (L)
+  (COND ((NULL L) NIL)
+	(T (LIST* (CAAR L) (CDAR L) (DOT2L (CDR L))))))
+
+
+;;; (A-ATOM sym selector value   )
+;;; (C-PUT  sym value    selector)
+;;;
+;;;  They make a symbol's property list look like a structure.
+;;;
+;;;  If the value to be stored is NIL,
+;;;     then flush the property.
+;;;     else store the value under the appropriate property.
+;;;
+;;; >>> Note: Since they do essentially the same thing, one (A-ATOM)
+;;; >>>       should eventually be flushed...
+
+(DEFMFUN A-ATOM (BAS SEL VAL) (CPUT BAS VAL SEL))
+
+(DEFMFUN CPUT (BAS VAL SEL)
+  (COND ((NULL VAL) (REMPROP BAS SEL) NIL)
+	(T (PUTPROP BAS VAL SEL))))
+
+;;; This is like the function SYMBOLCONC except that it binds base and *nopoint
+
+#-Franz
+(DEFMFUN CONCAT N
+ (LET ((BASE 10.) (*NOPOINT T)) (IMPLODE (MAPCAN 'EXPLODEN (LISTIFY N)))))
+
+
+(DECLARE (SPECIAL ALPHABET)) ; This should be DEFVAR'd somewhere. Sigh. -kmp
+
+(DEFMFUN ALPHABETP (N)
+ (DECLARE (FIXNUM N))
+ (OR (AND (>= N #/A) (<= N #/Z))  ; upper case
+     (AND (>= N #/a) (<= N #/z))  ; lower case
+     (MEMBER N ALPHABET)))	  ; test for %, _, or other declared
+				  ;    alphabetic characters.
+
+(DEFMFUN ASCII-NUMBERP (NUM)
+  (DECLARE (FIXNUM NUM))
+  (AND (<= NUM #/9) (>= NUM #/0)))
+

src/maxsrc/vt100.5

@@ -0,0 +1,33 @@
+;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
+;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(macsyma-module vt100)
+
+;; Package for doing character graphics on VT-100s and VT-132s.  The Macsyma
+;; display package uses this to draw quotients, matrices, boxes, etc.  with
+;; contiguous lines.  This file gets loaded when Macsyma is started up and
+;; it is determined that a VT-100 or VT-132 is being used.
+
+(DEFUN CG-BEGIN-GRAPHICS () (CG-IMAGE-TYO #^N))
+(DEFUN CG-END-GRAPHICS	 () (CG-IMAGE-TYO #^O))
+
+(DEFUN CG-VERTICAL-BAR   () (CG-TYO #/x))
+(DEFUN CG-HORIZONTAL-BAR () (CG-TYO #/q))
+
+(DEFUN CG-UL-CORNER      () (CG-TYO #/l))
+(DEFUN CG-UR-CORNER      () (CG-TYO #/k))
+(DEFUN CG-LL-CORNER      () (CG-TYO #/m))
+(DEFUN CG-LR-CORNER      () (CG-TYO #/j))
+
+;; Get the terminal in an unwedged state.  Set up character set G0
+;; as the ASCII set and G1 as the special graphics set.  Then
+;; make sure we are using the G0 set.
+
+(CG-IMAGE-TYO-N '(#\ALT #/( #/B #\ALT #/) #/0 #^O))
+
+;; This should really be set in ALJABR;LOADER and not here, but we're not
+;; always able to recognize the terminal type.  For example, coming in via
+;; supdup.  So we want things to turn on when the file is loaded by hand.
+
+(SETQ CHARACTER-GRAPHICS-TTY T)