From dc5e4505ae67448a73e08d4df8370271e23e7c73 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Fri, 13 Jul 2018 15:28:57 -0700 Subject: [PATCH] Update macsyma sources with newer versions of some files. Resolves #1059. --- build/build.tcl | 2 +- src/maxsrc/descri.68 | 227 +++++++++ src/maxsrc/inmis.106 | 92 ++++ src/maxsrc/ldisp.44 | 98 ++++ src/maxsrc/mdot.97 | 391 ++++++++++++++++ src/maxsrc/merror.56 | 275 +++++++++++ src/maxsrc/mload.139 | 563 ++++++++++++++++++++++ src/maxsrc/mtrace.46 | 789 +++++++++++++++++++++++++++++++ src/maxsrc/mtree.2 | 104 +++++ src/maxsrc/ndiffq.7 | 205 ++++++++ src/maxsrc/numer.20 | 278 +++++++++++ src/maxsrc/outmis.319 | 1028 +++++++++++++++++++++++++++++++++++++++++ src/maxsrc/rombrg.44 | 144 ++++++ src/maxsrc/sets.12 | 449 ++++++++++++++++++ src/maxsrc/sublis.12 | 118 +++++ src/maxsrc/sumcon.20 | 149 ++++++ 16 files changed, 4911 insertions(+), 1 deletion(-) create mode 100644 src/maxsrc/descri.68 create mode 100644 src/maxsrc/inmis.106 create mode 100644 src/maxsrc/ldisp.44 create mode 100644 src/maxsrc/mdot.97 create mode 100644 src/maxsrc/merror.56 create mode 100644 src/maxsrc/mload.139 create mode 100644 src/maxsrc/mtrace.46 create mode 100644 src/maxsrc/mtree.2 create mode 100644 src/maxsrc/ndiffq.7 create mode 100644 src/maxsrc/numer.20 create mode 100644 src/maxsrc/outmis.319 create mode 100644 src/maxsrc/rombrg.44 create mode 100644 src/maxsrc/sets.12 create mode 100644 src/maxsrc/sublis.12 create mode 100644 src/maxsrc/sumcon.20 diff --git a/build/build.tcl b/build/build.tcl index 510326af..91cfda39 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -93,7 +93,7 @@ proc build_macsyma_portion {} { } type "(mapcan " type "#'(lambda (x) (cond ((not (memq x\r" - type "'(SETS TRANSS MTREE TRHOOK EDLM)\r" + type "'(TRANSS MTREE TRHOOK EDLM)\r" type ")) (doit x)))) (append todo todoi))" set timeout 1000 expect { diff --git a/src/maxsrc/descri.68 b/src/maxsrc/descri.68 new file mode 100644 index 00000000..46d98a12 --- /dev/null +++ b/src/maxsrc/descri.68 @@ -0,0 +1,227 @@ +;;; -*- 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. + +(DEFMSPEC $DESCRIBE (NODES) (SETQ NODES (CDR 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)) + (MTELL "No info for ~A~%" (CAR L))) + ((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))) + CDATE + (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 FILE '((DSK MAXOUT) MACSYM DOC)) + (SETQ F (OPEN FILE '(IN ASCII))) +; (COND ((NOT (= CDATE (CAR (SYSCALL 1 'RFDATE F)))) ; Twenex doesn't like +; (CLOSE F) (SETQ F ()))) ;this and we don't need it anyway. + (CONS F NODES))) + +(DEFMFUN MDESCRIBE (X) (MEVAL `(($DESCRIBE) ,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) + +(DEFMSPEC $HELP (X) X (MDESCRIBE '$HELP)) + +(DECLARE (SPLITFILE EXAMPL)) + +;In essence, example(func):=DEMO([manual,demo,dsk,macsym],OFF,'func,OFF); + +(DEFMSPEC $example (func) + (setq func (FEXPRCHECK func)) + (NONSYMCHK func '$example) + (let (($change_filedefaults ())) + (batch1 `(#-Multics((MLIST) manual demo dsk macsym) + #+Multics((mlist) ,(string-to-mstring + (string-append macsyma-dir + ">demo>manual.demo"))) + NIL ((MQUOTE) ,func) NIL) + t nil nil)) + '$done) + \ No newline at end of file diff --git a/src/maxsrc/inmis.106 b/src/maxsrc/inmis.106 new file mode 100644 index 00000000..f334eb36 --- /dev/null +++ b/src/maxsrc/inmis.106 @@ -0,0 +1,92 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module inmis) + +(DECLARE (SPECIAL LISTOFVARS)) + +(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) + +(DEFMVAR $LISTDUMMYVARS T) + +(DEFMVAR $POLYFACTOR NIL) + +(DEFMFUN $UNKNOWN (F) (*CATCH 'UNKNOWN-FUNCTION (UNKNOWN (SPECREPCHECK F)))) + +(DEFUN UNKNOWN (F) + (AND (NOT (MAPATOM F)) + (COND ((AND (EQ (CAAR F) 'MQAPPLY) + (NOT (GET (CAAADR F) 'SPECSIMP))) + (*THROW 'UNKNOWN-FUNCTION T)) + ((NOT (GET (CAAR F) 'OPERATORS)) (*THROW 'UNKNOWN-FUNCTION T)) + (T (MAPC #'UNKNOWN (CDR F)) NIL)))) + +(DEFMFUN $LISTOFVARS (E) + (LET ((LISTOFVARS (NCONS '(MLIST)))) + (WHEN ($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) + (IF (NOT $LISTDUMMYVARS) + (DOLIST (U (CDR LISTOFVARS)) + (IF (FREEOF U E) (DELETE U LISTOFVARS 1)))) + LISTOFVARS)) + +(DEFUN ATOMVARS (E) + (COND ((AND (SYMBOLP E) (OR $LISTCONSTVARS (NOT ($CONSTANTP E)))) + (ADD2LNC E LISTOFVARS)) + ((ATOM E)) + ((SPECREPP E) (ATOMVARS (SPECDISREP E))) + ((MEMQ 'ARRAY (CAR E)) (MYADD2LNC E LISTOFVARS)) + (T (MAPC #'ATOMVARS (MARGS 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 $RESET () (LOAD "[MACSYMA]RESET")) + +#+Franz +(DEFMFUN $RESET () + (LOAD (CONCAT VAXIMA-MAIN-DIR "//aljabr//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)) +;; This version should be eventually used on Multics. +#-(or ITS Multics NIL Franz) +(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 "MACSYMA-OBJECT:ALJABR;INIT" + #+Multics (executable-dir "init_reset") + #+Franz (concat vaxima-main-dir "//aljabr//reset")) + ;; *** 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) + diff --git a/src/maxsrc/ldisp.44 b/src/maxsrc/ldisp.44 new file mode 100644 index 00000000..0c3c2d31 --- /dev/null +++ b/src/maxsrc/ldisp.44 @@ -0,0 +1,98 @@ +;;; -*- LISP -*- +;;; Auxiliary DISPLA package for doing 1-D display +;;; +;;; (c) 1979 Massachusetts Institute of Technology +;;; +;;; See KMP for details + +(MACSYMA-MODULE LDISP) + +(DECLARE (*EXPR MSTRING STRIPDOLLAR) + (SPECIAL LINEAR-DISPLAY-BREAK-TABLE FORTRANP)) + +;;; (LINEAR-DISPLA ) +;;; +;;; 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 ( . ) +;;; +;;; The linear display thing will feel free to break BEFORE any +;;; of these 's unless they are preceded by one of the +;;; characters. + +(SETQ LINEAR-DISPLAY-BREAK-TABLE + '((#/= #/: #/=) + (#/( #/( #/[) + (#/) #/) #/]) + (#/[ #/( #/[) + (#/] #/) #/]) + (#/: #/:) + (#/+ #/E #/B) + (#/- #/E #/B) + (#/* #/*) + (#/^))) + +;;; (FIND-NEXT-BREAK ) +;;; 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 ) +;;; Displays 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 +;;; 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.)))))) + diff --git a/src/maxsrc/mdot.97 b/src/maxsrc/mdot.97 new file mode 100644 index 00000000..ee199b28 --- /dev/null +++ b/src/maxsrc/mdot.97 @@ -0,0 +1,391 @@ +;; -*- 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, TRUE and ALL. See the manual for +more details.") + +;; The folloing lines were originally in the comment above. That made the +;; string more than 512 characters and FRANZ couldn't hack it. + +;; 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 + ERRORSW) + (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 (zerop1 factor) + (if (not errorsw) + (merror "~M has been generated" + (list '(mncexpt) factor power)) + (*throw 'errorsw t))) + (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) + (eq (typep power) 'fixnum)) + (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))) + (eq (typep power) 'fixnum) + (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))) + (eq (typep power) 'fixnum) + (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)) diff --git a/src/maxsrc/merror.56 b/src/maxsrc/merror.56 new file mode 100644 index 00000000..7ec7de6e --- /dev/null +++ b/src/maxsrc/merror.56 @@ -0,0 +1,275 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module merror) + +;;; Macsyma error signalling. +;;; 2:08pm Tuesday, 30 June 1981 George Carrette. + +(DEFMVAR $ERROR '((MLIST SIMP) |&No error.|) + "This is set 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. It would be better to bind these variables, for, among +;;; other things, then the values could get garbage collected. + +;; Define the MACSYMA-ERROR condition. +#+LISPM (PROGN 'COMPILE + +(DEFFLAVOR MACSYMA-ERROR (MFORMAT-STRING) (ERROR) + :INITABLE-INSTANCE-VARIABLES) +(DEFMETHOD (MACSYMA-ERROR :REPORT) (STREAM) (SEND STREAM ':STRING-OUT MFORMAT-STRING)) +(COMPILE-FLAVOR-METHODS MACSYMA-ERROR) + +;;; I'm not sure that this is the right way to do this. We can always flush this when +;;; enter-macsyma-debugger does the right thing. + +(DEFFLAVOR MACSYMA-DEBUGGER (MFORMAT-STRING) (ERROR) + :INITABLE-INSTANCE-VARIABLES) +(DEFMETHOD (MACSYMA-DEBUGGER :REPORT) (STREAM) (SEND STREAM ':STRING-OUT MFORMAT-STRING)) +(COMPILE-FLAVOR-METHODS MACSYMA-DEBUGGER) + +(DEFUN ENTER-MACSYMA-DEBUGGER () + (ERROR 'MACSYMA-DEBUGGER ':MFORMAT-STRING "Entering Lisp Debugger")) +(DEFPROP ENTER-MACSYMA-DEBUGGER T :ERROR-REPORTER) + +) ;#+LISPM + +(DEFMFUN MERROR (STRING &REST L) + (SETQ STRING (CHECK-OUT-OF-CORE-STRING STRING)) + (SETQ $ERROR `((MLIST) ,STRING ,@L)) + (AND $ERRORMSG ($ERRORMSG)) + #+LISPM (IF DEBUG + (ENTER-MACSYMA-DEBUGGER) + (ERROR 'MACSYMA-ERROR ':MFORMAT-STRING STRING)) + #+NIL (ERROR STRING) + #-(OR LISPM NIL) (ERROR)) + +#+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." + ;; 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 controlling 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 #-(OR LISPM NIL) 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 (mapcan #'(lambda (x) + (if (= x #/~) + (list x x) + (list x))) + (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 were 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)))))) +) \ No newline at end of file diff --git a/src/maxsrc/mload.139 b/src/maxsrc/mload.139 new file mode 100644 index 00000000..22a306d4 --- /dev/null +++ b/src/maxsrc/mload.139 @@ -0,0 +1,563 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1979, 1983 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. + +;; Define the Macsyma canonical type. +#+LispM +(progn 'compile +FS: +(DEFINE-CANONICAL-TYPE :MACSYMA "MACSYMA" + ((:TENEX :TOPS-20) "MAC" "MACSYMA") + (:ITS :UNSPECIFIC) + (:UNIX "M" "MACSYMA") + (:VMS "MAC"))) + +;; 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 #-Lispm (PROBEF #-PDP10 (ADD-TYPE ($FILENAME_MERGE X U) (CAR L)) + #+PDP10 ($FILENAME_MERGE X U (CAR L))) + #+Lispm (condition-case () + (probef (add-type ($filename_merge x u) (car l))) + (fs:directory-not-found nil))) + (IF LISTP + (PUSH (TO-MACSYMA-NAMESTRING PROBED) FOUND) + (RETURN T)))) + (RETURN (TO-MACSYMA-NAMESTRING PROBED))))) + +#-LispM +(DEFUN ADD-TYPE (PATH TYPE) + (MERGEF PATH TYPE)) + +#+LispM +(DEFUN ADD-TYPE (PATH MACSYMA-TYPE) + (LET ((TYPE (STRING (FULLSTRIP1 MACSYMA-TYPE)))) + (COND ((not (null (send path ':type))) + path) + ((STRING-EQUAL TYPE "FALSE") + PATH) + ((STRING-EQUAL TYPE "LISP") + (SEND PATH ':NEW-CANONICAL-TYPE ':LISP)) + ((STRING-EQUAL TYPE "MACSYMA") + (SEND PATH ':NEW-CANONICAL-TYPE ':MACSYMA)) + ((STRING-EQUAL TYPE "BIN") + (SEND PATH ':NEW-CANONICAL-TYPE ':BIN)) + ((STRING-EQUAL TYPE "QBIN") + (SEND PATH ':NEW-CANONICAL-TYPE ':QBIN)) + (T (SEND PATH ':NEW-RAW-TYPE TYPE))))) + +;; Filename merging is unheard of on Unix. +;; If the user doesn't supply a file extension, we look for .o, .l .mac 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) &aux char) + (if (or (= (setq char (substringn x 1 0)) #/&) + (= char #/$)) + (setq x (substring x 2))) + (let ((filelist (cond ((cdr $file_search)) + (t '(".")))) + (extlist (cond ((or (member (substring x -2) '(".o" ".l" ".v")) + (equal (substring x -4) ".mac")) + '(nil)) + (t (cdr $file_types))))) + (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 ((SPECS FILE-SPECS (CDR SPECS)) + (F "" (FS:MERGE-PATHNAMES F (MACSYMA-NAMESTRING-SUB (CAR SPECS))))) + ((NULL SPECS) + (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 USER-OBJECT)))) + (STRING SYSTEM-OBJECT)))) + +) + +#-LispM +(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 #-(or LISPM Multics) '(out dsk ascii block) + #+Multics '(out ascii block) + #+LISPM '(:out :ascii))) + +(DEFMFUN open-in-dsk(x) + (open x #-(or Lispm Multics) '(in dsk ascii block) + #+Multics '(in ascii block) + #+LISPM '(:in :ascii))) + +#-MAXII +(PROGN 'COMPILE + +(DECLARE (SPECIAL DSKFNP OLDST ST $NOLABELS REPHRASE ^W)) + +(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 + T) + (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)) + (TRUEFNAME NAME) + (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) ")) + (TRUEFNAME NAME) + (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) + "This is the generic 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 MACSYMA-USER-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) + (".mac" . $macsyma) (".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. + (REWIND-STREAM STREAM) + ;; 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. + (equal (send filename ':canonical-type) #+3600 ':BIN #-3600 ':QBIN)) + +(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 "//share1") + ,(concat vaxima-main-dir "//share2") + ,(concat vaxima-main-dir "//ode")))) + + #+LISPM + `((MLIST) + ,@(MAPCAR #'TO-MACSYMA-NAMESTRING + '("MC:SHARE;" "MC:SHARE1;" "MC:SHARE2;" "MC:SHAREM"))) + #+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 +(progn 'compile +(defmfun simple-file-search-list () + (let ((share-dir (fs:parse-pathname "macsyma-object:share;"))) + (setq $file_search `((mlist) ,(to-macsyma-namestring + (send share-dir ':translated-pathname)))))) + +(defmfun delete-file-search-list () + (setq $file_search ())) + +(defmfun add-user-homedir-to-file-search-list () + (setq $file_search `((mlist) ,(fs:user-homedir) ,@(cdr $file_search)))) + +(add-initialization 'simple-file-search-list + '(simple-file-search-list) + '(:cold)) + +(add-initialization 'simple-file-search-list + '(simple-file-search-list) + '(:logout)) + +(add-initialization 'delete-file-search-list + '(delete-file-search-list) + '(:before-cold)) + +(add-initialization 'add-user-homedir-to-file-search-list + '(add-user-homedir-to-file-search-list) + '(:login)) +) + +#-LISPM +(DEFMVAR $FILE_TYPES + `((MLIST) + ,@(MAPCAR #'TO-MACSYMA-NAMESTRING + #+ITS + ;; ITS filesystem. Sigh. This should be runtime conditionalization. + '("* FASL" "* TRLISP" "* LISP" "* >") + #+MULTICS + '("**" "**.lisp" "**.macsyma") + #+Franz + '("o" "l" "mac" "v"))) + "The types of files that can be loaded into a macsyma automatically") + +#+LISPM +(DEFMVAR $FILE_TYPES '((MLIST) #-3600 "QBIN" #+3600 "BIN" "LISP" "MACSYMA")) + + +(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))) + + \ No newline at end of file diff --git a/src/maxsrc/mtrace.46 b/src/maxsrc/mtrace.46 new file mode 100644 index 00000000..cbc70503 --- /dev/null +++ b/src/maxsrc/mtrace.46 @@ -0,0 +1,789 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mtrace) + +(declare (*lexpr trace-mprint) ;; forward references + (genprefix mtrace-) + (special $functions $transrun trace-allp)) + +;;; 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.] + +;; Internal notes on this package: -jkf +;; Trace works by storing away the real definition of a function and +;; replacing it by a 'shadow' function. The shadow function prints a +;; message, calls the real function, and then prints a message as it +;; leaves. The type of the shadow function may differ from the +;; function being shadowed. The chart below shows what type of shadow +;; function is needed for each type of Macsyma function. +;; +;; Macsyma function shadow type hook type mget +;; ____________________________________________________________ +;; subr expr expr +;; expr expr expr +;; lsubr expr expr +;; fsubr fexpr fexpr +;; fexpr fexpr fexpr +;; mexpr expr expr t +;; mfexpr* mfexpr* macro +;; mfexpr*s mfexpr* macro +;; +;; The 'hook type' refers to the form of the shadow function. 'expr' types +;; are really lexprs, they expect any number of evaluated arguments. +;; 'fexpr' types expect one unevaluated argument which is the list of +;; arguments. 'macro' types expect one argument, the caar of which is the +;; name of the function, and the cdr of which is a list of arguments. +;; +;; For systems which store all function properties on the property list, +;; it is easy to shadow a function. For systems with function cells, +;; the situation is a bit more difficult since the standard types of +;; functions are stored in the function cell (expr,fexpr,lexpr), whereas +;; the macsyma functions (mfexpr*,...) are stored on the property list. +;; + +;;; 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)) + +#+(or Franz LispM) +(defmacro trace-oldfun (x) `(mget ,x 'trace-oldfun)) + +;;; 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" + (let (trace-allp) + (if (null list) default + `((mlist) ,@(mapcan fun + (if (memq (car list) '($all $functions)) + (prog2 (setq trace-allp t) + (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. + (if (not trace-allp) (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) +#+Franz(setf (trace-oldfun fun) (getd fun)) +#+LispM(setf (trace-oldfun fun) (and (fboundp fun) (fsymeval fun))) + (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))) + +#+Maclisp +(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))))) + +#+Franz +(defun trace-fshadow (fun type value) + (cond ((and (get type 'uuolinks) + (status translink)) + (sstatus translink nil))) + (let ((shadow (get! type 'shadow))) + (cond ((memq shadow '(expr subr)) + (setf (trace-oldfun fun) (getd fun)) + (putd fun value)) + ((memq shadow '(fexpr fsubr)) + (setf (trace-oldfun fun) (getd fun)) + (putd fun (cons 'nlambda (cdr value)))) + (t (setplist fun + `(,shadow ,value ,@(plist fun))))))) + +#+LispM +(defun trace-fshadow (fun type value) + (let ((shadow (get! type 'shadow))) + (cond ((memq shadow '(expr subr)) + (setf (trace-oldfun fun) (and (fboundp fun) (fsymeval fun))) + (fset fun value)) + ((memq shadow '(fexpr fsubr)) + (setf (trace-oldfun fun) (fsymeval fun)) + (fset fun (cons 'nlambda (cdr value)))) + (t (setplist fun + `(,shadow ,value ,@(plist fun))))))) + +#+Maclisp +(defun trace-unfshadow (fun type) + ;; what a hack. + (remprop fun (get! type 'shadow))) + +#+Franz +(defun trace-unfshadow (fun type) + (cond ((memq type '(expr subr fexpr fsubr)) + (let ((oldf (trace-oldfun fun))) + (if (not (null oldf)) + (putd fun oldf) + (putd fun nil)))) + (t (remprop fun (get! type 'shadow)) + (putd fun nil)))) + +#+LispM +(defun trace-unfshadow (fun type) + (cond ((memq type '(expr subr fexpr fsubr)) + (let ((oldf (trace-oldfun fun))) + (if (not (null oldf)) + (fset fun oldf) + (fmakunbound fun)))) + (t (remprop fun (get! type 'shadow)) + (fmakunbound fun)))) + +;--- trace-fsymeval :: find original function +; fun : a function which is being traced. The original defintion may +; be hidden on the property list behind the shadow function. +; +(defun trace-fsymeval (fun) + (or + (let ((type-of (trace-type fun))) + (cond ((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))) + #+(or Franz LispM) + ((memq (get! type-of 'shadow) '(expr fexpr)) + (trace-oldfun fun)) + (t (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* "M" `((marrow) ,j ,(car ilist)) dlist)) + (ilist list (cdr ilist))) + ((null ilist) + (setq dlist (nconc header-message (cons "M" (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 + "M" "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 '(translated-mmacro mfexpr* mfexpr*s))) + (fcell-props (getl-fun fun '(subr lsubr expr fexpr macro fsubr)))) + (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 fcell-props mprops)) + (t + (or mprops lprops fcell-props))))) + +(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) + +#+Maclisp +(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)))))) + +#+Franz +(defun make-trace-hook (fun type handler) + (CASEQ (GET! TYPE 'HOOK-TYPE) + ((EXPR) + `(lexpr (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)))))) + +#+LispM +(defun make-trace-hook (fun type handler) + (CASEQ (GET! TYPE 'HOOK-TYPE) + ((EXPR) + `(lambda (&rest trace-args) + (,handler ',fun (copylist trace-args)))) + ((FEXPR) + `(LAMBDA ("e &rest TRACE-ARGL) + (,HANDLER ',FUN (copylist TRACE-ARGL)))) +;;;??? + ((MACRO) + `(lambda ("e &rest TRACE-FORM) + (,HANDLER (CAAR TRACE-FORM) (copyLIST TRACE-FORM)))))) + +#+Maclisp +(defmacro trace-setup-call (prop fun type) + `(args 'the-trace-apply-hack (args ,fun)) + `(setplist 'the-trace-apply-hack (list ,type ,prop))) + +#+Franz +(defmacro trace-setup-call (prop fun type) + `(putd 'the-trace-apply-hack ,prop)) + +#+Lispm +(defmacro trace-setup-call (prop fun type) + `(fset 'the-trace-apply-hack ,prop)) + +(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. + (trace-setup-call prop fun type) + (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 TIME-TO-SEC (RUNTIME) + (MUL RUNTIME #+Maclisp 1.0E-6 #+Franz 0.01666666666666667 #+LispM .01 '$SEC)) + +(DEFUN TIME-PER-CALL-TO-SEC (RUNTIME CALLS) + (DIV (TIME-TO-SEC RUNTIME) + (IF (ZEROP CALLS) 1 CALLS))) + +(DEFUN TIMER-MLIST (FUNCTION CALLS RUNTIME GCTIME) + `((MLIST SIMP) ,FUNCTION + ,(TIME-PER-CALL-TO-SEC (PLUS RUNTIME GCTIME) CALLS) + ,CALLS + ,(TIME-TO-SEC RUNTIME) + ,(TIME-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 (SYS-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 (- (SYS-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)))) + \ No newline at end of file diff --git a/src/maxsrc/mtree.2 b/src/maxsrc/mtree.2 new file mode 100644 index 00000000..56f15c2e --- /dev/null +++ b/src/maxsrc/mtree.2 @@ -0,0 +1,104 @@ +;;;;;;;;;;;;;;;;;;; -*- 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)))) + +#+XYZZY +(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) + +(DEFUN ($APPLY_NOUNS FOOBAR) (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))) + +(DEFMFUN $APPLY_NOUNS (EXP) + (LET (($SUBLIS_APPLY_LAMBDA T)) + (MTREE-SUBST EXP T NIL (GET '$APPLY_NOUNS 'FOOBAR)))) diff --git a/src/maxsrc/ndiffq.7 b/src/maxsrc/ndiffq.7 new file mode 100644 index 00000000..d9fa6ae5 --- /dev/null +++ b/src/maxsrc/ndiffq.7 @@ -0,0 +1,205 @@ +;;;;;;;;;;;;;;;;;;; -*- 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 (or ($listp f) ($listp y)) + (if higher-order + (merror "Runge_Kutta handles systems of order 1 only.") + (let* ((fl (IF ($LISTP F) (mapcar #'(lambda (f) (make-gtramp$ f 2)) (cdr f)))) + (FV (IF (NOT ($LISTP F)) (MAKE-GTRAMP F 3))) + (xa (get-array x '(flonum) 1)) + (n (array-dimension-n 1 xa))) + (if (and ($listp y) + (OR FV (= (length fl) (length (cdr y))))) + (runge-kutta-1-n fl FV 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 FV x yl + &aux + (m (array-dimension-n 1 x)) + (d (length yl))) + (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)) + (AR$GCALL2$ k1 fl x_n y_n) + (ar$*s k1 k1 h) + (ar$*s acc k1 one-half$) + (ar$+ar$ acc acc y_n) + (AR$GCALL2$-GCALL3 k2 fl FV (+$ x_n (*$ h one-half$)) acc) + (ar$*s k2 k2 h) + (ar$*s acc k2 one-half$) + (ar$+ar$ acc acc y_n) + (AR$GCALL2$-GCALL3 k3 fl FV (+$ x_n (*$ h one-half$)) acc) + (ar$*s k3 k3 h) + (ar$+ar$ acc k3 y_n) + (AR$GCALL2$-GCALL3 k4 fl FV (+$ 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))))) + +(DEFUN AR$GCALL2$-GCALL3 (K2 FL FV X ACC) + (IF FV + (GCALL3 FV K2 X ACC) + (AR$GCALL2$ K2 FL X ACC))) \ No newline at end of file diff --git a/src/maxsrc/numer.20 b/src/maxsrc/numer.20 new file mode 100644 index 00000000..9e2ddd30 --- /dev/null +++ b/src/maxsrc/numer.20 @@ -0,0 +1,278 @@ +;;;;;;;;;;;;;;;;;;; -*- 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 (FORMAT () "~S" NARGS) '$)) + #+MACLISP + (TRAMP$-S (SYMBOLCONC 'TRAMP (FORMAT () "~S" NARGS) '$-S)) + (TRAMP$-F (SYMBOLCONC 'TRAMP (FORMAT () "~S" NARGS) '$-F)) + (TRAMP$-M (SYMBOLCONC 'TRAMP (FORMAT () "~S" 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) + #+(OR LISPM Franz) + (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")))) + \ No newline at end of file diff --git a/src/maxsrc/outmis.319 b/src/maxsrc/outmis.319 new file mode 100644 index 00000000..9066e884 --- /dev/null +++ b/src/maxsrc/outmis.319 @@ -0,0 +1,1028 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1976, 1983 Massachusetts Institute of Technology ** + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; Miscellaneous Out-of-core Files ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module outmis) + +(DECLARE (FIXNUM NN)) + +#+ITS (DECLARE (SPECIAL TTY-FILE)) + +(DECLARE (SPLITFILE STATUS)) + +#+(or ITS Multics TOPS-20) +(DECLARE (SPECIAL LINEL MATHLAB-GROUP-MEMBERS) + (*EXPR STRIPDOLLAR MEVAL) + (*LEXPR CONCAT)) + + + +#+(or ITS Multics TOPS-20) +(PROGN 'COMPILE + +;;; These are used by $SEND when sending to logged in Mathlab members +#-Multics +(SETQ MATHLAB-GROUP-MEMBERS + '(JPG ELLEN JIM GJC ASB LPH RP KMP)) + +;;; IOTA is a macro for doing file I/O binding, guaranteeing that +;;; the files it loads will get closed. +;;; Usage: (IOTA (( ) +;;; ( ) ...) +;;; ) +;;; Opens with binding it to . Closes +;;; any which still has an open file or SFA in it when +;;; PDL unwinding is done. +;;; No IOTA on Multics yet, +#-Multics +(EVAL-WHEN (EVAL COMPILE) + (COND ((NOT (STATUS FEATURE IOTA)) + (LOAD #+ITS '((DSK LIBLSP) IOTA FASL) + #-ITS '((LISP) IOTA FASL))))) + +;;; TEXT-OUT +;;; Prints a list of TEXT onto STREAM. +;;; +;;; TEXT must be a list of things to be printed onto STREAM. +;;; For each element in TEXT, A, if A is a symbol with first +;;; character "&", it will be fullstripped and PRINC'd into the +;;; stream; otherwise it will be $DISP'd onto STREAM (by binding +;;; OUTFILES and just calling $DISP normally). +;;; +;;; STREAM must be an already-open file object. + +(DEFUN TEXT-OUT (TEXT STREAM) + (DO ((A TEXT (CDR A)) + (/^R T) + (/^W T) + (LINEL 69.) + (OUTFILES (NCONS STREAM))) + ((NULL A)) + (COND ((AND (SYMBOLP (CAR A)) + (EQ (GETCHAR (CAR A) 1.) '/&)) + (PRINC (STRIPDOLLAR (CAR A)) STREAM)) + (T (TERPRI STREAM) + (MEVAL `(($DISP) ($STRING ,(CAR A)))))) + (TERPRI STREAM))) + +;;; MAIL +;;; Sends mail to a recipient, TO, via the normal ITS mail protocol +;;; by writing out to DSK:.MAIL.;MAIL > and letting COMSAT pick it +;;; up and deliver it. Format for what goes in the MAIL > file should +;;; be kept up to date with what is documented in KSC;?RQFMT > +;;; +;;; TO must be a name (already STRIPDOLLAR'd) to whom the mail should +;;; be delivered. +;;; +;;; TEXT-LIST is a list of Macsyma strings and/or general expressions +;;; which will compose the message. + +#+(OR LISPM ITS) ;Do these both at once. +(DEFUN MAIL (TO TEXT-LIST) + (IOTA ((STREAM "DSK:.MAIL.;MAIL >" 'OUT)) + (mformat stream + "FROM-PROGRAM:Macsyma +AUTHOR:~A +FROM-UNAME:~A +RCPT:~A +TEXT;-1~%" + (STATUS USERID) + (STATUS UNAME) + (NCONS TO)) + (TEXT-OUT TEXT-LIST STREAM))) + +;;; This code is new and untested. Please report bugs -kmp +#+TOPS-20 +(DEFUN MAIL (TO TEXT-LIST) + (IOTA ((STREAM "MAIL:/[--NETWORK-MAIL--/]..-1" + '(OUT ASCII DSK BLOCK NODEFAULT))) + (MFORMAT STREAM + "/ ~A +~A +/ +From: ~A at ~A~%" + (STATUS SITE) TO (STATUS USERID) (STATUS SITE)) + (COND ((NOT (EQ (STATUS USERID) (STATUS UNAME))) + (MFORMAT STREAM "Sender: ~A at ~A~%" (STATUS UNAME) (STATUS SITE)))) + (MFORMAT STREAM "Date: ~A +TO: ~A~%~%" + (TIME-AND-DATE) TO) + (TEXT-OUT TEXT-LIST STREAM))) + +#+Multics +(defvar macsyma-mail-count 0 "The number of messages sent so far") +#+Multics +(progn 'compile +(DEFUN MAIL (TO TEXT-LIST) + (let* ((open-file ()) + (macsyma-unique-id (macsyma-unique-id 'unsent + (increment macsyma-mail-count))) + (file-name (catenate (pathname-util "pd") + ">macsyma_mail." macsyma-unique-id))) + (unwind-protect + (progn + (setq open-file (open file-name '(out ascii block dsk))) + (text-out text-list open-file) + (close open-file) + (cline (catenate "send_mail " to " -input_file " file-name + " -no_subject"))) + (deletef open-file)))) + +(defun macsyma-unique-id (prefix number) + (implode (append (explode prefix) (list number)))) +) + +;;; $BUG +;;; With no args, gives info on itself. With any positive number of +;;; args, mails all args to MACSYMA via the MAX-MAIL command. +;;; Returns $DONE + +(DEFMSPEC $BUG (X) (SETQ X (CDR X)) + (COND ((NULL X) + (MDESCRIBE '$BUG)) + (T + (MAX-MAIL 'BUG X))) + '$DONE) + +#+MULTICS +(DEFMACRO CHECK-AND-STRIP-ADDRESS (ADDRESS) + `(COND ((EQUAL (GETCHARN ,ADDRESS 1) #/&) + (STRIPDOLLAR ,ADDRESS)) + (T (MERROR "Mail: Address field must be a string")))) +#-MULTICS +(DEFMACRO CHECK-AND-STRIP-ADDRESS (ADDRESS) + `(STRIPDOLLAR ,ADDRESS)) + +;;; $MAIL +;;; With no args, gives info on itself. +;;; With 1 arg, sends the MAIL to Macsyma. Like bug, only doesn't +;;; tag the mail as a bug to be fixed. +;;; With 2 or more args, assumes that arg1 is a recipient and other +;;; args are the text to be MAIL'd. +;;; Works for Multics, ITS, and TOPS-20. + +(DEFMSPEC $MAIL (X) (SETQ X (CDR X)) + (COND ((NULL X) + (MDESCRIBE '$MAIL)) + ((= (LENGTH X) 1.) + (MAX-MAIL 'MAIL X)) + (T (LET ((NAME (CHECK-AND-STRIP-ADDRESS (CAR X)))) + (MAIL NAME (CDR X)) + #-Multics(MFORMAT NIL "~&;MAIL'd to ~A~%" NAME)))) +;;;On Multics Mailer will do this. + '$DONE) + +;;; MAX-MAIL +;;; Mails TEXT-LIST to MACSYMA mail. Normal ITS mail header +;;; is suppressed. Header comes out as: +;;; From via command. +;;; +;;; SOURCE is the name of the originating command (eg, BUG or +;;; MAIL) to be printed in the header of the message. +;;; +;;; TEXT-LIST is a list of expressions making up the message. + +#+(OR LISPM ITS) +(DEFUN MAX-MAIL (SOURCE TEXT-LIST) + (IOTA ((MAIL-FILE "DSK:.MAIL.;_MAXIM >" '(OUT ASCII DSK BLOCK))) + (LINEL MAIL-FILE 69.) + (MFORMAT MAIL-FILE + "FROM-PROGRAM:Macsyma +HEADER-FORCE:NULL +TO:(MACSYMA) +SENT-BY:~A +TEXT;-1 +From ~A via ~A command. ~A~%" + (STATUS UNAME) + (STATUS USERID) + SOURCE + (TIME-AND-DATE)) + (TEXT-OUT TEXT-LIST MAIL-FILE) + (RENAMEF MAIL-FILE "MAIL >")) + (MFORMAT NIL "~&;Sent to MACSYMA~%") + '$DONE) + +;;; This code is new and untested. Please report bugs -kmp +#+TOPS-20 +(DEFUN MAX-MAIL (SOURCE TEXT-LIST) + (IOTA ((MAIL-FILE "MAIL:/[--NETWORK-MAIL--/]..-1" + '(OUT ASCII DSK BLOCK NODEFAULT))) + (MFORMAT MAIL-FILE + "/ MIT-MC +BUG-MACSYMA +/ From ~A at ~A via ~A command. ~A~%" + (STATUS USERID) (STATUS SITE) SOURCE (TIME-AND-DATE)) + (TEXT-OUT TEXT-LIST MAIL-FILE) + (MFORMAT NIL "~%;Sent to MACSYMA"))) + +#+Multics +(defun max-mail (source text-list) + (let ((address (cond ((eq source 'mail) + (setq source "Multics-Macsyma-Consultant -at MIT-MC")) + (t (setq source "Multics-Macsyma-Bugs -at MIT-MC"))))) + (mail address text-list))) + +); END of (or ITS Multics TOPS-20) conditionalization. + + +;; On ITS, this returns a list of user ids for some random reason. On other +;; systems, just print who's logged in. We pray that nobody uses this list for +;; value. + +#+ITS +(PROGN 'COMPILE +(DEFMFUN $who nil + (do ((tty*) + (wholist nil (cond ((eq (getchar tty* 1) ;just consoles, not device + '/D) + wholist) + (t (LET ((UNAME (READUNAME))) + (COND ((MEMQ UNAME WHOLIST) WHOLIST) + (T (CONS UNAME WHOLIST))))))) + (ur (crunit)) + (tty-file ((lambda (tty-file) + (readline tty-file) ;blank line + tty-file) ;get rid of cruft + (open '((tty) |.file.| |(dir)|) 'single)))) + ((progn (readline tty-file) + (setq tty* (read tty-file)) + (eq tty* 'free)) + (close tty-file) + (apply 'crunit ur) + (cons '(mlist simp) wholist)))) + +;;; $SEND +;;; With no args, gives info about itself. +;;; With one arg, sends the info to any logged in Macsyma users. +;;; With 2 or more args, assumes that arg1 is a recipient and +;;; args 2 on are a list of expressions to make up the message. + +(DEFMSPEC $SEND (X) (SETQ X (CDR X)) + (COND ((NULL X) + (MDESCRIBE '$SEND)) + ((= (LENGTH X) 1.) + (MAX-SEND X)) + (T + (MSEND (STRIPDOLLAR (CAR X)) (CDR X) T))) + '$DONE) + +;;; MSEND +;;; Sends mail to a recipient, TO, by opening the CLI: device on the +;;; recipient's HACTRN. +;;; +;;; TO must be a name (already FULLSTRIP'd) to whom the mail should +;;; be delivered. A header is printed of the form: +;;; [MESSAGE FROM MACSYMA USER