github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-26 12:12:12 +00:00
Code Issues Releases Wiki Activity

Update macsyma sources with newer versions of some files.

Browse Source 
Resolves #1059.
This commit is contained in:
Eric Swenson
2018-07-13 15:28:57 -07:00
parent db5208548f
commit dc5e4505ae
16 changed files with 4911 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

227
src/maxsrc/descri.68 Normal file
View File

@@ -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)

92
src/maxsrc/inmis.106 Normal file
View File

@@ -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)

98
src/maxsrc/ldisp.44 Normal file
View File

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

391
src/maxsrc/mdot.97 Normal file
View File

@@ -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))

275
src/maxsrc/merror.56 Normal file
View File

@@ -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))))))
)

563
src/maxsrc/mload.139 Normal file
View File

@@ -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)))

789
src/maxsrc/mtrace.46 Normal file
View File

@@ -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 (&quote &rest TRACE-ARGL)
(,HANDLER ',FUN (copylist TRACE-ARGL))))
;;;???
((MACRO)
`(lambda (&quote &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))))

104
src/maxsrc/mtree.2 Normal file
View File

@@ -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))))

205
src/maxsrc/ndiffq.7 Normal file
View File

@@ -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)))

278
src/maxsrc/numer.20 Normal file
View File

@@ -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"))))

1028
src/maxsrc/outmis.319 Normal file
View File

File diff suppressed because it is too large Load Diff

144
src/maxsrc/rombrg.44 Normal file
View File

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

449
src/maxsrc/sets.12 Normal file
View File

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

118
src/maxsrc/sublis.12 Normal file
View File

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

149
src/maxsrc/sumcon.20 Normal file
View File

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