github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-30 03:13:58 +00:00
Code Issues Releases Wiki Activity

Added files to support building and running Macsyma.

Browse Source 
Resolves #284.

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

Updated the expect script statements in build_macsyma_portion to not
attempt to match expected strings, but simply sleep for some time
since in some cases the matching appears not to work.
This commit is contained in:
Eric Swenson
2018-03-08 22:06:53 -08:00
parent e88df80ca3
commit 85994ed770
231 changed files with 108800 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@@ -7,7 +7,9 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \
midas _teco_ emacs emacs1 rms klh syshst sra mrc ksc eak gren \
bawden _mail_ l lisp libdoc comlap lspsrc nilcom rwk chprog rg \
inquir acount gz sys decsys ecc alan sail kcc kcc_sy c games archy dcp \
spcwar rwg libmax rat z emaxim rz maxtul
spcwar rwg libmax rat z emaxim rz maxtul aljabr cffk das ell ellen \
jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \
tensor transl wgd zz
DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc chprog
BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon

3
README.md
View File

@@ -203,10 +203,13 @@ A list of [known ITS machines](doc/machines.md).
- LOSS (device).
- LSPEED, set tty line parameters.
- LUSER, request help from registered list of logged-in users.
- MACSYMA, symboling manipulation system.
- MAXTUL, tools for managing Macsyma.
- MAGDMP, standalone program loader/dumper for magtape.
- MAGFRM, create tapes for use with MAGDMP.
- MAIL, Mail sending client.
- MAILT, allows editing mail (from :MAIL) in EMACS.
- MCL, subsystem for compiling individual Macsyma files.
- METER, displays system metering information.
- MLDEV, MLSLV, Allows access to remote systems as devices (e.g. DB:).
- MLIFE, Bill Gosper's Conway Life.

BIN
bin/lisp/format.extend Executable file
View File

Binary file not shown.

BIN
bin/lisp/format.float Executable file
View File

Binary file not shown.

BIN
bin/lisp/format.hair Executable file
View File

Binary file not shown.

BIN
bin/lisp/format.invoke Executable file
View File

Binary file not shown.

BIN
bin/lisp/format.iter Executable file
View File

Binary file not shown.

BIN
bin/lisp/format.macros Executable file
View File

Binary file not shown.

BIN
bin/lisp/format.num Executable file
View File

Binary file not shown.

BIN
bin/lisp/format.umacs Executable file
View File

Binary file not shown.

184
build/build.tcl
View File

@@ -66,6 +66,32 @@ proc ip_address {string} {
format "%o" $x
}
proc build_macsyma_portion {} {
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load \"liblsp;iota\")"
respond "274630" "(load \"maxtul;docgen\")"
respond "300052" "(load \"maxtul;mcl\")"
respond "302615" "(load \"maxdoc;mcldat\")"
respond "302615" "(load \"libmax;module\")"
respond "303351" "(load \"libmax;maxmac\")"
respond "307161" "(todo)"
sleep 10
type "(todoi)"
sleep 10
type "(mapcan #'(lambda (x) (cond ((not (memq x\r"
type "'(SETS TRANSS MTREE TRHOOK EDLM)\r"
type ")) (doit x)))) (append todo todoi))"
expect {
";BKPT" {
type "(quit)"
}
"NIL" {
type "(quit)"
}
}
}
set timeout 100
expect_after timeout abort
@@ -861,11 +887,13 @@ respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "lisp;_libdoc;sharab\r"
respond "_" "liblsp;_libdoc;sharab\r"
respond "_" "lisp;_libdoc;bs\r"
respond "_" "\032"
type ":kill\r"
respond "*" ":link lisp;sharab fasl,liblsp;\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((lisp) subloa lsp))"
@@ -1594,6 +1622,160 @@ respond "_" "libmax;define\r"
respond "_" "\032"
type ":kill\r"
# build macsyma
respond "*" ":print macsym;..new. (udir)\r"
type ":vk\r"
respond "*" ":link macsym;mdefun fasl,libmax;\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "macsym;ermsgm_maxsrc;ermsgm\r"
respond "_" "maxdoc;tdcl\r"
respond "_" "rlb;bitmac\r"
respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "rlb;faslre\r"
respond "_" "rlb;faslro\r"
respond "_" "\032"
type ":kill\r"
respond "*" ":link rlb%;faslre fasl,rlb;\r"
respond "*" "l\013"
respond "Alloc?" "n"
respond "*" "(setq pure t)"
type "(load \"liblsp;sharab\")"
type "(load \"liblsp;comrd\")"
type "(load \"liblsp;time\")"
type "(load \"alan;ljob\")"
type "(load \"libmax;define\")"
type "(sstatus gcmax 'fixnum 30000)"
type "(sstatus gcmax 'list 60000)"
type "(load \"maxtul;strmrg\")"
type "(load \"maxtul;docgen\")"
type "(load \"maxtul;query\")"
type "(load \"maxtul;maxtul\")"
type "(load \"maxtul;dclmak\")"
type "(sstatus gcmax 'hunk32 6000)"
respond "T" "(sstatus gcmax 'symbol 12000)"
respond "T" "(sstatus gcmax 'list 60000)"
respond "T" "(sstatus gcmax 'fixnum 20000)"
respond "T" "(dump-it)"
respond "MAXIMUM TOOLAGE>" "load-info\r"
respond "MAXIMUM TOOLAGE>" "gen-mcl-check\r"
respond "MAXIMUM TOOLAGE>" "declare-file-make\r"
respond "MAXIMUM TOOLAGE>" "quit\r"
respond "*" "(quit)"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;mhayat_rat;mhayat\r"
respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;ratmac_rat;ratmac\r"
respond "_" "\032"
type ":kill\r"
# mforma needs to get recompiled (not sure exactly which
# dependency yet causes the version we've built so far
# not to work, but if recompiled at this point, we're
# able to build macsyma
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(load '((libmax) module))"
respond "274534" "(maklap)"
respond "_" "libmax;mforma\r"
respond "_" "\032"
type ":kill\r"
respond "*" "complr\013"
respond "_" "\007"
respond "*" "(setq pure t)"
respond "T" "(load \"liblsp;sharab\")"
respond "276437" "(load \"maxtul;mcldmp (init)\")"
respond "T" "\007"
respond "*" "(dump-mcl 32. t)"
respond "File name->" "\002"
respond ";BKPT" "(quit)"
respond "*" ":midas maxtul;ts mcl_mcldmp midas\r"
respond "*" ":link maxtul;.good. complr,sys;ts complr\r"
respond "*" ":link liblsp;gcdemn fasl,lisp;\r"
respond "*" "complr\013"
respond "_" "mrg;macros\r"
respond "_" "\032"
type ":kill\r"
respond "*" ":print maxout;..new. (udir)\r"
type ":vk\r"
respond "*" ":print share2;..new. (udir)\r"
type ":vk\r"
# Here we actually perform the compilation of Macsyma sources
# For some unknown reason, compilation fails in the same place
# every time (as though COMPLR gets corrupted or its state is
# inconsistent with the ability to compile the next source).
# A random error is raised and a break level entered. Simply
# quitting and restarting the process causes it to pick up
# where it left off and the previously failing source compiles
# fine. The only way I've been able to get past this is by
# exiting COMPLR and restarting it. The number of invocations,
# below, appears to get through the whole list of sources. The
# failures appear at the same places each time, so the number
# of COMPLR invocations needed to make it through all the
# compilations appears to be constant.
#
# We should investigate whether there is a better way to do this,
# but I (EJS) have not found one that works so far.
#
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
build_macsyma_portion
respond "*" ":maxtul;maxtul\r"
respond "MAXIMUM TOOLAGE>" "load-info\r"
respond "MAXIMUM TOOLAGE>" "merge-incore-system\r"
respond "MAXIMUM TOOLAGE>" "gen-tags\r"
respond "MAXIMUM TOOLAGE>" "quit\r"
respond "*" "(quit)"
respond "*" "aljabr\033\023"
respond "*" ":lisp\r"
type "(load \"libmax;module\")"
respond "132170" "(load \"libmax;define\")"
respond "134541" "(load \"libmax;maxmac\")"
respond "140351" "(load \"libmax;displm\")"
respond "141162" "(load \"aljabr;loader\")"
respond "T" "(loader 999)"
respond "(C1)" "quit();"
respond "*" ":link sys3;ts macsym,maxdmp;loser >\r"
bootable_tapes
# make output.tape

2
src/aljabr/*.lisp Normal file
View File

@@ -0,0 +1,2 @@
; Used for the creation of MACSYMA
(COMMENT CORE 130. REGPDL 2750. FLPDL 400. FXPDL 1500. SPECPDL 1750.)

206
src/aljabr/complr.163 Normal file
View File

@@ -0,0 +1,206 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1981 Massachusetts Institute of Technology **
; Do a COMPLR^K and type ^G to quit. Then load in this file.
; To compile files for a new MACSYMA, all you need do is type
; "(MSCOMP)" and hope for no bugs. (Set FASLP to NIL first if
; you don't want FASL files created; Set REDOALL to T if you want
; all files recompiled.)
; Use "MAKLAP1" instead of "MAKLAP" to compile (and assemble, unless
; FASLP is set to NIL) a single file.
; Sample calls are:
; (MAKLAP1 (RISCH > DSK JM))
; to put the output on the MACSYM; (or MAXOUT;) directory.
; The two-arg. format e.g.
; (MAKLAP1 (OUT FASL DSK WHO) (IN FILE DSK USER))
; is also acceptable.
; (You may reset UNFASLCOMMENTSP (default T), NOLAPP (default T),
; TTYNOTESP (default T), YESWARNTTYP (default T),
; MUZZLEDP (default NIL), and MAPEXP (default NIL).)
;;; Let files that need to know (e.g. MAXSRC;TRANS1 >) that we
;;; are compiling to INSTALL a new source.
(DEFUN SSTATUS-FEATURE-MACSYMA-COMPLR ()
(EVAL
(READLIST
'( /( S S T A T U S / F E A T U R E / M A C S Y M A - C O M P L R /) ))))
(SSTATUS-FEATURE-MACSYMA-COMPLR)
(SETQ OUT1 NIL UNDFUNL* NIL FASLP T REDOALL NIL TTYNOTESP T YESWARNTTYP T
UNFASLCOMMENTSP T NOLAPP T MUZZLEDP NIL MMSDIR 'MUNFAS MAPEXP NIL
FILEONE NIL)
(DEFPROP MACSYMA-MODULE MACSYMA-MODULE-MACRO MACRO)
(DEFPROP MACSYMA-MODULE-MACRO "DSK:LIBMAX;MODULE" AUTOLOAD)
; Format of files is: FILENAME1 > DSK Source
(PROG2
(SETQ FILES1 ; FASL file to MAXDMP; , UNFASL file to MUNFAS;
'((DISPLA > DSK MRG) (NFORMA > DSK MRG) (GRAM > DSK MRG)
(COMPAR > DSK MRG) (TRIGI > DSK MRG) (DB > DSK MRG)
(GRIND > DSK MRG) (MLISP > DSK JPG)
(MEDIT > DSK JPG) (SUPRV > DSK JPG) (COMM > DSK JPG)
(DSKFN > DSK JPG) (CSIMP > DSK PAULW) (MAT > DSK PAULW)
(MATRIX > DSK PAULW) (LESFAC > DSK RAT) (FACTOR > DSK RAT)
(RAT3A > DSK RAT) (RAT3B > DSK RAT) (RAT3C > DSK RAT)
(RAT3D > DSK RAT) (RAT3E > DSK RAT) (NRAT4 > DSK RAT)
(OPERS > DSK MAXSRC) (UTILS > DSK MAXSRC)
(MUTILS > DSK MAXSRC) (MLOAD > DSK MAXSRC)
(SIMP > DSK JM) (RUNTIM > DSK MAXSRC) (INMIS > DSK MAXSRC)
(ASUM > DSK RZ) (SPGCD > DSK RAT) (ERMSGM > DSK MAXSRC)
(MERROR > DSK MAXSRC) (MFORMT > DSK MAXSRC)))
'FILES1)
; The following files are not part of the core system
(PROG2
(SETQ FILES2 ; FASL file to MACSYM; , UNFASL file to MUNFAS;
'(;(TRANSL > DSK TRANSL) (TRANS1 > DSK TRANSL)
; GJC's files no longer automatically compiled at the request of GJC. - JPG
; (TRMODE > DSK TRANSL) (TRANS4 > DSK TRANSL)
; (TRANS3 > DSK TRANSL)
; (TRDATA > DSK TRANSL) (FCALL > DSK TRANSL)
; (TRANS2 > DSK TRANSL) (ACALL > DSK TRANSL)
; (EVALW > DSK TRANSL) (UPDATE > DSK TRANSL)
(FORTRA > DSK MRG) (OPTION > DSK ELLEN) (PRIMER > DSK ELLEN)
(LDISP > DSK MAXSRC)
(SCS > DSK MRG) (OPTIM > DSK MRG) (SININT > DSK JM)
(SIN > DSK JM) (RISCH > DSK JM) (ZERO > DSK JM)
(MATCOM > DSK RAT) (MATRUN > DSK RAT)
(POIS2 > DSK RAT) (POIS3 > DSK RAT)
(RATPOI > DSK RAT) (FLOAT > DSK RAT) (SOLVE > DSK RAT)
(MDOT > DSK MAXSRC)
(ARDS > DSK MAXSRC) (H19 > DSK MAXSRC) (VT100 > DSK MAXSRC)
(TLIMIT > DSK JIM) (LIMIT > DSK JIM)
(ASKP > DSK JIM) (DEFINT > DSK PAULW) (RESIDU > DSK PAULW)
(SPRDET > DSK PAULW) (ALGFAC > DSK PAULW) (IRINTE > DSK MAXSRC)
(NEWINV > DSK PAULW) (LINNEW > DSK PAULW) (EZGCD > DSK RAT)
(EEZ > DSK PAULW) (NEWFAC > DSK PAULW) (HOMOG > DSK RAT)
(UFACT > DSK RAT) (RPART > DSK MACRAK) (LOGARC > DSK MACRAK)
(SERIES > DSK RZ) (NUMTH > DSK RZ) (HAYAT > DSK RAT)
(SCHATC > DSK RZ) (TRGRED > DSK RZ) (NEWDET > DSK RAT)
(POLYRZ > DSK RAT) (ALGSYS > DSK RAT) (NISIMP > DSK RAT)
(NALGFA > DSK RAT) (LAPLAC > DSK MAXSRC) (CPOLY > DSK CFFK)
(PADE > DSK RAT) (SUMCON > DSK MAXSRC) (SYNEX > DSK MAXSRC)
(SUBLIS > DSK MAXSRC) (MMACRO > DSK REH) (BUILDQ > DSK REH)
(RESET > DSK ALJABR)))
'FILES2)
; The following are out-of-core "SPLITFILES"
(PROG2
(SETQ FILES3 ; FASL file and UNFASL file to MAXOUT;
'((COMM2 > DSK JPG) (CSIMP2 > DSK PAULW) (PLOT > DSK JPG)
(PSOLVE > DSK RAT) (OUTMIS > DSK MAXSRC) (COMBIN > DSK RZ)
(TRIGO > DSK MRG) (RATOUT > DSK RAT) (RESULT > DSK RAT)
(MSTUFF > DSK DAS) (SPECFN > DSK WGD) (DESCRI > DSK MAXSRC)))
'FILES3
;; Note that MSCOMP and MAKLAP1 get interned here while OBARRAY is
;; bound to SOBARRAY. This seems to be why they can be typed from
;; the compiler Lisp level.
((LAMBDA (OBARRAY NM)
(SET (SETQ NM (INTERN NM)) (APPEND '(MSCOMP MAKLAP1) (SYMEVAL NM))))
SOBARRAY 'SAIL-MORE-SYSFUNS))
(DEFUN MSCOMP NIL
((LAMBDA (MUZZLEDP)
(MSCOMP1 FILES1 T NIL) (MSCOMP1 FILES2 NIL NIL) (MSCOMP1 FILES3 NIL T)) T))
(DEFUN MSCOMP1 (FILES COREP SPLITP)
((LAMBDA (DEFAULTF ODEFAULTF)
(PROG (FILE UNFILE IN OUT EXP EXP1 MACSYMP)
A (COND ((NULL FILES) (RETURN '|All finished|)))
(APPLY 'UREAD (SETQ FILE (CAR FILES)))
(SETQ IN (STATUS UREAD))
(SETQ OUT (COND ((AND OUT1 (NOT FASLP)) OUT1)
(OUT1 (CONS (CAR OUT1) (CONS 'LAP (CDDR OUT1))))
(SPLITP (CONS (CAR FILE) '(LAP DSK MAXOUT)))
(COREP (CONS (CAR FILE) '(LAP DSK MAXDMP)))
((EQ (CAR (LAST IN)) 'LIBMAX)
(CONS (CAR FILE) '(LAP DSK LIBMAX)))
(T (CONS (CAR FILE) '(LAP DSK MACSYM)))))
(SETQ MACSYMP (MEMQ (CADDDR OUT) '(MACSYM MAXDMP)))
(COND ((OR REDOALL
(AND (NULL (PROBEF (SETQ UNFILE
(CONS (CAR OUT)
(CONS 'UNFASL (CDDR OUT))))))
(OR (NOT MACSYMP)
(NULL (PROBEF (SETQ UNFILE
(CONS (CAR OUT)
'(UNFASL DSK MUNFAS))))))))
(GO B)))
(APPLY 'UREAD UNFILE)
(SETQ ^Q T)
(SETQ EXP (CADR (READ)) EXP1 (PROG2 (READ) (CADR (READ))))
(COND ((EQ (CAR EXP1) 'THIS) (SETQ EXP EXP1)))
(SETQ EXP (CAR (LAST EXP)))
(SETQ ^Q NIL)
(COND ((EQ (CADR IN) (COND ((ATOM (CAR EXP)) (CADR EXP)) (T (CADDR EXP))))
(PRINT (CONS IN '(WAS ALREADY COMPILED AND ASSEMBLED)))
(GO C)))
B ;(INITIALIZE)
;; This is needed to make calls to FORMAT work at compile time.
;; They are necessary because the obarrays are reset.
(SSTATUS UUOLINKS)
; (REMPROP 'FORMAT 'LSUBR)
; (REMPROP 'FORMAT 'VERSION)
; (LOAD "LIBLSP;LOOP")
;; Figure out some better way of initializing the (STATUS FEATURES)
;; list to its initial state. (INITIALIZE) should actually be doing
;; this. This simply flushes all entries beginning with LIBMAX from
;; the list. Note that (SSTATUS NOFEATURE LIBMAX-MACROS) explicitly
;; doesn't work because of obarray problems.
(SSTATUS-FEATURE-MACSYMA-COMPLR)
(DO ((L (STATUS FEATURES) (CDR L))
(FEATURE) (X))
((NULL L))
(SETQ FEATURE (CAR L))
(SETQ X (EXPLODEN FEATURE))
(COND ((> (LENGTH X) 5) (RPLACD (CDR (CDDDDR X)) NIL)))
(SETQ X (MAKNAM X))
(COND ((SAMEPNAMEP X 'LIBMAX)
(APPLY 'SSTATUS (LIST 'NOFEATURE FEATURE))))
(COND ((SAMEPNAMEP X 'IOTA)
(APPLY 'SSTATUS (LIST 'NOFEATURE FEATURE)))))
(SETQ DEFAULTF ODEFAULTF)
(SETQ MAPEX NIL BARFP T DATAERRP T LISPERRP T TTYNOTES T
YESWARNTTY T MUZZLED T ARRAYOPEN T IBASE 10. BASE 10.
*NOPOINT NIL USE-STRT7 T DEFMACRO-FOR-COMPILING NIL
MESSAGES-INITIALIZED NIL
DEFMACRO-DISPLACE-CALL NIL)
(COND (FASLP (SETQ FASL T UNFASLCOMMENTS T NOLAP T
OUT (OR OUT1 (CONS (CAR OUT) (CONS 'FASL (CDDR OUT)))))
(COND (MACSYMP (SETQ MSDIR MMSDIR)))))
(COND ((NULL TTYNOTESP) (SETQ TTYNOTES NIL)))
(COND ((NULL YESWARNTTYP) (SETQ YESWARNTTY NIL)))
(COND ((NULL UNFASLCOMMENTSP) (SETQ UNFASLCOMMENTS NIL)))
(COND ((NULL NOLAPP) (SETQ NOLAP NIL)))
(COND ((NULL MUZZLEDP) (SETQ MUZZLED NIL)))
(COND (MAPEXP (SETQ MAPEX T)))
(PRINT (CONS IN '(COMPILATION BEGUN)))
(COND (FILEONE (BREAK FILE-ONE-DONE T)))
(APPLY 'MAKLAP (LIST OUT IN))
(PRINT (CONS IN '(COMPILATION ENDED)))
(SETQ FILEONE T)
C (SETQ FILES (CDR FILES))
(GO A)))
DEFAULTF DEFAULTF))
(DEFUN MAKLAP1 FEXPR (L)
(PROG (OUT1)
(COND ((CDR L) (COND ((CDDR L) (PRINC '/
MAKLAP1/ TAKES/ ONLY/ 1/ OR/ 2/ ARGS/.) (ERR)))
(APPLY 'CRUNIT (CDDAR L))
(SETQ OUT1 (CAR L) L (CDR L)) (ARGCHK OUT1))
(T (ARGCHK (CAR L))))
(RETURN (MSCOMP1 L (ASSQ (CAAR L) FILES1) (ASSQ (CAAR L) FILES3)))))
(DEFUN MCOMPILE FEXPR (L)
(LET ((TTYNOTESP NIL) (MUZZLEDP T)) (APPLY 'MAKLAP1 L)))
(DEFUN ARGCHK (L)
(COND ((NOT (= (LENGTH L) 4)) (PRINT L) (PRINC '/
ARG/ TO/ MAKLAP1/ MUST/ BE/ OF/ LENGTH/ 4) (ERR))))

348
src/aljabr/loader.262 Normal file
View File

@@ -0,0 +1,348 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1982 Massachusetts Institute of Technology **
; Do "ALJABR^S L^K"; the  (escape) is for loading in LISP symbols.
; "ALJABR;* LISP" which allocates pdls is automatically loaded in.
; Current contents of that file are:
(COMMENT CORE 130. REGPDL 2750. FLPDL 400. FXPDL 1500. SPECPDL 1750.)
; Load in "ALJABR;LOADER >".
; Now, all you need do is type "(LOADER version#)" (where version# is an
; integer) and hope for no bugs. When you are through, you must kill
; the job yourself. (LISP;LOCK > may need to be updated as to LISP
; version used.)
; The End
; All FASL files loaded here were created from compiled LISP files using
; ALJABR; COMPLR > , except for RATLAP whose source is RAT;RATLAP > .
;; The code in this file is run only once when a new Macsyma is created.
;; For this reason, it is interpreted and not compiled so that the code
;; can be gc'ed when no longer needed.
(PROG2
(SETQ FILES '(ERMSGM ;ERMSGM *MUST* be the first file loaded, since
;out-of-core-strings generate SQUIDs that refer to it.
MERROR MFORMT MUTILS UTILS
GRAM DISPLA NFORMA MLISP COMM SUPRV MLOAD SIMP OPERS RATLAP
FACTOR RAT3A RAT3B RAT3D RAT3E RAT3C LESFAC SPGCD
INMIS DB COMPAR NRAT4 MATRIX MAT CSIMP
TRIGI ASUM RUNTIM MEDIT DSKFN GRIND))
'FILES)
(SETQ BASE 10. IBASE 10. *NOPOINT T)
(SETQ MUNFAS T) ; Set to NIL if you don't want the UNFASL read.
(SETQ MAXDMP T) ; Set to NIL if you don't want "Being Loaded" to print.
(DEFUN STRING-FILE-NAME (FILE)
(COND ((AND INCORE-FILES (NOT (ASSOC FILE INCORE-FILES)))
(PRINC '|
;Out-of-core string file /"|)
(PRINC (NAMESTRING FILE))
(COND ((PROBEF FILE)
(PRINC '|/"
;has not been merged into /"|)
(PRINC (NAMESTRING INCORE-MESSAGE-FILE))
(PRINC '|/"
|)) (T (PRINC '|/" is ** MISSING **
|) (BREAK |MISSING STRING FILE|)))))
())
(DEFUN LOADER (VERSION)
(SETQ $VERSION VERSION SAVENOHACK (READLIST (NCONC (EXPLODEN $VERSION) '(/0))))
(NOUUO T)
(SETQ *PURE T)
(ALLOC '(LIST (4096. 30000. .1) FIXNUM (512. 9000. .1)
FLONUM (64. 3000. .1) BIGNUM (64. 3000. .1)
SYMBOL (4096. 7200. .05) ARRAY (64. 400. 50.)))
(SETQ PUTPROP '(SUBR FSUBR LSUBR ALPHABET NUMBER GRAD DISSYM OP OPR
RECIP $INVERSE ALIAS REVERSEALIAS NOUN VERB MFEXPR*
NUD LED LBP RBP EVFLAG OPALIAS OP2C DIMENSION AUTOLOAD
OPERATORS EVFUN GRIND LDP RDP MSIMPIND ASSIGN EVOK
$OUTATIVE STRSYM SPECSIMP SYSCONST BINARY MFEXPR*S))
;; set up information for shared out-of-core message file
((LAMBDA (FILE POS)
(SETQ POS (IN FILE))
(OPEN FILE '(IN ASCII))
(FILEPOS FILE (* POS 5))
(SETQ INCORE-FILES (CDR (ASSQ 'FILES (CDR (READ FILE))))))
(SETQ INCORE-MESSAGE-FILE
(OPEN '((DSK MAXDMP) INCORE >) '(IN FIXNUM)))
() )
(SETQ INCORE-MESSAGE-FILE (TRUENAME INCORE-MESSAGE-FILE))
(UWRITE DSK MAXDMP) (SETQ ^R T)
(PRINT '|LISPV: |)
(PRIN1 (STATUS LISPV))
(PRINT '|Message file: |)
(PRIN1 (NAMESTRING INCORE-MESSAGE-FILE)) (TERPRI)
(PROG NIL A (COND ((NULL FILES) (RETURN NIL))
(T (READLOOP (CAR FILES)) (SETQ FILES (CDR FILES)) (GO A))))
(FASLOAD SORT FASL DSK LISP)
;; Load initializations generated by MDEFVAR.
(LOAD '|MAXDOC;INIT RESET|)
(LOAD '|MAXDOC;INIT NORESE|)
(TOPL) (NOUUO NIL) (NORET NIL)
(SETQ IBASE 10. *NOPOINT T)
((LAMBDA (MSGFILES ^D) (GC)) (CONS UWRITE MSGFILES) T)
(PURIFY 0 0 'BPORG)
(SETQ PURE NIL FASLOAD NIL *PURE NIL)
(ALLOC '(LIST (16000. 30000. .3) FIXNUM (5000. 9000. .3)
FLONUM (1600. 3000. .3) BIGNUM (1600. 3000. .3)
SYMBOL (6200. 7200. .1) ARRAY (150. 400. 50.)))
(setq INCORE-FILES ())
(MAPC 'MAKUNBOUND '(INCORE-MESSAGE-FILE
MAXDMP MUNFAS))
(REMPROP 'STRING-FILE-NAME 'EXPR) ;Leaves NO-OP SUBR definition
(PRINT 'STATUS/ MEMFREE/:/ ) (PRINC (STATUS MEMFREE)) (TERPRI)
(AND (GETL 'PURE-SUSPEND '(SUBR LSUBR EXPR))
(PRINT 'PURE-SUSPEND))
(UFILE MSLOCS > DSK MAXDMP)
(SSTATUS WHO1 42. '% 118. 0)
(SSTATUS GCWHO 3)
(*RSET NIL)
(NOINTERRUPT 'TTY)
(SSTATUS FLUSH T)
(GC)
(COND ((GETL 'PURE-SUSPEND '(SUBR LSUBR EXPR))
(PURE-SUSPEND () '|DSK:MAXDMP;LOSER >|))
(T
(SUSPEND () '|DSK:MAXDMP;LOSER >|))))
(DEFUN READLOOP (FILE)
(PROG (B ^W ^Q)
(SETQ B 'LAP)
FILE (COND ((PROBEF (CONS FILE '(FASL DSK MAXDMP)))
(AND MAXDMP
(PRINT (CONS FILE '(FASL DSK MAXDMP LOADING BEGUN))))
(COND ((NULL (ERRSET (EVAL (LIST 'FASLOAD FILE 'FASL 'DSK 'MAXDMP))))
(BREAK |error in FASL file| T)
((LAMBDA (^Q ^R ^W) (PRINC '|/
Where do we go from here?/
|) (EVAL (READ)))
NIL NIL NIL)))
(AND MAXDMP
(PRINT (CONS FILE '(FASL DSK MAXDMP LOADED))))
(COND ((AND MUNFAS
(ERRSET (EVAL (LIST 'UREAD FILE 'UNFASL 'DSK 'MUNFAS))))
(AND MAXDMP
(PRINT (CONS FILE '(UNFASL DSK MUNFAS LOADING BEGUN))))
(SETQ ^W T B 'UNFASL) (GO C))
(T (RETURN NIL))))
((NULL (ERRSET (EVAL (LIST 'UREAD FILE B 'DSK 'MAXDMP)) NIL))
(PROG (^W) (PRINT (CONS FILE '(FASL NOT FOUND)))
(PRINT (LIST 'PLEASE 'COMPILE FILE '>))
(PRINT '(THEN TYPE $P<SPACE> TO CONTINUE)))
(BREAK WAITING T) (GO FILE))
(T (AND MAXDMP
(PRINT (LIST FILE B 'DSK 'MAXDMP 'LOADING 'BEGUN)))))
C (SETQ ^Q T)
CONT (COND ((NULL (ERRSET
(PROG (EXPR *EOF X Y)
(SETQ *EOF (LIST NIL))
LOOP (COND ((EQ *EOF (SETQ EXPR (READ *EOF))) (RETURN NIL))
((EQ B 'UNFASL)
(COND ((AND (EQ (CAR EXPR) 'COMMENT)
(EQ (CADR EXPR) '**FASL**)
(NUMBERP (CADDR EXPR))
(NOT (ATOM (CADDDR EXPR)))
(SETQ X (GETL (SETQ Y (CADR (CADDDR EXPR)))
'(SUBR FSUBR LSUBR))))
(SETQ EXPR
(NCONS (LIST Y (CAR X)
(MAKNUM (CADR X))))))
((AND (EQ (CAR EXPR) 'QUOTE)
(NOT (ATOM (CADR EXPR)))
(MEMQ (CAADR EXPR)
'(THIS COMPILED ASSEMBLED)))
(SETQ EXPR (CADR EXPR)))
(T (GO LOOP))))
(T (SETQ EXPR (EVAL EXPR))))
((LAMBDA (BASE) (PRINT EXPR)) 8.)
(GO LOOP))))
(BREAK |error in file| T)
((LAMBDA (^Q ^R ^W) (PRINC '|/
Where do we go from here?/
|) (EVAL (READ)))
NIL NIL NIL))
(T (SETQ ^W NIL)
(RETURN (AND MAXDMP
(PRINT (LIST FILE B 'DSK
(COND ((EQ B 'UNFASL) 'MUNFAS) (T 'MAXDMP))
'LOADED))))))))
(DEFUN TOPL NIL
(GCTWA)
(SSTATUS
TOPLE
'(PROGN
(TOPL-FUN)
(SSTATUS TOPLE NIL) (REMPROP 'TOPL-FUN 'EXPR)
(GCTWA) (NOINTERRUPT NIL)
(COND ((EQ (GETCHAR (STATUS JNAME) 1) 'T) (MEVAL '(($PRIMER)))))
(CONTINUE)))
(MAKUNBOUND 'FILES)
(REMPROP 'READLOOP 'EXPR) (REMPROP 'LOADER 'EXPR)
(REMPROP 'LAPTEMPS 'FEXPR) (REMPROP 'LAPCHECK 'EXPR)
(REMPROP 'TOPL 'EXPR))
(DEFUN JOB-EXISTS (JNAME) (PROBEF (LIST '(USR *) (STATUS UNAME) JNAME)))
(DEFUN TOPL-FUN NIL
(PROG (USER USRNAM X JCL I DEFAULTF*)
(SSTATUS TOPLE '(PROG2 (PRINC '|
THIS MACSYMA IS NO GOOD!|) (VALRET '|:KILL
|))) (SETQ USER (LIST 'DSK (STATUS UDIR)) USRNAM (STATUS USERID))
(SSTATUS FEATURE MACSYMA)
(MTERPRI)
(PRINC '|This is MACSYMA |)
(PRINC $VERSION) (MTERPRI)
(COND ((AND (= (GETCHARN USRNAM 1) 95.) (= (GETCHARN USRNAM 2) 95.)
(= (GETCHARN USRNAM 3) 95.)) ; test for underscore
(PRINC 'PLEASE/ LOG/ IN/!) ($QUIT)))
;; octal: 232020222022 232222220233
(SSTATUS TTY 20673799186. 20707877019.)
(SYSCALL 0 'TTYSET TYO
(CAR (STATUS TTY)) (CADR (STATUS TTY))
(BOOLE 7 1_34. (CADDR (STATUS TTY)))) ; fixes ^L lossage
; bit 4.8 (%TSCLE) of TTYSTS
(SETQ $PAGEPAUSE (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_25.)))
; bit 3.8 (%TSMOR) of TTYSTS
;; (LINEL T) is (1- (CDR (STATUS TTYSIZE)))
(SETQ $LINEL (SETQ LINEL (LINEL T)))
(SETQ SCROLLP (NOT (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_30.))))
;; Load the fix file, if one exists.
;; If :MACSYMA is being run, load MACSYM;FIXnnn > where nnn
;; is the version number. If :NMACSYMA is being run, load NFXnnn >.
(SETQ X (CONS (MAKNAM (APPEND (COND ((EQ (GETCHAR (STATUS JNAME) 1) 'N)
'(N F X))
(T '(F I X)))
(EXPLODEN $VERSION)))
'(> DSK MACSYM)))
(COND ((PROBEF X)
(COND ((NULL (ERRSET (LOADFILE X NIL T)))
(TERPRI) (PRINC '|Bad FIX file!|) (ERR)))))
;; If :DMACSYMA (Debug Macsyma) is being run, then also load the
;; compile time environment. (LIBMAX;PRELUD >)
;; This should be made to turn on $DEBUGMODE as well.
(COND ((AND (EQ (GETCHAR (STATUS JNAME) 1) 'D)
(NULL (ERRSET (LOAD '|LIBMAX;PRELUD >|))))
(TERPRI) (PRINC '|Bad prelude file!|)))
(COND ((NULL (SETQ X (STATUS JCL))))
((NULL (CDR X)) (SETQ JCL 'NO))
((MEMQ '/; X)
(SETQ X (NREVERSE (CDR (MEMQ '/; (REVERSE X)))))
(COND ((NULL (SETQ JCL (ERRSET (READLIST X) NIL)))
(SETQ JCL (NCONS (IMPLODE X))))))
((PROG2 (SETQ JCL (COND ((NULL (SETQ JCL (ERRSET (READLIST X) NIL)))
(IMPLODE X))
(T (CAR JCL))))
(EQ JCL 'NEWUSER)) ; sets up super-image mode
(SYSCALL 0 'TTYSET TYO
(CAR (STATUS TTY)) (CADR (STATUS TTY))
(BOOLE 7 1_19. (CADDR (STATUS TTY))))
;; bit 3.2 (%TSSII) of TTYSTS
(SSTATUS TTYINT 26. NIL)
(REMPROP '$QUIT 'SUBR) (SETQ JCL NIL))
(T (SETQ JCL (CONS JCL T))))
(SETQ TTYHEIGHT (CAR (STATUS TTYSIZE))
$PLOTHEIGHT (COND ((< TTYHEIGHT 200.) (- TTYHEIGHT 2)) (T 24.))
$DIREC (CADR USER) $FILENAME (EXPLODEN USRNAM) I 1)
(COND ((> (LENGTH $FILENAME) 3) (RPLACD (CDDR $FILENAME) NIL)))
LOOP (SETQ X (IMPLODE (APPEND $FILENAME (EXPLODEN I))))
(COND ((PROBEF (LIST X '> 'DNRF $DIREC)) (SETQ I (1+ I)) (GO LOOP)))
(SETQ $FILENAME (MAKEALIAS X) $DIREC (MAKEALIAS $DIREC))
(SSTATUS GCTIME 0)
(SETQ STIME0 (TIME) ERRLIST '((ERRLFUN NIL)))
(SETQ SAVEFILE (OPEN '((NUL)) '(OUT FIXNUM)))
(CLOSE SAVEFILE)
(PROG (TTYOPT)
(SETQ TTYOPT (CAR (CDDDDR (SYSCALL 6 'CNSGET TYO))))
;; %TOFCI (bit 3.4) = terminal has a 12 bit keyboard.
(SETQ 12-BIT-TTY (NOT (= (BOOLE 1 8_18. TTYOPT) 0)))
;; %TOMVU (bit 3.9) = terminal can do vertical cursor movement.
;; However, we must also make sure that the screen size
;; is within the ITS addressing limits.
(SETQ SMART-TTY (AND (NOT (= (BOOLE 1 256._18. TTYOPT) 0))
(< TTYHEIGHT 200.)
(< LINEL 128.)))
;; %TOERS (bit 4.6) = terminal can selectively erase.
;; %TOMVB (bit 4.4) = terminal can backspace.
;; %TOOVR (bit 4.1) = terminal can overstrike (i.e. printing one
;; character on top of another causes both to
;; appear.)
;; If it can either selectively erase, or backspace and not
;; overstrike, then we can do rubout processing. An example of
;; a terminal which can backspace and overstrike, but is not
;; selectively erasable is a storage tube display.
(SETQ RUBOUT-TTY
(OR (NOT (= (BOOLE 1 32._27. TTYOPT) 0)) ;%TOERS
(AND (NOT (= (BOOLE 1 8._27. TTYOPT) 0)) ;%TOMVB
(= (BOOLE 1 1_27. TTYOPT) 0)))) ;%TOOVR
;; %TOCID (bit 3.1) = terminal can insert and delete characters.
;; If the console has a 12-bit keyboard, an 85 by 50 screen, and
;; can't ins/del characters, then it must be a Plasma console.
(SETQ PLASMA-TTY
(AND 12-BIT-TTY (= LINEL 84.) (= TTYHEIGHT 50.)
(= 0 (BOOLE 1 1_18. TTYOPT))))
)
;; ***** Vestigial. To be flushed someday. *****
(SETQ CURSORPOS SMART-TTY)
(SETQ $ERROR_SIZE (COND (SMART-TTY 20.) (T 10.)))
;; Use block mode I/O for efficiency. .SIOT used instead of .IOT.
;; See DISPLA for how this is used.
(COND (SMART-TTY
(SETQ DISPLAY-FILE (OPEN '|TTY:| '(TTY OUT IMAGE BLOCK)))))
;; Sail characters to be supported someday.
;; (COND (12-BIT-TTY
;; (SETQ 12-BIT-INPUT (OPEN '|TTY:| '(TTY IN FIXNUM)))))
;; Load graphic support package for the particular terminal type.
;; Vectors are drawn if possible. Otherwise, an extended character
;; set is used. No TCTYP entry exists for the VT100, so look for
;; a CRTSTY instead.
(COND (PLASMA-TTY (LOAD '((MACSYM) ARDS)))
((OR (= TTY 13.) (JOB-EXISTS 'H19) (JOB-EXISTS 'H19WHO))
(LOAD '((MACSYM) H19)))
((JOB-EXISTS 'VT100)
(LOAD '((MACSYM) VT100))))
(REMPROP 'JOB-EXISTS 'EXPR)
;; Why is this necessary? Lisp sets it up to be '(T) by default.
(SETQ MSGFILES (LIST TYO))
(SETQ TTY-RETURN 'TTYRETFUN)
(SETQ DEFAULTF (OR DEFAULTF* (CONS USER '(NOFILE >))))
(COND ((EQ JCL 'NO))
((AND JCL (NULL (CDR JCL)))
(COND ((OR (PROBEF (SETQ X (LIST (CAR JCL) 'MACSYM 'DSK (CAR JCL))))
(PROBEF (SETQ X (CONS '|.ALL.| (CDR X)))))
(ERRSET (LOAD-FILE X)))))
(JCL
(COND ((OR (PROBEF (SETQ X (LIST (CAR JCL) 'MACSYM 'DSK
(STATUS HSNAME (CAR JCL)))))
(PROBEF (SETQ X (CONS '|.ALL.| (CDR X)))))
(ERRSET (LOAD-FILE X)))))
((OR (PROBEF (SETQ X (LIST (STATUS XUNAME) 'MACSYM 'DSK (STATUS HSNAME))))
(PROBEF (SETQ X (CONS '|.ALL.| (CDR X)))))
(ERRSET (LOAD-FILE X))))
(SETQ DEFAULTF (OR DEFAULTF* (CONS USER '(NOFILE >))))
(COND ((GETL 'FIXUP '(SUBR EXPR)) (FIXUP) (REMPROP 'FIXUP 'EXPR)))))
(DEFUN LAPTEMPS FEXPR (L)
((LAMBDA (I) (LAPCHECK (LENGTH L))
(DO Z L (CDR Z) (NULL Z) (DEFSYM (CAR Z) I) (SETQ I (1+ I))))
VORG))
(DEFUN LAPCHECK (N)
(COND ((SIGNP LE (SETQ VLNTH (- VLNTH N)))
(TERPRI) (PRINC 'IMPURE/ AREA/ IS/ TOO/ SMALL) (ERR)))
(SETQ VORG (+ VORG N)))
(PROGN (NORET T) ; GC shouldn't return core.
; (SSTATUS LOSEF 10.) ; LAP Object Storage Efficiency Factor
(SETQ VORG BPORG)
(GETSP 8.)
(SETQ BPORG (+ BPORG 8.) VLNTH (- BPORG VORG))
(DEFPROP MACSYMA-MODULE MACSYMA-MODULE-MACRO MACRO)
(DEFPROP MACSYMA-MODULE-MACRO "DSK:LIBMAX;MODULE" AUTOLOAD))

16
src/aljabr/reset.34 Normal file
View File

@@ -0,0 +1,16 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1983 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module reset)
;;;RESETs flags to their initial values.
;See ALJABR;GENRST > for instructions for constructing this file.
(SETQ IBASE 10. BASE 10. *RSET NIL NOUUO NIL MODULUS NIL ZUNDERFLOW T)
(SETQ $BERLEFACT T $RATSIMPEXPONS NIL $PARSEWINDOW 10. $LISPDISP NIL $NEGDISTRIB T $EXPONENTIALIZE NIL $CAUCHYSUM NIL $HOMOG_HACK NIL $RATPRINT T $INTANALYSIS T $PROGRAMMODE T $TRIGEXPANDTIMES T $INTFACLIM 1000. $NEGSUMDISPFLAG T $PREDERROR T $PSEXPAND NIL $SUMHACK NIL $PACKAGEFILE NIL $VECT_CROSS NIL $DOMAIN '$REAL $LASTTIME '((MLIST) 0. 0.) $GRINDSWITCH NIL $TRIGEXPANDPLUS T $MAXNEGEX 1000. $OPTIONSET NIL $PLOTHEIGHT 22. $NALGFAC T $NUMER_PBRANCH NIL $RATFAC NIL $LINSOLVE_PARAMS T $TRANSRUN T $TLIMSWITCH NIL $DOMXPLUS NIL $SUPERLOGCON T $PRODHACK NIL $RADSUBSTFLAG NIL $SOLVEFACTORS T $LEFTJUST NIL $SIGNBFLOAT T $DISPLAY_FORMAT_INTERNAL NIL $SAVEFACTORS NIL $FORTINDENT 0. $BATCOUNT 0. $NEWFAC NIL $TAYLORDEPTH 3. $ASSUME_POS NIL $RMXCHAR '&] $SAVEDEF T $BFTORAT NIL $%RNUM 0. $DISPLAY2D T $DOMXTIMES NIL $RATEPSILON 2.0E-8 $PARSETIME NIL $ROOTSEPSILON 1.0E-7 $SOLVENULLWARN T $FALSE NIL $LOGABS NIL $LMXCHAR '&[ $CFLENGTH 1. $SUBNUMSIMP NIL $INTEGRATION_CONSTANT_COUNTER 0. $LINEDISP T $FACTORFLAG NIL $ALGDELTA 1.0E-5 $BACKTRACE '$BACKTRACE $LIMSUBST NIL $LIMITDOMAIN '$COMPLEX $MATRIX_ELEMENT_ADD '&+ $MAXPRIME 489318. $RATVARSWITCH T $DEBUGMODE NIL $HALFANGLES NIL $SUBSCRMAP NIL $LISTARITH T $NOINTEGRATE NIL $FORTSPACES NIL $NOLABELS NIL $MOREWAIT NIL $TAYLOR_SIMPLIFIER 'SIMPLIFY $NOUNDISP NIL $DSKALL T $%EMODE T $STARDISP NIL $MAXTAYORDER T $DSKUSE NIL $INCHAR '$C $MAPPRINT T $PIECE '$PIECE $ALGEPSILON 100000000. $%PIARGS T $DSKGC NIL $FPPRINTPREC 0. $DERIVSUBST NIL $TTYINTFUN NIL $DISPTIME NIL $STORENUM 1000. $LOGARC NIL $REFCHECK NIL $SUMEXPAND NIL $ABCONVTEST NIL $RATWTLVL NIL $FLOAT2BF NIL $POINTBOUND 34359738337. $LOGNUMER NIL $ZEROBERN T $MATRIX_ELEMENT_MULT '&* $GCD '$SPMOD $TRIGEXPAND NIL $ERROR_SIZE 20. $TAYLOR_TRUNCATE_POLYNOMIALS T $BOXCHAR '&/" $MAPERROR T $SUMSPLITFACT T $SOLVEEXPLICIT NIL $MULTIPLICITIES '$NOT_SET_YET $SIMP T $SQRTDISPFLAG T $ABSBOXCHAR '&! $NUMER NIL $DEVICE '$DSK $DOSCMXPLUS NIL $SETVAL '$SETVAL $PARTSWITCH NIL $WTLEVEL NIL $GLOBALSOLVE NIL $M1PBRANCH NIL $MATRIX_ELEMENT_TRANSPOSE NIL $INFEVAL NIL $STRDISP T $FACTLIM -1. $LISTCONSTVARS NIL $SOLVE_INCONSISTENT_ERROR T $LOGSIMP T $BREAKUP T $TRANSLATE NIL $DEMOIVRE NIL $MAXPOSEX 1000. $%E_TO_NUMLOG NIL $OFF NIL $TAYLOR_LOGEXPAND NIL $LISTDUMMYVARS T $LINSOLVEWARN T $SOLVERADCAN NIL $FILESIZE 16. $CHANGE_FILEDEFAULTS T $ON T $SPARSE NIL $POLYFACTOR NIL $SIMPSUM NIL $OUTCHAR '$D $%IARGS T $EXPOP 0. $LOGNEGINT NIL $%EDISPFLAG NIL $TRIGINVERSES '$ALL $GAMMALIM 1000000. $FLOAT NIL $DETOUT NIL $EXPON 0. $CONTEXT '$INITIAL $POWERDISP NIL $DOMXEXPT T $RATDENOMDIVIDE T $INFLAG NIL $PFEFORMAT NIL $EXPTDISPFLAG T $ROOTSCONMODE T $VERBOSE NIL $ASSUME_POS_PRED NIL $SOLVEDECOMPOSES T $BFTRUNC T $NOREPEAT T $MYOPTIONS '((MLIST SIMP)) $FILENUM 0. $RATALGDENOM T $KEEPFLOAT NIL $TRIGSIGN T $GENINDEX '$I $LINECHAR '$E $ERRORFUN NIL $MX0SIMP T $GENSUMNUM 0. $EXPTSUBST NIL $LOADPRINT T $FACEXPAND T $DYNAMALLOC NIL $BACKSUBST T $ZETA%PI T $SOLVETRIGWARN T $ERRORMSG T $GRIND NIL $%ENUMER NIL $TTYINTNUM 21. $LOGEXPAND T $MAXTAYDIFF 4. $LHOSPITALLIM 4. $OPSUBST T $SETCHECK NIL $SETCHECKBREAK NIL $RATEXPAND NIL $RATMX NIL $ALGEBRAIC NIL $TAYLOR_ORDER_COEFFICIENTS T $RADEXPAND T $FILE_STRING_PRINT NIL $TRUE T $RESULTANT '$SUBRES $LOGCONCOEFFP NIL $DERIVABBREV NIL $RATWEIGHTS '((MLIST SIMP)) )
($DEBUGMODE NIL)
($DSKGC NIL)
(COND ((NOT (= $FPPREC 16.)) ($FPPREC 16.) (SETQ $FPPREC 16.)))

901
src/cffk/cpoly.64 Normal file
View File

@@ -0,0 +1,901 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module cpoly)
;;;This is a lisp version of algorithm 419 from the Communications of
;;;the ACM (p 97 vol 15 feb 1972) by Jenkins and Traub.
;;;That algorithm is followed very closely.
;;;Note the following modifications: arrays are indexed from 0 instead
;;;of 1. This means that the variables n and nn are one less than the
;;;acm verson. The zeros are put into the arrays pr\ and pi\, rather than
;;;into their own arrays. The algorithm seems to benefit be taking are
;;;mre 0.01 times the published values.
(declare
(*expr displa $listofvars meqhk displine)
(special logbas infin smalno are mre cr ci sr si tr ti zr zi n nn bool conv pvr
pvi $partswitch $keepfloat $demoivre $listconstvars $algebraic acp\
$polyfactor polysc polysc1 $ratfac $programmode)
(flonum logbas infin smalno are mre cr ci sr si tr ti zr zi xx yy cosr sinr bnd
xni t1 t2 otr oti svsr svsi pvr pvi mp ms omp relstp tp hvr hvi e ar
ai br bi x xm f dx df r1 $t hi lo max min acp\)
(fixnum degree n nn j l l1 l2 l3 cnt1 cnt2 jj polysc polysc1))
(declare (notype ($cpoly notype) (noshft\ fixnum) (fxshft\ fixnum)
(vrshft\ fixnum) (calct\) (nexth\) (polyev\)
(cdivid\ flonum flonum flonum flonum) (scale\))
(flonum (errev\ flonum flonum) (cauchy\) (cmod\ flonum flonum))
(fixnum (cpoly\ fixnum))
#-PDP10(flonum (*f flonum flonum) (//f flonum flonum) (_f flonum fixnum))
#-PDP10(*expr *f //f _f)
(*lexpr $rat error))
;; The Lisp Machine needs some way of declaring "functional" arrays.
;; It warns about these symbols being referenced as functions but not defined.
(declare
(array* (flonum pr\ 1. pi\ 1. shr\ 1. shi\ 1. qpr\ 1. qpi\ 1. hr\ 1. hi\
1. qhr\ 1. qhi\ 1.)))
;; Fixed for Twenex systems?
#+PDP10
(and (not (get '*f 'subr))
(mapc '(lambda (x) (putprop x '(arith fasl dsk macsym) 'autoload))
'(*f //f +f -f _f)))
;;; It is harder to underflow on lisp machine, but I suppose someday -BEE
#-PDP10
(progn 'compile
(defmacro *f (a b) `(*$ ,a ,b))
(defmacro //f (a b) `(//$ ,a ,b))
(defmacro +f (a b) `(+$ ,a ,b))
(defmacro -f (a b) `(-$ ,a ,b))
#+Multics(defmacro _f (a b) `(fsc ,a ,b))
)
(defmacro cpoly-large-flonum ()
#-LISPM '(fsc (lsh -1 -1) 0.)
#+LISPM (let ((a (float 0)))
(%p-dpb -1 1013 a) (%p-dpb -1 0007 a)
(%p-dpb-offset -1 0030 a 1) a))
(defmacro cpoly-small-flonum ()
#-LISPM '(fsc (rot 1. -10.) 0.)
#+LISPM (%p-dpb 100 0007 (float 0)))
(defmacro float-precision (pres)
pres ;Ignored on Lisp Machine
#-LISPM `(*$ (fsc (lsh 205. 26.) 0.) ,pres)
#+LISPM (let ((a (float 1)))
(%p-dpb-offset 1 0001 a 1) (- a 1.0)))
;; #+Franz
;; (defun _f (number scale) somebody-write-this)
#+LISPM
(defun _f (number scale)
(let ((ans (+ 0.0 number))
(exp))
(setq exp (+ scale (%p-ldb 1013 ans)))
(cond ((zerop number) 0.0)
((> exp 3777) (ferror nil "_F Overflow -- see MC:CFFK;CPOLY"))
;; Should check zunderflow
((< exp 0) (ferror nil "_F Underflow -- see MC:CFFK;CPOLY"))
(t (%p-dpb exp 1013 ans) ans))))
(setq acp\ 0.2)
(DEFMFUN $allroots (expr)
(prog (degree nn var res $partswitch $keepfloat $demoivre $listconstvars
$algebraic complex $ratfac den)
(setq $keepfloat t $listconstvars t $algebraic t)
(setq expr (meqhk expr) var (delq '$%i (cdr ($listofvars expr))))
(or var (setq var (list (gensym))))
(cond ((not (= (length var) 1.))
(merror "polynomial not univariate: ~M" var))
((setq var (car var))))
(setq expr ($rat expr '$%i var)
res (reverse (car (cdddar expr))))
(do ((i (- (length res) (length (caddar expr))) (1- i)))
((= i 0.))
(setq res (cdr res)))
(setq den (cddr expr) expr (cadr expr))
;;;check denominator is a complex number
(cond ((numberp den) (setq den (list den 0)))
((eq (car den) (cadr res))
(setq den (cddr den))
(cond ((numberp (car den))
(cond ((null (cddr den)) (setq den (list 0 (car den))))
((numberp (caddr den))
(setq den (list (caddr den) (car den))))
(t (error '|not a polynomial|))))
(t (error '|not a polynomial|))))
(t (error '|not a polynomial|)))
;;;if the name variable has disappeared, this is caught here
(setq nn 0)
(cond ((numberp expr) (setq expr (list expr 0)))
((eq (car expr) (car res)) (setq nn 1))
((eq (car expr) (cadr res))
(setq expr (cddr expr))
(cond ((numberp (car expr))
(cond ((null (cddr expr)) (setq expr (list 0 (car expr))))
((numberp (caddr expr))
(setq expr (list (caddr expr) (car expr))))
(t (error '|not a polynomial|))))
(t (error '|not a polynomial|))))
(t (error '|not a polynomial|)))
(cond ((= nn 0)
(cond ($polyfactor
((lambda (cr ci)
(cdivid\ (float (car expr)) (float (cadr expr))
(float (car den)) (float (cadr den)))
(return (simplify (list '(mplus)
(simplify (list '(mtimes)
'$%i ci))
cr))))
0.0 0.0))
(t (return (list '(mlist simp)))))))
(setq degree (cadr expr) nn (1+ degree))
(array pr\ flonum nn) #+LISPM (fillarray 'pr\ '(0.0))
(array pi\ flonum nn) #+LISPM (fillarray 'pi\ '(0.0))
(or (*catch 'notpoly
(errset (do ((expr (cdr expr) (cddr expr)) (l) (%i (cadr res)))
((null expr))
(setq l (- degree (car expr)) res (cadr expr))
(cond ((numberp res) (store (pr\ l) (float res)))
(t (or (eq (car res) %i) (*throw 'notpoly nil))
(setq res (cddr res))
(store (pi\ l) (float (car res)))
(setq res (caddr res))
(and res (store (pr\ l) (float res)))
(setq complex t))))))
;;;this should catch expressions like sin(x)-x
(progn (*rearray 'pr\)
(*rearray 'pi\)
(error '|not a polynomial|)))
(array shr\ flonum nn) #+LISPM (fillarray 'shr\ '(0.0))
(array shi\ flonum nn) #+LISPM (fillarray 'shi\ '(0.0))
(array qpr\ flonum nn) #+LISPM (fillarray 'qpr\ '(0.0))
(array hr\ flonum degree) #+LISPM (fillarray 'hr\ '(0.0))
(array qhr\ flonum degree) #+LISPM (fillarray 'qhr\ '(0.0))
(cond (complex (array qpi\ flonum nn)
#+LISPM (fillarray 'qpi\ '(0.0))
(array hi\ flonum degree)
#+LISPM (fillarray 'hi\ '(0.0))
(array qhi\ flonum degree)
#+LISPM (fillarray 'qhi\ '(0.0))))
(setq nn degree)
(cond (complex (setq res (errset (cpoly\ degree))))
((setq res (errset (rpoly\ degree)))))
(*rearray 'shr\)
(*rearray 'shi\)
(*rearray 'qpr\)
(*rearray 'hr\)
(*rearray 'qhr\)
(cond (complex (*rearray 'qpi\)
(*rearray 'hi\)
(*rearray 'qhi\)))
(or res
(mtell "~%Unexpected error. Treat results with caution."))
(cond ((= nn degree)
(*rearray 'pr\)
(*rearray 'pi\)
(merror "~%No roots found")))
(setq res nil)
(cond
((not (= nn 0.))
(mtell "~%Only ~S out of ~S roots found "
(- degree nn) degree)
(setq expr 0.0)
(do
((i 0. (1+ i)))
((> i nn))
(setq
expr
(simplify
(list '(mplus)
expr
(simplify (list '(mtimes)
(simplify (list '(mplus)
(simplify (list '(mtimes)
'$%i
(pi\ i)))
(pr\ i)))
(simplify (list '(mexpt)
var
(- nn i)))))))))
(setq res (cons expr res)))
($polyfactor
(setq expr ((lambda (cr ci)
(cdivid\ (pr\ 0) (pi\ 0)
(float (car den))
(float (cadr den)))
(simplify (list '(mplus)
(simplify (list '(mtimes)
'$%i ci))
cr)))
0.0 0.0)
res (cons expr res))))
(do
((i degree (1- i)))
((= i nn))
(setq expr (simplify (list '(mplus)
(simplify (list '(mtimes)
'$%i
(pi\ i)))
(pr\ i))))
(setq
res
(cond
($polyfactor (cons (cond ((or complex (= (pi\ i) 0.0))
(simplify (list '(mplus)
var
(simplify (list '(mminus)
expr)))))
(t (setq i (1- i))
(simplify (list '(mplus)
(simplify (list '(mexpt)
var
2.))
(simplify (list '(mtimes)
var
(pr\ i)))
(pr\ (1+ i))))))
res))
((cons ((lambda (expr) (cond ($programmode expr)
(t (displine expr))))
(simplify (list '(mequal) var expr)))
res)))))
(*rearray 'pr\)
(*rearray 'pi\)
(return (simplify (cond ($polyfactor (cons '(mtimes) res))
((cons '(mlist) (nreverse res))))))))
(defun cpoly\ (degree)
((lambda (logbas infin smalno are mre xx yy cosr sinr cr ci sr si tr ti zr zi bnd
n polysc polysc1 conv)
(setq mre (*$ 2.0 (sqrt 2.0) are) yy (-$ xx))
(do ((i degree (1- i)))
((not (and (= (pr\ i) 0.0) (= (pi\ i) 0.0))) (setq nn i n (1- i))))
(setq degree nn)
(do ((i 0. (1+ i)))
((> i nn))
(store (shr\ i) (cmod\ (pr\ i) (pi\ i))))
(scale\)
(do nil
((> 2. nn)
(cdivid\ (-$ (pr\ 1.)) (-$ (pi\ 1.)) (pr\ 0.) (pi\ 0.))
(store (pr\ 1.) cr)
(store (pi\ 1.) ci)
(setq nn 0.))
(do ((i 0. (1+ i)))
((> i nn))
(store (shr\ i) (cmod\ (pr\ i) (pi\ i))))
(setq bnd (cauchy\))
(*catch 'newroot
(do ((cnt1 1. (1+ cnt1)))
((> cnt1 2.))
(noshft\ 5.)
(do ((cnt2 1. (1+ cnt2)))
((> cnt2 9.))
(setq xx (prog2 nil
(-$ (*$ cosr xx) (*$ sinr yy))
(setq yy (+$ (*$ sinr xx)
(*$ cosr yy))))
sr (*$ bnd xx)
si (*$ bnd yy))
(fxshft\ (* 10. cnt2))
(cond (conv (store (pr\ nn) zr)
(store (pi\ nn) zi)
(setq nn n n (1- n))
(do ((i 0. (1+ i)))
((> i nn))
(store (pr\ i) (qpr\ i))
(store (pi\ i) (qpi\ i)))
(*throw 'newroot t))))))
(or conv (return t)))
(do ((i (1+ nn) (1+ i)))
((> i degree))
(store (pr\ i) (_f (pr\ i) polysc1))
(store (pi\ i) (_f (pi\ i) polysc1)))
(do ((i 0. (1+ i)) (j (- polysc (* polysc1 degree)) (+ j polysc1)))
((> i nn))
(store (pr\ i) (_f (pr\ i) j))
(store (pi\ i) (_f (pi\ i) j)))
nn)
(log 2.0) (cpoly-large-flonum)
(cpoly-small-flonum) (float-precision acp\)
0.0 0.70710677 0.0 -0.069756474 0.99756405
0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0. 0. 0. nil))
(defun noshft\ (l1)
(do ((i 0. (1+ i)) (xni (float nn) (1-$ xni)) (t1 (//$ (float nn))))
((> i n))
(store (hr\ i) (*$ (pr\ i) xni t1))
(store (hi\ i) (*$ (pi\ i) xni t1)))
(do ((jj 1. (1+ jj)))
((> jj l1))
(cond ((> (cmod\ (hr\ n) (hi\ n)) (*$ 10.0 are (cmod\ (pr\ n) (pi\ n))))
(cdivid\ (-$ (pr\ nn)) (-$ (pi\ nn)) (hr\ n) (hi\ n))
(setq tr cr ti ci)
(do ((j n (1- j)) (t1) (t2))
((> 1. j))
(setq t1 (hr\ (1- j)) t2 (hi\ (1- j)))
(store (hr\ j) (-$ (+$ (pr\ j) (*f t1 tr)) (*f t2 ti)))
(store (hi\ j) (+$ (pi\ j) (*f t1 ti) (*f t2 tr))))
(store (hr\ 0.) (pr\ 0.))
(store (hi\ 0.) (pi\ 0.)))
(t (do ((j n (1- j)))
((> 1. j))
(store (hr\ j) (hr\ (1- j)))
(store (hi\ j) (hi\ (1- j))))
(store (hr\ 0.) 0.0)
(store (hi\ 0.) 0.0)))))
(defun fxshft\ (l2)
((lambda (test pasd otr oti svsr svsi bool pvr pvi)
(polyev\)
(setq conv nil)
(calct\)
(do ((j 1. (1+ j)))
((> j l2))
(setq otr tr oti ti)
(nexth\)
(calct\)
(setq zr (+$ sr tr) zi (+$ si ti))
(cond ((and (not bool) test (not (= j l2)))
(cond ((> (*$ 0.5 (cmod\ zr zi))
(cmod\ (-$ tr otr) (-$ ti oti)))
(cond (pasd (do ((i 0. (1+ i)))
((> i n))
(store (shr\ i) (hr\ i))
(store (shi\ i) (hi\ i)))
(setq svsr sr svsi si)
(vrshft\ 10.)
(and conv (return nil))
(setq test nil)
(do ((i 0. (1+ i)))
((> i n))
(store (hr\ i) (shr\ i))
(store (hi\ i) (shi\ i)))
(setq sr svsr si svsi)
(polyev\)
(calct\))
((setq pasd t))))
((setq pasd nil))))))
(or conv (vrshft\ 10.))
nil)
t nil 0.0 0.0 0.0 0.0 nil 0.0 0.0))
(defun vrshft\ (l3)
(setq conv nil sr zr si zi)
(do ((i 1. (1+ i)) (bool1 nil) (mp) (ms) (omp) (relstp) (tp) (r1))
((> i l3))
(polyev\)
(setq mp (cmod\ pvr pvi) ms (cmod\ sr si))
(cond ((> (*$ 20.0 (errev\ ms mp)) mp)
(setq conv t zr sr zi si)
(return t)))
(cond ((= i 1.) (setq omp mp))
((or bool1 (> omp mp) (not (< relstp 0.05)))
(cond ((> (*$ 0.1 mp) omp) (return t)) (t (setq omp mp))))
(t (setq tp relstp bool1 t)
(cond ((> are relstp) (setq tp are)))
(setq r1 (sqrt tp)
sr (prog2 nil
(-$ (*$ (1+$ r1) sr) (*f r1 si))
(setq si (+$ (*$ (1+$ r1) si) (*f r1 sr)))))
(polyev\)
(do ((j 1. (1+ j))) ((> j 5.)) (calct\) (nexth\))
(setq omp infin)))
(calct\)
(nexth\)
(calct\)
(or bool
(setq relstp (//$ (cmod\ tr ti) (cmod\ sr si))
sr (+$ sr tr)
si (+$ si ti)))))
(defun calct\ nil
(do ((i 1. (1+ i))
($t)
(hvr (store (qhr\ 0.) (hr\ 0.)))
(hvi (store (qhi\ 0.) (hi\ 0.))))
((> i n)
(setq bool (not (> (cmod\ hvr hvi) (*$ 10.0 are (cmod\ (hr\ n) (hi\ n))))))
(cond ((not bool) (cdivid\ (-$ pvr) (-$ pvi) hvr hvi) (setq tr cr ti ci))
(t (setq tr 0.0 ti 0.0)))
nil)
(setq $t (-$ (+$ (hr\ i) (*f hvr sr)) (*f hvi si)))
(store (qhi\ i) (setq hvi (+$ (hi\ i) (*f hvr si) (*f hvi sr))))
(store (qhr\ i) (setq hvr $t))))
(defun nexth\ nil
(cond (bool (do ((j 1. (1+ j)))
((> j n))
(store (hr\ j) (qhr\ (1- j)))
(store (hi\ j) (qhi\ (1- j))))
(store (hr\ 0.) 0.0)
(store (hi\ 0.) 0.0))
(t (do ((j 1. (1+ j)) (t1) (t2))
((> j n))
(setq t1 (qhr\ (1- j)) t2 (qhi\ (1- j)))
(store (hr\ j) (-$ (+$ (qpr\ j) (*f t1 tr)) (*f t2 ti)))
(store (hi\ j) (+$ (qpi\ j) (*f t1 ti) (*f t2 tr))))
(store (hr\ 0.) (qpr\ 0.))
(store (hi\ 0.) (qpi\ 0.))))
nil)
(defun polyev\ nil
(setq pvr (store (qpr\ 0.) (pr\ 0.)) pvi (store (qpi\ 0.) (pi\ 0.)))
(do ((i 1. (1+ i)) ($t))
((> i nn))
(setq $t (-$ (+$ (pr\ i) (*f pvr sr)) (*f pvi si)))
(store (qpi\ i) (setq pvi (+$ (pi\ i) (*f pvr si) (*f pvi sr))))
(store (qpr\ i) (setq pvr $t))))
(defun errev\ (ms mp)
(-$ (*$ (do ((j 0. (1+ j))
(e (//$ (*$ (cmod\ (qpr\ 0.) (qpi\ 0.)) mre) (+$ are mre))))
((> j nn) e)
(setq e (+$ (cmod\ (qpr\ j) (qpi\ j)) (*$ e ms))))
(+$ are mre))
(*$ mp mre)))
(defun cauchy\ nil
((lambda (x xm)
(store (shr\ nn) (-$ (shr\ nn)))
(cond ((not (= (shr\ n) 0.0))
(setq xm (-$ (//$ (shr\ nn) (shr\ n))))
(cond ((> x xm) (setq x xm)))))
(do ((f))
(nil)
(setq xm (*$ 0.1 x) f (shr\ 0.))
(do ((i 1. (1+ i))) ((> i nn)) (setq f (+$ (shr\ i) (*f f xm))))
(cond ((not (< 0.0 f)) (return t)))
(setq x xm))
(do ((dx x) (df) (f))
((> 5.0e-3 (abs (//$ dx x))) x)
(setq f (shr\ 0.) df f)
(do ((i 1. (1+ i)))
((> i n))
(setq f (+$ (*$ f x) (shr\ i)) df (+$ (*$ df x) f)))
(setq f (+$ (*$ f x) (shr\ nn)) dx (//$ f df) x (-$ x dx))))
(exp (//$ (-$ (log (shr\ nn)) (log (shr\ 0.))) (float nn)))
0.0))
(defun scale\ nil
(do ((i 0. (1+ i)) (j 0.) (x 0.0) (dx 0.0))
((> i nn)
(setq x (//$ x (float (- (1+ nn) j)))
dx (//$ (-$ (log (shr\ nn)) (log (shr\ 0.))) (float nn))
polysc1 (fix (+$ 0.5 (//$ dx logbas)))
x (+$ x (*$ (float (* polysc1 nn)) logbas 0.5))
polysc (fix (+$ 0.5 (//$ x logbas)))))
(cond ((= (shr\ i) 0.0) (setq j (1+ j)))
(t (setq x (+$ x (log (shr\ i)))))))
(do ((i nn (1- i)) (j (- polysc) (+ j polysc1)))
((< i 0.))
(store (pr\ i) (_f (pr\ i) j))
(store (pi\ i) (_f (pi\ i) j))))
;; (defun scale\ nil
;; ((lambda (hi lo max min x l)
;; (do ((i 0. (1+ i)))
;; ((> i nn))
;; (setq x (shr\ i))
;; (cond ((> x max) (setq max x)))
;; (cond ((and (not (= x 0.0)) (< x min)) (setq min x))))
;; (cond ((or (> lo min) (> max hi))
;; (setq x (//$ lo min))
;; (cond ((> x 1.0)
;; (cond ((> max (//$ infin x))
;; ;;;acm has < here but imsl agrees with me
;; (setq x 1.0))))
;; ((setq x (//$ (*$ (sqrt max) (sqrt min))))))
;; (setq l (fix (+$ 0.5 (//$ (log x) logbas))))
;; (cond ((not (= l 0.))
;; (do ((i 0. (1+ i)))
;; ((> i nn))
;; (store (pr\ i) (_f (pr\ i) l))
;; (store (pi\ i) (_f (pi\ i) l)))))))
;; l)
;; (sqrt infin) (//$ smalno are) 0.0 infin 0.0 0.))
(defun cdivid\ (ar ai br bi)
((lambda (r1) (cond ((and (= br 0.0) (= bi 0.0)) (setq cr (setq ci infin)))
((> (abs bi) (abs br))
(setq r1 (//f br bi)
bi (+$ bi (*f br r1))
br (+$ ai (*f ar r1))
cr (//f br bi)
br (-$ (*f ai r1) ar)
ci (//f br bi)))
((setq r1 (//f bi br)
bi (+$ br (*f bi r1))
br (+$ ar (*f ai r1))
cr (//f br bi)
br (-$ ai (*f ar r1))
ci (//f br bi)))))
0.0)
nil)
(defun cmod\ (ar ai)
(setq ar (abs ar) ai (abs ai))
(cond ((> ai ar) (setq ar (//f ar ai)) (*$ ai (sqrt (1+$ (*f ar ar)))))
((> ar ai) (setq ai (//f ai ar)) (*$ ar (sqrt (1+$ (*f ai ai)))))
((*$ 1.41421357 ar))))
;;*page
;;;this is the algorithm for doing real polynomials. it is algorithm 493 from
;;;acm toms vol 1 p 178 (1975) by jenkins. note that array indexing starts from 0.
;;;the names of the arrays have been changed to be the same as for cpoly.
;;;the correspondence is: p - pr\, qp - qpr\, k - hr\, qk - qhr\, svk - shr\,
;;;temp - shi\. the roots are put in pr\ and pi\.
;;;the variable si appears not to be used here
(declare (special sr u v a b c d a1 a3 a7 e f g h szr szi lzr lzi are mre n nn nz
type ui vi s $polyfactor arp\)
(flonum a a0 a1 a3 a4 a5 a6 a7 aa are b b0 b1 b2 logbas bb betas betav bnd c c0
c1 c2 c3 c4 cc cosr d d0 e ee f g h infin kv lzi lzr mp mre ms omp
oss ots otv ovv pv relstp s sinr smalno sr ss svu svv szi szr t1 ts
tss tv tvv u ui v vi vv xx yy zm arp\)
(fixnum cnt degree i iflag j jj l l2 n nn nz type))
(declare (fixnum (realit\))
(notype (rpoly\ fixnum) (fxshfr\ fixnum) (quadit\) (calcsc\) (nextk\)
(newest\) (quadsd\) (quad\ flonum flonum flonum)))
(setq arp\ 1.0)
(defun rpoly\ (degree)
((lambda (logbas infin smalno are mre xx yy cosr sinr aa cc bb bnd sr u v t1 szr
szi lzr lzi nz n polysc polysc1 zerok conv1)
(setq mre are yy (-$ xx))
(do ((i degree (1- i))) ((not (= (pr\ i) 0.0)) (setq nn i n (1- i))))
(setq degree nn)
(do ((i 0. (1+ i))) ((> i nn)) (store (shr\ i) (abs (pr\ i))))
(scale\)
(do nil
((< nn 3.)
(cond ((= nn 2.)
(quad\ (pr\ 0.) (pr\ 1.) (pr\ 2.))
(cond ((and $polyfactor (not (= szi 0.0)))
(store (pr\ 2.) (//$ (pr\ 2.) (pr\ 0.)))
(store (pr\ 1.) (//$ (pr\ 1.) (pr\ 0.)))
(store (pi\ 2.) 1.0))
(t (store (pr\ 2.) szr)
(store (pi\ 2.) szi)
(store (pr\ 1.) lzr)
(store (pi\ 1.) lzi))))
(t (store (pr\ 1.) (-$ (//$ (pr\ 1.) (pr\ 0.))))))
(setq nn 0.))
(do ((i 0. (1+ i))) ((> i nn)) (store (shr\ i) (abs (pr\ i))))
(setq bnd (cauchy\))
(do ((i 1. (1+ i)))
((> i n))
(store (hr\ i) (//$ (*$ (float (- n i)) (pr\ i)) (float n))))
(store (hr\ 0.) (pr\ 0.))
(setq aa (pr\ nn) bb (pr\ n) zerok (= (hr\ n) 0.0))
(do ((jj 1. (1+ jj)))
((> jj 5.))
(setq cc (hr\ n))
(cond (zerok (do ((j n (1- j)))
((< j 1.))
(store (hr\ j) (hr\ (1- j))))
(store (hr\ 0.) 0.0)
(setq zerok (= (hr\ n) 0.0)))
(t (setq t1 (-$ (//$ aa cc)))
(do ((j n (1- j)))
((< j 1.))
(store (hr\ j) (+$ (*$ t1 (hr\ (1- j))) (pr\ j))))
(store (hr\ 0.) (pr\ 0.))
(setq zerok (not (> (abs (hr\ n))
(*$ (abs bb) are 10.0)))))))
(do ((i 0. (1+ i))) ((> i n)) (store (shi\ i) (hr\ i)))
(do ((cnt 1. (1+ cnt)))
((> cnt 20.) (setq conv1 nil))
(setq xx (prog2 nil
(-$ (*$ cosr xx) (*$ sinr yy))
(setq yy (+$ (*$ sinr xx) (*$ cosr yy))))
sr (*$ bnd xx)
u (*$ -2.0 sr)
v bnd)
(fxshfr\ (* 20. cnt))
(cond ((> nz 0.)
(store (pr\ nn) szr)
(store (pi\ nn) szi)
(cond ((= nz 2.)
(store (pr\ n) lzr)
(store (pi\ n) lzi)
(cond ((and $polyfactor (not (= szi 0.0)))
(store (pr\ nn) v)
(store (pr\ n) u)
(store (pi\ nn) 1.0)))))
(setq nn (- nn nz) n (1- nn))
(do ((i 0. (1+ i))) ((> i nn)) (store (pr\ i) (qpr\ i)))
(return nil)))
(do ((i 0. (1+ i))) ((> i n)) (store (hr\ i) (shi\ i))))
(or conv1 (return nil)))
(cond ($polyfactor
(do ((i degree (1- i)))
((= i nn))
(cond ((= (pi\ i) 0.0)
(store (pr\ i) (_f (pr\ i) polysc1)))
(t (store (pr\ i) (_f (pr\ i) (* 2. polysc1)))
(setq i (1- i))
(store (pr\ i) (_f (pr\ i) polysc1))))))
(t (do ((i (1+ nn) (1+ i)))
((> i degree))
(store (pr\ i) (_f (pr\ i) polysc1))
(store (pi\ i) (_f (pi\ i) polysc1)))))
(do ((i 0. (1+ i)) (j (- polysc (* polysc1 degree)) (+ j polysc1)))
((> i nn))
(store (pr\ i) (_f (pr\ i) j))))
(log 2.0) (cpoly-large-flonum)
(cpoly-small-flonum) (float-precision arp\)
0.0 0.70710677 0.0 -0.069756474 0.99756405
0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0. 0. 0. 0. 0. t))
(defun fxshfr\ (l2)
((lambda (type a b c d e f g h a1 a3 a7)
(setq nz 0.)
(quadsd\)
(calcsc\)
(do ((j 1. (1+ j)) (betav 0.25) (betas 0.25)
(oss sr) (ovv v) (tvv) (tss) (ss) (vv) (tv) (ts) (ots) (otv)
(ui) (vi) (s) (svv) (svu) (iflag) (vpass) (spass) (vtry) (stry))
((> j l2))
(nextk\)
(calcsc\)
(newest\)
(setq vv vi ss 0.0)
(or (= (hr\ n) 0.0) (setq ss (-$ (//$ (pr\ nn) (hr\ n)))))
(setq tv 1.0 ts 1.0)
(cond ((not (or (= j 1.) (= type 3.)))
(or (= vv 0.0) (setq tv (abs (//$ (-$ vv ovv) vv))))
(or (= ss 0.0) (setq ts (abs (//$ (-$ ss oss) ss))))
(setq tvv 1.0)
(and (< tv otv) (setq tvv (*$ tv otv)))
(setq tss 1.0)
(and (< ts ots) (setq tss (*$ ts ots)))
(setq vpass (< tvv betav) spass (< tss betas))
(cond ((or spass vpass)
(setq svu u svv v)
(do ((i 0. (1+ i))) ((> i n)) (store (shr\ i) (hr\ i)))
(setq s ss vtry nil stry nil)
(and (do ((bool (not (and spass
(or (not vpass) (< tss tvv))))
t)
(l50 nil nil))
(nil)
(cond (bool (quadit\)
(and (> nz 0.) (return t))
(setq vtry t betav (*$ 0.25 betav))
(cond ((or stry (not spass))
(setq l50 t))
(t (do ((i 0. (1+ i)))
((> i n))
(store (hr\ i)
(shr\ i)))))))
(cond ((not l50)
(setq iflag (realit\))
(and (> nz 0.) (return t))
(setq stry t betas (*$ 0.25 betas))
(cond ((= iflag 0.) (setq l50 t))
(t (setq ui (-$ (+$ s s))
vi (*$ s s))))))
(cond (l50 (setq u svu v svv)
(do ((i 0. (1+ i)))
((> i n))
(store (hr\ i) (shr\ i)))
(and (or (not vpass) vtry)
(return nil)))))
(return nil))
(quadsd\)
(calcsc\)))))
(setq ovv vv oss ss otv tv ots ts)))
0. 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
(defun quadit\ nil
(setq nz 0. u ui v vi)
(do ((tried) (j 0.) (ee) (zm) (t1) (mp) (relstp) (omp))
(nil)
(quad\ 1.0 u v)
(and (> (abs (-$ (abs szr) (abs lzr))) (*$ 0.01 (abs lzr))) (return nil))
(quadsd\)
(setq mp (+$ (abs (-$ a (*$ szr b))) (abs (*$ szi b)))
zm (sqrt (abs v))
ee (*$ 2.0 (abs (qpr\ 0.)))
t1 (-$ (*$ szr b)))
(do ((i 1. (1+ n))) ((> i n)) (setq ee (+$ (*$ ee zm) (abs (qpr\ i)))))
(setq ee (+$ (*$ ee zm) (abs (+$ a t1)))
ee (-$ (*$ (+$ (*$ 5.0 mre) (*$ 4.0 are)) ee)
(*$ (+$ (*$ 5.0 mre) (*$ 2.0 are))
(+$ (abs (+$ a t1)) (*$ (abs b) zm)))
(*$ -2.0 are (abs t1))))
(cond ((not (> mp (*$ 20.0 ee))) (setq nz 2.) (return nil)))
(setq j (1+ j))
(and (> j 20.) (return nil))
(cond ((not (or (< j 2.) (> relstp 0.01) (< mp omp) tried))
(and (< relstp are) (setq relstp are))
(setq relstp (sqrt relstp)
u (-$ u (*$ u relstp))
v (+$ v (*$ v relstp)))
(quadsd\)
(do ((i 1. (1+ i))) ((> i 5.)) (calcsc\) (nextk\))
(setq tried t j 0.)))
(setq omp mp)
(calcsc\)
(nextk\)
(calcsc\)
(newest\)
(and (= vi 0.0) (return nil))
(setq relstp (abs (//$ (-$ vi v) vi)) u ui v vi)))
(defun realit\ nil
(setq nz 0.)
(do ((j 0.) (pv) (ee) (ms) (mp) (kv) (t1) (omp))
(nil)
(setq pv (pr\ 0.))
(store (qpr\ 0.) pv)
(do ((i 1. (1+ i)))
((> i nn))
(setq pv (+$ (*$ pv s) (pr\ i)))
(store (qpr\ i) pv))
(setq mp (abs pv) ms (abs s) ee (*$ (//$ mre (+$ are mre)) (abs (qpr\ 0.))))
(do ((i 1. (1+ i))) ((> i nn)) (setq ee (+$ (*$ ee ms) (abs (qpr\ i)))))
(cond ((not (> mp (*$ 20.0 (-$ (*$ (+$ are mre) ee) (*$ mre mp)))))
(setq nz 1. szr s szi 0.0)
(return 0.)))
(setq j (1+ j))
(and (> j 10.) (return 0.))
(cond ((not (or (< j 2.)
(> (abs t1) (*$ 1.0e-3 (abs (-$ s t1))))
(not (> mp omp))))
(return 1.)))
(setq omp mp kv (hr\ 0.))
(store (qhr\ 0.) kv)
(do ((i 1. (1+ i)))
((> i n))
(setq kv (+$ (*$ kv s) (hr\ i)))
(store (qhr\ i) kv))
(cond ((> (abs kv) (*$ (abs (hr\ n)) 10.0 are))
(setq t1 (-$ (//$ pv kv)))
(store (hr\ 0.) (qpr\ 0.))
(do ((i 1. (1+ i)))
((> i n))
(store (hr\ i) (+$ (*$ t1 (qhr\ (1- i))) (qpr\ i)))))
(t (store (hr\ 0.) 0.0)
(do ((i 1. (1+ i))) ((> i n)) (store (hr\ i) (qhr\ (1- i))))))
(setq kv (hr\ 0.))
(do ((i 1. (1+ i))) ((> i n)) (setq kv (+$ (*$ kv s) (hr\ i))))
(setq t1 0.0)
(and (> (abs kv) (*$ (abs (hr\ n)) 10.0 are)) (setq t1 (-$ (//$ pv kv))))
(setq s (+$ s t1))))
(defun calcsc\ nil
(setq d (hr\ 0.))
(store (qhr\ 0.) d)
(setq c (-$ (hr\ 1.) (*$ u d)))
(store (qhr\ 1.) c)
(do ((i 2. (1+ i)) (c0))
((> i n))
(setq c0 (-$ (hr\ i) (*$ u c) (*$ v d)))
(store (qhr\ i) c0)
(setq d c c c0))
(cond ((not (or (> (abs c) (*$ (abs (hr\ n)) 100.0 are))
(> (abs d) (*$ (abs (hr\ (1- n))) 100.0 are))))
(setq type 3.))
((not (< (abs d) (abs c)))
(setq type 2.
e (//$ a d)
f (//$ c d)
g (*$ u b)
h (*$ v b)
a3 (+$ (*$ (+$ a g) e) (*$ h (//$ b d)))
a1 (-$ (*$ b f) a)
a7 (+$ (*$ (+$ f u) a) h)))
(t (setq type 1.
e (//$ a c)
f (//$ d c)
g (*$ u e)
h (*$ v b)
a3 (+$ (*$ a e) (*$ (+$ (//$ h c) g) b))
a1 (-$ b (*$ a (//$ d c)))
a7 (+$ a (*$ g d) (*$ h f)))))
nil)
(defun nextk\ nil
(cond ((= type 3.)
(store (hr\ 0.) 0.0)
(store (hr\ 1.) 0.0)
(do ((i 2. (1+ i))) ((> i n)) (store (hr\ i) (qhr\ (- i 2.)))))
((> (abs a1) (*$ (abs (cond ((= type 1.) b) (a))) 10.0 are))
(setq a7 (//$ a7 a1) a3 (//$ a3 a1))
(store (hr\ 0.) (qpr\ 0.))
(store (hr\ 1.) (-$ (qpr\ 1.) (*$ a7 (qpr\ 0.))))
(do ((i 2. (1+ i)))
((> i n))
(store (hr\ i)
(+$ (*$ a3 (qhr\ (- i 2.)))
(-$ (*$ a7 (qpr\ (1- i))))
(qpr\ i)))))
(t (store (hr\ 0.) 0.0)
(store (hr\ 1.) (-$ (*$ a7 (qpr\ 0.))))
(do ((i 2. (1+ i)))
((> i n))
(store (hr\ i)
(-$ (*$ a3 (qhr\ (- i 2.))) (*$ a7 (qpr\ (1- i))))))))
nil)
(defun newest\ nil
((lambda (a4 a5 b1 b2 c1 c2 c3 c4)
(cond ((= type 3.) (setq ui 0.0 vi 0.0))
(t (cond ((= type 2.)
(setq a4 (+$ (*$ (+$ a g) f) h)
a5 (+$ (*$ (+$ f u) c) (*$ v d))))
(t (setq a4 (+$ a (*$ u b) (*$ h f))
a5 (+$ c (*$ (+$ u (*$ v f)) d)))))
(setq b1 (-$ (//$ (hr\ n) (pr\ nn)))
b2 (-$ (//$ (+$ (hr\ (1- n)) (*$ b1 (pr\ n))) (pr\ nn)))
c1 (*$ v b2 a1)
c2 (*$ b1 a7)
c3 (*$ b1 b1 a3)
c4 (-$ c1 c2 c3)
c1 (+$ a5 (*$ b1 a4) (-$ c4)))
(cond ((= c1 0.0) (setq ui 0.0 vi 0.0))
(t (setq ui (-$ u
(//$ (+$ (*$ u (+$ c3 c2))
(*$ v
(+$ (*$ b1 a1)
(*$ b2 a7))))
c1))
vi (*$ v (1+$ (//$ c4 c1))))))))
nil)
0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
(defun quadsd\ nil
(setq b (pr\ 0.))
(store (qpr\ 0.) b)
(setq a (-$ (pr\ 1.) (*$ u b)))
(store (qpr\ 1.) a)
(do ((i 2. (1+ i)) (c0))
((> i nn))
(setq c0 (-$ (pr\ i) (*$ u a) (*$ v b)))
(store (qpr\ i) c0)
(setq b a a c0)))
(defun quad\ (a0 b1 c0)
(setq szr 0.0 szi 0.0 lzr 0.0 lzi 0.0)
((lambda (b0 d0 e)
(cond ((= a0 0.0) (or (= b1 0.0) (setq szr (-$ (//$ c0 b1)))))
((= c0 0.0) (setq lzr (-$ (//$ b1 a0))))
(t (setq b0 (//$ b1 2.0))
(cond ((< (abs b0) (abs c0))
(setq e a0)
(and (< c0 0.0) (setq e (-$ a0)))
(setq e (-$ (*$ b0 (//$ b0 (abs c0))) e)
d0 (*$ (sqrt (abs e)) (sqrt (abs c0)))))
(t (setq e (-$ 1.0 (*$ (//$ a0 b0) (//$ c0 b0)))
d0 (*$ (sqrt (abs e)) (abs b0)))))
(cond ((< e 0.0)
(setq szr (-$ (//$ b0 a0))
lzr szr
szi (abs (//$ d0 a0))
lzi (-$ szi)))
(t (or (< b0 0.0) (setq d0 (-$ d0)))
(setq lzr (//$ (-$ d0 b0) a0))
(or (= lzr 0.0) (setq szr (//$ c0 lzr a0)))))))
nil)
0.0 0.0 0.0))
(declare (unspecial logbas infin smalno are mre cr ci sr si tr ti zr zi
n nn bool conv pvr pvi acp\ polysc polysc1 sr u v a
b c d a1 a3 a7 e f g h szr szi lzr lzi are mre n nn nz
type ui vi s arp\))

74
src/das/mstuff.21 Normal file
View File

@@ -0,0 +1,74 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module mstuff)
(DECLARE (SPLITFILE MSORT) (FIXNUM N))
(DEFMFUN $SORT N
(IF (OR (= N 0) (> N 2)) (MERROR "SORT takes 1 or 2 arguments."))
(LET ((LLIST (ARG 1)) COMPARFUN BFUN)
(IF (NOT ($LISTP LLIST))
(MERROR "The first argument to SORT must be a list:~%~M" LLIST))
(SETQ LLIST (APPEND (CDR LLIST) NIL)
COMPARFUN
(MFUNCTION1 (SETQ BFUN (IF (= N 2) (GETOPR (ARG 2)) 'LESSTHAN))))
(IF (MEMQ BFUN '(LESSTHAN GREAT))
(SETQ LLIST (MAPCAR #'RATDISREP LLIST)))
(CONS '(MLIST SIMP) (SORT LLIST COMPARFUN))))
(DEFUN MFUNCTION1 (FUN)
`(LAMBDA (X Y) (MEVALP `((,',FUN) ((MQUOTE) ,X) ((MQUOTE) ,Y)))))
(DEFUN LESSTHAN (A B) (GREAT B A))
(DECLARE (SPLITFILE MAKEL))
(DEFMSPEC $MAKELIST (X) (SETQ X (CDR X))
(PROG (N FORM ARG A B LV D)
(SETQ N (LENGTH X))
(IF (OR (< N 3) (> N 4))
(MERROR "MAKELIST takes 3 or 4 arguments."))
(SETQ FORM (CAR X)
ARG (CADR X)
A (MEVAL (CADDR X))
LV (COND ((= N 3)
(IF ($LISTP A)
(MAPCAR #'(LAMBDA (U) (LIST '(MQUOTE) U)) (CDR A))
(MERROR "
If 3 arguments are given to MAKELIST,
the 3rd argument should evaluate to a list:~%~M" A)))
(T
(SETQ B (MEVAL (CADDDR X)))
(IF (OR (NOT (EQ (TYPEP (SETQ D (SUB* B A))) 'FIXNUM))
(< D -1))
(MERROR "
If 4 arguments are given to MAKELIST, the difference of the 3rd
and 4th arguments should evaluate to a non-negative integer:~%~M" D)
(INTERVAL A B)))))
(RETURN
(DO ((LV LV (CDR LV)) (ANS))
((NULL LV) (CONS '(MLIST SIMP) (NREVERSE ANS)))
(SETQ ANS (CONS (MEVAL `(($EV)
,@(LIST (LIST '(MQUOTE) FORM)
(LIST '(MEQUAL SIMP)
ARG
(CAR LV)))))
ANS))))))
(DEFUN INTERVAL (I J)
(DO ((NN I (ADD2 1 NN)) (M 0 (1+ M)) (K (SUB* J I)) (ANS))
((> M K) (NREVERSE ANS))
(SETQ ANS (CONS NN ANS))))
(DEFMFUN $SUBLIST (A F)
(IF ($LISTP A)
(DO ((A (CDR A) (CDR A)) (X))
((NULL A) (CONS '(MLIST SIMP) (NREVERSE X)))
(IF (MEVALP (LIST (NCONS F) (CAR A)))
(SETQ X (CONS (CAR A) X))))
(MERROR "The first argument to SUBLIST must be a list:~%~M" A)))
; Undeclarations for the file:
(DECLARE (NOTYPE N))

1234
src/ell/hyp.98 Normal file
View File

File diff suppressed because it is too large Load Diff

2395
src/ell/hypgeo.9 Normal file
View File

File diff suppressed because it is too large Load Diff

1048
src/ellen/option.88 Normal file
View File

File diff suppressed because it is too large Load Diff

297
src/ellen/primer.213 Normal file
View File

@@ -0,0 +1,297 @@
;;;-*-lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;To run this primer interpreted, the following files must be LOADFILED into ;;
;;MACSYMA: MRG;MACROS FASL, ELLEN;CHECK >, ELLEN;SCRIPT >, and this file. ;;
;;I do not recommend doing that, however. -Ellen ;;
;;(C) Copyright 1979, Massachusetts Institute of Technology ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DECLARE (SPECIAL CLABEL DLABEL NSP TB LP RP SCRIPTINDEX LISPREADTABLE
$% $LABELS $LINENUM $INCHAR $OUTCHAR
LINEL GCT $SHOWTIME $LASTTIME)
(UNSPECIAL *)
(*EXPR MEVAL STRIPDOLLAR DISPLA MGRIND MAKSTRING ADD2LNC RETRIEVE)
(*FEXPR $LOADFILE) (FASLOAD MACROS FASL DSK MRG))
(DECLARE (EVAL (READ)))
(SETSYNTAX '/# 'MACRO 'TYI)
(SETSYNTAX '/" 'MACRO 'READTEXT)
(DEFUN READTEXT ()
(LAMBIND ((READTABLE (GET 'PRIMER 'ARRAY)))
(DO ((S (READ) (READ)) (NL)) ((EQ '/" S) `(TEXT ',(NREVERSE NL)))
(SETQ NL (CONS S NL))
(IF (EQ '/@ S)
(LAMBIND ((READTABLE LISPREADTABLE)) (SETQ NL (CONS (READ) NL)))))))
(SETSYNTAX #~ 'MACRO 'NOFILL)
(DEFUN NOFILL ()
(DO ((C (TYI) (TYI)) (CL))
((= #~ C) `(PRINC ',(MAKNAM (NREVERSE CL))))
(SETQ CL (CONS C CL))))
(*ARRAY 'PRIMER 'READTABLE T)
(LAMBIND ((READTABLE (GET 'PRIMER 'ARRAY)))
(DO I ## (1+ I) (> I #@) (SETSYNTAX I 1 I))
(DO I #a (1+ I) (> I #z) (SETSYNTAX I 1 I))
(SETSYNTAX #` 'SINGLE #`)
(SETSYNTAX #@ 'SINGLE #@)
(SETSYNTAX #" 'SINGLE #"))
(DECLARE (COUTPUT (READ)))
(DEFUN IF MACRO (X)
(COND ((NULL (CDDDR X)) `(COND (,(CADR X) ,(CADDR X))))
(T `(COND (,(CADR X) ,(CADDR X)) (T . ,(CDDDR X))))))
(SETQ LISPREADTABLE READTABLE
SCRIPTINDEX '(($INTRO (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN))
($CONSOLEPRIMER (SCRIPT INTRO DSK ELLEN)
(CHECK FASL DSK ELLEN))
($HELP (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN))
($SYNTAX (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN))
($SIMPLIFICATION (SCRIPT INTRO DSK ELLEN)
(CHECK FASL DSK ELLEN))
($SCRATCHPAD (SCRIPT INTRO DSK ELLEN)
(CHECK FASL DSK ELLEN))
($ASSIGNMENT (SCRIPT AUX DSK ELLEN)
(CHECK FASL DSK ELLEN))
($FILING (SCRIPT AUX DSK ELLEN)
(CHECK FASL DSK ELLEN))
($STRINGCOMMANDS (SCRIPT AUX DSK ELLEN)
(CHECK FASL DSK ELLEN))
($MATRICES (SCRIPT MATRIX DSK ELLEN)
(CHECK FASL DSK ELLEN))
($SHARE (SHARE SCRIPT DSK ELLEN))
($ABSIMP (SHARE SCRIPT DSK ELLEN))
($ROMBER (SHARE SCRIPT DSK ELLEN))
($FFT (SHARE SCRIPT DSK ELLEN))
($DESOLN (SHARE SCRIPT DSK ELLEN))
($UNITS (SHARE SCRIPT DSK ELLEN))
($ARRAY (SHARE SCRIPT DSK ELLEN))
($DIMEN (SHARE SCRIPT DSK ELLEN))
($DUMP (SHARE SCRIPT DSK ELLEN))
($FACT (SHARE SCRIPT DSK ELLEN))
($INTPOL (SHARE SCRIPT DSK ELLEN))
($MATCH (MATCH SCRIPT DSK MRG))))
(DEFUN $PRIMER FEXPR (X)
(SETQ X (COND (X (CAR X))
((SEENP (STATUS UNAME) '$CONSOLEPRIMER) '$HELP)
(T '$CONSOLEPRIMER)))
(*CATCH 'PQUIT (SCRIPT X T))
'$DONE)
(DEFUN SEENP (USER SC)
(PROGB (IN)
(SETQ IN (OPEN '(USER PROFIL DSK ALJABR) 'IN))
(DO ((U (READ IN 'EOF) (READ IN 'EOF))) ((EQ U 'EOF) (CLOSE IN) NIL)
(COND ((EQ USER (CAR U)) (CLOSE IN) (RETURN (MEMQ SC (CDR U))))))))
(DEFUN SEEN (USER SC)
(PROGB (IN OUT)
(SETQ IN (OPEN '(USER PROFIL DSK ALJABR) 'IN)
OUT (OPEN '(USER PROFIL DSK ALJABR) 'OUT))
(DO ((U (READ IN NIL) (READ IN NIL)) (SUCCESS))
((NULL U) (IFN SUCCESS (PRINT (LIST USER SC) OUT)))
(IFN (EQ USER (CAR U)) T (SETQ SUCCESS T) (RPLACD U (CONS SC (CDR U))))
(PRINT U OUT))
(CLOSE IN) (CLOSE OUT)))
(DEFUN SCRIPT (SC TOP)
(SETQ SC (GETSCRIPT SC TOP))
(*CATCH 'EXIT (DO () ((NULL SC)) (TERPRI) (EVAL (CAR SC))
(SETQ SC (CDR SC)))))
(DEFUN GETSCRIPT (SC TOP)
(PROGB (*)
(COND ((GET SC 'SCRIPT))
((AND (SETQ * (CDR (ASSQ SC SCRIPTINDEX)))
(DO ((L * (CDR L))) ((NULL L) T)
(APPLY '$LOADFILE (CAR L)))
(GET SC 'SCRIPT)))
(T (TERPRI) (PRINC '|No such script.|) (COND (TOP (ERR)))))))
(DEFUN TEXT (L)
(TERPRI) (TYO TB)
(DO ((X) (W) (WD 8)) ((NULL L)) (DECLARE (FIXNUM W WD))
(IF (NOT (EQ '/@ (CAR L))) (SETQ X (CAR L) W (FLATC X))
(SETQ L (CDR L) X (STRGRIND (EVAL (CAR L))) W (LENGTH X)))
(COND ((>= (+ 3 W WD) LINEL) (TERPRI) (SETQ WD 0)))
(IF (ATOM X) (PRINC X) (MAPC 'TYO X)) (TYO NSP)
(SETQ L (CDR L) WD (+ 1 W WD))))
(DEFUN EXIT () (*THROW 'EXIT NIL))
(DEFUN PQUIT () (*THROW 'PQUIT NIL))
(DEFUN YESORNO ()
(TERPRI)
(DO ANS (RETRIEVE NIL NIL) (RETRIEVE NIL NIL) NIL
(COND ((MEMQ ANS '($YES $YEP $YEAH $Y $YUP $SURE $OK $T)) (RETURN T))
((MEMQ ANS '($NO $N $NOPE $NIL)) (RETURN NIL))
(T (PRINC '|Was that a YES or a NO?|)
(TERPRI)))))
(DEFUN MREAD ()
(SETQ CLABEL (MAKLABEL $INCHAR $LINENUM)) (ADD2LNC CLABEL $LABELS)
(TERPRI) (PRLABEL CLABEL) (SET CLABEL (RETRIEVE NIL NIL)))
(DEFUN MPRINEVAL ()
(PROGB (TIME)
(SETQ TIME (RUNTIME) GCT (STATUS GCTIME) $% (MEVAL (EVAL CLABEL)))
(SETQ DLABEL (MAKLABEL $OUTCHAR $LINENUM)) (ADD2LNC DLABEL $LABELS)
(DISPLA `((MLABLE) ,DLABEL ,(SET DLABEL $%)))
(SETQ $LASTTIME (LIST '(MLIST SIMP)
(COMPUTIME (RUNTIME) TIME)
(COMPUTIME (STATUS GCTIME) GCT)))
(COND ($SHOWTIME (IF (NOT (ZEROP (CHARPOS T))) (TERPRI))
(PRINC '|time=|) (PRINC (CADR $LASTTIME)) (PRINC '| msec.|)
(TERPRI)))
(SETQ $LINENUM (1+ $LINENUM))
$%))
(DEFUN MACSYMA (FORM)
(SETQ CLABEL (MAKLABEL $INCHAR $LINENUM)) (ADD2LNC CLABEL $LABELS)
(TERPRI) (PRLABEL CLABEL) (MAPC 'PRINC (MAKSTRING FORM)) (TYO #;)
(SET CLABEL FORM) (MPRINEVAL))
(DEFUN MAKLABEL (C N) (IMPLODE (NCONC (EXPLODEN C) (EXPLODEN N))))
(DEFUN PRLABEL (L) (PRINC '|(|) (PRINC (STRIPDOLLAR L)) (PRINC '|) |))
(DEFUN CLINE (X)
(TERPRI)
(TYO TB)
(MGRIND X T)) ;MGRIND take OUTPUT file as 2nd arg -- RWK
(DEFUN CENTER (X) (DISPLA (LIST '(MLABLE) NIL X)))
(DEFUN DEFSCRIPT FEXPR (F) (PUT (CAR F) (CDR F) 'SCRIPT) (CAR F))
(DEFUN MACSYM ()
(DO ((X)) ((NOT (ATOM X)) (CAR X))
(MREAD) (SETQ X (ERRSET (MPRINEVAL)))))
(DEFUN INCHK (PAT)
(DO ((X (MREAD) (MREAD))) (NIL)
(COND ((OR (EQ '$EXIT X)(EQ '$QUIT X))
(EXIT))
((EQ '$NO X)
(TERPRI) (PRINC '|O.K., I'll do it for you.|)
(RETURN (MACSYMA PAT)))
((PALIKE PAT X) (RETURN (MPRINEVAL)))
(T (TERPRI) (PRINC '|Try again.|) (TERPRI)))))
(DEFUN OUTCHK (PAT)
(DO X (MACSYM) (MACSYM) (PALIKE PAT X)
(TERPRI) (PRINC '|Try again.|) (TERPRI)))
(DEFUN INCHKP (P)
(DO ((X (MREAD) (MREAD))(Y)) (NIL)
(IF (SETQ Y (FUNCALL P X)) (RETURN (COND ((NOT (EQ Y 'NOLABEL))
(MPRINEVAL))))
(TERPRI) (PRINC '|Try again.|))))
(DEFUN OUTCHK2 (PRED)
(DO X (MACSYM)(MACSYM)
(COND ((OR (EQ '$EXIT X) (EQ '$QUIT X)) (EXIT))
((EQ '$NO X))
((FUNCALL PRED X)))
(TERPRI) (PRINC '|Try again.|) (TERPRI)))
(DEFUN PALIKE (PAT X)
(COND ((EQ PAT X))
((EQ 'DLABEL PAT) (PALIKE DLABEL X))
((ATOM PAT) (AND (ATOM X) (EQUAL (MEVAL PAT) (MEVAL X))))
((ATOM X) NIL)
((EQ (CAAR PAT) (CAAR X))
(SETQ PAT (CDR PAT) X (CDR X))
(DO () ((NOT (PALIKE (CAR PAT) (CAR X))))
(COND ((NULL PAT) (IF (NULL X) (RETURN T)))
((NULL X) (RETURN NIL))
(T (SETQ PAT (CDR PAT) X (CDR X))))))))
(DEFUN DECODE (X L)
(COND ((NOT (EQ (TYPEP X) 'FIXNUM)) (NOR-ERR))
((OR (NOT (> X 0)) (> X (LENGTH L))) (NOR-ERR))
((SETQ X (NTHCDR (1- X) L)) (CAR X))
(T (NOR-ERR))))
(DEFUN SPELLCHECK (X L)
(COND ((NOT (ISITIN X L)) (SPELL-ERR))
(T X)))
(DEFUN MENU (OPTS)
(DO ((L OPTS (CDR L)) (I 1 (1+ I))) ((NULL L))
(PRINC I) (PRINC '| - |) (PRINC (FULLSTRIP1 (CAR L)))
(COND ((GET (CAR L) 'KIND) (TYO NSP) (PRINC (GET (CAR L) 'KIND))))
(TERPRI)))
(DEFUN SPELL-ERR () (PRINC '|No such script. Try again.|) (TERPRI))
(DEFUN OPT-ERR () (PRINC '|Illegal command to OPTIONS|) (TERPRI))
(DEFUN NOR-ERR () (PRINC '|Number out of range|) (TERPRI))
(DEFUN SELECT (L) (IF (EQ '$EXIT (SETQ L (SELECT1 L))) (PQUIT) (SCRIPT L NIL)))
(DEFUN SELECT1 (L)
(DO ((ANS)) (NIL)
(MENU L)
(SETQ ANS (RETRIEVE NIL NIL))
(COND ((FIXP ANS) (IF (SETQ ANS (DECODE ANS L)) (RETURN ANS)))
((ATOM ANS) (IF (SETQ ANS (SPELLCHECK ANS L))(RETURN ANS))))))
(DEFUN CMDCHKP (CMD)
(DO ((X (MREAD) (MREAD))) (NIL)
(COND ((OR (EQ '$EXIT X)(EQ '$QUIT X))
(EXIT))
((EQ '$NO X)
(TERPRI) (PRINC '|O.K., I'll do it for you.|)
(RETURN (MACSYMA CMD)))
((CMDCHKP2 CMD X)(RETURN (MPRINEVAL)))
(T (TERPRI) (PRINC '|Try again.|)))))
(DEFUN CMDCHKP2 (C D)
(COND ((ATOM D)
(TERPRI) (PRINC '|Oops, you typed the ; too soon.|) NIL)
((NOT (EQ (CAAR C)(CAAR D)))
(CMDCHKP3 (CAAR D)(CAAR C)) NIL)
((EQ '$% (CADR D)))
((NOT (EQUAL (CADR C)(CADR D)))
(TERPRI) (PRINC '|Use |)
(PRINC (FULLSTRIP1 (CADR C))) NIL)
((NOT (PALIKE C D)) NIL)
(T T)))
(DEFUN CMDCHKP3 (E C)
(COND ((MEMQ (CAR (PLIST E)) '(SUBR LSUBR EXPR FEXPR))
(TERPRI)(PRINC '|Please use the |)
(PRINC (FULLSTRIP1 C))
(PRINC '| command.|))
(T (TERPRI) (PRINC '|Check your spelling.|))))
(DEFUN INOUTCHK (CMD PAT)
(DO ((X (MREAD) (MREAD))) (NIL)
(COND ((ATOM X)
(TERPRI) (PRINC '|Aw, come on, this is easy.|) NIL)
((NOT (EQ CMD (CAAR X)))
(COND ((MEMQ (CAR (PLIST (CAAR X))) '(SUBR LSUBR EXPR FEXPR))
(TERPRI)(PRINC '|Please use the |)
(PRINC (FULLSTRIP1 CMD))
(PRINC '| command.|))
(T (TERPRI) (PRINC '|Check your spelling.|))) NIL)
((PALIKE PAT (MPRINEVAL))(RETURN T)))
(TERPRI) (PRINC '|Try again.|)(TERPRI)))
(DEFUN ISITIN (A L)
(COND ((ATOM L) (EQ A L))
(T (DO () ((NULL L) NIL)
(COND ((ISITIN A (CAR L)) (RETURN T))
(T (SETQ L (CDR L))))))))

280
src/emaxim/edbuf.39 Executable file
View File

@@ -0,0 +1,280 @@
;; -*- Mode: Lisp; Package: Macsyma; Ibase: 8 -*-
(macsyma-module edbuf)
;; Macsyma display-oriented expression editor
;; Buffer management functions
;; See EMAXIM;ED > and EMAXIM;EDCOM > for more information.
;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE
;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference
;; Global variables and structure definitions.
(load-macsyma-macros edmac)
;; Creating new expressions -- By copying old ones and typing in new ones
;; Add a newly created expression to some buffer. Which buffer and whether or
;; not it becomes the selected expression is determined by the numerical
;; argument.
;; Currently copy region and copy expression immediately stick things in
;; a buffer. Later they will simply push it on the kill pdl and
;; things can be brought back anyplace.
(defun add-exp-to-buffer (exp argument)
(cond
;;Empty buffer.
((and (null (expression-list current-buffer))
(or (not argument) (= argument 0)))
(setf (expression-list current-buffer) (list exp))
(make-current-exp exp))
;;If no argument given, add the expression to the buffer immediately
;;after the current one and make the new expression current.
;;With zero argument, add it after the current one but don't
;;change which one is current.
((or (not argument) (= argument 0))
(do ((e-list (expression-list current-buffer) (cdr e-list)))
((null e-list)
(ed-internal-error 'add-exp-to-buffer
"Current expression not in current buffer."))
(cond ((eq (car e-list) current-exp)
(rplacd e-list (cons exp (cdr e-list)))
(return nil))))
(cond ((null argument)
(make-current-exp exp)
(setf (current-exp-distance-from-top current-buffer)
(1+ (current-exp-distance-from-top current-buffer))))))
;;Add the expression to the end of a different buffer.
(t (let* ((buffer-name
(read-line "Buffer to insert expression into (~A): "
(buffer-name previous-buffer)))
(buffer (select-buffer buffer-name)))
(setf (expression-list current-buffer)
(nconc (expression-list current-buffer) (list exp)))
(make-current-exp exp)
(setf (current-exp-distance-from-top buffer) 100.)))))
(set-key 'copy-region "C-c")
(defcom copy-region ((argument n))
"Creates a new expression from the region and enters it in the current buffer.
With no argument, makes the new expression be current.
With 0 argument, don't change which expression is current.
With any other argument, prompt for a buffer in which to insert the new expression."
(add-exp-to-buffer (make-exp (region-as-mexp current-exp)) n))
(set-key 'copy-expression "M-c")
(defcom copy-expression ((argument n))
"Creates a new expression from the current one and enters it in the current buffer.
With no argument, makes the new expression be current.
With 0 argument, don't change which expression is current.
With any other argument, prompt for a buffer in which to insert the new expression."
(add-exp-to-buffer (make-exp (cadr (displayed current-exp))) n))
(set-key 'insert-expression "M-i")
(defcom insert-expression ((argument n)
(read-expression exp
"Insert expression: ~A"
(if n "(no evaluation) " "")))
"Creates a new expression from one read in the minibuffer.
If a numeric argument is given, don't evaluate the entered expression."
;;Since we're not calling replace-region, must do this ourselves.
(if (expression-list current-buffer)
(setq exp (subst (region-as-mexp current-exp) '$% exp)))
(if (not n) (setq exp (meval exp)))
(add-exp-to-buffer (make-exp exp) nil))
(set-key 'replace-expression "M-r")
(defcom replace-expression ((argument n)
(read-expression exp
"Replace expression: ~A"
(if n "(no evaluation) " "")))
"Replace the current expression with one read from the minibuffer.
If a numeric argument is given, don't evaluate the entered expression."
(if (not (region-contains-top-node?)) (top-level))
(replace-region n exp))
; Add yank-expression here at some point.
; Changing expressions within the buffer.
(set-key 'first-expression "M-a")
(set-key 'first-expression "M-<")
(defcom first-expression ((discard-argument))
"Makes the first expression in the buffer be the current one."
(if (not (expression-list current-buffer))
(ed-error "No expressions in this buffer."))
(make-current-exp (car (expression-list current-buffer)))
(setf (current-exp-distance-from-top current-buffer) 0))
(set-key 'last-expression "M-e")
(set-key 'last-expression "M->")
(defcom last-expression ((discard-argument))
"Makes the last expression in the buffer be the current one."
(if (not (expression-list current-buffer))
(ed-error "No expressions in this buffer."))
(make-current-exp (car (last (expression-list current-buffer))))
(setf (current-exp-distance-from-top current-buffer) 100.))
(set-key 'previous-expression "M-p")
(defcom previous-expression ()
"Selects the expression preceding the current one as current."
(if (not (expression-list current-buffer))
(ed-error "No expressions in this buffer."))
(if (eq (car (expression-list current-buffer)) current-exp)
(ed-error "Current expression is first expression in buffer."))
(do ((e-list (expression-list current-buffer) (cdr e-list)))
((eq (cadr e-list) current-exp) (make-current-exp (car e-list))))
(setf (current-exp-distance-from-top current-buffer)
(max 0 (1- (current-exp-distance-from-top current-buffer)))))
(set-key 'next-expression "M-n")
(defcom next-expression ()
"Selects the expression following the current one as current."
(if (not (expression-list current-buffer))
(ed-error "No expressions in this buffer."))
(let ((exp-list (memq current-exp (expression-list current-buffer))))
(if (null (cdr exp-list))
(ed-error "Current expression is last expression in buffer."))
(make-current-exp (cadr exp-list))
(setf (current-exp-distance-from-top current-buffer)
(1+ (current-exp-distance-from-top current-buffer)))))
(set-key 'transpose-expression "M-t")
(defcom transpose-expression ()
"Transpose the current expression with the one below it.
The current expression remains current."
(if (null (expression-list current-buffer))
(ed-error "No expressions in this buffer."))
(if (null (cdr (expression-list current-buffer)))
(ed-error "Only one expression in this buffer."))
(do ((el (expression-list current-buffer) (cdr el)))
((null el)
(ed-internal-error 'transpose-expression
"Current expression not in current buffer."))
(cond ((eq (car el) current-exp)
(if (null (cdr el))
(ed-error "Current expression is last in current buffer."))
(rplaca el (cadr el))
(rplaca (cdr el) current-exp)
(setf (current-exp-distance-from-top current-buffer)
(1+ (current-exp-distance-from-top current-buffer)))
(return nil)))))
; Deleting expressions from a buffer.
(set-key 'delete-expression "M-d")
(defcom delete-expression ()
"Delete the current expression from the current buffer.
If the current expression is the last one in the buffer, the previous one is
selected. Otherwise, the following expression is selected."
(if (null (expression-list current-buffer))
(ed-error "No expressions in this buffer."))
(cond
;;Current exp is at the top of the buffer.
((eq current-exp (car (expression-list current-buffer)))
(pop (expression-list current-buffer))
(if (expression-list current-buffer)
(make-current-exp (car (expression-list current-buffer)))))
;;Here exp-list is that part of the expression list beginning
;;just before the current expression.
(t (let ((exp-list (do ((el (expression-list current-buffer) (cdr el)))
((eq (cadr el) current-exp) el))))
(rplacd exp-list (cddr exp-list))
(cond
;;Current exp is last in buffer. Make preceding one
;;become current. If it was the only expression on the
;;screen, be careful not to let distance-from-top go negative.
((null (cdr exp-list))
(make-current-exp (car exp-list))
(setf (current-exp-distance-from-top current-buffer)
(max 0 (1- (current-exp-distance-from-top current-buffer)))))
;;If there exists an expression after the current one, make
;;it now become current.
(t (make-current-exp (cadr exp-list))))))))
(set-key 'kill-following-expressions "M-k")
(defcom kill-following-expressions ((argument n))
"Delete the expressions following the current expression.
All equations following the current expression are removed from the current
buffer. With a negative argument, those equations preceding the current
expression are removed from the current buffer. The current expression is
not removed."
(if (null (expression-list current-buffer))
(ed-error "No expressions in this buffer."))
(if (not n) (setq n 1))
(do ((el (expression-list current-buffer) (cdr el)))
((null el)
(ed-internal-error 'kill-following-expressions
"Current expression missing from current buffer."))
(cond ((eq (car el) current-exp)
(cond ((> n 0)
(rplacd el nil))
((< n 0)
(setf (expression-list current-buffer) el)
(setf (current-exp-distance-from-top current-buffer) 0)))
(return nil)))))
;; Commands for adjusting a window onto a buffer.
(set-key 'new-window '("C-l" "FORM"))
(defcom new-window ((argument n))
"Adjust the window onto the current buffer.
With no argument, completely redisplay the screen and leave the current
window where it is. With an argument of n, make the current expression
be the nth from the top of the buffer."
(if n
(setf (current-exp-distance-from-top current-buffer) n)
(full-redisplay)))
;; Changing and listing buffers
(set-key 'select-buffer "C-x" "b")
(defcom select-buffer ((discard-argument)
(read-line name
"Select Buffer (~A): "
(buffer-name previous-buffer)))
"Selects the specified buffer as the named buffer.
If carriage return is typed in response to the prompt, then the previously
selected buffer is made current. The previously selected buffer is shown
in parenthesis in the prompt."
(let ((new-buffer (if (string-equal name "")
previous-buffer
(find-buffer-from-name name))))
(cond ((null new-buffer)
(setq new-buffer (make-buffer buffer-name name))
(push new-buffer buffer-list)))
(make-current-buffer new-buffer)
new-buffer))
(defun find-buffer-from-name (buffer-name)
(do ((bl buffer-list (cdr bl)))
((null bl) nil)
(if (string-equal buffer-name (buffer-name (car bl)))
(return (car bl)))))
(set-key 'list-buffers "C-x" "C-b")
(defcom list-buffers ((discard-argument))
"Lists the currently active buffers."
(cursorpos 0 0)
(cursorpos 'L) ;Clear to EOL
(format t " # ~15A~15A~15A~%" "Buffer" "(Mode)" "Expressions")
(cursorpos 'L)
(format t "~%")
(do ((bl (reverse buffer-list) (cdr bl))
(i 1 (1+ i)))
((null bl))
(cursorpos 'L)
(format t "~3D ~15A~15A~4D~%"
i
(buffer-name (car bl))
(buffer-mode (car bl))
(length (expression-list (car bl)))))
(setq screen-exp-list nil) ;Kludge to say that screen image
(setq supress-redisplay t)) ;destroyed.

857
src/emaxim/edctl.22 Executable file
View File

@@ -0,0 +1,857 @@
;; -*- Mode: Lisp; Package: Macsyma; Ibase: 8 -*-
(macsyma-module edctl)
;; Macsyma display-oriented expression editor
;; Control function package
;; See CWH;ED > and CWH;EDCOM > for more information.
;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE
;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference
;; Global variables and structure definitions.
(load-macsyma-macros edmac)
;; Initialize the static variables. These are preserved between invocations of
;; the editor.
(setq buffer-list nil
mark-pdl nil
kill-pdl nil
; current-exp nil
supress-redisplay nil
%kbd-control #o400
%kbd-meta #o1000
%kbd-control-meta (+ %kbd-control %kbd-meta)
)
(defun $displayedit (&rest exps)
(unwind-protect (progn (ed-prologue)
(display-edit exps))
(ed-epilogue)))
(defun display-edit (exp-list &aux buffer)
(cond (exp-list
(setq exp-list (mapcar #'make-exp exp-list))
(setq buffer (make-buffer buffer-name (make-buffer-name)
expression-list exp-list
current-exp (car exp-list)))
(push buffer buffer-list)
(make-current-buffer buffer))
((null buffer-list)
(setq buffer (make-buffer buffer-name (make-buffer-name)))
(push buffer buffer-list)
(make-current-buffer buffer)))
(full-redisplay)
(*catch 'exit-editor (ed-command-loop))
(and (boundp 'current-exp)
(cadr (body current-exp))))
;; Create an expression from one in the macsyma internal format. ED format
;; expressions are usually labelled "exp". Those in macsyma format are
;; labelled "mexp".
(defun make-exp (mexp &optional (label nil))
(cond (label (setq label (make-symbol label)))
(t (setq label (makelabel $outchar))
(setq $linenum (1+ $linenum))))
(setq mexp (list nil (nformat-all mexp)))
(setq mexp (make-expression body mexp displayed mexp region mexp))
(label-exp mexp label)
mexp)
; For changing an expression's label.
(defun label-exp (exp label)
(mset label (cadr (body exp)))
(setf (expression-label exp) label))
; Used for switching between buffers.
(defun make-current-buffer (buffer)
(cond ((not (and (boundp 'current-buffer)
(eq buffer current-buffer)))
(setq previous-buffer
(if (boundp 'current-buffer) current-buffer buffer))
(setq current-buffer buffer)
(if (expression-list buffer)
(make-current-exp (current-exp buffer))))))
;; Used for switching between expressions within a given buffer.
;; Makes "exp" be the current expression. Note that "current expression"
;; is defined with respect to a buffer.
(defun make-current-exp (exp)
(cond ((not (and (boundp 'current-exp)
(eq exp current-exp)))
(if (boundp 'current-exp)
(setf (region-boxed? current-exp) nil))
(setq current-exp exp)
(setf (region-boxed? exp) t)
(setf (current-exp current-buffer) exp)
; (set '$% (cadr (region exp)))
; (set '$%% (cadr (displayed exp)))
; (set '$%%% (cadr (body exp)))
)))
;; Generates new buffer names.
;; (format nil ...) creates a string. Format is special and
;; interned on the macsyma package in the lisp machine.
(setq buffer-name-count 1)
(defun make-buffer-name ()
(cond ((null buffer-list) "Main")
(t (setq buffer-name-count (1+ buffer-name-count))
(format nil "Buffer ~D" buffer-name-count))))
; Simple, isn't it. Well, it won't be for long.
(defun ed-command-loop ()
(do ()
(nil)
(*catch 'command-loop
(ed-dispatch (read-key t nil) single-char-table nil))
(cond (supress-redisplay (setq supress-redisplay nil))
((not (zerop (listen)))) ;Don't redisplay on typeahead
(need-full-redisplay (full-redisplay))
(t (redisplay)))))
;; Takes a character in internal format and a dispatch table and numeric
;; argument. Looks up function to find what to do with arg. When echoing
;; character, should use raw output so character 7 gets printed as pi and not a
;; bell.
(defun ed-dispatch (char table arg)
(declare (fixnum char))
(let* ((function (get-key table char)))
(if (not function)
(if (eq table single-char-table)
(ed-error "Undefined key: ~A"
(char-to-descriptor char))
(ed-error "Undefined key: Control-x ~A"
(char-to-descriptor char)))
(ed-dispatch-command function arg char))))
;; Takes a command defined with DEFCOM, a numeric argument (if any) and an
;; invoking character (if any) and calls the command.
(defun ed-dispatch-command (function arg char)
(if (not (fboundp function))
(if char
(ed-error "Undefined command on ~A: ~A"
(char-to-descriptor char)
function)
(ed-error "Undefined command: ~A" (symbol-to-descriptor function))))
(let ((arg-action (get function 'ed-arg-action))
(char-action (get function 'ed-char-action))
(arg-list nil))
(if (eq arg-action 'pass) (push arg arg-list))
(if (eq char-action 'pass) (push char arg-list))
(setq arg-list (nreverse arg-list))
(caseq arg-action
((pass discard) (apply function arg-list))
(t (if arg
(dotimes (i (abs (fixnum-identity arg)))
(apply function arg-list))
(apply function arg-list)))
)))
;; For signalling errors. Throws back into command loop and does a redisplay
;; immediately after.
(defun ed-error (&rest args)
(cond ((not (null args))
(minibuffer-clear)
(apply 'minibuffer-print args)))
(tv-beep)
(*throw 'command-loop nil))
(defun ed-internal-error (function message &optional datum)
(dotimes (i 3) (tv-beep))
(minibuffer-clear)
(minibuffer-print
"Macsyma Display Toplevel internal error -- please report to CWH or RZ:~%")
(if datum
(minibuffer-print "~A: ~A -- ~S" function message datum)
(minibuffer-print "~A: ~A" function message))
(*throw 'command-loop nil))
;; Redisplay
;; The purpose of this function is to look at what is currently on the screen
;; and what should be on the screen. It finds out what is different between
;; them and updates the screen. This algorithm can become arbitrarily hairy.
;; Right now, it simply recognizes EQness of expressions and makes no attempt
;; to optimize the redisplay of a single expression.
;; Screen state information:
;; If this list gets too long, may want to create a structure.
;;
;; screen-exp-list -- list of expressions displayed on the screen.
;; Equation at the top of this list is one at the top of the screen.
;; The needed information for each expression is the displayed region,
;; the label, the reveal depth, and whether its command region is
;; boxed. If its command region is boxed, then we must know the command
;; region and the region-length (i.e. where the box is).
;;
;; screen-buffer-name -- name displayed
;; screen-exp-list-length -- expression count displayed.
;; Stolen from MRG;DISPLA. Find the height in characters of an expression.
;; Later, we may want to save the dimension list returned to optimize
;; redisplay. This will lose completely if the expression has to be broken
;; across two lines -- fix later. We have a big problem here -- displa is
;; assuming that the expression is simplified, but we are handing it
;; non-simplified expressions. Either we can patch displa or start simplifying
;; everything.
(defun dimension-exp (exp)
(if (region-boxed? exp) (box-region exp))
(let ((displayp t) (mratp (checkrat exp)) (^r ^r) (maxht 1) (maxdp 0)
(width 0) (height 0) (depth 0) (level 0) (size 2) (break 0) (right 0)
(lines 1) bkpt (bkptwd 0) (bkptht 1) (bkptdp 0) (bkptout 0) (bkptlevel 0)
more-^w)
(checkbreak (dimension (cadr (displayed exp)) nil 'mparen 'mparen 0 0)
width)
(if (region-boxed? exp) (unbox-region exp))
(max (+ maxht maxdp) (+ bkptht bkptdp))))
;; Produce a new list of expressions to appear on the screen. Heights
;; of expressions stored in them. The expressions in this list are
;; the actual expressions in the buffer. The screen-list, however,
;; is a copy of a previously generated list.
;; If current buffer is empty, returns nil.
(defun generate-new-screen-image
(&aux (upward-exp-list nil) ;Exps above the current exp
(downward-exp-list nil) ;Exps below the current exp
total-height ;How many lines needed
screen-image) ;List of exps to display
(cond ((expression-list current-buffer)
(setq total-height (dimension-exp current-exp))
(setq screen-image (list current-exp))
(setf (expression-height current-exp) total-height)
;;Split the expression list into two lists -- those above the
;;current expression (in reverse order) and those below the current
;;expression.
(do ((el (expression-list current-buffer) (cdr el)))
((eq (car el) current-exp) (setq downward-exp-list (cdr el)))
(push (car el) upward-exp-list))
;;If distance from the top is less than the number of expressions
;;above us, cut them off.
(if (> (length upward-exp-list)
(current-exp-distance-from-top current-buffer))
(setq upward-exp-list
(firstn (current-exp-distance-from-top current-buffer)
upward-exp-list)))
;;Now redimension every equation on the screen. Since some
;;equations above us may have grown, the distance from the top will
;;be the same it was before or will decrease.
(setf (current-exp-distance-from-top current-buffer) 0)
(*catch 'screen-full
(progn
(do ((ul upward-exp-list (cdr ul)))
((null ul))
(setf (expression-height (car ul)) (dimension-exp (car ul)))
(setq total-height (+ total-height
(expression-height (car ul)) 1))
;;DISPLA clobbers line following last line of expression
;;displayed.
(if (>= (+ total-height 1) expr-area-height)
(*throw 'screen-full t))
(push (car ul) screen-image)
(setf (current-exp-distance-from-top current-buffer)
(1+ (current-exp-distance-from-top current-buffer))))
(do ((dl downward-exp-list (cdr dl)))
((null dl))
(setf (expression-height (car dl)) (dimension-exp (car dl)))
(setq total-height (+ total-height
(expression-height (car dl)) 1))
(if (>= (+ total-height 1) expr-area-height)
(*throw 'screen-full t))
(setq screen-image (nconc screen-image (list (car dl)))))))
screen-image)))
;; The real thing. Maybe we should be storing vertical position on screen in
;; each expression.
(defun redisplay ()
(let ((new-exp-list (generate-new-screen-image)))
;;Redisplay the expression region.
(do ((old-list screen-exp-list (cdr old-list))
(new-list new-exp-list (cdr new-list))
(old-height-from-top 0 (+ old-height-from-top
(expression-height (car old-list)) 1))
(new-height-from-top 0 (+ new-height-from-top
(expression-height (car new-list)) 1)))
(nil)
(cond
;;Just as many old equations as new. Clear whatever of the
;;bottom portion of the old equations that might be left over.
((and (null old-list) (null new-list))
(if (> old-height-from-top new-height-from-top)
(dctl-clear-lines new-height-from-top
(- old-height-from-top new-height-from-top)))
(return nil))
;;More new equations than old. Quit comparison and finish
;;displaying new equations.
((null old-list)
(do ((list new-list (cdr list))
(height-from-top new-height-from-top
(+ height-from-top
(expression-height (car list)) 1)))
((null list))
(display-expression (car list) height-from-top))
(return nil))
;;More old equations than new. Quit comparison and erase from
;;current position to last equation displayed.
((null new-list)
(do ((list old-list (cdr list))
(lines-to-clear 0 (+ 1 lines-to-clear
(expression-height (car list)))))
((null list)
(dctl-clear-lines new-height-from-top (1- lines-to-clear))))
(return nil))
;;Got the same expressions on the same line. Skip to next
;;expression.
((and (= old-height-from-top new-height-from-top)
(same-exp-image (car new-list) (car old-list))))
;;Display the expression on the current line if we can't scroll
;;regions of the screen.
(t (display-expression (car new-list) new-height-from-top))
))
; ;;Display the expression on the current line if we can't scroll
; ;;regions of the screen.
; ((not idel-lines-available?)
; (display-expression (car new-list) new-height-from-top))
; ;;First look to see if the new expression is anywhere below us
; ;;on the screen. If it is, bring it up to where we are.
; ((do ((ol (cdr old-list) (cdr ol))
; (lines-to-scroll (1+ (expression-height (car old-list)))))
; ((null ol) nil)
; (cond ((same-exp-image (car new-list) (car ol))
; (dctl-scroll-region-up ...)
; (setq old-list ol)
; (return t)))))
; ;;Otherwise, see if the old expression is anywere below is in
; ;;the new screen image. If so, move it down to where it belongs.
(setq screen-exp-list (mapcar 'rdis-copy-expression new-exp-list))
;;Redisplay the mode line.
(cond ((or (not (eq screen-buffer-name (buffer-name current-buffer)))
(not (= screen-exp-list-length
(length (expression-list current-buffer)))))
(display-mode-line)
(setq screen-buffer-name (buffer-name current-buffer))
(setq screen-exp-list-length
(length (expression-list current-buffer)))))
;;Home the cursor. ITS won't send any characters if the cursor
;;is already up there.
(cursorpos 0 0)))
;; This is really a kludge for our current mode of using this thing. We're
;; going to need something better if people start hacking macros, like EQUAL of
;; the displayed portions of the two expressions, whereby the screen expression
;; has been entirely copied.
(defun same-exp-image (new-exp screen-exp)
(and (eq (displayed new-exp) (displayed screen-exp))
(eq (expression-label new-exp) (expression-label screen-exp))
(= (reveal-depth new-exp) (reveal-depth screen-exp))
(= (length (operand new-exp)) (length (operand screen-exp)))
(or (and (not (region-boxed? new-exp))
(not (region-boxed? screen-exp)))
(and (region-boxed? new-exp)
(region-boxed? screen-exp)
(eq (cadr (region new-exp)) (cadr (region screen-exp)))
(eq (save-pdl new-exp) (save-pdl screen-exp))
(= (region-length new-exp) (region-length screen-exp))))))
;; This function only used by the redisplay for storing screen state
;; information, so don't have to copy whole thing. Maybe we should create a
;; special structure for the screen image. Region and region-length only have
;; to be remembered for screen-current-exp.
(defun rdis-copy-expression (exp)
(make-expression displayed (displayed exp)
operand (append (operand exp) nil)
expression-label (expression-label exp)
expression-height (expression-height exp)
reveal-depth (reveal-depth exp)
region-boxed? (region-boxed? exp)
;;The followning slots only needed for the current
;;expression. Copy region cons so that the screen
;;version won't also get clobbered. Displaying
;;this won't work since region not part of
;;displayed.
save-pdl (save-pdl exp)
region (list nil (cadr (region exp)))
region-length (region-length exp)
))
;; Completely restores the screen image.
;; Later make this move current expression to the top of the screen.
(defun full-redisplay ()
(setq need-full-redisplay nil)
(cursorpos 'C) ;Clear screen
(let ((screen-image (generate-new-screen-image)))
(display-expressions screen-image)
(setq screen-exp-list
(mapcar 'rdis-copy-expression screen-image)))
(display-mode-line)
(minibuffer-clear)
(cursorpos 0 0)
(setq screen-buffer-name (buffer-name current-buffer))
(setq screen-exp-list-length (length (expression-list current-buffer)))
)
;; Dispatch Tables
;;
;; The expression editor's idea of what a character is follows that of the Lisp
;; Machine. The low order eight bits of the character is a single key portion,
;; with 0-177 being alphanumeric. Bits 9 and 10 are set if control key or
;; meta keys were depressed, respectively. These bits can also be set for
;; a given character by typing a control, meta or control-meta prefix.
;; The item associated with each character is a symbol, which contains
;; a function to call and associated information about that function.
;; The "single-char-table" array contains those functions which are associated
;; with a single keystroke command.
;; 0-177 Alphanumeric characters
;; 200-377 Other single-key characters
;; 400-777 Control characters
;; 1000-1377 Meta characters
;; 1400-1777 Control-Meta characters (not used currently)
;; The "c-x-prefix-table" array contains those functions associated with a control-x
;; prefix.
;; Stick this elsewhere.
#+MacLisp (defmacro make-array (size) `(array nil t ,size))
;; Don't clobber the table if it already exists. For debugging purposes.
(cond ((not (boundp 'single-char-table))
(setq single-char-table-size #o1400)
(setq single-char-table (make-array single-char-table-size))
(setq c-x-prefix-table-size #o1400)
(setq c-x-prefix-table (make-array c-x-prefix-table-size))))
;; Take a description of the form Control-Meta-rubout and return the corresponding
;; character object.
(defun descriptor-to-char (descriptor)
(setq descriptor (string descriptor))
(let ((character 0)
(symbolic-name))
(if (or (string-search "C-" descriptor)
(string-search "Control-" descriptor))
(setq character (+ 1_8 character)
descriptor (substring descriptor
(1+ (string-search "-" descriptor)))))
(if (or (string-search "M-" descriptor)
(string-search "Meta-" descriptor))
(setq character (+ 1_9 character)
descriptor (substring descriptor
(1+ (string-search "-" descriptor)))))
(setq symbolic-name (assq (intern (make-symbol (string-upcase descriptor)))
descriptor-to-char-alist))
(if symbolic-name
(+ character (cdr symbolic-name))
(+ character (character descriptor)))))
;; Take a character object and return a desciption.
;; On lispm, use special characters.
(defun char-to-descriptor (char &optional (brief nil))
(let ((descriptor "")
(symbolic-name))
(if (not (= 0 (logand char %kbd-control)))
(setq descriptor (string-append descriptor (if brief "C-" "Control-"))))
(if (not (= 0 (logand char %kbd-meta)))
(setq descriptor (string-append descriptor (if brief "M-" "Meta-"))))
(setq symbolic-name (rassoc (logand char #o377) descriptor-to-char-alist))
(if symbolic-name
(string-append descriptor (string (car symbolic-name)))
(string-append descriptor (string (logand char #o 377))))))
(setq descriptor-to-char-alist
'((ALT . #o33) (SPACE . #o40) (CALL . #o203)
(BREAK . #o201) (CLEAR . #o202) (ESCAPE . #o204)
(BACKNEXT . #o205) (HELP . #o206) (RUBOUT . #o207)
(BS . #o210) (TAB . #o211) (LINE . #o212)
(VT . #o213) (FORM . #o214) (RETURN . #o215)))
;; Key binding functions
;; Single characters are specified as C-M-A or Control-Meta-A. Case matters in
;; the final letter. "C-" and "M-" set control and meta bits respectively.
;; (set-key 'exit-editor "C-x" "C-c") will associate "exit-editor" with C-x
;; C-c. Prefix characters may want to be generalized later on.
(defun set-key (function first-char &optional (second-char nil) &aux table)
(cond (second-char (setq table c-x-prefix-table)
(setq first-char second-char))
(t (setq table single-char-table)))
(if (atom first-char)
(aset function table (descriptor-to-char first-char))
(mapcar #'(lambda (key)
(aset function table (descriptor-to-char key)))
first-char)))
(defcom assign-key ((discard-argument)
(read-line command "Command Name: ")
(read-key key "On Key: "))
"Associate a single key with a command.
The name of the command is asked for first, then the key to associate it
with. When asked for the key, actually type the key you wish to place the
command on, not a description of the key. "
(setq command (descriptor-to-symbol command))
(let ((table))
(cond ((= key (descriptor-to-char "Control-x"))
(setq key (read-key nil t " (prefix character) "))
(setq table c-x-prefix-table))
(t (setq table single-char-table)))
(aset command table key)))
;; Returns function associated with a given key. If function not there or
;; reference beyond array bounds, then return nil.
(defun get-key (table char)
(declare (fixnum char))
(cond ((eq table single-char-table)
(and (< char single-char-table-size) (aref single-char-table char)))
((eq table c-x-prefix-table)
(and (< char c-x-prefix-table-size) (aref c-x-prefix-table char)))
(t (ed-internal-error 'get-key "Random table" table))))
;; Read a virtual character from the minibuffer, i.e. a single character from
;; the Lisp Machine's point of view. Note that CONTROL-PREFIX, META-PREFIX,
;; and CONTROL-META-PREFIX are now wired in functions.
;; Note on terminology here: A key is a virtual character -- something that
;; can be typed on a 12-bit keyboard in a single keystroke. A character
;; is something that can be typed on the keyboard in use in a single keystroke.
(defun read-key (&optional (clear-on-multiple-keystroke nil) (echo-key t)
&rest format-args)
(setq *multiple-keystroke-char-typed* nil)
(if format-args (apply 'minibuffer-print format-args))
(let* ((char (read-char))
(function (get-key single-char-table char))
(control-bit 0)
(meta-bit 0))
(cond ((memq function '(control-prefix meta-prefix control-meta-prefix))
(setq *multiple-keystroke-char-typed* t)
(if clear-on-multiple-keystroke (minibuffer-clear))
(cond ((eq function 'control-prefix)
(minibuffer-print "Control-")
(setq control-bit %kbd-control))
((eq function 'meta-prefix)
(minibuffer-print "Meta-")
(setq meta-bit %kbd-meta))
((eq function 'control-meta-prefix)
(minibuffer-print "Control-Meta-")
(setq control-bit %kbd-control meta-bit %kbd-meta)))
(setq char (read-char))))
;;If a multiple keystroke character is typed, the key is always echoed.
;;Global used in lieu of multiple value return.
(if (or *multiple-keystroke-char-typed* echo-key)
(minibuffer-print "~A" (char-to-descriptor char)))
(+ char control-bit meta-bit)))
;; Prefix Keys
(set-key 'control-prefix "C-^")
(set-key 'meta-prefix "")
(putprop 'control-prefix
"Sets the control bit of the next character typed.
For example, typing this key and then typing /"A/" is equivalent
to typing /"Control-A/"." 'ed-documentation)
(putprop 'meta-prefix
"Sets the meta bit of the next character typed.
For example, typing this key and then typing /"A/" is equivalent
to typing /"Meta-A/"." 'ed-documentation)
(set-key 'control-x-prefix "C-x")
(defcom control-x-prefix ((argument n))
"This command is a prefix character."
;;First arg to read-key means clear screen if no argument present
;;Second arg means always echo character typed.
;;Third arg is message.
(if (not n) (minibuffer-clear))
(ed-dispatch (read-key nil t "Control-x ") c-x-prefix-table n))
; Argument accumulators
(set-key 'accumulate-argument
'("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
"C-0" "C-1" "C-2" "C-3" "C-4" "C-5" "C-6" "C-7" "C-8" "C-9"
"M-0" "M-1" "M-2" "M-3" "M-4" "M-5" "M-6" "M-7" "M-8" "M-9"))
; Fix this up later to work like C-U in clearing to end of line.
; Must have character redisplay by then, though.
(defcom accumulate-argument ((argument n) (character c))
"This forms part of the next command's numeric argument."
(setq c (- (logand c #o377) #/0))
(cond ((not n) (minibuffer-clear)
(minibuffer-print "Argument: ~D " c))
;; This is a special case hack to distinguish "-" from "-1",
;; i.e. so that "-3" does not become -13.
;; If we come here, "Argument: -1 " is displayed.
((eq n 'negation)
(cond ((not (= c 1))
(dotimes (i 2) (cursorpos 'X))
(minibuffer-print "~D " c))))
((= n 0)
(cond ((not (= c 0))
(dotimes (i 2) (cursorpos 'X))
(minibuffer-print "~D " c))))
(t (cursorpos 'B) ;Backward char
(minibuffer-print "~D " c)))
(setq n (cond ((not n) c)
((eq n 'negation) (- c))
((< n 0) (+ (* n 10.) (- c)))
(t (+ (* n 10.) c))))
(let ((char (read-key nil nil)))
(if (not (or (memq (get-key single-char-table char)
'(accumulate-argument multiply-argument-by-4
negate-argument))
*multiple-keystroke-char-typed*))
(minibuffer-print "~A" (char-to-descriptor char)))
(ed-dispatch char single-char-table n)))
(set-key 'multiply-argument-by-4 "C-u")
(defcom multiply-argument-by-4 ((argument n))
"Multiply the number of times to do the following command by 4."
(cond (n (cursorpos minibuffer-vpos 10.)
(cursorpos 'L)
(minibuffer-print "~D " (* n 4)))
(t (minibuffer-clear)
(minibuffer-print "Argument: 4 ")))
(let ((char (read-key nil nil)))
(if (not (or (memq (get-key single-char-table char)
'(accumulate-argument multiply-argument-by-4
negate-argument))
*multiple-keystroke-char-typed*))
(minibuffer-print "~A" (char-to-descriptor char)))
(ed-dispatch char single-char-table (if n (* n 4) 4))))
(set-key 'negate-argument '("-" "C--" "M--"))
(defcom negate-argument ((argument n))
"Negate the numeric argument."
(cond (n (cursorpos minibuffer-vpos 10.)
(cursorpos 'L)
(minibuffer-print "~D " (- n)))
(t (minibuffer-clear)
(minibuffer-print "Argument: -1 ")))
(let ((char (read-key nil nil)))
(caseq (get-key single-char-table char)
(accumulate-argument
(ed-dispatch char single-char-table (if n (- n) 'negation)))
((multiply-argument-by-4 negate-argument)
(ed-dispatch char single-char-table (if n (- n) -1)))
(t (if (not *multiple-keystroke-char-typed*)
(minibuffer-print "~A" (char-to-descriptor char)))
(ed-dispatch char single-char-table (if n (- n) -1))))))
; Documentation Commands
; Translates "FORWARD-BRANCH" to "Forward Branch" for purposes of printing.
(defun symbol-to-descriptor (symbol)
(setq symbol (string symbol))
(do ((old-string symbol (substring old-string (1+ index)))
(new-string "" (string-append new-string
(string-capitalize
(substring old-string 0 index))
" "))
(index))
(nil)
(setq index (string-search "-" old-string))
(if (not index)
(return (string-append new-string (string-capitalize old-string))))))
; We really need a general purpose translation function. Write one at some point.
; (setq descriptor (string-translate descriptor '(#/-) '(#\SP)))
(defun descriptor-to-symbol (descriptor)
(setq descriptor (string-upcase (string-trim '(#\SP) (string descriptor))))
(do ((old-string descriptor (substring old-string (1+ index)))
(new-string "" (string-append new-string (substring old-string 0 index) "-"))
(index))
(nil)
(setq index (string-search " " old-string))
(if (not index)
(return (intern (string-append new-string old-string))))))
;; Turn off interrupts here so can describe control-g.
;; *** Note *** A quickie kludge was added here to need-full-redisplay
;; to allow multiple key descriptions without redisplay. Be sure to
;; fix asap. Right thing to do is record how many lines of current window
;; have been messed up and only redisplay as needed.
(set-key 'describe-key '("?" "C-?" "M-?" "HELP"))
(defcom describe-key ((discard-argument) (read-key first-char "Describe Key: "))
"Describes the command associated with a given key."
(let ((function)
(second-char))
(setq function (get-key single-char-table first-char))
;; Need a more general way of doing this.
(when (eq function 'control-x-prefix)
(setq second-char (read-key nil t " (prefix character) "))
(setq function (get-key c-x-prefix-table second-char)))
;;Flush when we get multiple windows in.
(if (and need-full-redisplay (fixp need-full-redisplay))
(cursorpos need-full-redisplay 0)
(cursorpos 0 0))
(cursorpos 'L)
(format t "~A" (char-to-descriptor first-char))
(if second-char
(format t " ~A" (char-to-descriptor second-char)))
(format t " is ~A.~%"
(if function (symbol-to-descriptor function) "an undefined key"))
(if function
(format t "~A~%"
(or (get function 'ed-documentation)
"No documentation found."))))
(setq supress-redisplay t)
;;Change this to (setq screen-exp-list nil) when multiple windows are in.
(setq need-full-redisplay (car (cursorpos))))
(defcom describe-command ((discard-argument)
(read-line name "Describe Command: "))
"Describes a command specified by its long name."
(cursorpos 0 0)
(cursorpos 'L)
(setq name (descriptor-to-symbol name))
(if (get name 'ed-documentation)
(format t "~A~%" (get name 'ed-documentation))
(format t "No documentation found for ~A.~%" name))
(setq supress-redisplay t)
(setq need-full-redisplay t))
(defcom list-keys ((discard-argument))
"Lists those keys which are associated with editor commands."
(cursorpos 0 0)
(cursorpos 'L)
(make-key-listing #+lispm standard-output #+maclisp tyo)
;;Supress redisplay of this command, but do a full redisplay after
;;next command is typed.
(setq supress-redisplay t)
(setq need-full-redisplay t))
; Once we start maintaining a list of commands.
; (defcom list-commands ((discard-argument))
; "Lists all commands which are part of the display toplevel.
; If the command is associated with a key, then the key is also listed. Ony
; the first line of documentation for each command is printed. For more
; documentation on a command, use the /"Describe Command/" extended command."
; Walk through the key dispatch tables and print the key, its binding,
; and the first line of documentation.
(defun make-key-listing (stream)
(format stream "Macsyma Display Toplevel -- Command Summary~2%")
(format stream "Single Character Commands~2%")
(make-key-listing-table single-char-table single-char-table-size stream)
(format stream "~2%Control-x Prefix Commands~2%")
(make-key-listing-table c-x-prefix-table c-x-prefix-table-size stream))
; Search a single table.
(defun make-key-listing-table (table size stream &aux function documentation)
(format stream "~8A~30A~A~%" "Key" "Command" "Description")
(format stream "~8A~30A~A~%" "---" "-------" "-----------")
(do i 0 (1+ i) (= i size)
;;Don't display Sail characters if using an Ascii keyboard.
(setq function
#-lispm (if (or 12-bit-kbd-available?
(= i #o33)
(> i #o37))
(get-key table i))
#+lispm (get-key table i))
(cond (function
(setq documentation (get function 'ed-documentation))
(if documentation
(setq documentation
(substring documentation 0
(min (- linel 38.)
(or (string-search-char #\CR documentation)
(string-length documentation))))))
(format stream "~8A~30A~A~%"
(char-to-descriptor i t)
(symbol-to-descriptor function)
(if documentation documentation "Not documented."))))))
; Miscellaneous stuff.
(set-key 'extended-command-prefix "M-x")
(defcom extended-command-prefix
((argument n)
(read-line command
"Extended Command: ~A"
(if n (format nil "(argument = ~D) " n) "")))
"Invoke a command by specifying its long name."
(setq command (descriptor-to-symbol command))
(ed-dispatch-command command n nil))
(set-key 'command-quit "C-g")
(set-key 'command-quit "C-x" "C-g")
(defcom command-quit ((discard-argument))
"Abort the current command and return to editor toplevel."
(minibuffer-clear))
(set-key 'no-op " ")
(defcom no-op ((discard-argument))
"Does nothing other than redisplaying the screen.
Useful for reconstructing the screen image after a message or documentation
has been printed." nil)
(set-key 'debug-it "~")
(defcom debug-it ((discard-argument))
"Break into Lisp. Control-G takes you back to editor toplevel."
(setq need-full-redisplay t)
#+its (enable-echoing)
#+its (unwind-protect (break debug) (disable-echoing))
#+lispm (break debug))
(set-key 'exit-editor "C-z")
(set-key 'exit-editor "C-x" "C-c")
(defcom exit-editor ((discard-argument))
"Exit the editor."
(*throw 'exit-editor nil))
;; Rethink this. Need ways to eval Lisp and Macsyma forms.
;; What about typing monitor commands?
(set-key 'eval-macsyma-expression "C-x" "C-e")
(set-key 'eval-macsyma-expression "M-")
(defcom eval-macsyma-expression ((discard-argument)
(read-expression exp "Evaluate: "))
"Evaluate a Macsyma expression."
(if (expression-list current-buffer)
(setq exp (subst (region-as-mexp current-exp) '$% exp)))
(meval exp))
(set-key 'return-to-emacs "C-x" "z")
(defcom return-to-emacs ((discard-argument))
"Return to Emacs from Macsyma."
#+its (setq need-full-redisplay t)
(minibuffer-print " [into emacs] ")
#+its (ledit)
#+lispm (ed)
)

656
src/emaxim/edexp.174 Executable file
View File

@@ -0,0 +1,656 @@
;; -*- Mode: Lisp; Package: Macsyma; Ibase: 8 -*-
(macsyma-module edexp)
;; Macsyma display-oriented expression editor
;; Expression Manipulation functions
;; See EMAXIM;ED > and EMAXIM;EDCOM > for more information.
;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE
;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference
;; Global variables and structure definitions.
(load-macsyma-macros edmac)
;; Expression manipulation primitives
(defun region-as-mexp (exp)
(if (= (region-length exp) 1)
(cadr (region exp))
(cons (list (operator exp))
(firstn (region-length exp) (cdr (region exp))))))
; Modify the current level of the expression so that the region is boxed.
; Needed for dimensioning and displaying the current expression.
(defun box-region (exp)
(rplacd (region exp)
(cons ($box (region-as-mexp exp))
(nthcdr (1+ (region-length exp)) (region exp)))))
; Undo the effects of the above.
(defun unbox-region (exp)
(let ((boxed-exp (cadr (cadr (region exp)))))
(cond ((= 1 (region-length exp))
(rplaca (cdr (region exp)) boxed-exp))
(t (rplacd (last boxed-exp) (cddr (region exp)))
(rplacd (region exp) (cdr boxed-exp))))))
; Note: Save pdl format has been changed. For CDR transitions, it is
; (CDR . <previous region>). For CAR transitions, it is
; (CAR <previous region> . <previous operand>).
(defun pop-save-pdl ()
(if (null (save-pdl current-exp))
(ed-internal-error 'pop-save-pdl "Attempt to pop save pdl when empty.")
(let ((top-of-pdl (pop (save-pdl current-exp))))
(caseq (car top-of-pdl)
(CDR (setf (region current-exp) (cdr top-of-pdl)))
(CAR (setf (region current-exp) (cadr top-of-pdl))
(setf (operand current-exp) (cddr top-of-pdl))
(setf (operator current-exp) (caar (cddr top-of-pdl))))
(t (ed-internal-error 'pop-save-pdl "Garbage on save pdl" top-of-pdl))))))
;; Movement commands -- modifying the expression region.
;; Later, check iteration count and do the first two checks only
;; the first time around. Make empty expression-list check be option
;; to defcom?
(set-key 'forward-branch '("C-f" |/|))
(defcom forward-branch ()
"Move the region forward a single branch at this level.
The width of the region does not change. If the region
contains the last branch of this level, no action is taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(if (region-contains-last-branch?)
(ed-error "Region contains the last branch of this level."))
(push `(CDR . ,(region current-exp))
(save-pdl current-exp))
(pop (region current-exp)))
(set-key 'backward-branch '("C-b" |/|))
(defcom backward-branch ()
"Move the region backward a single branch at this level.
The width of the region does not change. If the region
contains the first branch of this level, no action is taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(if (region-contains-first-branch?)
(ed-error "Region contains the first branch of this level."))
(pop-save-pdl))
(set-key 'previous-level '("C-p" |/ |))
(defcom previous-level ()
"Move the region up to the previous level.
The width of the region becomes a single branch. If the region already
is at the top level of the current expression, no action is taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(do ()
((eq (caar (save-pdl current-exp)) 'CAR))
(pop-save-pdl))
(pop-save-pdl)
(setf (region-length current-exp) 1))
(set-key 'next-level '("C-n" |/|))
(defcom next-level ()
"Move the region down to the next level.
The region becomes a single branch wide. If the region
is at a terminal node of the current expression, i.e. contains
a single symbol, no action is taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-terminal-node?)
(ed-error "Region contains a terminal branch."))
(push `(CAR ,(region current-exp) . ,(operand current-exp))
(save-pdl current-exp))
(setf (region current-exp) (cadr (region current-exp)))
(setf (operand current-exp) (region current-exp))
(setf (operator current-exp) (caar (operand current-exp)))
(setf (region-length current-exp) 1)
)
(set-key 'top-level '("<" |/|))
(defcom top-level ((discard-argument))
"Move the region up to the top level.
The region becomes a single branch wide, and contains the entire expession."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(do ()
((region-contains-top-node?))
(previous-level)))
(set-key 'grow-region "M-f")
(defcom grow-region ()
"Increase the width of the region by one.
Extend the region forward to include the next branch at this level. If the
region would then include the entire expression, then the region is moved up
a level. If the region already contains the entire expression, no action is
taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
;;Wrong kind of operator.
(if (not (memq (operator current-exp) '(MPLUS MTIMES MNCTIMES MLIST)))
(ed-error "Cannot grow the region at this node."))
;;Region at far right end of the expression, but doesn't contain
;;the first branch.
(if (region-contains-last-branch?)
(ed-error "Region contains the last branch of this level."))
(cond
;;Extension would make region include every branch at this level,
;;so move up a level.
((= (length (cdr (operand current-exp)))
(1+ (region-length current-exp)))
(previous-level))
(t (setf (region-length current-exp)
(1+ (region-length current-exp))))))
(set-key 'shrink-region "M-b")
(defcom shrink-region ()
"Decrease the size of the region by one.
Shrink the region to contain one less branch at this level. If the width of
the region is one, and the branch it contains is not terminal, then the
region is moved down a level and then extended to include all but the last
branch."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(cond ((= (region-length current-exp) 1)
;;Region includes an entire node. Step down and extend to include
;;all but last branch.
(cond ((region-contains-terminal-node?)
(ed-error "Region contains a terminal node."))
((not (memq (caar (cadr (region current-exp)))
'(MPLUS MTIMES MNCTIMES MLIST)))
(ed-error "Cannot shrink the region at this node."))
(t (next-level)
(setf (region-length current-exp)
(length (cddr (operand current-exp)))))))
(t (setf (region-length current-exp) (1- (region-length current-exp))))))
(set-key 'first-branch "C-a")
(defcom first-branch ((discard-argument))
"Move the region to the first branch at this level.
The width of the region stays the same. If the region contains the entire
expression, no action is taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(if (region-contains-first-branch?)
(ed-error "Region contains the first branch of this level."))
(do ()
((region-contains-first-branch?))
(backward-branch)))
(set-key 'last-branch "C-e")
(defcom last-branch ((discard-argument))
"Move the region to the last branch at this level.
The width of the region stays the same. If the region contains the entire
expression, no action is taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(if (region-contains-last-branch?)
(ed-error "Region contains the last branch of this level."))
(do ()
((region-contains-last-branch?))
(forward-branch)))
;; Expression modification -- deleting portions of expressions
(set-key 'delete-region "C-d")
(defcom delete-region ()
"Delete the subexpression contained in the region from this level.
If the region contains the entire expression, then the expression
itself is removed from the buffer. If the region contains all but one
term of a sum or product, then the region is replaced with that term
alone."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(cond
;;The region is the same as the body of the expression, so delete
;;the entire expression.
((region-contains-top-node?) (delete-expression))
(t (cond ((equal (region-length current-exp) 1)
(push (cadr (region current-exp)) kill-pdl))
(t (push (cons (list (operator current-exp)
'spread
(region-length current-exp))
(firstn (region-length current-exp)
(cdr (region current-exp))))
kill-pdl)))
(rplacd (region current-exp)
(nthcdr (region-length current-exp) (cdr (region current-exp))))
(setf (region-length current-exp) 1)
;;Normally, when a branch is deleted, the region is moved to
;;the following branch and its width is made 1.
;;If we delete all branches to the end
;;of this level, then move the region to the previous branch.
(if (null (cdr (region current-exp)))
(pop-save-pdl))
;;If there were only two branches at this level when we started,
;;then we now have an operator applied to one term.
;;If the operator applied to one expression is the expression
;;itself, or not meaningful with a single operand, (such as
;;MQUOTIENT), then just leave the expression. Use "replace-region"
;;rather than rplaca so that (A + B) + C --> A + B + C merging happens
;;correctly and so that assignment of the label takes place if
;;the region is the top node in the structure.
(cond ((and (region-contains-entire-level?)
(memq (operator current-exp)
'(MPLUS MTIMES MNCTIMES MEXPT MNCEXPT MQUOTIENT MEQUAL)))
(previous-level)
(replace-region t (cadr (cadr (region current-exp)))))))))
; This command isn't too winning.
; Also, redisplay can't handle it since it doesn't modify the region.
; (set-key 'rubout-expression "RUBOUT")
; (defcom rubout-expression ()
; "Delete the branch just before the region from this level."
; (if (region-contains-top-node?)
; (ed-error "Region contains the entire expression."))
; (if (region-contains-first-branch?)
; (ed-error "Region contains the first branch of this level."))
; (if (not (memq (operator current-exp)
; '(MPLUS MTIMES MNCTIMES MLIST)))
; (ed-error "Cannot delete a branch at this level."))
; (let ((save-region-length (region-length current-exp)))
; (setf (region-length current-exp) 1)
; (backward-branch)
; (delete-region)
; (setf (region-length current-exp) save-region-length)))
; Rewrite this in terms of delete-region and movement functions.
(set-key 'kill-following-branches "C-k")
(defcom kill-following-branches ((argument n))
"Delete the branches following the last branch in the region.
Those branches at the current level following the last branch contained in the
region are deleted from the level. With a negative argument, those branches
preceding the first branch contained in the region are deleted from the level.
If the region is at the top level of the current expression or at the far right
or left end of the current level respectively, no action is taken."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(if (not (memq (operator current-exp) '(MPLUS MTIMES MNCTIMES MLIST)))
(ed-error "Cannot delete branches at this level."))
(if (not n) (setq n 1))
(cond ((= n 0))
(t (cond ((> n 0)
(if (region-contains-last-branch?)
(ed-error "Region contains the last branch at this level."))
;;Splice out stuff from region to end of level.
(rplacd (nthcdr (region-length current-exp)
(region current-exp)) nil))
((< n 0)
(if (region-contains-first-branch?)
(ed-error "Region contains the first branch at this level."))
;;Splice out stuff between operator and region.
(rplacd (operand current-exp) (cdr (region current-exp)))
;;Move region to far left edge of level.
(do ()
((region-contains-first-branch?))
(pop-save-pdl))))
;;If the region is the only thing that's left, move up one level.
(cond ((region-contains-entire-level?)
(previous-level)
;;If there's only one term left at the old level, pull it
;;up a level.
(if (null (cddr (cadr (region current-exp))))
(replace-region t (cadr (cadr (region current-exp))))))))))
; Another way of writing this. Nearly independent of representation.
; (defun kill-following-branches ()
; (let ((save-region-length (region-length current-exp)))
; (dotimes (i (1- save-region-length)) (shrink-region))
; (dotimes (i save-region-length) (forward-branch))
; (do ()
; ((region-contains-last-branch?))
; (grow-region))
; (delete-region)
; (dotimes (i (1- save-region-length)) (backward-branch))
; (dotimes (i (1- save-region-length)) (grow-region))))
; And yet another. But far less efficient.
; (defun kill-preceding-branches ()
; (let ((save-region-length (region-length current-exp)))
; (dotimes (i (1- save-region-length)) (shrink-region))
; (backward-branch)
; (do ()
; ((region-contains-first-branch?))
; (backward-branch)
; (grow-region))
; (delete-region)
; (dotimes (i (1- save-region-length)) (grow-region))))
;; Modifying expressions -- Inserting and replacing expressions
;; If you're ever clobbering anything into the region, you should
;; be calling this function.
(set-key 'replace-region "C-r")
(defcom replace-region ((argument n)
(read-expression exp
"Replace region: ~A"
(if n "(no evaluation) " "")))
"Replace the region with an expression read from the minibuffer.
If a numeric argument is given, don't evaluate the entered expression."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
;; Should we be rebinding % instead? Of course. We would
;; have to simplify the region before binding, though.
(setq exp (subst (region-as-mexp current-exp) '$% exp))
(if (null n) (setq exp (meval exp)))
;; Operator must be associative to merge levels. Structural
;; simplification being made here. (A + (B + C) + D) --> (A + B + C + D)
;; Maybe we should always be simplifying the body, i.e. letting the
;; simplifier do this. (Redundant knowledge)
(cond ((and (memq (operator current-exp) '(MPLUS MTIMES MNCTIMES))
(not (atom exp))
(eq (caar exp) (operator current-exp)))
;; The region will soon contain this new expression
;; so its length should be the same as that of the
;; expression.
(let ((new-region-length (length (cdr exp))))
(rplacd (last exp)
(nthcdr (1+ (region-length current-exp))
(region current-exp)))
(rplacd (region current-exp) (cdr exp))
(setf (region-length current-exp) new-region-length)))
(t (rplacd (region current-exp)
(cons (nformat-all exp)
(nthcdr (1+ (region-length current-exp))
(region current-exp))))
(setf (region-length current-exp) 1)))
;; Make sure the expression label is bound to the expression
;; body. Not necessary if inner part of expression clobbered.
(if (eq (body current-exp) (region current-exp))
(mset (expression-label current-exp) (cadr (body current-exp)))))
;; (defcom replace-region-operator ((discard-argument)
;; (read-line function-name "Replace function: "))
;; "Replace the region operator."
;; (cond ((null operator)
;; (ed-error))
;; ((let ((temp (cvt-name function-name)))
;; (setq operator temp)
;; (rplaca operand (list temp))))))
;; (defun cvt-name (nm)
;; (setq nm (implode (nreverse nm)))
;; (setq nm (or (cdr (assq nm '((+ . MPLUS) (* . MTIMES) (^ . MEXPT)
;; (** . MEXPT) (|.| . MNCTIMES) (^^ . MNCEXPT))))
;; nm)))
;; (defun insert-from-echo ()
;; (insert-by-cursor (nformat-all (read-from-echo-area '|Insert:|))))
;; (defun insert-from-echo-eval ()
;; (insert-by-cursor
;; (nformat-all
;; (meval (read-from-echo-area '|Insert:|)))))
;; (defun insert-by-cursor (temp)
;; (let ((temp (subst (cadr region) '$% temp)))
;; (cond ((and (null (atom temp))
;; (eq (caar temp) operator)
;; (eq 'spread (cadar temp)))
;; (rplacd region
;; (append (cdr temp) (cdr region)))
;; (setq region-length (caddar temp)))
;; (t (rplacd region
;; (cons temp (cdr region)))))
;; (setq redisplay t)))
;; Modifying expressions -- using marks and kill-pdls
;; (defun top-kill-pdl ()
;; (cond ((null kill-pdl) (ed-error))
;; (t (insert-by-cursor (car kill-pdl)))))
;; (defun pop-kill-pdl ()
;; (cond ((null kill-pdl) (ed-error))
;; (t (insert-by-cursor (car kill-pdl))
;; (setq kill-pdl (cdr kill-pdl)))))
;; (defun mark-point ()
;; (cond ((> argument 1)
;; (pop-mark-into-point))
;; (t
;; (setq mark-pdl (cons (list operator operand region
;; (displayed current-exp))
;; mark-pdl)))))
;; (defun full-memq (a e)
;; (cond ((eq a e))
;; ((atom e) nil)
;; ((or (full-memq a (car e))
;; (full-memq a (cdr e))))))
;; (defun pop-mark-into-point ()
;; (cond ((null mark-pdl) (ed-error))
;; ((and (full-memq (cadddr (car mark-pdl)) (body current-exp))
;; (full-memq (caddar mark-pdl) (cadddr (car mark-pdl))))
;; (setq operator (caar mark-pdl)
;; operand (cadar mark-pdl)
;; region (caddar mark-pdl))
;; (setf (displayed current-exp) (cadddr (car mark-pdl)))))
;; (t (setq mark-pdl (cdr mark-pdl))
;; (ed-error)))
; (defun exchange-mark-point ()
; (mark-point)
; (rplaca (cdr mark-pdl)
; (prog2 0 (car mark-pdl)
; (rplaca mark-pdl (cadr mark-pdl))))
; (pop-mark-into-point))
; Make this work with negative args for moving stuff backwards.
(set-key 'transpose-branch "C-t")
(defcom transpose-branch ((argument n))
"Transpose the region with the branch immediately following it.
The domain and width of the region remains the same. If given a negative
argument, then transpose the region with the branch at the same level
immediately preceding it."
(if (null (expression-list current-buffer))
(ed-error "Current Buffer is empty."))
(if (region-contains-top-node?)
(ed-error "Region contains the entire expression."))
(if (null n) (setq n 1))
(cond ((> n 0)
(if (region-contains-last-branch?)
(ed-error "Region contains the last branch of this level."))
(transpose-branch-forward n))
((< n 0)
(if (region-contains-first-branch?)
(ed-error "Region contains the last branch of this level."))
(transpose-branch-backward (- n)))))
(defun transpose-branch-forward (n)
(do ((i 0 (1+ i)))
((or (= i n) (region-contains-last-branch?)))
(let ((next-branch
(nthcdr (1+ (region-length current-exp)) (region current-exp))))
(rplacd (nthcdr (region-length current-exp) (region current-exp))
(cdr next-branch))
(rplacd next-branch (cdr (region current-exp)))
(rplacd (region current-exp) next-branch)
(forward-branch))))
(defun transpose-branch-backward (n)
(do ((i 0 (1+ i)))
((or (= i n) (region-contains-first-branch?)))
(let ((current-branch (cdr (region current-exp))))
(rplacd (region current-exp)
(nthcdr (1+ (region-length current-exp)) (region current-exp)))
(rplacd (nthcdr (1- (region-length current-exp)) current-branch)
(region current-exp))
(backward-branch)
(rplacd (region current-exp) current-branch))))
;; Manipulating expressions with standard macsyma commands
;; There is some lossage here. Expressions are stored internally
;; in "nformat" form, i.e. in the form in which they are displayed.
;; Generally, they will be stripped of simp flags since only the
;; displayer looks at them. When passing them back to Macsyma, though,
;; any remaining simp flags must be ignored. Simp flags are left on
;; %LOG, %SIN, and others, while taken off of MPLUS, MTIMES, etc.
;; So this is done by binding DOSIMP to T, and calling SIMPLIFY.
;; This is what the SSIMPLIFYA function does. (Name sucks)
;; If MEVAL is being called, we don't need to do this, since it ignores
;; simp flags anyway.
;; If the first argument to REPLACE-REGION is NIL, the expression
;; is evaluated and simplified before being formatted.
(set-key 'simplify-region '("C-s" "s"))
(defcom simplify-region ((discard-argument))
"Simplifies the expression in the region.
No evaluation of the expression takes place."
(minibuffer-clear)
(minibuffer-print "Simplify region.")
(replace-region t (ssimplifya (region-as-mexp current-exp))))
(set-key 'evaluate-region "v")
(defcom evaluate-region ((discard-argument))
"Evaluates and simplifies the expression in the region."
(minibuffer-clear)
(minibuffer-print "Evaluate region.")
(replace-region nil (region-as-mexp current-exp)))
(set-key 'add-to-region "+")
(defcom add-to-region ((argument n)
(read-expression term
"Add to region: ~A"
(if n "(no evaluation) " "")))
"Add the expression contained in the region to one read from the minibuffer.
If a numeric argument is given, don't evaluate the entered expression."
(replace-region n `((mplus) ,(region-as-mexp current-exp) ,term)))
(set-key 'multiply-to-region "*")
(defcom multiply-to-region ((argument n)
(read-expression factor
"Multiply to region: ~A"
(if n "(no evaluation) " "")))
"Multiply the expression in the region to one read from the minibuffer.
If a numeric argument is given, don't evaluate the entered expression."
(replace-region n `((mtimes) ,(region-as-mexp current-exp) ,factor)))
(set-key 'divide-region "//")
(defcom divide-region ((argument n)
(read-expression factor
"Divide region by: ~A"
(if n "(no evaluation) " "")))
"Divide the expression in the region by one read from the minibuffer.
If a numeric argument is given, don't evaluate the entered expression."
(replace-region n `((mquotient) ,(region-as-mexp current-exp) ,factor)))
(set-key 'exponentiate-region "^")
(defcom exponentiate-region ((argument n)
(read-expression exponent
"Exponentiate region: ~A"
(if n "(no evaluation) " "")))
"Exponentiate the expression contained in the region.
If a numeric argument is given, don't evaluate the entered expression."
(replace-region n `((mexpt) ,(region-as-mexp current-exp) ,exponent)))
; Do we need to simplify the values returned by $expand, $factor, etc?
(set-key 'expand-region "e")
(defcom expand-region ((discard-argument))
"Expand the expression contained in the region.
The expression is first simplified before being given to EXPAND."
(minibuffer-clear)
(minibuffer-print "Expand region.")
(replace-region t ($expand (ssimplifya (region-as-mexp current-exp)))))
(set-key 'factor-region "f")
(defcom factor-region ((discard-argument))
"Factor the expression contained in the region.
The expression is first simplified before being given to FACTOR."
(minibuffer-clear)
(minibuffer-print "Factor region.")
(replace-region t ($factor (ssimplifya (region-as-mexp current-exp)))))
(set-key 'differentiate-region "d")
(defcom differentiate-region ((discard-argument)
(read-expression var "Differentiate with respect to: "))
"Differentiate the expression contained in the region.
The expression is first simplified before being given to DIFF."
(replace-region t ($diff (ssimplifya (region-as-mexp current-exp)) var)))
(set-key 'integrate-region "i")
(defcom integrate-region ((discard-argument)
(read-expression var "Integrate with respect to: "))
"Integrate the expression contained in the region.
The expression is first simplified before being given to INTEGRATE."
(replace-region t ($integrate (ssimplifya (region-as-mexp current-exp)) var)))
(set-key 'multthru-region "m")
(defcom multthru-region ((discard-argument))
"Invoke MULTTHRU on the region."
(minibuffer-clear)
(minibuffer-print "Multthru region. (distribute products over sums)")
(replace-region t ($multthru (region-as-mexp current-exp))))
(set-key 'partfrac-region "p")
(defcom partfrac-region ((discard-argument)
(read-expression var "Partial fraction decomposition with respect to:"))
"Expand the region in partial fractions.
The expansion is performed with respect to the specified main variable, and
the expression is simplified before the expansion is done."
(replace-region t ($partfrac (ssimplifya (region-as-mexp current-exp)) var)))
(set-key 'ratsimp-region "r")
(defcom ratsimp-region ((discard-argument))
"Invoke RATSIMP on the region."
(minibuffer-clear)
(minibuffer-print "Ratsimp region.")
(replace-region t ($ratsimp (region-as-mexp current-exp))))
;; Changing an expression's label and the binding of the label.
;; Better to use read-expression than read-line since user could insert random
;; characters like space or : into label and not be able to reference it.
(set-key 'assign-expression ":")
(defcom assign-expression ((discard-argument)
(read-expression label "Assign region to: "))
"Change the label of the current expression.
The label also represents a macsyma variable, and this variable gets bound
to the current expression."
(label-exp current-exp label))

BIN
src/emaxim/edits.99 Normal file
View File

Binary file not shown.

BIN
src/emaxim/edlm.20 Executable file
View File

Binary file not shown.

103
src/jim/askp.85 Normal file
View File

@@ -0,0 +1,103 @@
;;; -*- Mode: Lisp; Package: Macsyma -*-
;;;
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **
;;;
;;; Toplevel Functions: ($ASKINTEGER EXP <OPTIONAL-ARG>)
;;;
;;; EXP -> any Macsyma expression.
;;; <OPTIONAL-ARG> -> $EVEN, $ODD, $INTEGER.
;;; If not given, defaults to $INTEGER.
;;;
;;; returns -> $YES, $NO, $UNKNOWN.
;;;
;;; If LIMITP is non-NIL the facts collected will be consed onto the list
;;; INTEGER-INFO.
;;;
;;; Implementors Functions: (ASK-INTEGER <EXP> <WHAT-KIND>)
;;; same as $ASKINTEGER with less error checking and
;;; requires two arguments.
;;;
;;; Support Functions: ASK-EVOD -> is a symbol an even or odd number?
;;; ASK-INTEGERP -> is a symbol an integer?
;;; ASK-PROP -> ask the user a question about a symbol.
;;;
(macsyma-module askp)
(declare (special limitp integer-info)
(fixnum n)
(*expr evod free $numberp integerp retrieve $featurep
sratsimp ssimplifya ratnump))
(defmfun $askinteger n
(if (or (> n 2) (< n 1)) (wna-err '$askinteger))
(if (= n 1) (ask-integer (arg 1) '$integer)
(if (memq (arg 2) '($even $odd $integer))
(ask-integer (arg 1) (arg 2))
(improper-arg-err (arg 2) '$askinteger))))
(defmfun ask-integer (x even-odd)
(setq x (sratsimp (sublis '((z** . 0) (*z* . 0)) x)))
(cond ((or (not (free x '$%pi)) (not (free x '$%i)) (ratnump x)) '$no)
((eq even-odd '$integer) (ask-integerp x))
(t (ask-evod x even-odd))))
(defun ask-evod (x even-odd)
(let ((evod-ans (evod x)) (is-integer (integerp x)))
(cond ((equal evod-ans even-odd) '$yes)
((and ($numberp x) (not is-integer)) '$no)
((and is-integer evod-ans) '$no)
((eq (setq evod-ans
(ask-prop x
(if (eq even-odd '$even) '|even| '|odd|)
'|number|))
'$yes)
(ask-declare x even-odd) '$yes)
((eq evod-ans '$no)
(if is-integer
(if (eq even-odd '$even) (ask-declare x '$odd)
(ask-declare x '$even)))
'$no)
(t '$unknown))))
(defun ask-integerp (x)
(let (integer-ans)
(if (and (mplusp x) (fixp (cadr x))) (setq x (addn (cddr x) t)))
(cond ((integerp x) '$yes)
(($numberp x) '$no)
(($featurep x '$noninteger) '$no)
((eq (setq integer-ans (ask-prop x '|integer| nil)) '$yes)
(ask-declare x '$integer) '$yes)
((eq integer-ans '$no)
(ask-declare x '$noninteger) '$no)
(t '$unknown))))
(defun ask-declare (x property)
(when (atom x)
(meval `(($declare) ,x ,property))
(if limitp
(setq integer-info (cons `(($kind) ,x ,property) integer-info)))))
(defun ask-prop (object property fun-or-number)
(if fun-or-number (setq fun-or-number (list '| | fun-or-number)))
;;; Asks the user a question about the property of an object.
;;; Returns only $yes, $no or $unknown.
(do ((end-flag) (answer))
(end-flag (cond ((memq answer '($yes $y)) '$yes)
((memq answer '($no $n)) '$no)
((memq answer '($unknown $uk)) '$unknown)))
(setq answer (retrieve
`((mtext) |Is | ,object
,(if (member (getcharn property 1)
'(#/a #/e #/i #/o #/u))
'| an |
'| a |)
,property ,@fun-or-number |?|)
nil))
(cond
((memq answer '($yes $y $no $n $unknown $uk))
(setq end-flag t))
(t (mtell
"~%Acceptable answers are Yes, Y, No, N, Unknown, Uk~%")))))
(declare (notype n))

2616
src/jim/limit.273 Normal file
View File

File diff suppressed because it is too large Load Diff

49
src/jim/tlimit.47 Normal file
View File

@@ -0,0 +1,49 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module tlimit)
(load-macsyma-macros rzmac)
;; TOP LEVEL FUNCTION(S): $TLIMIT $TLDEFINT
(DECLARE (GENPREFIX TL)
(*LEXPR $LIMIT)
(SPECIAL $TLIMSWITCH TAYLORED EXP VAR VAL LL UL
SILENT-TAYLOR-FLAG))
(DEFMFUN $TLIMIT NARGS
((LAMBDA ($TLIMSWITCH) (APPLY '$LIMIT (LISTIFY NARGS))) T))
(DEFMFUN $TLDEFINT (EXP VAR LL UL)
((LAMBDA ($TLIMSWITCH) ($LDEFINT EXP VAR LL UL)) T))
(DEFUN TLIMP (EXP) ; TO BE EXPANDED TO BE SMARTER (MAYBE)
T)
(DEFUN TAYLIM (E *I*)
(PROG (EX)
(SETQ EX (*CATCH 'TAYLOR-CATCH
(let ((SILENT-TAYLOR-FLAG t))
($TAYLOR E VAR (RIDOFAB VAL) 1.))))
(OR EX (RETURN (COND ((EQ *I* T) (LIMIT1 E VAR VAL))
((EQ *I* 'THINK) (COND ((MEMQ (CAAR EXP)
'(MTIMES MEXPT))
(LIMIT1 E VAR VAL))
(T (SIMPLIMIT E VAR VAL))))
(T (SIMPLIMIT E VAR VAL)))))
(RETURN
(let ((TAYLORED t))
(LIMIT
(SIMPLIFY
($logcontract ($RATDISREP ex)))
;;(COND ((EQ (CADR EX) 'PS)
;; (CONS (CAR EX)
;; (LIST 'PS (THIRD EX) (FOURTH EX)
;; (FIFTH EX))))
;; (t (EX)))
VAR
VAL
'THINK)))))
(DECLARE (UNSPECIAL TAYLORED EXP VAR VAL LL UL))

1039
src/jm/risch.434 Normal file
View File

File diff suppressed because it is too large Load Diff

2130
src/jm/simp.834 Normal file
View File

File diff suppressed because it is too large Load Diff

1419
src/jm/sin.200 Normal file
View File

File diff suppressed because it is too large Load Diff

374
src/jm/sinint.140 Normal file
View File

@@ -0,0 +1,374 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module sinint)
(load-macsyma-macros ratmac)
(DECLARE (GENPREFIX I)
(SPECIAL RISCHPF GENVAR $SAVEFACTORS CHECKFACTORS
EXP VAR $FACTORFLAG $RATFAC $LOGABS $EXPOP $EXPON
$KEEPFLOAT RATFORM ROOTFACTOR PARDENOM $ALGEBRAIC
WHOLEPART PARNUMER VARLIST LOGPTDX SWITCH1)
(FIXNUM NARGS I N KLTH KX))
(DEFUN ROOTFAC (Q)
(PROG (NTHDQ NTHDQ1 SIMPROOTS ANS)
(SETQ NTHDQ (PGCD Q (PDERIVATIVE Q VAR)))
(SETQ SIMPROOTS (PQUOTIENT Q NTHDQ))
(SETQ ANS (LIST (PQUOTIENT SIMPROOTS (PGCD NTHDQ SIMPROOTS))))
AMEN (IF (OR (PCOEFP NTHDQ) (POINTERGP VAR (CAR NTHDQ)))
(RETURN (REVERSE ANS)))
(SETQ NTHDQ1 (PGCD (PDERIVATIVE NTHDQ VAR) NTHDQ))
(SETQ ANS (CONS (PQUOTIENT (PGCD NTHDQ SIMPROOTS) (PGCD NTHDQ1 SIMPROOTS))
ANS))
(SETQ NTHDQ NTHDQ1)
(GO AMEN)))
(DEFUN APROG (Q)
(SETQ Q (OLDCONTENT Q))
(SETQ ROOTFACTOR (ROOTFAC (CADR Q)))
(SETQ ROOTFACTOR
(CONS (PTIMES (CAR Q) (CAR ROOTFACTOR)) (CDR ROOTFACTOR)))
(DO ((PD (LIST (CAR ROOTFACTOR)))
(RF (CDR ROOTFACTOR) (CDR RF))
(N 2 (1+ N)))
((NULL RF) (SETQ PARDENOM (REVERSE PD)))
(PUSH (PEXPT (CAR RF) N) PD))
ROOTFACTOR)
(DEFUN CPROG (TOP BOTTOM)
(PROG (FRPART PARDENOMC PPDENOM THEBPG)
(SETQ FRPART (PDIVIDE TOP BOTTOM))
(SETQ WHOLEPART (CAR FRPART))
(SETQ FRPART (CADR FRPART))
(IF (= (LENGTH PARDENOM) 1)
(RETURN (SETQ PARNUMER (LIST FRPART))))
(SETQ PARDENOMC (CDR PARDENOM))
(SETQ PPDENOM (LIST (CAR PARDENOM)))
DSEQ (IF (= (LENGTH PARDENOMC) 1) (GO OK))
(SETQ PPDENOM (CONS (PTIMES (CAR PPDENOM) (CAR PARDENOMC)) PPDENOM))
(SETQ PARDENOMC (CDR PARDENOMC))
(GO DSEQ)
OK (SETQ PARDENOMC (REVERSE PARDENOM))
NUMC (SETQ THEBPG (BPROG (CAR PARDENOMC) (CAR PPDENOM)))
(SETQ PARNUMER
(CONS (CDR (RATDIVIDE (RATTI FRPART (CDR THEBPG) T)
(CAR PARDENOMC)))
PARNUMER))
(SETQ FRPART
(CDR (RATDIVIDE (RATTI FRPART (CAR THEBPG) T)
(CAR PPDENOM))))
(SETQ PARDENOMC (CDR PARDENOMC))
(SETQ PPDENOM (CDR PPDENOM))
(IF (NULL PPDENOM)
(RETURN (SETQ PARNUMER (CONS FRPART PARNUMER))))
(GO NUMC)))
(DEFUN POLYINT (P) (RATQU (POLYINT1 (RATNUMERATOR P)) (RATDENOMINATOR P)))
(DEFUN POLYINT1 (P)
(COND ((OR (NULL P) (EQUAL P 0)) (CONS 0 1))
((ATOM P) (LIST VAR 1 P))
((NOT (NUMBERP (CAR P)))
(IF (POINTERGP VAR (CAR P)) (LIST VAR 1 P) (POLYINT1 (CDR P))))
(T (RATPLUS (POLYINT2 P) (POLYINT1 (CDDR P))))))
(DEFUN POLYINT2 (P) (CONS (LIST VAR (ADD1 (CAR P)) (CADR P)) (ADD1 (CAR P))))
(DEFUN DPROG (RATARG)
(PROG (KLTH KX AROOTF DERIV THEBPG THETOP THEBOT PROD1 PROD2 ANS)
(SETQ ANS (CONS 0 1))
(IF (OR (PCOEFP (CDR RATARG)) (POINTERGP VAR (CADR RATARG)))
(RETURN (DISREP (POLYINT RATARG))))
(APROG (RATDENOMINATOR RATARG))
(CPROG (RATNUMERATOR RATARG) (RATDENOMINATOR RATARG))
(SETQ ROOTFACTOR (REVERSE ROOTFACTOR))
(SETQ PARNUMER (REVERSE PARNUMER))
(SETQ KLTH (LENGTH ROOTFACTOR))
INTG (IF (= KLTH 1) (GO SIMP))
(SETQ AROOTF (CAR ROOTFACTOR))
(IF (ZEROP (PDEGREE AROOTF VAR)) (GO RESET))
(SETQ DERIV (PDERIVATIVE AROOTF VAR))
(SETQ THEBPG (BPROG AROOTF DERIV))
(SETQ KX (1- KLTH))
(SETQ THETOP (CAR PARNUMER))
ITER (SETQ PROD1 (RATTI THETOP (CAR THEBPG) T))
(SETQ PROD2 (RATTI THETOP (CDR THEBPG) T))
(SETQ THEBOT (PEXPT AROOTF KX))
(SETQ ANS
(RATPLUS ANS (RATQU (RATMINUS PROD2) (RATTI KX THEBOT T))))
(SETQ THETOP
(RATPLUS PROD1
(RATQU (RATREDUCE (PDERIVATIVE (CAR PROD2) VAR)
(CDR PROD2))
KX)))
(SETQ THETOP (CDR (RATDIVIDE THETOP THEBOT)))
(COND ((= KX 1) (SETQ LOGPTDX (CONS (RATQU THETOP AROOTF) LOGPTDX))
(GO RESET)))
(SETQ KX (1- KX))
(GO ITER)
RESET(SETQ ROOTFACTOR (CDR ROOTFACTOR))
(SETQ PARNUMER (CDR PARNUMER))
(SETQ KLTH (1- KLTH))
(GO INTG)
SIMP (SETQ LOGPTDX
(CONS (RATQU (CAR PARNUMER) (CAR ROOTFACTOR)) LOGPTDX))
(IF (EQUAL ANS 0) (RETURN (DISREP (POLYINT WHOLEPART))))
(SETQ THETOP
(CADR (PDIVIDE (RATNUMERATOR ANS) (RATDENOMINATOR ANS))))
(RETURN (LIST '(MPLUS)
(DISREP (POLYINT WHOLEPART))
(DISREP (RATQU THETOP (RATDENOMINATOR ANS)))))))
(DEFUN LOGMABS (X)
(LIST '(%LOG) (IF $LOGABS (SIMPLIFY (LIST '(MABS) X)) X)))
(DEFUN NPASK (EXP)
(COND ((FREEOF '$%I EXP)
(LEARN `((MNOTEQUAL) ,EXP 0) T) (ASKSIGN EXP))
(T '$POSITIVE)))
(DEFUN EPROG (P)
(PROG (P1E P2E A1E A2E A3E DISCRIM REPART SIGN NCC DCC ALLCC XX DEG)
(IF (OR (EQUAL P 0) (EQUAL (CAR P) 0)) (RETURN 0))
(SETQ P1E (RATNUMERATOR P) P2E (RATDENOMINATOR P))
(COND ((OR SWITCH1
(AND (NOT (ATOM P2E))
(EQ (CAR (SETQ XX (CADR (OLDCONTENT P2E)))) VAR)
(MEMBER (SETQ DEG (PDEGREE XX VAR)) '(5 6))
(ZEROCOEFL XX DEG)
(OR (EQUAL DEG 5) (NOT (PMINUSP (CAR (LAST XX)))))))
(GO EFAC)))
(SETQ A1E (INTFACTOR P2E))
(IF (> (LENGTH A1E) 1) (GO E40))
EFAC (SETQ NCC (OLDCONTENT P1E))
(SETQ P1E (CADR NCC))
(SETQ DCC (OLDCONTENT P2E))
(SETQ P2E (CADR DCC))
(SETQ ALLCC (RATQU (CAR NCC) (CAR DCC)))
(SETQ DEG (PDEGREE P2E VAR))
(SETQ A1E (PDERIVATIVE P2E VAR))
(SETQ A2E (RATQU (POLCOEF P1E (PDEGREE P1E VAR))
(POLCOEF A1E (PDEGREE A1E VAR))))
(COND ((EQUAL (RATTI A2E A1E T) (CONS P1E 1))
(RETURN (LIST '(MTIMES)
(DISREP (RATTI ALLCC A2E T))
(LOGMABS (DISREP P2E))))))
(COND ((EQUAL DEG 1) (GO E10))
((EQUAL DEG 2) (GO E20))
((AND (EQUAL DEG 3) (EQUAL (POLCOEF P2E 2) 0)
(EQUAL (POLCOEF P2E 1) 0))
(RETURN (E3PROG P1E P2E ALLCC)))
((AND (MEMBER DEG '(4 5 6)) (ZEROCOEFL P2E DEG))
(RETURN (ENPROG P1E P2E ALLCC DEG))))
(RETURN (LIST '(MTIMES)
(DISREP ALLCC)
(LIST '(%INTEGRATE)
(LIST '(MQUOTIENT) (DISREP P1E) (DISREP P2E))
(CAR (LAST VARLIST)))))
E10 (RETURN (LIST '(MTIMES)
(DISREP (RATTI ALLCC
(RATQU (POLCOEF P1E (PDEGREE P1E VAR))
(POLCOEF P2E 1))
T))
(LOGMABS (DISREP P2E))))
E20 (SETQ DISCRIM
(RATDIFFERENCE (CONS (PEXPT (POLCOEF P2E 1) 2) 1)
(RATTI 4 (RATTI (POLCOEF P2E 2) (POLCOEF P2E 0) T) T)))
(SETQ A2E (RATTI (POLCOEF P2E (PDEGREE P2E VAR)) 2 T))
(IF (NOT (FREE (SETQ XX (SIMPLIFY (DISREP DISCRIM))) '$%I)) (GO POS))
(SETQ SIGN (NPASK XX))
(COND ((EQ SIGN '$NEGATIVE) (GO E30))
((EQ SIGN '$ZERO) (GO ZIP)))
POS (SETQ A1E (RATSQRT DISCRIM))
(SETQ A3E (LOGMABS
(LIST '(MQUOTIENT)
(LIST '(MPLUS)
(LIST '(MTIMES)
(DISREP A2E) (DISREP (LIST VAR 1 1)))
(DISREP (POLCOEF P2E 1))
(LIST '(MMINUS) A1E))
(LIST '(MPLUS)
(LIST '(MTIMES)
(DISREP A2E) (DISREP (LIST VAR 1 1)))
(DISREP (POLCOEF P2E 1))
A1E))))
(COND ((ZEROP (PDEGREE P1E VAR))
(RETURN (LIST '(MTIMES)
(DISREP ALLCC)
(LIST '(MQUOTIENT) (DISREP (POLCOEF P1E 0)) A1E)
A3E))))
(RETURN
(LIST
'(MPLUS)
(LIST '(MTIMES)
(DISREP (RATTI ALLCC (RATQU (POLCOEF P1E (PDEGREE P1E VAR)) A2E) T))
(LOGMABS (DISREP P2E)))
(LIST
'(MTIMES)
(LIST
'(MQUOTIENT)
(DISREP (RATTI ALLCC (RATQU (EPROGRATD A2E P1E P2E) A2E) T))
A1E)
A3E)))
E30 (SETQ A1E (RATSQRT (RATMINUS DISCRIM)))
(SETQ
REPART
(RATQU (COND ((ZEROP (PDEGREE P1E VAR)) (RATTI A2E (POLCOEF P1E 0) T))
(T (EPROGRATD A2E P1E P2E)))
(POLCOEF P2E (PDEGREE P2E VAR))))
(SETQ A3E (COND ((EQUAL 0 (CAR REPART)) 0)
(T `((MTIMES) ((MQUOTIENT)
,(DISREP (RATTI ALLCC REPART T))
,A1E)
((%ATAN)
((MQUOTIENT)
,(DISREP (PDERIVATIVE P2E VAR))
,A1E))))))
(IF (ZEROP (PDEGREE P1E VAR)) (RETURN A3E))
(RETURN (LIST '(MPLUS)
(LIST '(MTIMES)
(DISREP (RATTI ALLCC
(RATQU (POLCOEF P1E (PDEGREE P1E VAR)) A2E)
T))
(LOGMABS (DISREP P2E)))
A3E))
ZIP (SETQ
P2E
(RATQU
(PSIMP
(P-VAR P2E)
(PCOEFADD 2
(PEXPT (PTIMES 2 (POLCOEF P2E 2)) 2)
(PCOEFADD 1 (PTIMES 4 (PTIMES (POLCOEF P2E 2)
(POLCOEF P2E 1)))
(PCOEFADD 0 (PEXPT (POLCOEF P2E 1) 2) ()))))
(PTIMES 4 (POLCOEF P2E 2))))
(RETURN (FPROG (RATTI ALLCC (RATQU P1E P2E) T)))
E40 (SETQ PARNUMER NIL PARDENOM A1E SWITCH1 T)
(CPROG P1E P2E)
(SETQ A2E
(MAPCAR #'(LAMBDA (J K) (EPROG (RATQU J K))) PARNUMER PARDENOM))
(SETQ SWITCH1 NIL)
(RETURN (CONS '(MPLUS) A2E))))
(DEFUN E3PROG (NUM DENOM CONT)
(PROG (A B C D E R RATR VAR* X)
(SETQ A (POLCOEF NUM 2) B (POLCOEF NUM 1) C (POLCOEF NUM 0)
D (POLCOEF DENOM 3) E (POLCOEF DENOM 0))
(SETQ R (COND ((EQ (NPASK (SIMPLIFY (DISREP (RATQU E D)))) '$NEGATIVE)
(SIMPNRT (DISREP (RATQU (RATTI -1 E T) D)) 3))
(T (NEG (SIMPNRT (DISREP (RATQU E D)) 3)))))
(SETQ VAR* (LIST VAR 1 1))
(NEWVAR R)
(ORDERPOINTER VARLIST)
(SETQ X (RATF R))
(SETQ RATFORM (CAR X) RATR (CDR X))
(RETURN
(SIMPLIFY
(LIST '(MPLUS)
(LIST '(MTIMES)
(DISREP (RATQU (R* CONT (R+ (R* A RATR RATR) (R* B RATR) C))
(R* RATR RATR 3 D)))
(LOGMABS (DISREP (RATPL (RATTI -1 RATR T) VAR*))))
(EPROG (R* CONT (RATQU (R+ (R* (R+ (R* 2 A RATR RATR)
(R* -1 B RATR)
(R* -1 C))
VAR*)
(R+ (RATQU (R* -1 A E) D)
(R* B RATR RATR)
(R* -1 2 C RATR)))
(R* 3 D RATR RATR
(R+ (RATTI VAR* VAR* T)
(RATTI RATR VAR* T)
(RATTI RATR RATR T))))))
)))))
(DEFUN EPROGRATD (A2E P1E P2E)
(RATDIFFERENCE (RATTI A2E (POLCOEF P1E (SUB1 (PDEGREE P1E VAR))) T)
(RATTI (POLCOEF P2E (SUB1 (PDEGREE P2E VAR)))
(POLCOEF P1E (PDEGREE P1E VAR))
T)))
(DEFUN ENPROG (NUM DENOM CONT DEG)
; Denominator is (A*VAR^4+B) =
; (SQRT(A)*VAR^2 - SQRT(2)*A^(1/4)*B^(1/4)*VAR + SQRT(B)) *
; (SQRT(A)*VAR^2 + SQRT(2)*A^(1/4)*B^(1/4)*VAR + SQRT(B))
; or (A*VAR^5+B) =
; (1/4) * (A^(1/5)*VAR + B^(1/5)) *
; (2*A^(2/5)*VAR^2 + (-SQRT(5)-1)*A^(1/5)*B^(1/5)*VAR + 2*B^(2/5)) *
; (2*A^(2/5)*VAR^2 + (+SQRT(5)-1)*A^(1/5)*B^(1/5)*VAR + 2*B^(2/5))
; or (A*VAR^6+B) =
; (A^(1/3)*VAR^2 + B^(1/3)) *
; (A^(1/3)*VAR^2 - SQRT(3)*A^(1/6)*B^(1/6)*VAR + B^(1/3)) *
; (A^(1/3)*VAR^2 + SQRT(3)*A^(1/6)*B^(1/6)*VAR + B^(1/3))
(PROG ($EXPOP $EXPON A B TERM DISVAR $ALGEBRAIC)
(SETQ $EXPOP 0 $EXPON 0)
(SETQ A (SIMPLIFY (DISREP (POLCOEF DENOM DEG)))
B (SIMPLIFY (DISREP (POLCOEF DENOM 0)))
DISVAR (SIMPLIFY (GET VAR 'DISREP))
NUM (SIMPLIFY (DISREP NUM))
CONT (SIMPLIFY (DISREP CONT)))
(COND ((= DEG 4)
(SETQ DENOM (ADD2 (MUL2 (POWER A '((RAT SIMP) 1 2)) (POWER DISVAR 2))
(POWER B '((RAT SIMP) 1 2)))
TERM (MULN (LIST (POWER 2 '((RAT SIMP) 1 2))
(POWER A '((RAT SIMP) 1 4))
(POWER B '((RAT SIMP) 1 4))
DISVAR)
T))
(SETQ DENOM (MUL2 (ADD2 DENOM TERM) (SUB DENOM TERM))))
((= DEG 5)
(SETQ TERM (MUL3 (POWER A '((RAT SIMP) 1 5))
(POWER B '((RAT SIMP) 1 5))
DISVAR))
(SETQ DENOM (ADD2 (MUL3 2 (POWER A '((RAT SIMP) 2 5))
(POWER DISVAR 2))
(SUB (MUL2 2 (POWER B '((RAT SIMP) 2 5))) TERM)))
(SETQ TERM (MUL2 (POWER 5 '((RAT SIMP) 1 2)) TERM))
(SETQ DENOM (MULN (LIST '((RAT SIMP) 1 4)
(ADD2 (MUL2 (POWER A '((RAT SIMP) 1 5)) DISVAR)
(POWER B '((RAT SIMP) 1 5)))
(ADD2 DENOM TERM) (SUB DENOM TERM))
T)))
(T (SETQ DENOM (ADD2 (MUL2 (POWER A '((RAT SIMP) 1 3)) (POWER DISVAR 2))
(POWER B '((RAT SIMP) 1 3)))
TERM (MULN (LIST (POWER 3 '((RAT SIMP) 1 2))
(POWER A '((RAT SIMP) 1 6))
(POWER B '((RAT SIMP) 1 6))
DISVAR)
T))
(SETQ DENOM (MUL3 DENOM (ADD2 DENOM TERM) (SUB DENOM TERM)))))
;;Needs $ALGEBRAIC NIL so next call to RATF will preserve factorization.
(RETURN (MUL2 CONT (RATINT (DIV NUM DENOM) DISVAR)))))
(DEFUN ZEROCOEFL (E N)
(DO ((I 1 (1+ I))) ((= I N) T)
(IF (NOT (EQUAL (POLCOEF E I) 0)) (RETURN NIL))))
(DEFUN RATSQRT (A) (LET (VARLIST) (SIMPNRT (DISREP A) 2)))
(DEFUN FPROG (RAT*)
(PROG (ROOTFACTOR PARDENOM PARNUMER LOGPTDX WHOLEPART SWITCH1)
(RETURN (ADDN (CONS (DPROG RAT*) (MAPCAR #'EPROG LOGPTDX)) NIL))))
(DEFMFUN RATINT (EXP VAR)
(PROG (GENVAR CHECKFACTORS VARLIST RATARG RATFORM $KEEPFLOAT)
(SETQ VARLIST (LIST VAR))
(SETQ RATARG (RATF EXP))
(SETQ RATFORM (CAR RATARG))
(SETQ VAR (CAADR (RATF VAR)))
(RETURN (FPROG (CDR RATARG)))))
(DEFUN INTFACTOR (L)
(PROG ($FACTORFLAG A B)
(SETQ A (OLDCONTENT L) B (EVERYSECOND (PFACTOR (CADR A))))
(RETURN (IF (EQUAL (CAR A) 1) B (CONS (CAR A) B)))))
(DEFUN EVERYSECOND (A)
(IF A (CONS (IF (NUMBERP (CAR A))
(PEXPT (CAR A) (CADR A))
(CAR A))
(EVERYSECOND (CDDR A)))))

63
src/jm/zero.23 Normal file
View File

@@ -0,0 +1,63 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module zero)
(DECLARE (SPECIAL S VAR EXP V1 V R1 R2 $NUMER $LISTCONSTVARS VARLIST GENVAR)
(*LEXPR $RAT))
(DEFMFUN $ZEROEQUIV (EXP VAR)
(PROG (R S V VARLIST GENVAR)
(SETQ EXP (SPECREPCHECK EXP))
(SETQ R (LET ($LISTCONSTVARS) ($LISTOFVARS EXP)))
(IF (AND (CDR R) (OR (CDDR R) (NOT (ALIKE1 (CADR R) VAR))))
(RETURN '$DONTKNOW))
(SETQ EXP ($EXPONENTIALIZE EXP))
(SETQ R (SDIFF EXP VAR))
(IF (ISINOP R '%DERIVATIVE) (RETURN '$DONTKNOW))
($RAT R)
(SETQ R ($RAT EXP))
(SETQ S (CAR R))
(SETQ V (RATNUMERATOR (CDR R)))
(RETURN (ZEROEQUIV1 V))))
(DEFUN ZEROEQUIV1 (V)
(PROG (V1 V2 COEFF DEG)
(IF (ATOM V) (RETURN (EQUAL V 0)))
COEFFLOOP (IF (NULL (CDR V)) (RETURN T))
(SETQ DEG (CADR V))
(IF (EQUAL DEG 0) (RETURN (ZEROEQUIV1 (CADDR V))))
(SETQ COEFF (CADDR V))
(WHEN (ZEROEQUIV1 COEFF)
(SETQ V (CONS (CAR V) (CDDDR V)))
(GO COEFFLOOP))
(SETQ V1 ($RAT (SDIFF (RATDISREP (CONS S (CONS V (CADDR V))))
VAR)))
(SETQ V2 (CADR ($RAT (RATDISREP V1))))
(IF (EQUAL (PDEGREE V2 (CAR V)) (CADR V))
(RETURN (ZEROEQUIV2 V)))
(IF (LESSP (PDEGREE V2 (CAR V)) (CADR V))
(RETURN (IF (ZEROEQUIV1 V2) (ZEROEQUIV2 V))))
(RETURN '$DONTKNOW)))
(DEFUN ZEROEQUIV2 (V)
(PROG (R R1 R2)
(SETQ R (SIN (TIMES 0.001 (RANDOM 1000.))))
(SETQ V (SUBSTITUTE R VAR (RATDISREP (CONS S (CONS V 1)))))
(SETQ V (MEVAL '(($EV) V $NUMER)))
(COND ((AND (NUMBERP V) (LESSP (ABS V) (TIMES R 0.01)))
(RETURN T))
((NUMBERP V) (RETURN NIL)))
(IF (AND (FREE V '$%I) (NOT (ISINOP V '%LOG)))
(RETURN '$DONTKNOW))
(SETQ R1 ($REALPART V))
(SETQ R1 (MEVAL '(($EV) R1 $NUMER)))
(IF (NOT (NUMBERP R1)) (RETURN '$DONTKNOW))
(SETQ R2 ($IMAGPART V))
(SETQ R2 (MEVAL '(($EV) R2 $NUMER)))
(IF (NOT (NUMBERP R2)) (RETURN '$DONTKNOW))
(COND ((AND (LESSP (ABS R1) (TIMES R 0.01))
(LESSP (ABS R2) (TIMES R 0.01)))
(RETURN T))
(T (RETURN NIL)))))

917
src/jpg/comm.395 Normal file
View File

@@ -0,0 +1,917 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1982 Massachusetts Institute of Technology **
(macsyma-module comm)
(DECLARE (GENPREFIX C)
(SPECIAL $EXPTSUBST $LINECHAR $NOLABELS $INFLAG $PIECE $DISPFLAG
$GRADEFS $PROPS $DEPENDENCIES DERIVFLAG DERIVLIST
$LINENUM $PARTSWITCH LINELABLE NN* DN* ISLINP
$POWERDISP ATVARS ATP $ERREXP $DERIVSUBST $DOTDISTRIB
$OPSUBST $SUBNUMSIMP $TRANSRUN IN-P SUBSTP $SQRTDISPFLAG
$PFEFORMAT)
(*LEXPR FACTOR)
(FIXNUM I N LARGL LVRS COUNT TIM (SIGNUM1)))
(PROG1 '(OP properties)
(MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP)
(PUTPROP (CADR X) (CAR X) 'OPR))
'((MPLUS &+) (MMINUS &-) (MTIMES &*) (MEXPT &**) (MEXPT &^)
(MNCTIMES &/.) (RAT &//) (MQUOTIENT &//) (MNCEXPT &^^)
(MEQUAL &=) (MGREATERP &>) (MLESSP &<) (MLEQP &<=) (MGEQP &>=)
(MNOTEQUAL &/#) (MAND &AND) (MOR &OR) (MNOT &NOT) (MSETQ &/:)
(MDEFINE &/:=) (MDEFMACRO &/:/:=) (MQUOTE &/') (MLIST &[)
(MSET &/:/:) (MFACTORIAL &!) (MARROW &->) (MPROGN &/()
(MCOND &IF)))
(MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP))
'((MQAPPLY $SUBVAR) (BIGFLOAT $BFLOAT))))
(SETQ $EXPTSUBST NIL $PARTSWITCH NIL $INFLAG NIL $GRADEFS '((MLIST SIMP))
$DEPENDENCIES '((MLIST SIMP)) ATVARS '(&@1 &@2 &@3 &@4) ATP NIL
ISLINP NIL LNORECURSE NIL &** '&^ $DERIVSUBST NIL TIMESP NIL
$OPSUBST T IN-P NIL SUBSTP NIL)
(DEFMVAR $VECT_CROSS NIL
"If TRUE allows DIFF(X~Y,T) to work where ~ is defined in
SHARE;VECT where VECT_CROSS is set to TRUE.")
(DEFMFUN $SUBSTITUTE N
(COND ((= N 2)
(LET ((L (ARG 1)) (Z (ARG 2)))
(COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L)))
($SUBSTITUTE (CADR L) Z))
((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE))
((EQ (CAAR L) 'MEQUAL) (SUBSTITUTE (CADDR L) (CADR L) Z))
(T (DO ((L (CDR L) (CDR L))) ((NULL L) Z)
(SETQ Z ($SUBSTITUTE (CAR L) Z)))))))
((= N 3) (SUBSTITUTE (ARG 1) (ARG 2) (ARG 3)))
(T (WNA-ERR '$SUBSTITUTE))))
(DECLARE (SPECIAL X Y OPRX OPRY NEGXPTY TIMESP))
(DEFMFUN SUBSTITUTE (X Y Z) ; The args to SUBSTITUTE are assumed to be simplified.
(LET ((IN-P T) (SUBSTP T))
(IF (AND (MNUMP Y) (= (SIGNUM1 Y) 1))
(LET ($SQRTDISPFLAG ($PFEFORMAT T)) (SETQ Z (NFORMAT-ALL Z))))
(SIMPLIFYA
(IF (ATOM Y)
(COND ((EQUAL Y -1)
(SETQ Y '((MMINUS) 1)) (SUBST2 (NFORMAT-ALL Z)))
(T (LET ((OPRX (GETOPR X)) (OPRY (GETOPR Y)))
(SUBST1 Z))))
(LET ((NEGXPTY (IF (AND (EQ (CAAR Y) 'MEXPT)
(= (SIGNUM1 (CADDR Y)) 1))
(MUL2 -1 (CADDR Y))))
(TIMESP (IF (EQ (CAAR Y) 'MTIMES) (SETQ Y (NFORMAT Y)))))
(SUBST2 Z)))
NIL)))
(DEFUN SUBST1 (Z) ; Y is an atom
(COND ((ATOM Z) (IF (EQUAL Y Z) X Z))
((SPECREPP Z) (SUBST1 (SPECDISREP Z)))
((EQ (CAAR Z) 'BIGFLOAT) Z)
((AND (EQ (CAAR Z) 'RAT) (OR (EQUAL Y (CADR Z)) (EQUAL Y (CADDR Z))))
(DIV (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))))
((AND ATP (MEMQ (CAAR Z) '(%DERIVATIVE %LAPLACE))) Z)
((AND (EQ Y T) (EQ (CAAR Z) 'MCOND))
(LIST (NCONS (CAAR Z)) (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))
(CADDDR Z) (SUBST1 (CAR (CDDDDR Z)))))
(T (LET ((MARGS (MAPCAR #'SUBST1 (CDR Z))))
(SUBST0
(IF (AND $OPSUBST
(OR (EQ OPRY (CAAR Z))
(AND (EQ (CAAR Z) 'RAT) (EQ OPRY 'MQUOTIENT))))
(IF (OR (NUMBERP X)
(MEMQ X '(T NIL $%E $%PI $%I))
(AND (NOT (ATOM X))
(NOT (OR (EQ (CAR X) 'LAMBDA)
(EQ (CAAR X) 'LAMBDA)))))
(IF (OR (AND (MEMQ 'ARRAY (CDAR Z))
(OR (AND (MNUMP X) $SUBNUMSIMP)
(AND (NOT (MNUMP X)) (NOT (ATOM X)))))
($SUBVARP X))
(LIST* '(MQAPPLY) X MARGS)
(MERROR
"Attempt to substitute ~M for ~M in ~M~
~%Illegal substitution for operator of expression"
X Y Z))
(CONS (NCONS OPRX) MARGS))
(CONS (NCONS (CAAR Z)) MARGS))
Z)))))
(DEFUN SUBST2 (Z)
(LET (NEWEXPT)
(COND ((ATOM Z) Z)
((SPECREPP Z) (SUBST2 (SPECDISREP Z)))
((AND ATP (MEMQ (CAAR Z) '(%DERIVATIVE %LAPLACE))) Z)
((ALIKE1 Y Z) X)
((AND TIMESP (EQ (CAAR Z) 'MTIMES) (ALIKE1 Y (SETQ Z (NFORMAT Z)))) X)
((AND (EQ (CAAR Y) 'MEXPT) (EQ (CAAR Z) 'MEXPT) (ALIKE1 (CADR Y) (CADR Z))
(SETQ NEWEXPT (COND ((ALIKE1 NEGXPTY (CADDR Z)) -1)
($EXPTSUBST (EXPTHACK (CADDR Y) (CADDR Z))))))
(LIST '(MEXPT) X NEWEXPT))
((AND $DERIVSUBST (EQ (CAAR Y) '%DERIVATIVE) (EQ (CAAR Z) '%DERIVATIVE)
(ALIKE1 (CADR Y) (CADR Z)))
(LET ((TAIL (SUBST-DIFF-MATCH (CDDR Y) (CDR Z))))
(COND ((NULL TAIL) Z)
(T (CONS (NCONS (CAAR Z)) (CONS X (CDR TAIL)))))))
(T (RECUR-APPLY #'SUBST2 Z)))))
(DECLARE (UNSPECIAL X Y OPRX OPRY NEGXPTY TIMESP))
(DEFMFUN SUBST0 (NEW OLD)
(COND ((ALIKE (CDR NEW) (CDR OLD))
(COND ((EQ (CAAR NEW) (CAAR OLD)) OLD)
(T (SIMPLIFYA (CONS (CONS (CAAR NEW) (MEMQ 'ARRAY (CDAR OLD))) (CDR OLD))
NIL))))
((MEMQ 'ARRAY (CDAR OLD))
(SIMPLIFYA (CONS (CONS (CAAR NEW) '(ARRAY)) (CDR NEW)) NIL))
(T (SIMPLIFYA NEW NIL))))
(DEFUN EXPTHACK (Y Z)
(PROG (NN* DN* YN YD ZN ZD QD)
(COND ((AND (MNUMP Y) (MNUMP Z))
(RETURN (IF (NUMBERP (SETQ Y (DIV* Z Y))) Y)))
((ATOM Z) (IF (NOT (MNUMP Y)) (RETURN NIL)))
((OR (RATNUMP Z) (EQ (CAAR Z) 'MPLUS)) (RETURN NIL)))
(NUMDEN Y) ; (CSIMP) sets NN* and DN*
(SETQ YN NN* YD DN*)
(NUMDEN Z)
(SETQ ZN NN* ZD DN*)
(SETQ QD (COND ((AND (EQUAL ZD 1) (EQUAL YD 1)) 1)
((PROG2 (NUMDEN (DIV* ZD YD))
(AND (EQUAL DN* 1) (EQUAL NN* 1)))
1)
((EQUAL NN* 1) (DIV* 1 DN*))
((EQUAL DN* 1) NN*)
(T (RETURN NIL))))
(NUMDEN (DIV* ZN YN))
(IF (EQUAL DN* 1) (RETURN (DIV* NN* QD)))))
(DEFUN SUBST-DIFF-MATCH (L1 L2)
(DO ((L L1 (CDDR L)) (L2 (APPEND L2 NIL)) (FAILED NIL NIL))
((NULL L) L2)
(DO ((L2 L2 (CDDR L2)))
((NULL (CDR L2)) (SETQ FAILED T))
(IF (ALIKE1 (CAR L) (CADR L2))
(IF (AND (EQ (TYPEP (CADR L)) 'FIXNUM)
(EQ (TYPEP (CADDR L2)) 'FIXNUM))
(COND ((< (CADR L) (CADDR L2))
(RETURN (RPLACD (CDR L2)
(CONS (- (CADDR L2) (CADR L))
(CDDDR L2)))))
((= (CADR L) (CADDR L2))
(RETURN (RPLACD L2 (CDDDR L2))))
(T (RETURN (SETQ FAILED T))))
(RETURN (SETQ FAILED T)))))
(IF FAILED (RETURN NIL))))
(DEFMFUN RECUR-APPLY (FUN E)
(COND ((EQ (CAAR E) 'BIGFLOAT) E)
((SPECREPP E) (FUNCALL FUN (SPECDISREP E)))
(T (LET ((NEWARGS (MAPCAR FUN (CDR E))))
(IF (ALIKE NEWARGS (CDR E))
E
(SIMPLIFYA (CONS (CONS (CAAR E) (MEMQ 'ARRAY (CDAR E))) NEWARGS)
NIL))))))
(DEFMFUN $DEPENDS N
(IF (ODDP N) (MERROR "DEPENDS takes an even number of arguments."))
(DO ((I 1 (+ I 2)) (L))
((> I N) (I-$DEPENDENCIES (NREVERSE L)))
(COND (($LISTP (ARG I))
(DO L1 (CDR (ARG I)) (CDR L1) (NULL L1)
(SETQ L (CONS (DEPENDS1 (CAR L1) (ARG (1+ I))) L))))
(T (SETQ L (CONS (DEPENDS1 (ARG I) (ARG (1+ I))) L))))))
(DEFUN DEPENDS1 (X Y)
(NONSYMCHK X '$DEPENDS)
(CONS (NCONS X) (IF ($LISTP Y) (CDR Y) (NCONS Y))))
(DEFMSPEC $DEPENDENCIES (FORM) (I-$DEPENDENCIES (CDR FORM)))
(DEFMFUN I-$DEPENDENCIES (L)
(DOLIST (Z L)
(COND ((ATOM Z) (MERROR "Wrong format. Try F(X)."))
((OR (EQ (CAAR Z) 'MQAPPLY) (MEMQ 'ARRAY (CDAR Z)))
(MERROR "Improper form for DEPENDS:~%~M" Z))
(T (LET ((Y (MGET (CAAR Z) 'DEPENDS)))
(MPUTPROP (CAAR Z)
(SETQ Y (UNION* (REVERSE (CDR Z)) Y))
'DEPENDS)
(ADD2LNC (CONS (NCONS (CAAR Z)) Y) $DEPENDENCIES)))))
(CONS '(MLIST SIMP) L))
(DEFMSPEC $GRADEF (L) (SETQ L (CDR L))
(LET ((Z (CAR L)) (N 0))
(COND ((ATOM Z)
(IF (NOT (= (LENGTH L) 3)) (MERROR "Wrong arguments to GRADEF"))
(MPUTPROP Z
(CONS (CONS (CADR L) (MEVAL (CADDR L)))
(MGET Z '$ATOMGRAD))
'$ATOMGRAD)
(I-$DEPENDENCIES (NCONS (LIST (NCONS Z) (CADR L))))
(ADD2LNC Z $PROPS)
Z)
((OR (MOPP1 (CAAR Z)) (MEMQ 'ARRAY (CDAR Z)))
(MERROR "Wrong arguments to GRADEF:~%~M" Z))
((PROG2 (SETQ N (- (LENGTH Z) (LENGTH L))) (MINUSP N))
(WNA-ERR '$GRADEF))
(T (DO ZL (CDR Z) (CDR ZL) (NULL ZL)
(IF (NOT (SYMBOLP (CAR ZL)))
(MERROR "Parameters to GRADEF must be names:~%~M"
(CAR ZL))))
(SETQ L (NCONC (MAPCAR #'(LAMBDA (X) (REMSIMP (MEVAL X)))
(CDR L))
(MAPCAR #'(LAMBDA (X) (LIST '(%DERIVATIVE) Z X 1))
(NTHCDR (- (LENGTH Z) N) Z))))
(PUTPROP (CAAR Z)
(SUBLIS (MAPCAR #'CONS (CDR Z) (MAPCAR #'STRIPDOLLAR (CDR Z)))
(CONS (CDR Z) L))
'GRAD)
(ADD2LNC (CONS (NCONS (CAAR Z)) (CDR Z)) $GRADEFS)
Z))))
(DEFMFUN $DIFF N (LET (DERIVLIST) (DERIV (LISTIFY N))))
(DEFMFUN $DEL (E) (STOTALDIFF E))
(DEFUN DERIV (E)
(PROG (EXP Z COUNT)
(COND ((NULL E) (WNA-ERR '$DIFF))
((NULL (CDR E)) (RETURN (STOTALDIFF (CAR E))))
((NULL (CDDR E)) (NCONC E '(1))))
(SETQ EXP (CAR E) Z (SETQ E (APPEND E NIL)))
LOOP (IF (OR (NULL DERIVLIST) (MEMBER (CADR Z) DERIVLIST)) (GO DOIT))
; DERIVLIST is set by $EV
(SETQ Z (CDR Z))
LOOP2(COND ((CDR Z) (GO LOOP)) ((NULL (CDR E)) (RETURN EXP)) (T (GO NOUN)))
DOIT (COND ((NONVARCHK (CADR Z) '$DIFF NIL T))
((NULL (CDDR Z)) (WNA-ERR '$DIFF))
((NOT (FIXP (CADDR Z))) (GO NOUN))
((MINUSP (SETQ COUNT (CADDR Z)))
(MERROR "Improper count to DIFF:~%~M" COUNT)))
LOOP1(COND ((ZEROP COUNT) (RPLACD Z (CDDDR Z)) (GO LOOP2))
((EQUAL (SETQ EXP (SDIFF EXP (CADR Z))) 0) (RETURN 0)))
(SETQ COUNT (1- COUNT))
(GO LOOP1)
NOUN (RETURN (DIFF%DERIV (CONS EXP (CDR E))))))
(DEFUN CHAINRULE (E X)
(LET (W)
(COND (ISLINP (IF (AND (NOT (ATOM E))
(EQ (CAAR E) '%DERIVATIVE)
(NOT (FREEL (CDR E) X)))
(DIFF%DERIV (LIST E X 1))
0))
((ATOMGRAD E X))
((NOT (SETQ W (MGET (COND ((ATOM E) E)
((MEMQ 'ARRAY (CDAR E)) (CAAR E))
((ATOM (CADR E)) (CADR E))
(T (CAAADR E)))
'DEPENDS)))
0)
(T (LET (DERIVFLAG)
(ADDN (MAPCAR
#'(LAMBDA (U)
(LET ((Y (SDIFF U X)))
(IF (EQUAL Y 0)
0
(LIST '(MTIMES)
(OR (ATOMGRAD E U)
(LIST '(%DERIVATIVE) E U 1))
Y))))
W)
NIL))))))
(DEFUN ATOMGRAD (E X)
(LET (Y) (AND (ATOM E) (SETQ Y (MGET E '$ATOMGRAD)) (ASSOLIKE X Y))))
(DEFUN DEPENDS (E X)
(COND ((ALIKE1 E X) T)
((MNUMP E) NIL)
((ATOM E) (MGET E 'DEPENDS))
(T (OR (DEPENDS (CAAR E) X) (DEPENDSL (CDR E) X)))))
(DEFUN DEPENDSL (L X)
(DO ((L L (CDR L))) ((NULL L) NIL)
(IF (DEPENDS (CAR L) X) (RETURN T))))
(DEFMFUN SDIFF (E X) ; The args to SDIFF are assumed to be simplified.
(COND ((ALIKE1 E X) 1)
((MNUMP E) 0)
((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) (CHAINRULE E X))
((EQ (CAAR E) 'MRAT) (RATDX E X))
((EQ (CAAR E) 'MPLUS) (ADDN (SDIFFMAP (CDR E) X) T))
((MBAGP E) (CONS (CAR E) (SDIFFMAP (CDR E) X)))
((EQ (CAAR E) '%SUM) (DIFFSUM E X))
((NOT (DEPENDS E X)) 0)
((EQ (CAAR E) 'MTIMES) (ADDN (SDIFFTIMES (CDR E) X) T))
((EQ (CAAR E) 'MEXPT) (DIFFEXPT E X))
((EQ (CAAR E) 'MNCTIMES)
(LET (($DOTDISTRIB T))
(ADD2 (NCMULN (CONS (SDIFF (CADR E) X) (CDDR E)) T)
(NCMUL2 (CADR E) (SDIFF (CONS '(MNCTIMES) (CDDR E)) X)))))
((AND $VECT_CROSS (EQ (CAAR E) '|$~|))
(ADD2* `((|$~|) ,(CADR E) ,(SDIFF (CADDR E) X))
`((|$~|) ,(SDIFF (CADR E) X) ,(CADDR E))))
((EQ (CAAR E) 'MNCEXPT) (DIFFNCEXPT E X))
((MEMQ (CAAR E) '(%LOG %PLOG))
(SDIFFGRAD (COND ((AND (NOT (ATOM (CADR E))) (EQ (CAAADR E) 'MABS))
(CONS (CAR E) (CDADR E)))
(T E))
X))
((EQ (CAAR E) '%DERIVATIVE)
(COND ((OR (ATOM (CADR E)) (MEMQ 'ARRAY (CDAADR E))) (CHAINRULE E X))
((FREEL (CDDR E) X) (DIFF%DERIV (CONS (SDIFF (CADR E) X) (CDDR E))))
(T (DIFF%DERIV (LIST E X 1)))))
((MEMQ (CAAR E) '(%BINOMIAL $BETA))
(LET ((EFACT ($MAKEFACT E))) (MUL2 (FACTOR (SDIFF EFACT X)) (DIV E EFACT))))
((EQ (CAAR E) '%INTEGRATE) (DIFFINT E X))
((EQ (CAAR E) '%LAPLACE) (DIFFLAPLACE E X))
((MEMQ (CAAR E) '(%REALPART %IMAGPART))
(LIST (NCONS (CAAR E)) (SDIFF (CADR E) X)))
(T (SDIFFGRAD E X))))
(DEFUN SDIFFGRAD (E X)
(LET ((FUN (CAAR E)) GRAD ARGS)
(COND ((AND (EQ FUN 'MQAPPLY) (GET (CAAADR E) 'GRAD))
(SDIFFGRAD (CONS (NCONS (CAAADR E)) (APPEND (CDADR E) (CDDR E)))
X))
((OR (EQ FUN 'MQAPPLY) (NULL (SETQ GRAD (GET FUN 'GRAD))))
(IF (NOT (DEPENDS E X)) 0 (DIFF%DERIV (LIST E X 1))))
((NOT (= (LENGTH (CDR E)) (LENGTH (CAR GRAD))))
(MERROR "Wrong number of arguments for ~:M" FUN))
(T (SETQ ARGS (SDIFFMAP (CDR E) X))
(ADDN (MAPCAR
#'MUL2
(CDR (SUBSTITUTEL
(CDR E) (CAR GRAD)
(DO ((L1 (CDR GRAD) (CDR L1))
(ARGS ARGS (CDR ARGS)) (L2))
((NULL L1) (CONS '(MLIST) (NREVERSE L2)))
(SETQ L2 (CONS (COND ((EQUAL (CAR ARGS) 0) 0)
(T (CAR L1)))
L2)))))
ARGS)
T)))))
(DEFUN SDIFFMAP (E X) (MAPCAR #'(LAMBDA (TERM) (SDIFF TERM X)) E))
(DEFUN SDIFFTIMES (L X)
(PROG (TERM LEFT OUT)
LOOP (SETQ TERM (CAR L) L (CDR L))
(SETQ OUT (CONS (MULN (CONS (SDIFF TERM X) (APPEND LEFT L)) T) OUT))
(IF (NULL L) (RETURN OUT))
(SETQ LEFT (CONS TERM LEFT))
(GO LOOP)))
(DEFUN DIFFEXPT (E X)
(IF (MNUMP (CADDR E))
(MUL3 (CADDR E) (POWER (CADR E) (ADDK (CADDR E) -1)) (SDIFF (CADR E) X))
(MUL2 E (ADD2 (MUL3 (POWER (CADR E) -1) (CADDR E) (SDIFF (CADR E) X))
(MUL2 (SIMPLIFYA (LIST '(%LOG) (CADR E)) T)
(SDIFF (CADDR E) X))))))
(DEFUN DIFF%DERIV (E) (LET (DERIVFLAG) (SIMPLIFYA (CONS '(%DERIVATIVE) E) T)))
(PROG1 '(GRAD properties)
(LET ((HEADER (PURCOPY '(X))))
(MAPC #'(LAMBDA (Z) (PUTPROP (CAR Z) (CONS HEADER (CDR Z)) 'GRAD))
; All these GRAD templates have been simplified and then the SIMP flags
; (which are unnecessary) have been removed to save core space.
'((%LOG ((MEXPT) X -1)) (%PLOG ((MEXPT) X -1))
(%GAMMA ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) X) ((%GAMMA) X)))
(MFACTORIAL ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) ((MPLUS) 1 X))
((MFACTORIAL) X)))
(%SIN ((%COS) X))
(%COS ((MTIMES) -1 ((%SIN) X)))
(%TAN ((MEXPT) ((%SEC) X) 2))
(%COT ((MTIMES) -1 ((MEXPT) ((%CSC) X) 2)))
(%SEC ((MTIMES) ((%SEC) X) ((%TAN) X)))
(%CSC ((MTIMES) -1 ((%COT) X) ((%CSC) X)))
(%ASIN ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2)))
(%ACOS ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2)))
((RAT) -1 2))))
(%ATAN ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1))
(%ACOT ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)))
(%ACSC ((MTIMES) -1 ((MEXPT) X -1)
((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
(%ASEC ((MTIMES) ((MEXPT) X -1) ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
(%SINH ((%COSH) X))
(%COSH ((%SINH) X))
(%TANH ((MEXPT) ((%SECH) X) 2))
(%COTH ((MTIMES) -1 ((MEXPT) ((%CSCH) X) 2)))
(%SECH ((MTIMES) -1 ((%SECH) X) ((%TANH) X)))
(%CSCH ((MTIMES) -1 ((%COTH) X) ((%CSCH) X)))
(%ASINH ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2)))
(%ACOSH ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))
(%ATANH ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) -1))
(%ACOTH ((MTIMES) -1 ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) -1)))
(%ASECH ((MTIMES) -1 ((MEXPT) X -1)
((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2))))
(%ACSCH ((MTIMES) -1 ((MEXPT) X -1)
((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2))))
(MABS ((MTIMES) X ((MEXPT) ((MABS) X) -1)))
(%ERF ((MTIMES) 2 ((MEXPT) $%PI ((RAT) -1 2))
((MEXPT) $%E ((MTIMES) -1 ((MEXPT) X 2)))))
; ($LI2 ((MTIMES) -1 ((%LOG) ((MPLUS) 1 ((MTIMES) -1 X))) ((MEXPT) X -1)))
($EI ((MTIMES) ((MEXPT) X -1) ((MEXPT) $%E X))))))
(DEFPROP $ATAN2 ((X Y) ((MTIMES) Y ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1))
((MTIMES) -1 X ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1)))
GRAD)
(DEFPROP $%J ((N X) ((%DERIVATIVE) ((MQAPPLY) (($%J ARRAY) N) X) N 1)
((MPLUS) ((MQAPPLY) (($%J ARRAY) ((MPLUS) -1 N)) X)
((MTIMES) -1 N ((MQAPPLY) (($%J ARRAY) N) X) ((MEXPT) X -1))))
GRAD)
(DEFPROP $LI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($LI ARRAY) N) X) N 1)
((MTIMES) ((MQAPPLY) (($LI ARRAY) ((MPLUS) -1 N)) X) ((MEXPT) X -1)))
GRAD)
(DEFPROP $PSI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($PSI ARRAY) N) X) N 1)
((MQAPPLY) (($PSI ARRAY) ((MPLUS) 1 N)) X))
GRAD))
(DEFMFUN ATVARSCHK (ARGL)
(DO ((LARGL (LENGTH ARGL) (1- LARGL)) (LATVRS (LENGTH ATVARS)) (L))
((NOT (< LATVRS LARGL)) (NCONC ATVARS L))
(SETQ L (CONS (IMPLODE (CONS '& (CONS '@ (MEXPLODEN LARGL)))) L))))
(DEFMFUN NOTLOREQ (X)
(OR (ATOM X)
(NOT (MEMQ (CAAR X) '(MLIST MEQUAL)))
(AND (EQ (CAAR X) 'MLIST)
(DOLIST (U (CDR X)) (IF (NOT (MEQUALP U)) (RETURN T))))))
(DEFMFUN SUBSTITUTEL (L1 L2 E)
(DO ((L1 L1 (CDR L1)) (L2 L2 (CDR L2))) ((NULL L1) E)
(SETQ E (SUBSTITUTE (CAR L1) (CAR L2) E))))
(DEFMFUN UNION* (A B)
(DO ((A A (CDR A)) (X B)) ((NULL A) X)
(IF (NOT (MEMALIKE (CAR A) B)) (SETQ X (CONS (CAR A) X)))))
(DEFMFUN NTHELEM (N E) (CAR (NTHCDR (1- N) E)))
(DEFMFUN DELSIMP (E) (DELQ 'SIMP (APPEND E NIL) 1))
(DEFMFUN REMSIMP (E)
(IF (ATOM E) E (CONS (DELSIMP (CAR E)) (MAPCAR #'REMSIMP (CDR E)))))
(DEFMFUN $TRUNC (E)
(COND ((ATOM E) E)
((EQ (CAAR E) 'MPLUS) (CONS (APPEND (CAR E) '(TRUNC)) (CDR E)))
((MBAGP E) (CONS (CAR E) (MAPCAR #'$TRUNC (CDR E))))
((SPECREPP E) ($TRUNC (SPECDISREP E)))
(T E)))
(DEFMSPEC $LDISPLAY (FORM) (DISP1 (CDR FORM) T T))
(DEFMFUN $LDISP N (DISP1 (LISTIFY N) T NIL))
(DEFMSPEC $DISPLAY (FORM) (DISP1 (CDR FORM) NIL T))
(DEFMFUN $DISP N (DISP1 (LISTIFY N) NIL NIL))
(DEFUN DISP1 (LL LABLIST EQNSP)
(IF LABLIST (SETQ LABLIST (NCONS '(MLIST SIMP))))
(DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0))
((NULL LL) (OR LABLIST '$DONE))
(SETQ L (CAR LL) ANS (IF EQNSP (MEVAL L) L))
(IF (AND EQNSP (NOT (MEQUALP ANS)))
(SETQ ANS (LIST '(MEQUAL SIMP) (DISP2 L) ANS)))
(IF LABLIST (NCONC LABLIST (NCONS (ELABEL ANS))))
(SETQ TIM (RUNTIME))
(DISPLA (LIST '(MLABLE) (IF LABLIST LINELABLE) ANS))
(MTERPRI)
(TIMEORG TIM)))
(DEFUN DISP2 (E)
(COND ((ATOM E) E)
((EQ (CAAR E) 'MQAPPLY)
(CONS '(MQAPPLY) (CONS (CONS (CAADR E) (MAPCAR #'MEVAL (CDADR E)))
(MAPCAR #'MEVAL (CDDR E)))))
((EQ (CAAR E) 'MSETQ) (DISP2 (CADR E)))
((EQ (CAAR E) 'MSET) (DISP2 (MEVAL (CADR E))))
((EQ (CAAR E) 'MLIST) (CONS (CAR E) (MAPCAR #'DISP2 (CDR E))))
((MSPECFUNP (CAAR E)) E)
(T (CONS (CAR E) (MAPCAR #'MEVAL (CDR E))))))
(DEFMFUN ELABEL (E)
(IF (NOT (CHECKLABEL $LINECHAR)) (SETQ $LINENUM (1+ $LINENUM)))
(MAKELABEL $LINECHAR)
(IF (NOT $NOLABELS) (SET LINELABLE E))
LINELABLE)
(DEFMFUN $DISPTERMS (E)
(COND ((OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) (DISPLA E))
((SPECREPP E) ($DISPTERMS (SPECDISREP E)))
(T (LET (($DISPFLAG T))
(MTERPRI)
(DISPLA (GETOP (MOP E)))
(DO E (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
(REVERSE (CDR E))
(MARGS E))
(CDR E) (NULL E) (MTERPRI) (DISPLA (CAR E)) (MTERPRI)))
(MTERPRI)))
'$DONE)
(DEFMFUN $DISPFORM N
(IF (NOT (OR (= N 1) (AND (= N 2) (EQ (ARG 2) '$ALL))))
(MERROR "Incorrect arguments to DISPFORM"))
(LET ((E (ARG 1)))
(IF (OR (ATOM E)
(ATOM (SETQ E (IF (= N 1) (NFORMAT E) (NFORMAT-ALL E))))
(MEMQ 'SIMP (CDAR E)))
E
(CONS (CONS (CAAR E) (CONS 'SIMP (CDAR E)))
(IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
(REVERSE (CDR E))
(CDR E))))))
(DEFMFUN $PART N (MPART (LISTIFY N) NIL NIL $INFLAG '$PART))
(DEFMFUN $INPART N (MPART (LISTIFY N) NIL NIL T '$INPART))
(DEFMSPEC $SUBSTPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL $INFLAG '$SUBSTPART)))
(DEFMSPEC $SUBSTINPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL T '$SUBSTINPART)))
(DEFMFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG) ; called only by TRANSLATE
(LET ((SUBSTP T)) (MPART ARGLIST SUBSTFLAG DISPFLAG INFLAG '$SUBSTPART)))
(DEFMFUN MPART (ARGLIST SUBSTFLAG DISPFLAG INFLAG FN)
(PROG (SUBSTITEM ARG ARG1 EXP EXP1 EXP* SEVLIST COUNT PREVCOUNT N SPECP
LASTELEM LASTCOUNT)
(DECLARE (FIXNUM PREVCOUNT LASTELEM LASTCOUNT))
(SETQ SPECP (OR SUBSTFLAG DISPFLAG))
(IF SUBSTFLAG (SETQ SUBSTITEM (CAR ARGLIST) ARGLIST (CDR ARGLIST)))
(IF (NULL ARGLIST) (WNA-ERR '$PART))
(SETQ EXP (IF SUBSTFLAG (MEVAL (CAR ARGLIST)) (CAR ARGLIST)))
(WHEN (NULL (SETQ ARGLIST (CDR ARGLIST)))
(SETQ $PIECE EXP)
(RETURN (COND (SUBSTFLAG (MEVAL SUBSTITEM))
(DISPFLAG (BOX EXP DISPFLAG))
(T EXP))))
(COND ((NOT INFLAG)
(COND ((OR (AND ($LISTP EXP) (NULL (CDR ARGLIST)))
(AND ($MATRIXP EXP)
(OR (NULL (CDR ARGLIST)) (NULL (CDDR ARGLIST)))))
(SETQ INFLAG T))
((NOT SPECP) (SETQ EXP (NFORMAT EXP)))
(T (SETQ EXP (NFORMAT-ALL EXP)))))
((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
(IF (AND (ATOM EXP) (NULL $PARTSWITCH))
(MERROR "~:M called on atom: ~:M" FN EXP))
(IF (AND INFLAG SPECP) (SETQ EXP (SUBST NIL NIL EXP)))
(SETQ EXP* EXP)
START(COND ((OR (ATOM EXP) (EQ (CAAR EXP) 'BIGFLOAT)) (GO ERR))
((EQUAL (SETQ ARG (COND (SUBSTFLAG (MEVAL (CAR ARGLIST)))
(T (CAR ARGLIST))))
0)
(SETQ ARGLIST (CDR ARGLIST))
(COND ((MNUMP SUBSTITEM)
(MERROR "~M is an invalid operator in ~:M"
SUBSTITEM FN))
((AND SPECP ARGLIST)
(IF (EQ (CAAR EXP) 'MQAPPLY)
(PROG2 (SETQ EXP (CADR EXP)) (GO START))
(MERROR "Invalid operator in ~:M" FN)))
(T (SETQ $PIECE (GETOP (MOP EXP)))
(RETURN
(COND (SUBSTFLAG
(SETQ SUBSTITEM (GETOPR (MEVAL SUBSTITEM)))
(COND ((MNUMP SUBSTITEM)
(MERROR "Invalid operator in ~:M:~%~M"
FN SUBSTITEM))
((NOT (ATOM SUBSTITEM))
(IF (NOT (EQ (CAAR EXP) 'MQAPPLY))
(RPLACA (RPLACD EXP (CONS (CAR EXP)
(CDR EXP)))
'(MQAPPLY)))
(RPLACA (CDR EXP) SUBSTITEM)
(RETURN (RESIMPLIFY EXP*)))
((EQ (CAAR EXP) 'MQAPPLY)
(RPLACD EXP (CDDR EXP))))
(RPLACA EXP (CONS SUBSTITEM
(IF (AND (MEMQ 'ARRAY (CDAR EXP))
(NOT (MOPP SUBSTITEM)))
'(ARRAY))))
(RESIMPLIFY EXP*))
(DISPFLAG
(RPLACD EXP (CDR (BOX (SUBST NIL NIL EXP) DISPFLAG)))
(RPLACA EXP (IF (EQ DISPFLAG T)
'(MBOX)
'(MLABOX)))
(RESIMPLIFY EXP*))
(T (WHEN ARGLIST (SETQ EXP $PIECE) (GO A))
$PIECE))))))
((NOT (ATOM ARG)) (GO SEVERAL))
((NOT (EQ (TYPEP ARG) 'FIXNUM))
(MERROR "Non-integer argument to ~:M:~%~M" FN ARG))
((< ARG 0) (GO BAD)))
(IF (EQ (CAAR EXP) 'MQAPPLY) (SETQ EXP (CDR EXP)))
LOOP (COND ((NOT (ZEROP ARG)) (SETQ ARG (1- ARG) EXP (CDR EXP))
(IF (NULL EXP) (GO ERR)) (GO LOOP))
((NULL (SETQ ARGLIST (CDR ARGLIST)))
(RETURN (COND (SUBSTFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
(RPLACA EXP (MEVAL SUBSTITEM))
(RESIMPLIFY EXP*))
(DISPFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
(RPLACA EXP (BOX (CAR EXP) DISPFLAG))
(RESIMPLIFY EXP*))
(INFLAG (SETQ $PIECE (CAR EXP)))
(T (SETQ $PIECE (SIMPLIFY (CAR EXP))))))))
(SETQ EXP (CAR EXP))
A (COND ((AND (NOT INFLAG) (NOT SPECP)) (SETQ EXP (NFORMAT EXP)))
((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
(GO START)
ERR (COND ((EQ $PARTSWITCH 'MAPPLY)
(MERROR "Improper index to list or matrix"))
($PARTSWITCH (RETURN (SETQ $PIECE '$END)))
(T (MERROR "~:M fell off end." FN)))
BAD (IMPROPER-ARG-ERR ARG FN)
SEVERAL
(IF (OR (NOT (MEMQ (CAAR ARG) '(MLIST $ALLBUT))) (CDR ARGLIST))
(GO BAD))
(SETQ EXP1 (CONS (CAAR EXP) (IF (MEMQ 'ARRAY (CDAR EXP)) '(ARRAY))))
(IF (EQ (CAAR EXP) 'MQAPPLY)
(SETQ SEVLIST (LIST (CADR EXP) EXP1) EXP (CDDR EXP))
(SETQ SEVLIST (NCONS EXP1) EXP (CDR EXP)))
(SETQ ARG1 (CDR ARG) PREVCOUNT 0 EXP1 EXP)
(DOLIST (ARG* ARG1)
(IF (NOT (EQ (TYPEP ARG*) 'FIXNUM))
(MERROR "Non-integer argument to ~:M:~%~M" FN ARG*)))
(WHEN (AND SPECP (EQ (CAAR ARG) 'MLIST))
(IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1))))
(SETQ ARG1 (SORT (APPEND ARG1 NIL) #'<)))
(WHEN (EQ (CAAR ARG) '$ALLBUT)
(SETQ N (LENGTH EXP))
(DOLIST (I ARG1)
(IF (OR (< I 1) (> I N))
(MERROR "Invalid argument to ~:M:~%~M" FN I)))
(DO ((I N (1- I)) (ARG2))
((= I 0) (SETQ ARG1 ARG2))
(IF (NOT (MEMBER I ARG1)) (SETQ ARG2 (CONS I ARG2))))
(IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1)))))
(IF (NULL ARG1) (IF SPECP (GO BAD) (GO END)))
(IF SUBSTFLAG (SETQ LASTCOUNT LASTELEM))
SEVLOOP
(IF SPECP
(SETQ COUNT (- (CAR ARG1) PREVCOUNT) PREVCOUNT (CAR ARG1))
(SETQ COUNT (CAR ARG1)))
(IF (< COUNT 1) (GO BAD))
(IF (AND SUBSTFLAG (< (CAR ARG1) LASTELEM))
(SETQ LASTCOUNT (1- LASTCOUNT)))
COUNT(COND ((NULL EXP) (GO ERR))
((NOT (= COUNT 1)) (SETQ COUNT (1- COUNT) EXP (CDR EXP)) (GO COUNT)))
(SETQ SEVLIST (CONS (CAR EXP) SEVLIST))
(SETQ ARG1 (CDR ARG1))
END (COND ((NULL ARG1)
(SETQ SEVLIST (NREVERSE SEVLIST))
(SETQ $PIECE (IF (OR INFLAG (NOT SPECP))
(SIMPLIFY SEVLIST)
(RESIMPLIFY SEVLIST)))
(RETURN (COND (SUBSTFLAG (RPLACA (NTHCDR (1- LASTCOUNT) EXP1)
(MEVAL SUBSTITEM))
(RESIMPLIFY EXP*))
(DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
(RESIMPLIFY EXP*))
(T $PIECE))))
(SUBSTFLAG (IF (NULL (CDR EXP)) (GO ERR))
(RPLACA EXP (CADR EXP)) (RPLACD EXP (CDDR EXP)))
(DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
(SETQ EXP (CDR EXP)))
(T (SETQ EXP EXP1)))
(GO SEVLOOP)))
(DEFMFUN GETOP (X) (OR (AND (SYMBOLP X) (GET X 'OP)) X))
(DEFMFUN GETOPR (X) (OR (AND (SYMBOLP X) (GET X 'OPR)) X))
; List manipulation commands
(DEFMFUN LISTERCHK (L FUN 2NDP)
(WHEN (NOT ($LISTP L))
(MERROR "~Margument to ~:M not a list: ~M"
(IF 2NDP '|2nd | '||)
FUN
L)))
(DEFMFUN $LISTP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MLIST)))
(DEFMFUN $CONS (X L) (LISTERCHK L '$CONS T) (CONS (CAR L) (CONS X (CDR L))))
(DEFMFUN $APPEND N
`((MLIST SIMP)
,@(APPLY #'APPEND
(MAPCAR #'(LAMBDA (X)
(LISTERCHK X '$APPEND NIL)
(CDR X))
(LISTIFY N)))))
(DEFMFUN $ENDCONS (X L) (LISTERCHK L '$ENDCONS T) (APPEND L (NCONS X)))
(DEFMFUN $MEMBER (X L)
(LISTERCHK (SETQ L ($TOTALDISREP L)) '$MEMBER T)
(IF (MEMALIKE ($TOTALDISREP X) (CDR L)) T))
; General manipulation commands
(DEFMFUN ATOMCHK (E FUN 2NDP)
(WHEN (OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT))
(MERROR "~Margument to ~:M was atomic: ~M"
(IF 2NDP '|2nd | '||) FUN E)))
(DEFMFUN FORMAT1 (E)
(COND (($LISTP E) E) ($INFLAG (SPECREPCHECK E)) (T (NFORMAT E))))
(DEFMFUN $FIRST (E)
(ATOMCHK (SETQ E (FORMAT1 E)) '$FIRST NIL)
(IF (NULL (CDR E)) (MERROR "Argument to FIRST is empty."))
(CAR (MARGS E)))
(DEFMFUN $REST N
(PROG (M FUN FUN1 REVP)
(IF (AND (= N 2) (EQUAL (ARG 2) 0)) (RETURN (ARG 1)))
(ATOMCHK (SETQ M (FORMAT1 (ARG 1))) '$REST NIL)
(COND ((= N 1))
((NOT (= N 2)) (WNA-ERR '$REST))
((NOT (EQ (TYPEP (ARG 2)) 'FIXNUM))
(MERROR "2nd argument to REST must be an integer:~%~M"
(ARG 2)))
((MINUSP (SETQ N (ARG 2))) (SETQ N (- N) REVP T)))
(IF (< (LENGTH (MARGS M)) N)
(IF $PARTSWITCH (RETURN '$END) (MERROR "REST fell off end.")))
(SETQ FUN (CAR M))
(IF (EQ (CAR FUN) 'MQAPPLY) (SETQ FUN1 (CADR M) M (CDR M)))
(SETQ M (CDR M))
(IF REVP (SETQ M (REVERSE M)))
(DO N N (1- N) (ZEROP N) (SETQ M (CDR M)))
(SETQ M (CONS (IF (EQ (CAR FUN) 'MLIST) FUN (DELSIMP FUN))
(IF REVP (NREVERSE M) M)))
(IF (EQ (CAR FUN) 'MQAPPLY)
(RETURN (CONS (CAR M) (CONS FUN1 (CDR M)))))
(RETURN M)))
(DEFMFUN $LAST (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$LAST NIL)
(IF (NULL (CDR E)) E (CAR (LAST E))))
(DEFMFUN $ARGS (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$ARGS NIL)
(CONS '(MLIST) (MARGS E)))
(DEFMFUN $REVERSE (E)
(ATOMCHK (SETQ E (FORMAT1 E)) '$REVERSE NIL)
(IF (EQ (CAAR E) 'MQAPPLY)
(LIST* (DELSIMP (CAR E)) (CADR E) (REVERSE (CDDR E)))
(CONS (IF (EQ (CAAR E) 'MLIST) (CAR E) (DELSIMP (CAR E)))
(REVERSE (CDR E)))))
(DEFMFUN $DELETE N
(COND ((= N 2) (SETQ N -1))
((NOT (= N 3)) (WNA-ERR '$DELETE))
((OR (NOT (EQ (TYPEP (ARG 3)) 'FIXNUM)) (MINUSP (SETQ N (ARG 3))))
(MERROR "Improper 3rd argument to DELETE:~%~M" (ARG 3))))
(LET ((X (ARG 1)) (L (ARG 2)))
(ATOMCHK (SETQ L (SPECREPCHECK L)) '$DELETE T)
(SETQ X (SPECREPCHECK X) L (CONS (DELSIMP (CAR L)) (APPEND (CDR L) NIL)))
(PROG (L1)
(SETQ L1 (IF (EQ (CAAR L) 'MQAPPLY) (CDR L) L))
LOOP (COND ((OR (NULL (CDR L1)) (ZEROP N)) (RETURN L))
((ALIKE1 X (SPECREPCHECK (CADR L1)))
(SETQ N (1- N)) (RPLACD L1 (CDDR L1)))
(T (SETQ L1 (CDR L1))))
(GO LOOP))))
(DEFMFUN $LENGTH (E)
(SETQ E (COND (($LISTP E) E)
((OR $INFLAG (NOT ($RATP E))) (SPECREPCHECK E))
(T ($RATDISREP E))))
(COND ((SYMBOLP E) (MERROR "LENGTH called on atomic symbol ~:M" E))
((OR (NUMBERP E) (EQ (CAAR E) 'BIGFLOAT))
(IF (AND (NOT $INFLAG) (MNEGP E))
1
(MERROR "LENGTH called on number ~:M" E)))
((OR $INFLAG (NOT (MEMQ (CAAR E) '(MTIMES MEXPT)))) (LENGTH (MARGS E)))
((EQ (CAAR E) 'MEXPT)
(IF (AND (ALIKE1 (CADDR E) '((RAT SIMP) 1 2)) $SQRTDISPFLAG) 1 2))
(T (LENGTH (CDR (NFORMAT E))))))
(DEFMFUN $ATOM (X)
(SETQ X (SPECREPCHECK X)) (OR (ATOM X) (EQ (CAAR X) 'BIGFLOAT)))
(DEFMFUN $SYMBOLP (X) (SETQ X (SPECREPCHECK X)) (SYMBOLP X))
(DEFMFUN $NUM (E)
(LET (X)
(COND ((ATOM E) E)
((EQ (CAAR E) 'MRAT) ($RATNUMER E))
((EQ (CAAR E) 'RAT) (CADR E))
((EQ (CAAR (SETQ X (NFORMAT E))) 'MQUOTIENT) (SIMPLIFY (CADR X)))
((AND (EQ (CAAR X) 'MMINUS) (NOT (ATOM (SETQ X (CADR X))))
(EQ (CAAR X) 'MQUOTIENT))
(SIMPLIFY (LIST '(MTIMES) -1 (CADR X))))
(T E))))
(DEFMFUN $DENOM (E)
(COND ((ATOM E) 1)
((EQ (CAAR E) 'MRAT) ($RATDENOM E))
((EQ (CAAR E) 'RAT) (CADDR E))
((OR (EQ (CAAR (SETQ E (NFORMAT E))) 'MQUOTIENT)
(AND (EQ (CAAR E) 'MMINUS) (NOT (ATOM (SETQ E (CADR E))))
(EQ (CAAR E) 'MQUOTIENT)))
(SIMPLIFY (CADDR E)))
(T 1)))
(DEFMFUN $FIX (E) ($ENTIER E))
(DEFMFUN $ENTIER (E)
(LET ((E1 (SPECREPCHECK E)))
(COND ((NUMBERP E1) (FIX E1))
((RATNUMP E1) (SETQ E (QUOTIENT (CADR E1) (CADDR E1)))
(IF (MINUSP (CADR E1)) (SUB1 E) E))
(($BFLOATP E1)
(SETQ E (FPENTIER E1))
(IF (AND (MINUSP (CADR E1)) (NOT (ZEROP1 (SUB E E1))))
(SUB1 E)
E))
(T (LIST '($ENTIER) E)))))
(DEFMFUN $FLOAT (E)
(COND ((NUMBERP E) (FLOAT E))
((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) E)
((EQ (CAAR E) 'RAT) (FPCOFRAT E))
((EQ (CAAR E) 'BIGFLOAT) (FP2FLO E))
((MEMQ (CAAR E) '(MEXPT MNCEXPT))
(LIST (NCONS (CAAR E)) ($FLOAT (CADR E)) (CADDR E)))
(T (RECUR-APPLY #'$FLOAT E))))
(DEFMFUN $COEFF N
(COND ((= N 3) (IF (EQUAL (ARG 3) 0)
(COEFF (ARG 1) (ARG 2) (ARG 3))
(COEFF (ARG 1) (POWER (ARG 2) (ARG 3)) 1)))
((= N 2) (COEFF (ARG 1) (ARG 2) 1))
(T (WNA-ERR '$COEFF))))
(DEFMFUN COEFF (E VAR POW)
(SIMPLIFY
(COND ((ALIKE1 E VAR) (IF (EQUAL POW 1) 1 0))
((ATOM E) (IF (EQUAL POW 0) E 0))
((EQ (CAAR E) 'MEXPT)
(COND ((ALIKE1 (CADR E) VAR)
(IF (OR (EQUAL POW 0) (NOT (ALIKE1 (CADDR E) POW))) 0 1))
((EQUAL POW 0) E)
(T 0)))
((OR (EQ (CAAR E) 'MPLUS) (MBAGP E))
(CONS (IF (EQ (CAAR E) 'MPLUS) '(MPLUS) (CAR E))
(MAPCAR #'(LAMBDA (E) (COEFF E VAR POW)) (CDR E))))
((EQ (CAAR E) 'MRAT) (RATCOEFF E VAR POW))
((EQUAL POW 0) (IF (FREE E VAR) E 0))
((EQ (CAAR E) 'MTIMES)
(LET ((TERM (IF (EQUAL POW 1) VAR (POWER VAR POW))))
(IF (MEMALIKE TERM (CDR E)) ($DELETE TERM E 1) 0)))
(T 0))))
(DECLARE (SPECIAL POWERS VAR HIFLG NUM FLAG))
(DEFMFUN $HIPOW (E VAR) (FINDPOWERS E T))
; These work best on expanded "simple" expressions.
(DEFMFUN $LOPOW (E VAR) (FINDPOWERS E NIL))
(DEFUN FINDPOWERS (E HIFLG)
(LET (POWERS NUM FLAG)
(FINDPOWERS1 E)
(COND ((NULL POWERS) (IF (NULL NUM) 0 NUM))
(T (IF NUM (SETQ POWERS (CONS NUM POWERS)))
(MAXIMIN POWERS (IF HIFLG '$MAX '$MIN))))))
(DEFUN FINDPOWERS1 (E)
(COND ((ALIKE1 E VAR) (CHECKPOW 1))
((ATOM E))
((EQ (CAAR E) 'MPLUS)
(COND ((NOT (FREEL (CDR E) VAR))
(DO E (CDR E) (CDR E) (NULL E)
(SETQ FLAG NIL) (FINDPOWERS1 (CAR E))
(IF (NULL FLAG) (CHECKPOW 0))))))
((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADR E) VAR)) (CHECKPOW (CADDR E)))
((SPECREPP E) (FINDPOWERS1 (SPECDISREP E)))
(T (MAPC #'FINDPOWERS1 (CDR E)))))
(DEFUN CHECKPOW (POW)
(SETQ FLAG T)
(COND ((NOT (NUMBERP POW)) (SETQ POWERS (CONS POW POWERS)))
((NULL NUM) (SETQ NUM POW))
(HIFLG (IF (GREATERP POW NUM) (SETQ NUM POW)))
((LESSP POW NUM) (SETQ NUM POW))))
(DECLARE (UNSPECIAL POWERS VAR HIFLG NUM FLAG))
; Undeclarations for the file:
(DECLARE (NOTYPE I N LARGL LVRS COUNT TIM))

771
src/jpg/comm2.56 Normal file
View File

@@ -0,0 +1,771 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1982 Massachusetts Institute of Technology **
(macsyma-module comm2)
(DECLARE (GENPREFIX CC) (SPECIAL $PROPS) (FIXNUM N I J))
(DECLARE (SPLITFILE DIFF2) (SPECIAL $DOTDISTRIB))
(DEFMFUN DIFFINT (E X)
((LAMBDA (A)
(COND ((NULL (CDDDR E))
(COND ((ALIKE1 X (CADDR E)) (CADR E))
((AND (NOT (ATOM (CADDR E))) (ATOM X) (NOT (FREE (CADDR E) X)))
(MUL2 (CADR E) (SDIFF (CADDR E) X)))
((OR ($CONSTANTP (SETQ A (SDIFF (CADR E) X)))
(AND (ATOM (CADDR E)) (FREE A (CADDR E))))
(MUL2 A (CADDR E)))
(T (SIMPLIFYA (LIST '(%INTEGRATE) A (CADDR E)) T))))
((ALIKE1 X (CADDR E)) (ADDN (DIFFINT1 (CDR E) X X) T))
(T (ADDN (CONS (COND ((EQUAL (SETQ A (SDIFF (CADR E) X)) 0) 0)
(T (SIMPLIFYA (LIST '(%INTEGRATE) A (CADDR E)
(CADDDR E) (CAR (CDDDDR E))) T)))
(DIFFINT1 (CDR E) X (CADDR E))) T))))
NIL))
(DEFUN DIFFINT1 (E X Y)
(LET ((U (SDIFF (CADDDR E) X)) (V (SDIFF (CADDR E) X)))
(LIST (IF (ZEROP U) 0 (MUL2 U (SUBSTITUTE (CADDDR E) Y (CAR E))))
(IF (ZEROP V) 0 (MUL3 V (SUBSTITUTE (CADDR E) Y (CAR E)) -1)))))
(DEFMFUN DIFFSUM (E X)
(COND ((OR (NOT (ATOM X)) (NOT (FREE (CADDDR E) X)) (NOT (FREE (CAR (CDDDDR E)) X)))
(DIFF%DERIV (LIST E X 1)))
((EQ (CADDR E) X) 0)
(T (SIMPLIFYA (LIST '(%SUM) (SDIFF (CADR E) X) (CADDR E) (CADDDR E) (CAR (CDDDDR E)))
T))))
(DEFMFUN DIFFLAPLACE (E X)
(COND ((OR (NOT (ATOM X)) (EQ (CADDDR E) X)) (DIFF%DERIV (LIST E X 1)))
((EQ (CADDR E) X) 0)
(T ($LAPLACE (SDIFF (CADR E) X) (CADDR E) (CADDDR E)))))
(DEFMFUN DIFFNCEXPT (E X)
((LAMBDA (BASE* POW)
(COND ((AND (MNUMP POW) (OR (NOT (EQ (TYPEP POW) 'FIXNUM)) (< POW 0))) ; POW cannot be 0
(DIFF%DERIV (LIST E X 1)))
((AND (ATOM BASE*) (EQ BASE* X) (FREE POW BASE*))
(MUL2* POW (LIST '(MNCEXPT) BASE* (ADD2 POW -1))))
((EQ (TYPEP POW) 'FIXNUM)
((LAMBDA (DERIV ANS)
(DO I 0 (1+ I) (= I POW)
(SETQ ANS (CONS (LIST '(MNCTIMES) (LIST '(MNCEXPT) BASE* I)
(LIST '(MNCTIMES) DERIV
(LIST '(MNCEXPT) BASE* (- POW 1 I))))
ANS)))
(ADDN ANS NIL))
(SDIFF BASE* X) NIL))
((AND (NOT (DEPENDS POW X)) (OR (ATOM POW) (AND (ATOM BASE*) (FREE POW BASE*))))
((LAMBDA (DERIV INDEX)
(SIMPLIFYA
(LIST '(%SUM)
(LIST '(MNCTIMES) (LIST '(MNCEXPT) BASE* INDEX)
(LIST '(MNCTIMES) DERIV
(LIST '(MNCEXPT) BASE*
(LIST '(MPLUS) POW -1 (LIST '(MTIMES) -1 INDEX)))))
INDEX 0 (LIST '(MPLUS) POW -1)) NIL))
(SDIFF BASE* X) (GENSUMINDEX)))
(T (DIFF%DERIV (LIST E X 1)))))
(CADR E) (CADDR E)))
(DEFMFUN STOTALDIFF (E)
(COND ((OR (MNUMP E) (CONSTANT E)) 0)
((OR (ATOM E) (MEMQ 'ARRAY (CDAR E)))
(LET ((W (MGET (IF (ATOM E) E (CAAR E)) 'DEPENDS)))
(IF W (CONS '(MPLUS)
(MAPCAR #'(LAMBDA (X)
(LIST '(MTIMES) (CHAINRULE E X) (LIST '(%DEL) X)))
W))
(LIST '(%DEL) E))))
((SPECREPP E) (STOTALDIFF (SPECDISREP E)))
((EQ (CAAR E) 'MNCTIMES)
(LET (($DOTDISTRIB T))
(ADD2 (NCMULN (CONS (STOTALDIFF (CADR E)) (CDDR E)) T)
(NCMUL2 (CADR E) (STOTALDIFF (NCMULN (CDDR E) T))))))
((EQ (CAAR E) 'MNCEXPT)
(IF (AND (EQ (TYPEP (CADDR E)) 'FIXNUM) (> (CADDR E) 0))
(STOTALDIFF (LIST '(MNCTIMES) (CADR E)
(NCPOWER (CADR E) (1- (CADDR E)))))
(LIST '(%DERIVATIVE) E)))
(T (ADDN (CONS 0 (MAPCAR #'(LAMBDA (X)
(MUL2 (SDIFF E X) (LIST '(%DEL SIMP) X)))
(EXTRACTVARS (MARGS E))))
T))))
(DEFUN EXTRACTVARS (E)
(COND ((NULL E) NIL)
((ATOM (CAR E))
(IF (NOT (CONSTANTP (CAR E)))
(UNION* (NCONS (CAR E)) (EXTRACTVARS (CDR E)))
(EXTRACTVARS (CDR E))))
((MEMQ 'ARRAY (CDAAR E)) (UNION* (NCONS (CAR E)) (EXTRACTVARS (CDR E))))
(T (UNION* (EXTRACTVARS (CDAR E)) (EXTRACTVARS (CDR E))))))
(DECLARE (SPLITFILE AT)
(SPECIAL ATVARS ATEQS ATP MUNBOUND) (*LEXPR $SUBSTITUTE))
(DEFMFUN $ATVALUE (EXP EQS VAL)
(LET (DL VL FUN)
(COND ((NOTLOREQ EQS) (IMPROPER-ARG-ERR EQS '$ATVALUE))
((OR (ATOM EXP) (AND (EQ (CAAR EXP) '%DERIVATIVE) (ATOM (CADR EXP))))
(IMPROPER-ARG-ERR EXP '$ATVALUE)))
(COND ((NOT (EQ (CAAR EXP) '%DERIVATIVE))
(SETQ FUN (CAAR EXP) VL (CDR EXP) DL (LISTOF0S VL)))
(T (SETQ FUN (CAAADR EXP) VL (CDADR EXP))
(DOLIST (V VL)
(SETQ DL (NCONC DL (NCONS (OR (GET (CDR EXP) V) 0)))))))
(IF (OR (MOPP FUN) (EQ FUN 'MQAPPLY)) (IMPROPER-ARG-ERR EXP '$ATVALUE))
(ATVARSCHK VL)
(DO ((VL1 VL (CDR VL1)) (L ATVARS (CDR L))) ((NULL VL1))
(IF (AND (SYMBOLP (CAR VL1)) (NOT (MGET (CAR VL1) '$CONSTANT)))
(SETQ VAL (SUBSTITUTE (CAR L) (CAR VL1) VAL))
(IMPROPER-ARG-ERR (CONS '(MLIST) VL) '$ATVALUE)))
(SETQ EQS (IF (EQ (CAAR EQS) 'MEQUAL) (LIST EQS) (CDR EQS)))
(SETQ EQS (DO ((EQS EQS (CDR EQS)) (L)) ((NULL EQS) L)
(IF (NOT (MEMQ (CADAR EQS) VL))
(IMPROPER-ARG-ERR (CAR EQS) '$ATVALUE))
(SETQ L (NCONC L (NCONS (CONS (CADAR EQS) (CADDAR EQS)))))))
(SETQ VL (DO ((VL VL (CDR VL)) (L)) ((NULL VL) L)
(SETQ L (NCONC L (NCONS (CDR (OR (ASSQ (CAR VL) EQS)
(CONS NIL MUNBOUND))))))))
(DO ((ATVALUES (MGET FUN 'ATVALUES) (CDR ATVALUES)))
((NULL ATVALUES)
(MPUTPROP FUN (CONS (LIST DL VL VAL) (MGET FUN 'ATVALUES)) 'ATVALUES))
(WHEN (AND (EQUAL (CAAR ATVALUES) DL) (EQUAL (CADAR ATVALUES) VL))
(RPLACA (CDDAR ATVALUES) VAL) (RETURN NIL)))
(ADD2LNC FUN $PROPS)
VAL))
(DEFMFUN $AT (EXP ATEQS)
(IF (NOTLOREQ ATEQS) (IMPROPER-ARG-ERR ATEQS '$AT))
(ATSCAN (LET ((ATP T)) ($SUBSTITUTE ATEQS EXP))))
(DEFUN ATSCAN (EXP)
(COND ((OR (ATOM EXP) (MEMQ (CAAR EXP) '(%AT MRAT))) EXP)
((EQ (CAAR EXP) '%DERIVATIVE)
(OR (AND (NOT (ATOM (CADR EXP)))
(LET ((VL (CDADR EXP)) DL)
(DOLIST (V VL)
(SETQ DL (NCONC DL (NCONS (OR (GET (CDR EXP) V)
0)))))
(ATFIND (CAAADR EXP)
(CDR ($SUBSTITUTE ATEQS (CONS '(MLIST) VL)))
DL)))
(LIST '(%AT) EXP ATEQS)))
((EQ (CAAR EXP) '%LAPLACE) (LIST '(%AT) EXP ATEQS))
((AT1 EXP))
(T (RECUR-APPLY #'ATSCAN EXP))))
(DEFUN AT1 (EXP) (ATFIND (CAAR EXP) (CDR EXP) (LISTOF0S (CDR EXP))))
(DEFUN ATFIND (FUN VL DL)
(DO ATVALUES (MGET FUN 'ATVALUES) (CDR ATVALUES) (NULL ATVALUES)
(AND (EQUAL (CAAR ATVALUES) DL)
(DO ((L (CADAR ATVALUES) (CDR L)) (VL VL (CDR VL)))
((NULL L) T)
(IF (AND (NOT (EQUAL (CAR L) (CAR VL)))
(NOT (EQ (CAR L) MUNBOUND)))
(RETURN NIL)))
(RETURN (PROG2 (ATVARSCHK VL)
(SUBSTITUTEL VL ATVARS (CADDAR ATVALUES)))))))
(DEFUN LISTOF0S (LIST)
(DO ((LIST LIST (CDR LIST)) (L NIL (CONS 0 L))) ((NULL LIST) L)))
(DECLARE (SPLITFILE LOGCON) (SPECIAL $RATFAC GENVAR VARLIST $KEEPFLOAT *E*))
(DEFMVAR $LOGCONCOEFFP NIL)
(DEFMVAR $SUPERLOGCON T)
(DEFMFUN $LOGCONTRACT (E) (LGCCHECK (LOGCON E))) ; E is assumed to be simplified.
(DEFUN LOGCON (E)
(COND ((ATOM E) E)
((MEMQ (CAAR E) '(MPLUS MTIMES))
(IF (AND $SUPERLOGCON (NOT (LGCSIMPLEP E))) (SETQ E (LGCSORT E)))
(COND ((MPLUSP E) (LGCPLUS E)) ((MTIMESP E) (LGCTIMES E)) (T (LOGCON E))))
(T (RECUR-APPLY #'LOGCON E))))
(DEFUN LGCPLUS (E)
(DO ((X (CDR E) (CDR X)) (LOG) (NOTLOGS) (Y))
((NULL X)
(COND ((NULL LOG) (SUBST0 (CONS '(MPLUS) (NREVERSE NOTLOGS)) E))
(T (SETQ LOG (SRATSIMP (MULN LOG T)))
(ADDN (CONS (LGCSIMP LOG) NOTLOGS) T))))
(COND ((ATOM (CAR X)) (SETQ NOTLOGS (CONS (CAR X) NOTLOGS)))
((EQ (CAAAR X) '%LOG) (SETQ LOG (CONS (LOGCON (CADAR X)) LOG)))
((EQ (CAAAR X) 'MTIMES)
(SETQ Y (LGCTIMES (CAR X)))
(COND ((OR (ATOM Y) (NOT (EQ (CAAR Y) '%LOG)))
(SETQ NOTLOGS (CONS Y NOTLOGS)))
(T (SETQ LOG (CONS (CADR Y) LOG)))))
(T (SETQ NOTLOGS (CONS (LOGCON (CAR X)) NOTLOGS))))))
(DEFUN LGCTIMES (E)
(SETQ E (SUBST0 (CONS '(MTIMES) (MAPCAR 'LOGCON (CDR E))) E))
(COND ((NOT (MTIMESP E)) E)
(T (DO ((X (CDR E) (CDR X)) (LOG) (NOTLOGS) (DECINTS))
((NULL X)
(COND ((OR (NULL LOG) (NULL DECINTS)) E)
(T (MULN (CONS (LGCSIMP (POWER LOG (MULN DECINTS T)))
NOTLOGS)
T))))
(COND ((AND (NULL LOG) (NOT (ATOM (CAR X)))
(EQ (CAAAR X) '%LOG) (NOT (EQUAL (CADAR X) -1)))
(SETQ LOG (CADAR X)))
((LOGCONCOEFFP (CAR X)) (SETQ DECINTS (CONS (CAR X) DECINTS)))
(T (SETQ NOTLOGS (CONS (CAR X) NOTLOGS))))))))
(DEFUN LGCSIMP (E)
(COND ((ATOM E) (SIMPLN (LIST '(%LOG) E) 1 T)) (T (LIST '(%LOG SIMP) E))))
(DEFUN LGCSIMPLEP (E)
(AND (EQ (CAAR E) 'MPLUS)
(NOT (DO L (CDR E) (CDR L) (NULL L)
(COND ((NOT (OR (ATOM (CAR L))
(NOT (ISINOP (CAR L) '%LOG))
(EQ (CAAAR L) '%LOG)
(AND (EQ (CAAAR L) 'MTIMES)
(NULL (CDDDAR L))
(MNUMP (CADAR L))
(NOT (ATOM (CADDAR L)))
(EQ (CAAR (CADDAR L)) '%LOG))))
(RETURN T)))))))
(DEFUN LGCSORT (E)
(LET (GENVAR VARLIST ($KEEPFLOAT T) VL E1)
(NEWVAR E)
(SETQ VL (DO ((VL VARLIST (CDR VL)) (LOGS) (NOTLOGS) (DECINTS))
((NULL VL)
(SETQ LOGS (SORT LOGS 'GREAT))
(NRECONC DECINTS (NCONC LOGS (NREVERSE NOTLOGS))))
(COND ((AND (NOT (ATOM (CAR VL))) (EQ (CAAAR VL) '%LOG))
(SETQ LOGS (CONS (CAR VL) LOGS)))
((LOGCONCOEFFP (CAR VL))
(SETQ DECINTS (CONS (CAR VL) DECINTS)))
(T (SETQ NOTLOGS (CONS (CAR VL) NOTLOGS))))))
(SETQ E1 (RATDISREP (RATREP E VL)))
(IF (ALIKE1 E E1) E E1)))
(DEFUN LGCCHECK (E)
(LET (NUM DENOM)
(COND ((ATOM E) E)
((AND (EQ (CAAR E) '%LOG)
(SETQ NUM (MEMBER ($NUM (CADR E)) '(1 -1)))
(NOT (EQUAL (SETQ DENOM ($DENOM (CADR E))) 1)))
(LIST '(MTIMES SIMP) -1
(LIST '(%LOG SIMP) (IF (= (CAR NUM) 1) DENOM (NEG DENOM)))))
(T (RECUR-APPLY #'LGCCHECK E)))))
(DEFUN LOGCONCOEFFP (E)
(IF $LOGCONCOEFFP (LET ((*E* E)) (IS '(($LOGCONCOEFFP) *E*))) (INTEGERP E)))
(DECLARE (SPLITFILE RTCON) (SPECIAL $RADEXPAND $DOMAIN RADPE))
(DEFMVAR $ROOTSCONMODE T)
(DEFUN $ROOTSCONTRACT (E) ; E is assumed to be simplified
((LAMBDA (RADPE $RADEXPAND) (RTCON E))
(AND $RADEXPAND (NOT (EQ $RADEXPAND '$ALL)) (EQ $DOMAIN '$REAL)) NIL))
(DEFUN RTCON (E)
(COND ((ATOM E) E)
((EQ (CAAR E) 'MTIMES)
(IF (AND (NOT (FREE E '$%I))
(LET ((NUM ($NUM E)))
(AND (NOT (ALIKE1 E NUM))
(OR (EQ NUM '$%I)
(AND (NOT (ATOM NUM)) (MEMQ '$%I NUM)
(MEMQ '$%I (RTCON NUM)))))))
(SETQ E (LIST* (CAR E) -1 '((MEXPT) -1 ((RAT SIMP) -1 2))
(DELQ '$%I (APPEND (CDR E) NIL) 1))))
(DO ((X (CDR E) (CDR X)) (ROOTS) (NOTROOTS) (Y))
((NULL X)
(COND ((NULL ROOTS) (SUBST0 (CONS '(MTIMES) (NREVERSE NOTROOTS)) E))
(T (IF $ROOTSCONMODE
(LET (((MIN GCD LCM) (RTC-GETINFO ROOTS)))
(COND ((AND (= MIN GCD) (NOT (= GCD 1))
(NOT (= MIN LCM))
(NOT (EQ $ROOTSCONMODE '$ALL)))
(SETQ ROOTS
(RT-SEPAR
(LIST GCD
(RTCON
(RTC-FIXITUP
(RTC-DIVIDE-BY-GCD ROOTS GCD)
NIL))
1)
NIL)))
((EQ $ROOTSCONMODE '$ALL)
(SETQ ROOTS
(RT-SEPAR (SIMP-ROOTS LCM ROOTS)
NIL))))))
(RTC-FIXITUP ROOTS NOTROOTS))))
(COND ((ATOM (CAR X))
(COND ((EQ (CAR X) '$%I) (SETQ ROOTS (RT-SEPAR (LIST 2 -1) ROOTS)))
(T (SETQ NOTROOTS (CONS (CAR X) NOTROOTS)))))
((AND (EQ (CAAAR X) 'MEXPT) (RATNUMP (SETQ Y (CADDAR X))))
(SETQ ROOTS (RT-SEPAR (LIST (CADDR Y)
(LIST '(MEXPT)
(RTCON (CADAR X)) (CADR Y)))
ROOTS)))
((AND RADPE (EQ (CAAAR X) 'MABS))
(SETQ ROOTS (RT-SEPAR (LIST 2 `((MEXPT) ,(RTCON (CADAR X)) 2) 1)
ROOTS)))
(T (SETQ NOTROOTS (CONS (RTCON (CAR X)) NOTROOTS))))))
((AND RADPE (EQ (CAAR E) 'MABS))
(POWER (POWER (RTCON (CADR E)) 2) '((RAT SIMP) 1 2)))
(T (RECUR-APPLY #'RTCON E))))
; RT-SEPAR separates like roots into their appropriate "buckets",
; where a bucket looks like:
; ((<denom of power> (<term to be raised> <numer of power>)
; (<term> <numer>)) etc)
(DEFUN RT-SEPAR (A ROOTS)
(LET ((U (ASSOC (CAR A) ROOTS)))
(COND (U (NCONC U (CDR A))) (T (SETQ ROOTS (CONS A ROOTS)))))
ROOTS)
(DEFUN SIMP-ROOTS (LCM ROOT-LIST)
(LET (ROOT1)
(DO ((X ROOT-LIST (CDR X)))
((NULL X) (PUSH LCM ROOT1))
(PUSH (LIST '(MEXPT) (MULN (CDAR X) NIL) (QUOTIENT LCM (CAAR X)))
ROOT1))))
(DEFUN RTC-GETINFO (LIST)
(LET ((M (CAAR LIST)) (G (CAAR LIST)) (L (CAAR LIST)))
(DO ((X (CDR LIST) (CDR X)))
((NULL X) (LIST M G L))
(SETQ M (MIN M (CAAR X)) G (GCD G (CAAR X)) L (LCM L (CAAR X))))))
(DEFUN RTC-FIXITUP (ROOTS NOTROOTS)
(MAPCAR #'(LAMBDA (X) (RPLACD X (LIST (SRATSIMP (MULN (CDR X) (NOT $ROOTSCONMODE))))))
ROOTS)
(MULN (NCONC (MAPCAR #'(LAMBDA (X) (POWER* (CADR X) `((RAT) 1 ,(CAR X))))
ROOTS)
NOTROOTS)
(NOT $ROOTSCONMODE)))
(DEFUN RTC-DIVIDE-BY-GCD (LIST GCD)
(MAPCAR #'(LAMBDA (X) (RPLACA X (QUOTIENT (CAR X) GCD))) LIST)
LIST)
(DECLARE (SPLITFILE NTERMS))
(DEFMFUN $NTERMS (E)
(COND ((ZEROP1 E) 0)
((ATOM E) 1)
((EQ (CAAR E) 'MTIMES)
(IF (EQUAL -1 (CADR E)) (SETQ E (CDR E)))
(DO ((L (CDR E) (CDR L)) (C 1 (TIMES C ($NTERMS (CAR L)))))
((NULL L) C)))
((EQ (CAAR E) 'MPLUS)
(DO ((L (CDR E) (CDR L)) (C 0 (PLUS C ($NTERMS (CAR L)))))
((NULL L) C)))
((AND (EQ (CAAR E) 'MEXPT) (FIXP (CADDR E)) (PLUSP (CADDR E)))
($BINOMIAL (PLUS (CADDR E) ($NTERMS (CADR E)) -1) (CADDR E)))
((SPECREPP E) ($NTERMS (SPECDISREP E)))
(T 1)))
(DECLARE (SPLITFILE ATAN2)
(SPECIAL $NUMER $%PIARGS $LOGARC $TRIGSIGN HALF%PI FOURTH%PI))
(DEFUN SIMPATAN2 (E VESTIGIAL Z) ; atan2(y,x) ~ atan(y/x)
VESTIGIAL ;ignored
(TWOARGCHECK E)
(LET (Y X SIGN)
(SETQ Y (SIMPCHECK (CADR E) Z) X (SIMPCHECK (CADDR E) Z))
(COND ((AND (ZEROP1 Y) (ZEROP1 X))
(MERROR "ATAN2(0,0) has been generated."))
((OR (AND (FLOATP Y) (FLOATP X))
(AND $NUMER (NUMBERP Y) (NUMBERP X)))
(ATAN2 Y X))
((AND ($BFLOATP Y) ($BFLOATP X))
(IF (MMINUSP* Y) (NEG (*FPATAN (NEG Y) (LIST X)))
(*FPATAN Y (LIST X))))
((AND $%PIARGS (FREE X '$%I) (FREE Y '$%I)
(COND ((ZEROP1 Y) (IF (ATAN2NEGP X) (SIMPLIFY '$%PI) 0))
((ZEROP1 X)
(IF (ATAN2NEGP Y) (MUL2* -1 HALF%PI) (SIMPLIFY HALF%PI)))
((ALIKE1 Y X)
(IF (ATAN2NEGP X) (MUL2* -3 FOURTH%PI) (SIMPLIFY FOURTH%PI)))
((ALIKE1 Y (MUL2 -1 X))
(IF (ATAN2NEGP X) (MUL2* 3 FOURTH%PI) (MUL2* -1 FOURTH%PI)))
((AND (EQUAL Y 1) (ALIKE1 X '((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
(MUL2* '((RAT SIMP) 1 6) '$%PI)))))
($LOGARC (LOGARC '%ATAN (DIV Y X)))
((AND $TRIGSIGN (MMINUSP* Y))
(NEG (SIMPLIFYA (LIST '($ATAN2) (NEG Y) X) T)))
; atan2(y,x) = atan(y/x) + pi sign(y) (1-sign(x))/2
((AND (FREE X '$%I) (EQ (SETQ SIGN ($SIGN X)) '$POS))
(SIMPLIFYA (LIST '(%ATAN) (DIV Y X)) T))
((AND (EQ SIGN '$NEG) (FREE Y '$%I)
(MEMQ (SETQ SIGN ($SIGN Y)) '($POS $NEG)))
(ADD2 (SIMPLIFYA (LIST '(%ATAN) (DIV Y X)) T)
(PORM (EQ SIGN '$POS) (SIMPLIFY '$%PI))))
(T (EQTEST (LIST '($ATAN2) Y X) E)))))
(DEFUN ATAN2NEGP (E) (EQ (ASKSIGN-P-OR-N E) '$NEG))
(DECLARE (SPLITFILE ARITHF) (SPECIAL LNORECURSE))
(DEFMFUN $FIBTOPHI (E)
(COND ((ATOM E) E)
((EQ (CAAR E) '$FIB)
(SETQ E (COND (LNORECURSE (CADR E)) (T ($FIBTOPHI (CADR E)))))
(LET ((PHI (MEVAL '$%PHI)))
(DIV (ADD2 (POWER PHI E) (NEG (POWER (ADD2 1 (NEG PHI)) E)))
(ADD2 -1 (MUL2 2 PHI)))))
(T (RECUR-APPLY #'$FIBTOPHI E))))
(DEFMSPEC $NUMERVAL (L) (SETQ L (CDR L))
(DO ((L L (CDDR L)) (X (NCONS '(MLIST SIMP)))) ((NULL L) X)
(COND ((NULL (CDR L)) (MERROR "NUMERVAL takes an even number of args"))
((NOT (SYMBOLP (CAR L)))
(MERROR "~M must be atomic - NUMERVAL" (CAR L)))
((BOUNDP (CAR L))
(MERROR "~M is bound - NUMERVAL" (CAR L))))
(MPUTPROP (CAR L) (CADR L) '$NUMER)
(ADD2LNC (CAR L) $PROPS)
(NCONC X (NCONS (CAR L)))))
(DECLARE (SPLITFILE DERIVD) (SPECIAL POWERS VAR DEPVAR))
(DEFMFUN $DERIVDEGREE (E DEPVAR VAR)
(LET (POWERS) (DERIVDEG1 E) (IF (NULL POWERS) 0 (MAXIMIN POWERS '$MAX))))
(DEFUN DERIVDEG1 (E)
(COND ((OR (ATOM E) (SPECREPP E)))
((EQ (CAAR E) '%DERIVATIVE)
(COND ((ALIKE1 (CADR E) DEPVAR)
(DO L (CDDR E) (CDDR L) (NULL L)
(COND ((ALIKE1 (CAR L) VAR)
(RETURN (SETQ POWERS (CONS (CADR L) POWERS)))))))))
(T (MAPC 'DERIVDEG1 (CDR E)))))
(DECLARE (UNSPECIAL POWERS VAR DEPVAR))
(DECLARE (SPLITFILE BOX))
(DEFMFUN $DPART N (MPART (LISTIFY N) NIL T NIL '$DPART))
(DEFMFUN $LPART N (MPART (CDR (LISTIFY N)) NIL (LIST (ARG 1)) NIL '$LPART))
(DEFMFUN $BOX N
(COND ((= N 1) (LIST '(MBOX) (ARG 1)))
((= N 2) (LIST '(MLABOX) (ARG 1) (BOX-LABEL (ARG 2))))
(T (WNA-ERR '$BOX))))
(DEFMFUN BOX (E LABEL) (IF (EQ LABEL T) (LIST '(MBOX) E) ($BOX E (CAR LABEL))))
(DEFUN BOX-LABEL (X) (IF (ATOM X) X (IMPLODE (CONS #/& (MSTRING X)))))
(DECLARE (SPECIAL LABEL))
(DEFMFUN $REMBOX N
(LET ((LABEL (COND ((= N 1) '(NIL))
((= N 2) (BOX-LABEL (ARG 2)))
(T (WNA-ERR '$REMBOX)))))
(REMBOX1 (ARG 1))))
(DEFUN REMBOX1 (E)
(COND ((ATOM E) E)
((OR (AND (EQ (CAAR E) 'MBOX)
(OR (EQUAL LABEL '(NIL)) (MEMQ LABEL '($UNLABELLED $UNLABELED))))
(AND (EQ (CAAR E) 'MLABOX)
(OR (EQUAL LABEL '(NIL)) (EQUAL LABEL (CADDR E)))))
(REMBOX1 (CADR E)))
(T (RECUR-APPLY #'REMBOX1 E))))
(DECLARE (UNSPECIAL LABEL))
(DECLARE (SPLITFILE MAPF) (SPECIAL SCANMAPP) (*LEXPR SCANMAP1))
(DEFUN MMAPEV1 (L) ; very temporary
(IF (NULL (CDDR L))
(MERROR "~:M called with fewer than two arguments." (CAAR L)))
(LET ((OP (GETOPR (MEVAL (CADR L)))))
(BADFUNCHK (CADR L) OP NIL)
(CONS OP (MAPCAR #'MEVAL (CDDR L)))))
(DEFMSPEC $SCANMAP (L)
(LET ((SCANMAPP T)) (RESIMPLIFY (APPLY #'SCANMAP1 (MMAPEV1 L)))))
(DEFUN SCANMAP1 N
(LET ((FUNC (ARG 1)) (ARG2 (SPECREPCHECK (ARG 2))) NEWARG2)
(COND ((EQ FUNC '$RAT) (MERROR "SCANMAP results must be in general representation."))
((> N 2)
(COND ((EQ (ARG 3) '$BOTTOMUP)
(COND ((MAPATOM ARG2) (FUNCER FUNC (NCONS ARG2)))
(T (SUBST0 (FUNCER FUNC
(NCONS (MCONS-OP-ARGS
(MOP ARG2)
(MAPCAR #'(LAMBDA (U)
(SCANMAP1
FUNC U '$BOTTOMUP))
(MARGS ARG2)))))
ARG2))))
((> N 3) (WNA-ERR '$SCANMAP))
(T (MERROR "Only BOTTOMUP is an acceptable 3rd arg to SCANMAP."))))
((MAPATOM ARG2) (FUNCER FUNC (NCONS ARG2)))
(T (SETQ NEWARG2 (SPECREPCHECK (FUNCER FUNC (NCONS ARG2))))
(COND ((MAPATOM NEWARG2) NEWARG2)
((AND (ALIKE1 (CADR NEWARG2) ARG2) (NULL (CDDR NEWARG2)))
(SUBST0 (CONS (NCONS (CAAR NEWARG2))
(NCONS (SUBST0
(MCONS-OP-ARGS
(MOP ARG2)
(MAPCAR #'(LAMBDA (U) (SCANMAP1 FUNC U))
(MARGS ARG2)))
ARG2)))
NEWARG2))
(T (SUBST0 (MCONS-OP-ARGS
(MOP NEWARG2)
(MAPCAR #'(LAMBDA (U) (SCANMAP1 FUNC U))
(MARGS NEWARG2)))
NEWARG2)))))))
(DEFUN SUBGEN (FORM) ; This function does mapping of subscripts.
(DO ((DS (IF (EQ (CAAR FORM) 'MQAPPLY) (LIST (CAR FORM) (CADR FORM))
(NCONS (CAR FORM)))
(OUTERMAP1 #'DSFUNC1 (SIMPLIFY (CAR SUB)) DS))
(SUB (REVERSE (OR (AND (EQ 'MQAPPLY (CAAR FORM)) (CDDR FORM))
(CDR FORM)))
(CDR SUB)))
((NULL SUB) DS)))
(DEFUN DSFUNC1 (DSN DSO)
(COND ((OR (ATOM DSO) (ATOM (CAR DSO))) DSO)
((MEMQ 'ARRAY (CAR DSO))
(COND ((EQ 'MQAPPLY (CAAR DSO))
(NCONC (LIST (CAR DSO) (CADR DSO) DSN) (CDDR DSO)))
(T (NCONC (LIST (CAR DSO) DSN) (CDR DSO)))))
(T (MAPCAR #'(LAMBDA (D) (DSFUNC1 DSN D)) DSO))))
(DECLARE (SPLITFILE GENMAT) (FIXNUM DIM1 DIM2))
(DEFMFUN $GENMATRIX N
(LET ((ARGS (LISTIFY N)))
(IF (OR (< N 2) (> N 5)) (WNA-ERR '$GENMATRIX))
(IF (NOT (OR (SYMBOLP (CAR ARGS))
(AND (NOT (ATOM (CAR ARGS)))
(EQ (CAAAR ARGS) 'LAMBDA))))
(IMPROPER-ARG-ERR (CAR ARGS) '$GENMATRIX))
(IF (MEMQ NIL (MAPCAR #'(LAMBDA (U) (EQ (TYPEP U) 'FIXNUM))
(CDR ARGS)))
(MERROR "Invalid arguments to GENMATRIX:~%~M"
(CONS '(MLIST) (CDR ARGS))))
(LET* ((HEADER (LIST (CAR ARGS) 'ARRAY))
(DIM1 (CADR ARGS))
(DIM2 (IF (= N 2) (CADR ARGS) (CADDR ARGS)))
(I (IF (> N 3) (ARG 4) 1))
(J (IF (= N 5) (ARG 5) I))
(L (NCONS '($MATRIX))))
(COND ((AND (OR (= DIM1 0) (= DIM2 0)) (= I 1) (= J 1)))
((OR (> I DIM1) (> J DIM2))
(MERROR "Invalid arguments to GENMATRIX:~%~M"
(CONS '(MLIST) ARGS))))
(DO I I (1+ I) (> I DIM1) (NCONC L (NCONS (NCONS '(MLIST)))))
(DO ((I I (1+ I)) (L (CDR L) (CDR L))) ((> I DIM1))
(DO J J (1+ J) (> J DIM2)
(NCONC (CAR L) (NCONS (MEVAL (LIST HEADER I J))))))
L)))
(DEFMFUN $COPYMATRIX (X)
(IF (NOT ($MATRIXP X)) (MERROR "Argument not a matrix - COPYMATRIX:~%~M" X))
(CONS (CAR X) (MAPCAR #'(LAMBDA (X) (APPEND X NIL)) (CDR X))))
(DEFMFUN $COPYLIST (X)
(IF (NOT ($LISTP X)) (MERROR "Argument not a list - COPYLIST:~%~M" X))
(CONS (CAR X) (APPEND (CDR X) NIL)))
(DECLARE (SPLITFILE ADDROW))
(DEFMFUN $ADDROW N
(COND ((= N 0) (WNA-ERR '$ADDROW))
((NOT ($MATRIXP (ARG 1))) (MERROR "First argument to ADDROW must be a matrix"))
((= N 1) (ARG 1))
(T (DO ((I 2 (1+ I)) (M (ARG 1))) ((> I N) M)
(SETQ M (ADDROW M (ARG I)))))))
(DEFMFUN $ADDCOL N
(COND ((= N 0) (WNA-ERR '$ADDCOL))
((NOT ($MATRIXP (ARG 1))) (MERROR "First argument to ADDCOL must be a matrix"))
((= N 1) (ARG 1))
(T (DO ((I 2 (1+ I)) (M ($TRANSPOSE (ARG 1)))) ((> I N) ($TRANSPOSE M))
(SETQ M (ADDROW M ($TRANSPOSE (ARG I))))))))
(DEFUN ADDROW (M R)
(COND ((NOT (MXORLISTP R)) (MERROR "Illegal argument to ADDROW or ADDCOL"))
((AND (CDR M)
(OR (AND (EQ (CAAR R) 'MLIST) (NOT (= (LENGTH (CADR M)) (LENGTH R))))
(AND (EQ (CAAR R) '$MATRIX)
(NOT (= (LENGTH (CADR M)) (LENGTH (CADR R))))
(PROG2 (SETQ R ($TRANSPOSE R))
(NOT (= (LENGTH (CADR M)) (LENGTH (CADR R))))))))
(MERROR "Incompatible structure - ADDROW//ADDCOL")))
(APPEND M (IF (EQ (CAAR R) '$MATRIX) (CDR R) (NCONS R))))
(DECLARE (SPLITFILE ARRAYF))
(DEFMFUN $ARRAYMAKE (ARY SUBS)
(COND ((OR (NOT ($LISTP SUBS)) (NULL (CDR SUBS)))
(MERROR "Wrong type argument to ARRAYMAKE:~%~M" SUBS))
((EQ (TYPEP ARY) 'SYMBOL)
(CONS (CONS (GETOPR ARY) '(ARRAY)) (CDR SUBS)))
(T (CONS '(MQAPPLY ARRAY) (CONS ARY (CDR SUBS))))))
(DEFMSPEC $ARRAYINFO (ARY) (SETQ ARY (CDR ARY))
(LET ((GEN (MGETL (SETQ ARY (CAR ARY)) '(HASHAR ARRAY))) ARY1)
(COND ((NULL GEN) (MERROR "Not an array - ARRAYINFO:~%~M" ARY))
((MFILEP (CADR GEN))
(I-$UNSTORE (NCONS ARY))
(SETQ GEN (MGETL ARY '(HASHAR ARRAY)))))
(SETQ ARY1 (CADR GEN))
(COND ((EQ (CAR GEN) 'HASHAR)
(APPEND '((MLIST SIMP) $HASHED)
(CONS (FUNCALL ARY1 2)
(DO ((I 3 (1+ I)) (L) (N (CADR (ARRAYDIMS ARY1))))
((= I N) (SORT L '(LAMBDA (X Y) (GREAT Y X))))
(DO L1 (FUNCALL ARY1 I) (CDR L1) (NULL L1)
(SETQ L (CONS (CONS '(MLIST SIMP) (CAAR L1))
L)))))))
(T (SETQ ARY1 (ARRAYDIMS ARY1))
(LIST '(MLIST SIMP)
(COND ((GET ARY 'ARRAY)
(CDR (ASSQ (CAR ARY1)
'((T . $COMPLETE) (FIXNUM . $INTEGER)
(FLONUM . $FLOAT)))))
(T '$DECLARED))
(LENGTH (CDR ARY1))
(CONS '(MLIST SIMP) (MAPCAR #'1- (CDR ARY1))))))))
(DECLARE (SPLITFILE ALIAS)
(SPECIAL ALIASLIST ALIASCNTR GREATORDER LESSORDER)
(FIXNUM ALIASCNTR))
(DEFMSPEC $MAKEATOMIC (L) (SETQ L (CDR L))
(DO ((L L (CDR L)) (BAS) (X)) ((NULL L) '$DONE)
(IF (OR (ATOM (CAR L))
(NOT (OR (SETQ X (MEMQ (CAAAR L) '(MEXPT MNCEXPT)))
(MEMQ 'ARRAY (CDAAR L)))))
(IMPROPER-ARG-ERR (CAR L) '$MAKEATOMIC))
(IF X (SETQ BAS (CADAR L) X (AND (ATOM (CADDAR L)) (CADDAR L)))
(SETQ BAS (CAAAR L) X (AND (ATOM (CADAR L)) (CADAR L))))
(IF (NOT (ATOM BAS)) (IMPROPER-ARG-ERR (CAR L) '$MAKEATOMIC))
(SETQ ALIASLIST
(CONS (CONS (CAR L)
(IMPLODE
(NCONC (EXPLODEN BAS)
(OR (AND X (EXPLODEN X)) (NCONS '/ ))
(CONS '$ (MEXPLODEN (SETQ ALIASCNTR (1+ ALIASCNTR)))))))
ALIASLIST))))
(DEFMSPEC $ORDERGREAT (L)
(IF GREATORDER (MERROR "Reordering is not allowed."))
(MAKORDER (SETQ GREATORDER (REVERSE (CDR L))) '_))
(DEFMSPEC $ORDERLESS (L)
(IF LESSORDER (MERROR "Reordering is not allowed."))
(MAKORDER (SETQ LESSORDER (CDR L)) '/#))
(DEFUN MAKORDER (L CHAR)
(DO ((L L (CDR L)) (N 101 (1+ N))) ((NULL L) '$DONE)
(ALIAS (CAR L)
(IMPLODE (NCONC (NCONS CHAR) (MEXPLODEN N)
(EXPLODEN (STRIPDOLLAR (CAR L))))))))
(DEFMFUN $UNORDER NIL
(LET ((L (DELQ NIL
(CONS '(MLIST SIMP)
(NCONC (MAPCAR #'REMALIAS (MAPCAR #'GETALIAS LESSORDER))
(MAPCAR #'REMALIAS (MAPCAR #'GETALIAS GREATORDER)))))))
(SETQ LESSORDER NIL GREATORDER NIL) L))
(DECLARE (SPLITFILE CONCAT) (NOTYPE (ASCII-NUMBERP FIXNUM)))
(DEFMFUN $CONCAT N
(LET ((L (LISTIFY N)))
(IF (NULL L) (MERROR "CONCAT needs at least one argument."))
(IMPLODE
(CONS (COND ((NOT (ATOM (CAR L))))
((OR (NUMBERP (CAR L)) (= (GETCHARN (CAR L) 1) #/&)) #/&)
(T #/$))
(APPLY #'NCONC
(MAPCAR
#'(LAMBDA (X)
(IF (NOT (ATOM X))
(MERROR "Argument to CONCAT not an atom: ~M" X))
(STRING* X))
L))))))
(DEFMFUN $GETCHAR (X Y)
(LET ((N 0))
(COND ((NOT (EQ (TYPEP X) 'SYMBOL))
(MERROR "1st argument to GETCHAR not a symbol: ~M" X))
((OR (NOT (EQ (TYPEP Y) 'FIXNUM)) (NOT (> Y 0)))
(MERROR "Incorrect 2nd argument to GETCHAR: ~M" Y))
((= (SETQ N (GETCHARN (FULLSTRIP1 X) Y)) 0) NIL)
((= (GETCHARN X 1) '#/&) (IMPLODE (LIST #/& N)))
((ASCII-NUMBERP N) (- N #/0))
(T (IMPLODE (LIST #/$ N))))))
#+ITS
(DECLARE (SPLITFILE TTYINI)
(SPECIAL $PAGEPAUSE LINEL $LINEL SCROLLP TTYHEIGHT $PLOTHEIGHT
SMART-TTY RUBOUT-TTY 12-BIT-TTY CURSORPOS PLASMA-TTY
DISPLAY-FILE))
#+ITS
(DEFMFUN $TTY_INIT NIL
(SETQ $PAGEPAUSE (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_25.)))
; bit 3.8 (%TSMOR) of TTYSTS
(SETQ $LINEL (SETQ LINEL (LINEL T)))
(SETQ SCROLLP (NOT (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_30.))))
(SETQ TTYHEIGHT (CAR (STATUS TTYSIZE))
$PLOTHEIGHT (IF (< TTYHEIGHT 200.) (- TTYHEIGHT 2) 24.))
(LET ((TTYOPT (CAR (CDDDDR (SYSCALL 6 'CNSGET TYO)))))
; %TOFCI (bit 3.4) = terminal has a 12 bit keyboard.
(SETQ 12-BIT-TTY (NOT (= (BOOLE 1 8_18. TTYOPT) 0)))
; %TOMVU (bit 3.9) = terminal can do vertical cursor movement.
; However, we must also make sure that the screen size
; is within the ITS addressing limits.
(SETQ SMART-TTY (AND (NOT (= (BOOLE 1 256._18. TTYOPT) 0))
(< TTYHEIGHT 200.)
(< LINEL 128.)))
; %TOERS (bit 4.6) = terminal can selectively erase.
; %TOMVB (bit 4.4) = terminal can backspace.
; %TOOVR (bit 4.1) = terminal can overstrike (i.e. printing one
; character on top of another causes both
; to appear.)
(SETQ RUBOUT-TTY
(OR (NOT (= (BOOLE 1 32._27. TTYOPT) 0)) ;%TOERS
(AND (NOT (= (BOOLE 1 8._27. TTYOPT) 0)) ;%TOMVB
(= (BOOLE 1 1_27. TTYOPT) 0)))) ;%TOOVR
; %TOCID (bit 3.1) = terminal can insert and delete characters.
; If the console has a 12-bit keyboard, an 85 by 50 screen, and
; can't ins/del characters, then it must be a Plasma console.
(SETQ PLASMA-TTY
(AND 12-BIT-TTY (= LINEL 84.) (= TTYHEIGHT 50.)
(= 0 (BOOLE 1 1_18. TTYOPT)))))
(SETQ CURSORPOS SMART-TTY)
(IF SMART-TTY (SETQ DISPLAY-FILE (OPEN '|TTY:| '(TTY OUT IMAGE BLOCK))))
(COND (PLASMA-TTY (LOAD '((DSK MACSYM) ARDS)))
((OR (= TTY 13.) (JOB-EXISTS 'H19) (JOB-EXISTS 'H19WHO))
(LOAD '((DSK MACSYM) H19)))
((JOB-EXISTS 'VT100) (LOAD '((DSK MACSYM) VT100))))
'$DONE)
#+ITS
(DEFUN JOB-EXISTS (JNAME) (PROBEF (LIST '(USR *) (STATUS UNAME) JNAME)))
; Undeclarations for the file:
(DECLARE (NOTYPE N I J))

492
src/jpg/dskfn.169 Normal file
View File

@@ -0,0 +1,492 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1982 Massachusetts Institute of Technology **
(macsyma-module dskfn)
(DECLARE (GENPREFIX DK)
(SPECIAL $FILENAME $DEVICE $DIREC $STORENUM $FILENUM $DSKALL
$FILESIZE FILELIST FILELIST1 *NOPOINT OPERS $PACKAGEFILE
FASDUMPFL FASDEQLIST FASDNONEQLIST SAVENOHACK
DSKSAVEP AAAAA ERRSET LESSORDER GREATORDER INDLIST
$LABELS $ALIASES VARLIST MOPL $PROPS DEFAULTF
$INFOLISTS $FEATURES FEATUREL SAVEFILE $GRADEFS
$VALUES $FUNCTIONS $ARRAYS PRINLENGTH PRINLEVEL
$CONTEXTS CONTEXT $ACTIVECONTEXTS)
(FIXNUM N $FILESIZE $STORENUM $FILENUM)
(*LEXPR $FACTS))
(SETQ FILELIST NIL FILELIST1 NIL $PACKAGEFILE NIL
INDLIST (PURCOPY '(EVFUN EVFLAG BINDTEST NONARRAY SP2 OPERS SPECIAL
AUTOLOAD ASSIGN MODE)))
(DEFMSPEC $UNSTORE (FORM) (I-$UNSTORE (CDR FORM)))
(DEFMFUN I-$UNSTORE (X)
(DO ((X X (CDR X)) (LIST (NCONS '(MLIST SIMP))) (PROP) (FL NIL NIL))
((NULL X) LIST)
(SETQ X (INFOLSTCHK X))
(WHEN (AND (BOUNDP (CAR X)) (MFILEP (SETQ PROP (SYMEVAL (CAR X)))))
(SETQ FL T)
(SET (CAR X) (EVAL (DSKGET (CADR PROP) (CADDR PROP) 'VALUE NIL))))
(DO PROPS (CDR (OR (GET (CAR X) 'MPROPS) '(NIL))) (CDDR PROPS) (NULL PROPS)
(COND ((MFILEP (CADR PROPS))
(SETQ FL T)
(COND ((MEMQ (CAR PROPS) '(HASHAR ARRAY))
(LET ((AAAAA (GENSYM)))
(SETQ PROP (DSKGET (CADADR PROPS)
(CADDR (CADR PROPS))
(CAR PROPS)
T))
(MPUTPROP (CAR X)
(IF (EQ PROP 'AAAAA) AAAAA (CAR X))
(CAR PROPS))))
(T (SETQ PROP (DSKGET (CADADR PROPS) (CADDR (CADR PROPS))
(CAR PROPS) NIL))
(MPUTPROP (CAR X) PROP (CAR PROPS)))))))
(AND FL (NCONC LIST (NCONS (CAR X))))))
(DEFUN INFOLSTCHK (X)
((LAMBDA (ITEML)
(IF (EQ ITEML T) X (APPEND (OR ITEML '(NIL)) (CDR X))))
(COND ((NOT (AND X (OR (MEMQ (CAR X) '($ALL $CONTEXTS))
(MEMQ (CAR X) (CDR $INFOLISTS)))))
T)
((EQ (CAR X) '$ALL)
(INFOLSTCHK (APPEND (CDR $INFOLISTS)
'($LINENUM $RATVARS $WEIGHTLEVELS *RATWEIGHTS
TELLRATLIST $DONTFACTOR $FEATURES $CONTEXTS))))
((EQ (CAR X) '$LABELS) (REVERSE (CDR $LABELS)))
((MEMQ (CAR X) '($FUNCTIONS $MACROS $GRADEFS $DEPENDENCIES))
(MAPCAR #'CAAR (CDR (SYMEVAL (CAR X)))))
((EQ (CAR X) '$CONTEXTS) (DELQ '$GLOBAL (REVERSE (CDR $CONTEXTS)) 1))
(T (CDR (SYMEVAL (CAR X)))))))
#-Franz
(DEFUN FILELENGTH (FILE)
(PROG2 (SETQ FILE (OPEN FILE '(IN FIXNUM)))
(LET ((N (FIX (+$ (//$ (FLOAT (LENGTHF FILE)) 1024.0) 0.999999))))
(LIST '(MTIMES SIMP) N (IF (= N 1) '$BLOCK '$BLOCKS)))
(CLOSE FILE)))
(DEFMSPEC $SAVE (FORM) (DSKSETUP (CDR FORM) NIL NIL '$SAVE))
(DEFMSPEC $STORE (FORM) (I-$STORE (CDR FORM)))
(DEFMFUN I-$STORE (X) (DSKSETUP X T NIL '$STORE))
(DEFMSPEC $FASSAVE (FORM) (DSKSETUP (CDR FORM) NIL T '$FASSAVE))
#-LISPM
(DEFUN DSKSETUP (X STOREFL FASDUMPFL FN)
(LET ((*NOPOINT T) PRINLENGTH PRINLEVEL OFILE FILE
LIST FASDEQLIST FASDNONEQLIST ERROR #+PDP10 LENGTH #+PDP10 OINT)
#-Franz
(SETQ FILE (COND (($LISTP (CAR X)) (PROG1 (FILESTRIP (CDAR X)) (SETQ X (CDR X))))
(T ;;Set OFILE to the last thing we wrote to.
#-LISPM (SETQ OFILE (DEFAULTF ()))
#+LISPM (SETQ OFILE (FILE-EXPAND-PATHNAME ""))
;;Cons up a new filename if none specified in
;;SAVE or STORE command.
#+Multics
(merror "First argument to ~:M must be a list.~
~%~:M([/"myfile/"],all); is acceptable."
FN FN)
#-Multics
(FULLSTRIP (LIST $FILENAME
(IF DSKSAVEP
(SETQ $STORENUM (1+ $STORENUM))
(SETQ $FILENUM (1+ $FILENUM)))
$DEVICE $DIREC)))))
#+Franz (setq file (filestrip x) x (cdr x))
;;Lisp Machine FILESTRIP returns a string. Fix later.
#+LISPM (IF (STRINGP FILE) (SETQ FILE (UNEXPAND-PATHNAME FILE)))
(DOLIST (U X)
(COND ((ATOM U) (IF (NOT (SYMBOLP U)) (IMPROPER-ARG-ERR U FN)))
((LISTARGP U))
((OR (NOT (EQ (CAAR U) 'MEQUAL)) (NOT (SYMBOLP (CADR U))))
(IMPROPER-ARG-ERR U FN))))
#-Franz
(IF (AND STOREFL (EQ (CADR FILE) '>))
(MERROR "> as second filename has not been implemented for STORE."))
#+PDP10 (IF STOREFL (SETQ OINT (NOINTERRUPT 'TTY)))
(COND (DSKSAVEP (SETQ FILELIST (CONS FILE FILELIST)))
(OFILE (SETQ FILELIST1 (CONS FILE FILELIST1))))
;;Create a stream to the file. On ITS, use a hack to avoid repeated
;;creation of file arrays.
#-Franz
(LET ((TEMP-FILE #-Multics`(,(CARFILE (CDDR FILE)) |!SAVE!| OUTPUT)
#+Multics "macsyma.saved.output"))
#+PDP10 (OPEN (CNAMEF SAVEFILE TEMP-FILE)
(IF FASDUMPFL '(OUT FIXNUM BLOCK) '(OUT ASCII)))
#+LISPM (SETQ SAVEFILE (OPEN TEMP-FILE '(:OUT :ASCII)))
#-(OR LISPM PDP10) (SETQ SAVEFILE (OPEN TEMP-FILE '(OUT ASCII))))
#+Franz (setq savefile (outfile file))
(SETQ *NOPOINT NIL)
(WHEN (NULL FASDUMPFL)
(PRINC ";;; -*- Mode: LISP; Package: Macsyma; -*- Saved by " SAVEFILE)
(PRINC (sys-user-id) SAVEFILE))
#-(or Franz LISPM Multics) (FASPRINT T `(SETQ SAVENO ,SAVENOHACK))
(SETQ LIST (NCONS (IF (SYMBOLP FILE) FILE (MFILE-OUT FILE)))
X (CONS '$ALIASES X))
(IF (NULL (ERRSET (DSKSTORE X STOREFL FILE LIST))) (SETQ ERROR T))
(SETQ *NOPOINT T)
(COND ((NULL (CDR LIST))
(DELETEF SAVEFILE)
(IF (NOT DSKSAVEP)
(MTELL "~M~%Nothing has been ~:Md. ~:M attempt aborted."
(CAR LIST) FN FN))
(SETQ LIST '$ABORTED))
#-Franz
(FASDUMPFL (*FASDUMP SAVEFILE (NREVERSE FASDNONEQLIST) (NREVERSE FASDEQLIST) NIL)
(RENAMEF SAVEFILE FILE))
(T (TERPRI SAVEFILE) #-Franz (RENAMEF SAVEFILE FILE)))
#+PDP10 (IF STOREFL (NOINTERRUPT OINT))
#-(or Franz LISPM Multics) (DEFAULTF (IF DSKSAVEP OFILE FILE))
#+PDP10
(WHEN (NOT (ATOM LIST))
(RPLACA LIST (MTRUENAME SAVEFILE))
(SETQ LENGTH (FILELENGTH SAVEFILE))
(WHEN (> (CADR LENGTH) 30.)
(MTELL "~:M is ~A blocks big!" (CAR LIST) (CADR LENGTH))
(COND ((> (CADR LENGTH) 60.)
(MTELL "You probably want to delete it."))
((> (CADR LENGTH) 50.)
(MTELL "Do you really want such a large file?")))))
(IF ERROR (LET ((ERRSET 'ERRBREAK1)) (MERROR "Error in ~:M attempt" FN)))
;;The CLOSE happens inside of RENAMEF on ITS.
#-PDP10 (CLOSE SAVEFILE)
(IF (ATOM LIST) LIST
`((MLIST SIMP) ,(CAR LIST) #+PDP10 ,LENGTH . ,(CDR LIST)))))
#+LISPM
(DEFUN DSKSETUP (X STOREFL FASDUMPFL FN)
(LET ((*NOPOINT T) PRINLENGTH PRINLEVEL OFILE FILE
LIST FASDEQLIST FASDNONEQLIST ERROR #+PDP10 LENGTH #+PDP10 OINT)
(SETQ SAVEFILE (OPEN (NSUBSTRING (STRING (CAR X)) 1) '(:OUT :ASCII)))
(SETQ FILE (LIST (CAR X)))
(WHEN (NULL FASDUMPFL)
(PRINC ";;; -*- Mode: LISP; Package: Macsyma; -*- Saved by " SAVEFILE)
(PRINC (sys-user-id) SAVEFILE))
(DOLIST (U X)
(COND ((ATOM U) (IF (NOT (SYMBOLP U)) (IMPROPER-ARG-ERR U FN)))
((LISTARGP U))
((OR (NOT (EQ (CAAR U) 'MEQUAL)) (NOT (SYMBOLP (CADR U))))
(IMPROPER-ARG-ERR U FN))))
(COND (DSKSAVEP (SETQ FILELIST (CONS FILE FILELIST)))
(OFILE (SETQ FILELIST1 (CONS FILE FILELIST1))))
(SETQ LIST (NCONS (CAR X)) X (CDR X))
(IF (NULL (ERRSET (DSKSTORE X STOREFL FILE LIST))) (SETQ ERROR T))
(CLOSE SAVEFILE)
'$DONE))
(DEFUN DSKSTORE (X STOREFL FILE LIST)
(DO ((X X (CDR X)) (VAL) (RENAME) (ITEM)
(ALRDYSTRD) (STFL STOREFL STOREFL) (NITEMFL NIL NIL))
((NULL X))
(COND ((SETQ VAL (LISTARGP (CAR X)))
(SETQ X (NCONC (GETLABELS (CAR VAL) (CDR VAL) NIL) (CDR X))))
((SETQ VAL (ASSQ (CAR X) '(($CLABELS . $INCHAR) ($DLABELS . $OUTCHAR)
($ELABELS . $LINECHAR))))
(SETQ X (NCONC (GETLABELS* (EVAL (CDR VAL)) NIL) (CDR X)))))
(IF (NOT (ATOM (CAR X)))
(SETQ RENAME (CADAR X) ITEM (GETOPR (CADDAR X)))
(SETQ X (INFOLSTCHK X) ITEM (SETQ RENAME (AND X (GETOPR (CAR X))))))
(COND ((NOT (SYMBOLP ITEM))
(SETQ NITEMFL ITEM)
(SETQ ITEM (LET ((NITEM (GENSYM))) (SET NITEM (MEVAL ITEM)) NITEM)))
((EQ ITEM '$RATWEIGHTS) (SETQ ITEM '*RATWEIGHTS))
((EQ ITEM '$TELLRATS) (SETQ ITEM 'TELLRATLIST)))
(COND
((NULL X) (RETURN NIL))
((NULL (CAR X)))
((AND (SETQ VAL (ASSQ ITEM ALRDYSTRD)) (EQ RENAME (CDR VAL))))
((NULL (SETQ ALRDYSTRD (CONS (CONS ITEM RENAME) ALRDYSTRD))))
((AND (OR (NOT (BOUNDP ITEM))
(AND (EQ ITEM '$RATVARS) (NULL VARLIST))
(PROG2 (SETQ VAL (SYMEVAL ITEM))
(OR (AND (MEMQ ITEM '($WEIGHTLEVELS $DONTFACTOR))
(NULL (CDR VAL)))
(AND (MEMQ ITEM '(TELLRATLIST *RATWEIGHTS)) (NULL VAL))
(AND (EQ ITEM '$FEATURES) (ALIKE (CDR VAL) FEATUREL))
(AND (EQ ITEM '$DEFAULT_LET_RULE_PACKAGE)
(EQ ITEM VAL))))
(AND (MFILEP VAL)
(OR DSKSAVEP (NOT (UNSTOREP ITEM)) (NULL (SETQ STFL T)))))
(OR (NULL (SETQ VAL (GET ITEM 'MPROPS))) (EQUAL VAL '(NIL))
(IF (NOT DSKSAVEP) (NOT (UNSTOREP ITEM))))
(NOT (GETL ITEM '(OPERATORS REVERSEALIAS GRAD NOUN VERB EXPR OP DATA)))
(NOT (MEMQ ITEM (CDR $PROPS)))
(OR (NOT (MEMQ ITEM (CDR $CONTEXTS)))
(NOT (EQ ITEM '$INITIAL))
(LET ((CONTEXT '$INITIAL)) (NULL (CDR ($FACTS '$INITIAL)))))))
(T (WHEN (AND (BOUNDP ITEM) (NOT (MFILEP (SETQ VAL (SYMEVAL ITEM)))))
(IF (EQ ITEM '$CONTEXT) (SETQ X (LIST* NIL VAL (CDR X))))
(DSKATOM ITEM RENAME VAL)
(IF (NOT (OPTIONP RENAME)) (INFOSTORE ITEM FILE 'VALUE STFL RENAME)))
(WHEN (SETQ VAL (AND (MEMQ ITEM (CDR $ALIASES)) (GET ITEM 'REVERSEALIAS)))
(DSKDEFPROP RENAME VAL 'REVERSEALIAS)
(PRADD2LNC RENAME '$ALIASES)
(DSKDEFPROP (MAKEALIAS VAL) RENAME 'ALIAS)
(AND GREATORDER (NOT (ASSQ 'GREATORDER ALRDYSTRD))
(SETQ X (LIST* NIL 'GREATORDER (CDR X))))
(AND LESSORDER (NOT (ASSQ 'LESSORDER ALRDYSTRD))
(SETQ X (LIST* NIL 'LESSORDER (CDR X))))
(SETQ X (LIST* NIL (MAKEALIAS VAL) (CDR X))))
(COND ((SETQ VAL (GET ITEM 'NOUN))
(SETQ X (LIST* NIL VAL (CDR X)))
(DSKDEFPROP RENAME VAL 'NOUN))
((SETQ VAL (GET ITEM 'VERB))
(SETQ X (LIST* NIL VAL (CDR X)))
(DSKDEFPROP RENAME VAL 'VERB)))
(WHEN (MGET ITEM '$RULE)
(IF (SETQ VAL (RULEOF ITEM))
(SETQ X (LIST* NIL VAL (CDR X))))
(PRADD2LNC (GETOP RENAME) '$RULES))
(WHEN (AND (SETQ VAL (CADR (GETL-FUN ITEM '(EXPR))))
(OR (MGET ITEM '$RULE) (GET ITEM 'TRANSLATED)))
#-Franz
(IF (MGET ITEM 'TRACE)
(LET (VAL1 #+PDP10 (OINT (NOINTERRUPT 'TTY)))
(REMPROP ITEM 'EXPR)
(IF (SETQ VAL1 (GET ITEM 'EXPR))
(DSKDEFPROP RENAME VAL1 'EXPR))
(SETPLIST ITEM (LIST* 'EXPR VAL (PLIST ITEM)))
#+PDP10 (NOINTERRUPT OINT))
(DSKDEFPROP RENAME VAL 'EXPR))
#+Franz (fasprin `(def ,rename ,(getd item)))
(IF (SETQ VAL (ARGS ITEM))
(FASPRIN `(ARGS (QUOTE ,RENAME) (QUOTE ,VAL))))
(PROPSCHK ITEM RENAME 'TRANSLATED))
(WHEN (AND (SETQ VAL (GETL ITEM '(A-EXPR FEXPR TRANSLATED-MMACRO)))
(GET ITEM 'TRANSLATED))
(DSKDEFPROP RENAME (CADR VAL) (CAR VAL))
(PROPSCHK ITEM RENAME 'TRANSLATED))
(WHEN (SETQ VAL (GET ITEM 'OPERATORS))
(DSKDEFPROP RENAME VAL 'OPERATORS)
(WHEN (SETQ VAL (GET ITEM 'RULES))
(DSKDEFPROP RENAME VAL 'RULES)
(SETQ X (CONS NIL (APPEND VAL (CDR X)))))
(IF (MEMQ ITEM (CDR $PROPS)) (PRADD2LNC RENAME '$PROPS))
(SETQ VAL (MGET ITEM 'OLDRULES))
(AND VAL (SETQ X (CONS NIL (NCONC (CDR (REVERSE VAL)) (CDR X))))))
(IF (MEMQ ITEM (CDR $FEATURES)) (PRADD2LNC RENAME '$FEATURES))
(WHEN (MEMQ (GETOP ITEM) (CDR $PROPS))
(DOLIST (IND INDLIST) (PROPSCHK ITEM RENAME IND))
(WHEN (GET (SETQ VAL (STRIPDOLLAR ITEM)) 'ALPHABET)
(DSKDEFPROP VAL T 'ALPHABET)
(PRADD2LNC (GETCHARN VAL 1) 'ALPHABET)
(PRADD2LNC ITEM '$PROPS))
(DOLIST (OPER OPERS) (PROPSCHK ITEM RENAME OPER)))
(WHEN (AND (SETQ VAL (GET ITEM 'OP)) (MEMQ VAL (CDR $PROPS)))
(DSKDEFPROP ITEM VAL 'OP)
(DSKDEFPROP VAL ITEM 'OPR)
(PRADD2LNC VAL '$PROPS)
(IF (SETQ VAL (EXTOPCHK ITEM VAL))
(SETQ X (LIST* NIL VAL (CDR X)))))
(WHEN (AND (SETQ VAL (GET ITEM 'GRAD)) (ASSOC (NCONS ITEM) $GRADEFS))
(DSKDEFPROP RENAME VAL 'GRAD)
(PRADD2LNC (CONS (NCONS RENAME) (CAR VAL)) '$GRADEFS))
(WHEN (AND (GET ITEM 'DATA)
(NOT (MEMQ ITEM (CDR $CONTEXTS)))
(SETQ VAL (CDR ($FACTS ITEM))))
(FASPRIN `(RESTORE-FACTS (QUOTE ,VAL)))
(IF (MEMQ ITEM (CDR $PROPS)) (PRADD2LNC ITEM '$PROPS)))
(WHEN (AND (MEMQ ITEM (CDR $CONTEXTS))
(LET ((CONTEXT ITEM)) (SETQ VAL (CDR ($FACTS ITEM)))))
(FASPRINT T `(DSKSETQ $CONTEXT (QUOTE ,ITEM)))
(IF (MEMQ ITEM (CDR $ACTIVECONTEXTS))
(FASPRINT T `($ACTIVATE (QUOTE ,ITEM))))
(FASPRINT T `(RESTORE-FACTS (QUOTE ,VAL))))
(MPROPSCHK ITEM RENAME FILE STFL)
(IF (NOT (GET ITEM 'VERB))
(NCONC LIST (NCONS (OR NITEMFL (GETOP ITEM)))))))))
(DEFUN DSKATOM (ITEM RENAME VAL)
(COND ((EQ ITEM '$RATVARS)
(FASPRINT T `(SETQ VARLIST (APPEND VARLIST (QUOTE ,VARLIST))))
(FASPRINT T '(SETQ $RATVARS (CONS '(MLIST SIMP) VARLIST)))
(PRADD2LNC '$RATVARS '$MYOPTIONS))
((MEMQ ITEM '($WEIGHTLEVELS $DONTFACTOR))
(FASPRIN `(SETQ ,ITEM (NCONC (QUOTE ,VAL) (CDR ,ITEM))))
(PRADD2LNC ITEM '$MYOPTIONS))
((EQ ITEM 'TELLRATLIST)
(FASPRIN `(SETQ TELLRATLIST (NCONC (QUOTE ,VAL) TELLRATLIST)))
(PRADD2LNC 'TELLRATLIST '$MYOPTIONS))
((EQ ITEM '*RATWEIGHTS)
(FASPRIN `(APPLY (FUNCTION $RATWEIGHT) (QUOTE ,(DOT2L VAL)))))
((EQ ITEM '$FEATURES)
(DOLIST (VAR (CDR $FEATURES))
(IF (NOT (MEMQ VAR FEATUREL)) (PRADD2LNC VAR '$FEATURES))))
((AND (EQ ITEM '$LINENUM) (EQ ITEM RENAME))
(FASPRINT T `(SETQ $LINENUM ,VAL)))
((NOT ($RATP VAL))
(FASPRINT T (LIST 'DSKSETQ RENAME
(IF (OR (NUMBERP VAL) (MEMQ VAL '(NIL T)))
VAL
(LIST 'QUOTE VAL)))))
(T (FASPRINT T `(DSKSETQ ,RENAME (DSKRAT (QUOTE ,VAL)))))))
(DEFUN MPROPSCHK (ITEM RENAME FILE STFL)
(DO ((PROPS (CDR (OR (GET ITEM 'MPROPS) '(NIL))) (CDDR PROPS)) (VAL))
((NULL PROPS))
(COND ((OR (MEMQ (CAR PROPS) '(TRACE TRACE-TYPE TRACE-LEVEL))
(MFILEP (SETQ VAL (CADR PROPS)))
(AND (EQ (CAR PROPS) 'T-MFEXPR) (NOT (GET ITEM 'TRANSLATED)))))
((NOT (MEMQ (CAR PROPS) '(HASHAR ARRAY)))
(FASPRIN (LIST 'MDEFPROP RENAME VAL (CAR PROPS)))
(IF (NOT (MEMQ (CAR PROPS) '(MLEXPRP MFEXPRP T-MFEXPR)))
(INFOSTORE ITEM FILE (CAR PROPS) STFL
(COND ((MEMQ (CAR PROPS) '(MEXPR MMACRO))
(LET ((VAL1 (ARGS ITEM)))
(IF VAL1 (FASPRIN `(ARGS (QUOTE ,RENAME)
(QUOTE ,VAL1)))))
(LET ((VAL1 (GET ITEM 'FUNCTION-MODE)))
(IF VAL1 (DSKDEFPROP RENAME
VAL1
'FUNCTION-MODE)))
(CONS (NCONS RENAME) (CDADR VAL)))
((EQ (CAR PROPS) 'DEPENDS)
(CONS (NCONS RENAME) VAL))
(T RENAME)))))
(T (DSKARY ITEM (LIST 'QUOTE RENAME) VAL (CAR PROPS))
(INFOSTORE ITEM FILE (CAR PROPS) STFL RENAME)))))
(DEFUN DSKARY (ITEM RENAME VAL IND)
; Some small forms ordinarily non-EQ for fasdump must be output
; in proper sequence with the big mungeables.
; For this reason only they are output as EQ-forms.
(LET ((ARY (COND ((AND (EQ IND 'ARRAY) (GET ITEM 'ARRAY)) RENAME)
; This code handles "COMPLETE" arrays.
(T (FASPRINT T '(SETQ AAAAA (GENSYM))) 'AAAAA)))
(DIMS (ARRAYDIMS VAL))
VAL1)
(IF (EQ IND 'HASHAR) (FASPRINT T `(REMCOMPARY ,RENAME)))
(FASPRINT T `(MREMPROP ,RENAME (QUOTE ,(IF (EQ IND 'ARRAY) 'HASHAR 'ARRAY))))
(FASPRINT T `(MPUTPROP ,RENAME ,ARY (QUOTE ,IND)))
(FASPRINT T `(*ARRAY ,ARY (QUOTE ,(CAR DIMS)) ,.(CDR DIMS)))
(FASPRINT T `(FILLARRAY ,ARY (QUOTE ,(LISTARRAY VAL))))
(IF (SETQ VAL1 (GET ITEM 'ARRAY-MODE))
(FASPRINT T `(DEFPROP ,(CADR RENAME) ,VAL1 ARRAY-MODE)))))
(DEFUN EXTOPCHK (ITEM VAL)
(LET ((VAL1 (IMPLODE (CONS #/$ (CDR (EXPLODEN VAL))))))
(WHEN (OR (GET VAL1 'NUD) (GET VAL1 'LED) (GET VAL1 'LBP))
(FASPRIN `(DEFINE-SYMBOL (QUOTE ,VAL)))
(IF (MEMQ VAL MOPL)
(FASPRIN `(SETQ MOPL (CONS (QUOTE ,VAL) MOPL))))
(WHEN (SETQ VAL (GET VAL1 'DIMENSION))
(DSKDEFPROP VAL1 VAL 'DIMENSION)
(DSKDEFPROP VAL1 (GET VAL1 'DISSYM) 'DISSYM)
(DSKDEFPROP VAL1 (GET VAL1 'GRIND) 'GRIND))
(IF (SETQ VAL (GET VAL1 'LBP)) (DSKDEFPROP VAL1 VAL 'LBP))
(IF (SETQ VAL (GET VAL1 'RBP)) (DSKDEFPROP VAL1 VAL 'RBP))
(IF (SETQ VAL (GET VAL1 'NUD)) (DSKDEFPROP VAL1 VAL 'NUD))
(IF (SETQ VAL (GET VAL1 'LED)) (DSKDEFPROP VAL1 VAL 'LED))
(WHEN (SETQ VAL (GET VAL1 'VERB))
(DSKDEFPROP VAL (GET VAL 'DIMENSION) 'DIMENSION)
(DSKDEFPROP VAL (GET VAL 'DISSYM) 'DISSYM))
(WHEN (SETQ VAL (GET ITEM 'MATCH))
(DSKDEFPROP ITEM VAL 'MATCH) VAL))))
(DEFUN PROPSCHK (ITEM RENAME IND)
(LET ((VAL (GET ITEM IND)))
(WHEN VAL (DSKDEFPROP RENAME VAL IND)
(PRADD2LNC (GETOP RENAME) '$PROPS))))
(DEFUN FASPRIN (FORM) (FASPRINT NIL FORM))
(DEFUN FASPRINT (EQFL FORM)
(COND ((NULL FASDUMPFL) #-Franz (PRINT FORM SAVEFILE)
#+Franz (pp-form form savefile))
(EQFL (SETQ FASDEQLIST (CONS FORM FASDEQLIST)))
(T (SETQ FASDNONEQLIST (CONS FORM FASDNONEQLIST)))))
(DEFUN UNSTOREP (ITEM) (I-$UNSTORE (NCONS ITEM)))
(DEFUN INFOSTORE (ITEM FILE FLAG STOREFL RENAME)
(LET ((PROP (COND ((EQ FLAG 'VALUE)
(IF (MEMQ RENAME (CDR $LABELS)) '$LABELS '$VALUES))
((EQ FLAG 'MEXPR) '$FUNCTIONS)
((EQ FLAG 'MMACRO) '$MACROS)
((MEMQ FLAG '(ARRAY HASHAR)) '$ARRAYS)
((EQ FLAG 'DEPENDS) (SETQ STOREFL NIL) '$DEPENDENCIES)
(T (SETQ STOREFL NIL) '$PROPS))))
(COND ((EQ PROP '$LABELS)
(FASPRIN `(ADDLABEL (QUOTE ,RENAME)))
(IF (GET ITEM 'NODISP) (DSKDEFPROP RENAME T 'NODISP)))
(T (PRADD2LNC RENAME PROP)))
(COND (STOREFL
(COND ((MEMQ FLAG '(MEXPR MMACRO)) (SETQ RENAME (CAAR RENAME)))
((EQ FLAG 'ARRAY) (REMCOMPARY ITEM)))
(SETQ PROP (LIST '(MFILE) FILE RENAME))
(COND ((EQ FLAG 'VALUE) (SET ITEM PROP))
((MEMQ FLAG '(MEXPR MMACRO AEXPR ARRAY HASHAR))
(MPUTPROP ITEM PROP FLAG)))))))
(DEFUN PRADD2LNC (ITEM PROP)
(IF (OR (NULL $PACKAGEFILE) (NOT (MEMQ PROP (CDR $INFOLISTS)))
(AND (EQ PROP '$PROPS) (GET ITEM 'OPR)))
(FASPRIN `(ADD2LNC (QUOTE ,ITEM) ,PROP))))
(DEFUN DSKDEFPROP (NAME VAL IND)
(FASPRIN (IF (AND (MEMQ IND '(EXPR FEXPR MACRO)) (EQ (CAR VAL) 'LAMBDA))
(LIST* 'DEFUN NAME
(IF (EQ IND 'EXPR) (CDR VAL) (CONS IND (CDR VAL))))
(LIST 'DEFPROP NAME VAL IND))))
(DEFUN DSKGET (FILE NAME FLAG UNSTOREP)
(LET ((DEFAULTF DEFAULTF) (EOF (LIST NIL)) ITEM (*NOPOINT T))
(SETQ FILE (OPEN FILE '(IN ASCII)))
(SETQ ITEM (DO ((ITEM (READ FILE EOF) (READ FILE EOF)))
((EQ ITEM EOF) (MERROR "~%~:M not found" NAME))
(IF (OR (AND (NOT (ATOM ITEM)) (EQ (CAR ITEM) 'DSKSETQ)
(EQ FLAG 'VALUE) (EQ (CADR ITEM) NAME))
(AND (NOT (ATOM ITEM)) (= (LENGTH ITEM) 4)
(OR (EQ (CADDDR ITEM) FLAG)
(AND (EQ (CAR (CADDDR ITEM)) 'QUOTE)
(EQ (CADR (CADDDR ITEM)) FLAG)))
(OR (EQ (CADR ITEM) NAME)
(AND (EQ (CAADR ITEM) 'QUOTE)
(EQ (CADADR ITEM) NAME)))))
(RETURN ITEM))))
(WHEN UNSTOREP (EVAL (READ FILE)) (EVAL (READ FILE)))
(CLOSE FILE)
(CADDR ITEM)))
(DEFUN DSKSAVE NIL
(LET ((DSKSAVEP T))
(IF $DSKALL (I-$STORE '($LABELS $VALUES $FUNCTIONS $MACROS $ARRAYS))
(I-$STORE '($LABELS)))))
(DEFMSPEC $REMFILE (L) (SETQ L (CDR L))
(IF (AND L (OR (CDR L) (NOT (MEMQ (CAR L) '($ALL $TRUE T)))))
(IMPROPER-ARG-ERR L '$REMFILE))
(DOLIST (FILE (IF L (APPEND FILELIST1 FILELIST) FILELIST))
(ERRSET (DELETEF FILE) NIL)
(SETQ FILELIST (DELETE FILE FILELIST 1))
(SETQ FILELIST1 (DELETE FILE FILELIST1 1)))
'$DONE)
(DEFMSPEC $RESTORE (FILE) (SETQ FILE (CDR FILE))
(LET ((EOF (NCONS NIL)) (IN (OPEN (FILESTRIP FILE) '(IN ASCII))))
(SETQ FILE (TRUENAME IN))
(SETQ FILE (IF (ATOM FILE) FILE (APPEND (CDR FILE) (CAR FILE))))
(DO ITEM (READ IN EOF) (READ IN EOF) (EQ ITEM EOF)
(COND ((AND (EQ (CAR ITEM) 'DSKSETQ) (NOT (OPTIONP (CADR ITEM))))
(SET (CADR ITEM) (LIST '(MFILE) FILE (CADR ITEM))))
((AND (EQ (CAR ITEM) 'MDEFPROP)
(MEMQ (CADDDR ITEM) '(MEXPR MMACRO AEXPR)))
(MPUTPROP (CADR ITEM)
(LIST '(MFILE) FILE (CADR ITEM))
(CADDDR ITEM)))
((AND (EQ (CAR ITEM) 'MPUTPROP)
(MEMQ (CADR (CADDDR ITEM)) '(ARRAY HASHAR)))
(MPUTPROP (CADADR ITEM)
(LIST '(MFILE) FILE (CADADR ITEM))
(CADR (CADDDR ITEM)))
(DO ITEM (READ IN) (READ IN) NIL
(IF (EQ (CAR ITEM) 'ADD2LNC) (RETURN (EVAL ITEM)))))
(T (EVAL ITEM))))
(CLOSE IN)
(IF $CHANGE_FILEDEFAULTS (DEFAULTF FILE))
(IF (ATOM FILE) FILE (MFILE-OUT FILE))))

382
src/jpg/medit.85 Normal file
View File

@@ -0,0 +1,382 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **
(macsyma-module medit)
(DECLARE (GENPREFIX ED)
(SPECIAL ST COMMAND WINDOW ^W ^S BEFORE AFTER AVANT APRES
GSTRING ^R $CURSOR REPRINT POS ERRSET ERRBREAK2 OLDST
^HMSG EDITMSG STATE-PDL BACKRUB READING)
(*EXPR REPRINT)
(FIXNUM WINDOW AVANT APRES COUNT SCOUNT LENGTH CNT N I OTHER
(UPCASIFY FIXNUM))
(NOTYPE (PRIN NOTYPE FIXNUM) (CHARACTER FIXNUM) (REV* FIXNUM)
(ASCII-NUMBERP FIXNUM)))
#.(SETQ NALT #-MULTICS #\ALT #+MULTICS #/&)
(SETQ EDITMSG #-Multics '(|In editor: (Type just <Alt><Alt> to exit.)/
| . |In editor:/
|)
#+Multics '(|In editor: (Type just &&<Carriage Return> to exit.)/
| . |In editor:/
|) $CURSOR '&$ WINDOW -1 *NOPOINT (SETQ IBASE (SETQ BASE (+ 5 5))))
(DEFUN EDIT* (AFTER)
(LET ((STATE-PDL (CONS 'EDIT STATE-PDL)))
(PROG (COMMAND STRING N BEFORE AVANT APRES SSTRING ISTRING
GSTRING COUNT FLAG ^R REPRINT POS RSSTRING RISTRING
LENGTH CLEARP GRINDP MFRP QUIETP)
(IF ^S (SETQ ^W NIL ^S NIL))
(SETQ AVANT 0 APRES (LENGTH AFTER))
(TERPRI)
(COND ((CAR EDITMSG)
(PRINC (CAR EDITMSG))
(SETQ EDITMSG (CONS NIL (CDR EDITMSG))))
(T (PRINC (CDR EDITMSG))))
(PRINC (STRIPDOLLAR $CURSOR))
(PRAFTER)
A (SETQ POS (CURSORPOS))
RDLOOP
(SETQ N (LET ((READING T)) (TYI)))
(COND ((AND (NULL COMMAND) (MEMBER N '(#\SP #\NEWLINE #\TAB #/; #/$)))
(GO RDLOOP))
((= N #.NALT)
;;; The EQUAL clause remains here because (CAR COMMAND)
;;; may be NIL (and NIL is non-numeric).
(COND ((AND (EQUAL (CAR COMMAND) #.NALT) (NULL (CDR COMMAND)))
(GO EXIT))
((AND (EQUAL (CAR COMMAND) #.NALT)
(OR (NOT (EQUAL (CADR COMMAND) #/\))
(AND (CDDR COMMAND) (= (CADDR COMMAND) #/\))))
(SETQ COMMAND (NREVERSE COMMAND))
(SETQ REPRINT NIL) (GO LOOP))))
((= N #\VT) (GO VT))
((= N #\BS)
(COND (BACKRUB (POP COMMAND) (GO RDLOOP))
(T (PRINC ^HMSG) (GO VT))))
((= N #\FF) (FORMFEED) (PRTEXT) (GO VT))
((= N #/?)
(COND ((AND (EQUAL (CAR COMMAND) #/?)
(OR (NOT (AND (CDR COMMAND) (= (CADR COMMAND) #/\)))
(AND (CDDR COMMAND) (= (CADDR COMMAND) #/\))))
(SETQ COMMAND NIL) (TERPRI) (GO RDLOOP))))
((OR (= N #\NEWLINE) (= N #\TAB)))
((< N 32.) (SETQ REPRINT T) (GO RDLOOP)) ; Test for control chars.
((AND (= N #/\) (PUSH N COMMAND) (PROG2 (SETQ N (TYI)) NIL)))
((= N #\RUBOUT) (RUBOUT* COMMAND) (POP COMMAND) (GO RDLOOP)))
(PUSH N COMMAND)
(GO RDLOOP)
VT (REPRINT COMMAND (= N #\FF)) (GO RDLOOP)
LOOP (COND ((NULL COMMAND) (PRTEXT) (GO A))
((OR (= (SETQ N (READ1UCCH)) #.NALT) (= N #\SP)
(= N #\NEWLINE) (= N #\TAB))
(GO LOOP)))
(SETQ COUNT 0 STRING NIL FLAG NIL CLEARP NIL GRINDP NIL MFRP NIL)
(COND ((= N #/-) (GO MINUS))
((ASCII-NUMBERP N) (SETQ FLAG T))
(T (SETQ COUNT 1) (GO X)))
NUM (PUSH N STRING)
(IF (ASCII-NUMBERP (SETQ N (READ1UCCH))) (GO NUM))
(SETQ COUNT (READLIST (NREVERSE STRING)) STRING NIL)
X1 (COND ((OR (= N #\SP) (= N #\NEWLINE) (= N #\TAB))
(SETQ N (READ1UCCH)) (GO X1))
((MEMBER N '(#/B #/G #/I #/J #/P #/T #/V #/( #/)
#/[ #/] #/M #/Y #/Q #/Z))
(TERPRI) (IF (NULL FLAG) (PRINC '-)) (GO NOGO1))
((AND (NULL FLAG) (PLUSP COUNT)) (GO MX))
((OR (PLUSP COUNT) (= N #/W)))
((MEMBER N '(#/L #/K)) (GO MX))
(T (GO NOGO)))
X (CASEQ N
((#/J #/T) (GO T))
(#/C (GO C))
(#/R (GO R))
(#/I (GO SI))
(#/G (COND ((MEMBER (SETQ N (READ1UCCH)) '(#/V #/F))
(SETQ GRINDP T) (GO Y))
((= N #/R) (INSERT (APPEND GSTRING NIL))
(GO LOOP))
(T (SETQ FLAG 'G) (GO NOGO))))
(#/B (GO B))
(#/P (GO LOOP))
(#/Q (COND ((OR (NULL (CDR COMMAND))
(AND (NULL (CDDR COMMAND))
(MEMBER (CAR COMMAND) '(#\SP #\NEWLINE))))
(SETQ QUIETP T) (GO EXIT))
(T (GO NOGO))))
(#/V (SETQ WINDOW -1) (GO LOOP))
(#/W (SETQ WINDOW COUNT) (GO LOOP))
((#/D #/S #/K #/L)
(IF (= APRES 0) (GO WHAT))
(CASEQ N
(#/D (DELETE* T (MIN COUNT APRES)))
(#/S (SETQ FLAG T) (GO SI))
(#/K (KILL* COUNT))
(T (LINE* COUNT)))
(GO LOOP))
(#/Y (COND ((MEMBER (SETQ N (READ1UCCH)) '(#/V #/F))
(GO Y))
(T (SETQ FLAG (IF GRINDP 'G 'Y))
(GO NOGO))))
((#/( #/[) (COND ((= AVANT 0) (GO WHAT))
((NULL (MOVE N NIL NIL)) (GO ERR)))
(GO LOOP))
((#/) #/]) (COND ((= APRES 0) (GO WHAT))
((NULL (MOVE N T NIL)) (GO ERR)))
(GO LOOP))
(#/M (SETQ FLAG 'M)
(IF (= (SETQ N (READ1UCCH)) #/Y)
(PROG2 (SETQ CLEARP T) (GO X)))
(CASEQ N
(#/G (SETQ N #/Y GRINDP T CLEARP T)
(GO X))
(#/F (SETQ MFRP T) (GO X))
((#/) #/]) (COND ((= APRES 0) (GO WHAT))
((NULL (MOVE N T T)) (GO ERR)))
(GO LOOP))
((#/( #/[) (COND ((= AVANT 0) (GO WHAT))
((NULL (MOVE N NIL T)) (GO ERR)))
(GO LOOP))
(T (GO NOGO))))
(#/Z (COND ((= (SETQ N (READ1UCCH)) #/J) (GO B))
(T (SETQ FLAG 'Z) (GO NOGO))))
(#/F (SETQ FLAG 'F) (IF (= (SETQ N (READ1UCCH)) #/R)
(GO FR)
(GO NOGO)))
(T (GO NOGO)))
MINUS(COND ((ASCII-NUMBERP (SETQ N (READ1UCCH))) (SETQ FLAG NIL) (GO NUM)))
(SETQ COUNT 1)
MX (CASEQ N
(#/C (GO R))
(#/R (GO C))
((#/D #/S #/K #/L)
(IF (= AVANT 0)
(IF (NOT (= COUNT 0))
(PROG2 (PRINC "
-") (GO WHAT1))))
(CASEQ N
(#/D (DELETE* NIL (MIN COUNT AVANT)))
(#/S (SETQ FLAG NIL) (GO SI))
(#/K (MKILL* COUNT))
(T (MLINE COUNT)))
(GO LOOP))
(T (PRINC "
-") (GO NOGO1)))
SI (COND ((AND (NULL (SETQ STRING (READSTRING)))
(NULL (SETQ STRING (IF (= N #/S) SSTRING ISTRING)))))
((= N #/S)
(IF (NULL (SEARCH (SETQ SSTRING STRING) FLAG COUNT NIL))
(GO ERR)))
(T (INSERT (REVERSE (SETQ ISTRING STRING)))))
(GO LOOP)
FR (COND ((= APRES 0) (GO WHAT))
((NULL (SETQ STRING (READSTRING)))
(IF (NULL RSSTRING) (GO LOOP)))
(T (SETQ RSSTRING STRING RISTRING (AND COMMAND (READSTRING)))))
(SETQ LENGTH (LENGTH RSSTRING))
FR1 (COND ((NULL (SEARCH RSSTRING T 1 MFRP)) (IF MFRP (GO LOOP)) (GO ERR)))
(DELETE* NIL LENGTH)
(IF RISTRING (INSERT (REVERSE RISTRING)))
(IF (AND (NOT MFRP) (= (SETQ COUNT (1- COUNT)) 0)) (GO LOOP))
(GO FR1)
C (COND ((NOT (< APRES COUNT)) (CHARACTER COUNT) (GO LOOP)))
B (IF (PLUSP APRES) (CHARACTER APRES))
(GO LOOP)
R (COND ((NOT (< AVANT COUNT)) (REV* COUNT) (GO LOOP)))
T (IF (PLUSP AVANT) (REV* AVANT))
(GO LOOP)
Y (COND ((NULL (YANK N CLEARP GRINDP)) (GO ERR)) (CLEARP (GO T)))
(GO LOOP)
WHAT (TERPRI)
WHAT1(IF (NOT (= COUNT 1)) (PRINC COUNT))
(IF (MEMQ FLAG '(F M)) (PRINC FLAG))
(TYO N) (PRINC " impossible") (GO ERR)
NOGO (TERPRI)
NOGO1(IF (NOT (= COUNT 1)) (PRINC COUNT))
(IF CLEARP (PRINC 'M))
(IF (MEMQ FLAG '(F Y G M Z)) (PRINC FLAG))
(TYO N) (PRINC " incorrect command")
ERR (SETQ COMMAND NIL) (PRTEXT) (GO A)
EXIT (IF (PLUSP APRES) (CHARACTER APRES))
(SETQ ST BEFORE) (RETURN QUIETP))))
;;; Read1ch returns the first character on the command-list, (the
;;; previous character, in other words).
(DEFUN READ1CH NIL (POP COMMAND))
(DEFUN READ1UCCH NIL (UPCASIFY (POP COMMAND))) ; Read one upper case character
(DEFUN PRTEXT NIL (PRBEFORE) (PRINC (STRIPDOLLAR $CURSOR)) (PRAFTER))
(DEFUN PRBEFORE NIL
(TERPRI)
(IF (OR (MINUSP WINDOW) (< AVANT WINDOW))
(PRIN (REVERSE BEFORE) AVANT)
(DO ((I WINDOW (1- I)) (X1 BEFORE) (X2))
((= I 0) (PRIN X2 WINDOW))
(SETQ X2 (CONS (CAR X1) X2) X1 (CDR X1)))))
(DEFUN PRAFTER NIL
(PRIN AFTER (IF (OR (MINUSP WINDOW) (< APRES WINDOW)) APRES WINDOW))
(TERPRI))
(DEFUN PRIN (X1 I) (DO I I (1- I) (= I 0) (TYO (POP X1))))
(DEFUN READSTRING NIL
(PROG (CHAR STRING)
LOOP (COND ((= (SETQ CHAR (READ1CH)) #/\)
(PUSH #/\ STRING) (SETQ CHAR (READ1CH)))
((= CHAR #.NALT) (RETURN STRING))
((AND (MEMBER CHAR '(#/; #/$)) (NOT (EQUAL (CAR STRING) #/\)))
(PUSH #/\ STRING)))
(PUSH CHAR STRING)
(GO LOOP)))
(DEFUN DELETE* (FLAG COUNT)
(PROG (SAVE)
(SETQ SAVE (COND (FLAG (SETQ APRES (- APRES COUNT)) AFTER)
(T (SETQ AVANT (- AVANT COUNT)) BEFORE))
GSTRING NIL)
LOOP (SETQ GSTRING (CONS (CAR SAVE) GSTRING) SAVE (CDR SAVE))
(COND ((PLUSP (SETQ COUNT (1- COUNT))) (GO LOOP))
(FLAG (SETQ AFTER SAVE GSTRING (NREVERSE GSTRING)))
(T (SETQ BEFORE SAVE)))
(RETURN NIL)))
(DEFUN YANK (N CLEARP GRINDP)
(PROG (ST ITEM)
(COND ((NULL (SETQ ST (READSTRING))) (RETURN T))
((AND (= N #/V) (EQUAL ST '(#/^)))
(SETQ ITEM (REVERSE OLDST)) (GO END))
((NULL (SETQ ITEM (PARSE2))) (RETURN NIL)))
(SETQ ITEM (CAR ITEM))
(LET ((ERRSET 'ERRBREAK2))
(COND ((NULL
(SETQ ITEM (ERRSET
(PROG2 (SETQ ITEM (IF (= N #/F)
(CONSFUNDEF
ITEM NIL NIL)
(STRMEVAL ITEM)))
(IF GRINDP (STRGRIND ITEM)
(MSTRING ITEM))))))
(RETURN NIL))))
(SETQ ITEM (CAR ITEM))
END (IF CLEARP (SETQ BEFORE NIL AFTER NIL AVANT 0 APRES 0))
(INSERT ITEM)
(RETURN T)))
(DEFUN SEARCH (STRING FLAG COUNT MFRP)
(SETQ STRING (MAPCAR #'UPCASIFY STRING))
(PROG (PROV SAVE SCOUNT LENGTH)
(SETQ LENGTH (LENGTH STRING) SCOUNT 0)
(IF FLAG (SETQ STRING (REVERSE STRING)))
START(SETQ PROV STRING SAVE (IF FLAG AFTER BEFORE))
LOOP (COND ((NULL PROV) (IF FLAG (CHARACTER LENGTH) (REV* LENGTH))
(IF (= (SETQ COUNT (1- COUNT)) 0) (RETURN T))
(SETQ SCOUNT 0) (GO START))
((NULL SAVE)
(IF (NOT (= SCOUNT 0))
(IF FLAG (REV* SCOUNT) (CHARACTER SCOUNT)))
(IF (NOT MFRP) (PRINC "
Search failed")) (RETURN NIL))
((NOT (= (CAR PROV) (UPCASIFY (CAR SAVE))))
(IF FLAG (CHARACTER 1) (REV* 1))
(SETQ SCOUNT (1+ SCOUNT)) (GO START)))
(SETQ PROV (CDR PROV) SAVE (CDR SAVE))
(GO LOOP)))
(DEFUN UPCASIFY (N)
(IF (AND (>= N #/a) (<= N #/z)) (- N #.(- #/a #/A)) N))
(DEFUN MOVE (N FLAG DELP)
(PROG (I SCOUNT SAVE OTHER)
(SETQ I 0 SCOUNT 1 SAVE (IF FLAG AFTER BEFORE)
OTHER (CDR (ASSOC N '((#/( . #/)) (#/[ . #/])
(#/) . #/() (#/] . #/[)))))
LOOP (COND ((NULL SAVE)
(COND ((= I 0) (PRINC "
No ") (TYO OTHER) (PRINC "s encountered"))
(T (TERPRI) (PRINC I)
(PRINC " too few ") (TYO N) (PRINC "s")))
(RETURN NIL))
((= (CAR SAVE) OTHER) (SETQ I (1+ I)))
((= (CAR SAVE) N)
(COND ((= I 0) (TERPRI) (TYO N)
(PRINC " seen before ")
(TYO OTHER)
(RETURN NIL))
((= (SETQ I (1- I)) 0)
(COND (DELP (DELETE* FLAG SCOUNT))
(FLAG (CHARACTER SCOUNT))
(T (REV* SCOUNT)))
(RETURN T))))
((= (CAR SAVE) #/\) (SETQ SCOUNT (1+ SCOUNT) SAVE (CDR SAVE))))
(SETQ SCOUNT (1+ SCOUNT) SAVE (CDR SAVE))
(GO LOOP)))
(DEFUN INSERT (STRING)
(PROG (SAVE)
(SETQ AVANT (+ AVANT (LENGTH STRING)))
LOOP (IF (NULL STRING) (RETURN NIL))
(SETQ STRING (CDR (SETQ SAVE STRING)) BEFORE (RPLACD SAVE BEFORE))
(GO LOOP)))
(DEFUN CHARACTER (COUNT)
(PROG (SAVE)
(SETQ APRES (- APRES COUNT) AVANT (+ AVANT COUNT))
LOOP (SETQ AFTER (CDR (SETQ SAVE AFTER)) BEFORE (RPLACD SAVE BEFORE))
(IF (PLUSP (SETQ COUNT (1- COUNT))) (GO LOOP))
(RETURN NIL)))
(DEFUN REV* (COUNT)
(PROG (SAVE)
(SETQ AVANT (- AVANT COUNT) APRES (+ APRES COUNT))
LOOP (SETQ BEFORE (CDR (SETQ SAVE BEFORE)) AFTER (RPLACD SAVE AFTER))
(IF (PLUSP (SETQ COUNT (1- COUNT))) (GO LOOP))
(RETURN NIL)))
(DEFUN LINE* (COUNT)
(PROG NIL
LOOP (CHARACTER 1)
(COND ((= APRES 0))
((OR (NOT (= (CAR BEFORE) #\NEWLINE))
(PLUSP (SETQ COUNT (1- COUNT))))
(GO LOOP)))
(RETURN NIL)))
(DEFUN KILL* (COUNT)
(PROG (N)
(SETQ GSTRING NIL)
LOOP (SETQ GSTRING (NCONC GSTRING (NCONS (SETQ N (CAR AFTER))))
AFTER (CDR AFTER))
(COND ((= (SETQ APRES (1- APRES)) 0))
((OR (NOT (= N #\NEWLINE)) (PLUSP (SETQ COUNT (1- COUNT))))
(GO LOOP)))
(RETURN NIL)))
(DEFUN MLINE (COUNT)
(PROG NIL
LOOP (IF (OR (= AVANT 0)
(AND (= (CAR BEFORE) #\NEWLINE)
(MINUSP (SETQ COUNT (1- COUNT)))))
(RETURN NIL))
(REV* 1)
(GO LOOP)))
(DEFUN MKILL* (COUNT)
(PROG NIL
(SETQ GSTRING NIL COUNT (1+ COUNT))
LOOP (COND ((= AVANT 0))
((OR (NOT (= (CAR BEFORE) #\NEWLINE))
(PLUSP (SETQ COUNT (1- COUNT))))
(SETQ GSTRING (CONS (CAR BEFORE) GSTRING)
BEFORE (CDR BEFORE))
(SETQ AVANT (1- AVANT)) (GO LOOP)))
(RETURN NIL)))
; Undeclarations for the file:
(DECLARE (NOTYPE COUNT SCOUNT LENGTH CNT N I OTHER))

1959
src/jpg/mlisp.613 Normal file
View File

File diff suppressed because it is too large Load Diff

231
src/jpg/ode2.trlisp Normal file
View File

@@ -0,0 +1,231 @@
;;; -*- Mode: Lisp; Package: Macsyma -*-
;;; Translated code for DSK:JPG;ODE2 69
;;; TRANSL-AUTOLOAD version by GJC on FRIDAY, October 2, 1981, at 2:55:39
;;; TRHOOK version 5 TRMODE version NIL DCL version 7/28/81 17:25:57
;;; MCOMPI version NIL TRDATA version 66 ACALL version NIL
;;; FCALL version NIL TRANSQ version NIL MDEFUN version NIL
;;; MTAGS version NIL TRPRED version 2 TROPER version 13
;;; TRANSF version 11 TRANS5 version 25 TRANS4 version NIL
;;; TRANS3 version 46 TRANS2 version 39 TRANS1 version 106
;;; TRUTIL version 22 TRANSL version 1154 TRANSS version 79
(includef (cond ((status feature ITS) '|DSK:LIBMAX;TPRELU >|)
((status feature Multics) '|translate|)
((status feature Unix) '|libmax/tprelu.l|)
(t (error '|Unknown system, see GJC@MIT-MC|))))
(eval-when (compile eval)
(or (status feature lispm)
(setq *infile-name-key*
((lambda (file-name)
;; temp crock for multics.
(cond ((eq (typep file-name) 'list)
(namestring file-name))
(t file-name)))
(truename infile)))))
(eval-when (compile)
(setq $tr_semicompile 'NIL)
(setq forms-to-compile-queue ()))
(comment |DSK:JPG;ODE2 68|)
(DECLARE (SPECIAL $INTFACTOR $ODEINDEX))
(DEF-MTRVAR $YNEW (QUOTE $YNEW) 1.)
(DEFMTRFUN-EXTERNAL ($ODE2 $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $MSG1 (QUOTE $MSG1) 1.)
(DEFMTRFUN-EXTERNAL ($ODE2A $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $MSG2 (QUOTE $MSG2) 1.)
(DEFMTRFUN-EXTERNAL ($ODE1A $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($DESIMP $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $Y (QUOTE $Y) 1.)
(DEF-MTRVAR $X (QUOTE $X) 1.)
(DEFMTRFUN-EXTERNAL ($PR2 $BOOLEAN MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($FTEST $BOOLEAN MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($SOLVE1 $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $F (QUOTE $F) 1.)
(DEF-MTRVAR $G (QUOTE $G) 1.)
(DEFMTRFUN-EXTERNAL ($LINEAR2 $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $%C (QUOTE $%C) 1.)
(DEFMTRFUN-EXTERNAL ($SOLVELNR $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($SEPARABLE $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($INTEGFACTOR $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $YOLD (QUOTE $YOLD) 1.)
(DEF-MTRVAR $Q (QUOTE $Q) 1.)
(DEFMTRFUN-EXTERNAL ($EXACT $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($SOLVEHOM $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($SOLVEBERNOULLI $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($GENHOM $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($HOM2 $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $ALL (QUOTE $ALL) 1.)
(DEF-MTRVAR $PNZ (QUOTE $PNZ) 1.)
(DEF-MTRVAR $%K1 (QUOTE $%K1) 1.)
(DEF-MTRVAR $%K2 (QUOTE $%K2) 1.)
(DEF-MTRVAR $ZERO (QUOTE $ZERO) 1.)
(DEF-MTRVAR $POS (QUOTE $POS) 1.)
(DEF-MTRVAR $EXPONENTIALIZE NIL 1.)
(DEFMTRFUN-EXTERNAL ($CC2 $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($EXACT2 $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($XCC2 $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $METHOD (QUOTE $METHOD) 1.)
(DEF-MTRVAR $CONSTCOEFF (QUOTE $CONSTCOEFF) 1.)
(DEF-MTRVAR $YP (QUOTE $YP) 1.)
(DEFMTRFUN-EXTERNAL ($VARP $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($REDUCE2 $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($NLX $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($NLY $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($NLXY $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($PTTEST $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $PT (QUOTE $PT) 1.)
(DEFMTRFUN-EXTERNAL ($EULER2 $ANY MDEFINE NIL NIL))
(DEF-MTRVAR $INTEGER (QUOTE $INTEGER) 1.)
(DEF-MTRVAR $%J (QUOTE $%J) 1.)
(DEF-MTRVAR $%Y (QUOTE $%Y) 1.)
(DEFMTRFUN-EXTERNAL ($BESSEL2 $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($IC1 $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($BC2 $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($IC2 $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($NOTEQN $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($BOUNDTEST $ANY MDEFINE NIL NIL))
(DEFMTRFUN-EXTERNAL ($FAILURE $BOOLEAN MDEFINE NIL NIL))
(DEFPROP $ODE2 T TRANSLATED)
(ADD2LNC (QUOTE $ODE2) $PROPS)
(DEFMTRFUN ($ODE2 $ANY MDEFINE NIL NIL) ($EQ $YOLD $X) NIL ((LAMBDA ($DERIVSUBST) NIL (SIMPLIFY ($SUBSTITUTE $YOLD (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) (SIMPLIFY (MFUNCTION-CALL $ODE2A (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) $YOLD $EQ)) (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) $X))))) NIL))
(DEFPROP $ODE2A T TRANSLATED)
(ADD2LNC (QUOTE $ODE2A) $PROPS)
(DEFMTRFUN ($ODE2A $ANY MDEFINE NIL NIL) ($EQ $Y $X) NIL ((LAMBDA ($DE $A1 $A2 $A3 $A4 $Q) NIL (PROG NIL (SETQ $INTFACTOR NIL) (SETQ $METHOD (QUOTE $NONE)) (COND (($FREEOF (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X 2.)) $EQ) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $ODE1A $EQ $Y $X))))) (RETURN $Q)) (T (RETURN NIL))))) (COND ((NOT (LIKE (SIMPLIFY ($DERIVDEGREE (SETQ $DE (SIMPLIFY (MFUNCTION-CALL $DESIMP (ADD* ($LHS $EQ) (SIMPLIFY (LIST (QUOTE (MMINUS)) ($RHS $EQ))))))) $Y $X)) 2.)) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG1 (QUOTE $MSG1)) $EQ))))) (SETQ $A1 (SIMPLIFY ($COEFF $DE (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X 2.))))) (SETQ $A2 (SIMPLIFY ($COEFF $DE (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X))))) (SETQ $A3 (SIMPLIFY ($COEFF $DE $Y))) (SETQ $A4 (SIMPLIFY ($EXPAND (ADD* $DE (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A1 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X 2.))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A2 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A3 $Y))))))) (COND ((AND (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A1))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A2))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A3))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A4))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $HOM2 $A1 $A2 $A3)))))) (COND ((LIKE $A4 0.) (RETURN $Q)) (T (RETURN (SIMPLIFY (MFUNCTION-CALL $VARP $Q (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV $A4 $A1)))))))))) (RETURN (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $REDUCE2 $DE))))) (RETURN $Q)) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $A1) (QUOTE $A2) (QUOTE $A3) (QUOTE $A4) (QUOTE $Q)))
(DEFPROP $ODE1A T TRANSLATED)
(ADD2LNC (QUOTE $ODE1A) $PROPS)
(DEFMTRFUN ($ODE1A $ANY MDEFINE NIL NIL) ($EQ $Y $X) NIL ((LAMBDA ($DE $DES $F $G $Q) NIL (PROG NIL (COND ((NOT (LIKE (SIMPLIFY ($DERIVDEGREE (SETQ $DE (SIMPLIFY ($EXPAND (ADD* ($LHS $EQ) (SIMPLIFY (LIST (QUOTE (MMINUS)) ($RHS $EQ))))))) $Y $X)) 1.)) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG1 (QUOTE $MSG1)) $EQ))))) (COND ((LIKE (SIMPLIFY (MFUNCTION-CALL $LINEAR2 $DE (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X)))) NIL) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG2 (QUOTE $MSG2)) $EQ))))) (SETQ $DES (SIMPLIFY (MFUNCTION-CALL $DESIMP $DE))) (SETQ $DE (SIMPLIFY (MFUNCTION-CALL $SOLVE1 $DES (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SOLVELNR $DE))))) (RETURN $Q))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SEPARABLE $DE))))) (RETURN $Q))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $INTEGFACTOR $G $F))))) (RETURN (SIMPLIFY (MFUNCTION-CALL $EXACT (MUL* $Q $G) (MUL* $Q $F)))))) (COND ((LIKE (SIMPLIFY (MFUNCTION-CALL $LINEAR2 $DES (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X)))) NIL) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG2 (QUOTE $MSG2)) $EQ))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $INTEGFACTOR $G $F))))) (RETURN (SIMPLIFY (MFUNCTION-CALL $EXACT (MUL* $Q $G) (MUL* $Q $F)))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SOLVEHOM $DE))))) (RETURN $Q))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SOLVEBERNOULLI $DE))))) (RETURN $Q))) (RETURN (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $GENHOM $DE))))) (RETURN $Q)) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $DES) (QUOTE $F) (QUOTE $G) (QUOTE $Q)))
(DEFPROP $DESIMP T TRANSLATED)
(ADD2LNC (QUOTE $DESIMP) $PROPS)
(DEFMTRFUN ($DESIMP $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($INFLAG) NIL (PROG NIL (SETQ $EQ (SIMPLIFY ($FACTOR $EQ))) (COND ((OR ($ATOM $EQ) (NOT (LIKE (SIMPLIFY ($INPART $EQ 0.)) (QUOTE &*)))) (RETURN (SIMPLIFY ($EXPAND $EQ))))) (SETQ $EQ (SIMPLIFY (MAP1 (GETOPR (M-TLAMBDA ($U) NIL (COND (($FREEOF (SIMPLIFY ($NOUNIFY (QUOTE $DIFF))) $U) 1.) (T $U)))) $EQ))) (RETURN (SIMPLIFY ($EXPAND $EQ))))) T))
(DEFPROP $PR2 T TRANSLATED)
(ADD2LNC (QUOTE $PR2) $PROPS)
(DEFMTRFUN ($PR2 $BOOLEAN MDEFINE NIL NIL) ($F) NIL ($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) $F))
(DEFPROP $FTEST T TRANSLATED)
(ADD2LNC (QUOTE $FTEST) $PROPS)
(DEFMTRFUN ($FTEST $BOOLEAN MDEFINE NIL NIL) ($CALL) NIL (NOT (LIKE (SETQ $Q $CALL) NIL)))
(DEFPROP $SOLVE1 T TRANSLATED)
(ADD2LNC (QUOTE $SOLVE1) $PROPS)
(DEFMTRFUN ($SOLVE1 $ANY MDEFINE NIL NIL) ($EQ $Y) NIL ((LAMBDA ($PROGRAMMODE) NIL (SIMPLIFY ($FIRST (SIMPLIFY ($SOLVE $EQ $Y))))) T))
(DEFPROP $LINEAR2 T TRANSLATED)
(ADD2LNC (QUOTE $LINEAR2) $PROPS)
(DEFMTRFUN ($LINEAR2 $ANY MDEFINE NIL NIL) ($EXPR $X) NIL ((LAMBDA NIL NIL (PROG NIL (SETQ $F (SIMPLIFY ($RATCOEF $EXPR $X))) (COND ((NOT ($FREEOF $X (TRD-MSYMEVAL $F (QUOTE $F)))) (RETURN NIL))) (SETQ $G (SIMPLIFY ($RATSIMP (ADD* $EXPR (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* (TRD-MSYMEVAL $F (QUOTE $F)) $X))))))) (RETURN ($FREEOF $X (TRD-MSYMEVAL $G (QUOTE $G))))))))
(DEFPROP $SOLVELNR T TRANSLATED)
(ADD2LNC (QUOTE $SOLVELNR) $PROPS)
(DEFMTRFUN ($SOLVELNR $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($F $G $W) NIL (PROG NIL (COND ((LIKE (SIMPLIFY (MFUNCTION-CALL $LINEAR2 ($RHS $EQ) (TRD-MSYMEVAL $Y (QUOTE $Y)))) NIL) (RETURN NIL))) (SETQ $W (SIMPLIFY ($EXP (SIMPLIFY ($INTEGRATE $F (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $METHOD (QUOTE $LINEAR)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* $W (ADD* (SIMPLIFY ($INTEGRATE (DIV $G $W) (TRD-MSYMEVAL $X (QUOTE $X)))) (TRD-MSYMEVAL $%C (QUOTE $%C))))))))) (QUOTE $F) (QUOTE $G) (QUOTE $W)))
(DEFPROP $SEPARABLE T TRANSLATED)
(ADD2LNC (QUOTE $SEPARABLE) $PROPS)
(DEFMTRFUN ($SEPARABLE $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($XPART $YPART $FLAG $INFLAG) NIL (PROG NIL (SETQ $EQ (SIMPLIFY ($FACTOR ($RHS $EQ)))) (COND ((OR ($ATOM $EQ) (NOT (LIKE (SIMPLIFY ($INPART $EQ 0.)) (QUOTE &*)))) (SETQ $EQ (LIST (QUOTE (MLIST)) $EQ)))) (DO (($U) (MDO (CDR $EQ) (CDR MDO))) ((NULL MDO) (QUOTE $DONE)) (SETQ $U (CAR MDO)) (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $U) (SETQ $YPART ($CONS $U $YPART))) (($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $U) (SETQ $XPART ($CONS $U $XPART))) (T (RETURN (SETQ $FLAG T))))) (COND ((LIKE $FLAG T) (RETURN NIL))) (COND ((LIKE $XPART (QUOTE ((MLIST)))) (SETQ $XPART 1.)) (T (SETQ $XPART (SIMPLIFY (MAPPLY-TR (QUOTE &*) $XPART))))) (COND ((LIKE $YPART (QUOTE ((MLIST)))) (SETQ $YPART 1.)) (T (SETQ $YPART (SIMPLIFY (MAPPLY-TR (QUOTE &*) $YPART))))) (SETQ $METHOD (QUOTE $SEPARABLE)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY ($RATSIMP (SIMPLIFY ($INTEGRATE (DIV 1. $YPART) (TRD-MSYMEVAL $Y (QUOTE $Y)))))) (ADD* (SIMPLIFY ($RATSIMP (SIMPLIFY ($INTEGRATE $XPART (TRD-MSYMEVAL $X (QUOTE $X)))))) (TRD-MSYMEVAL $%C (QUOTE $%C)))))))) (QUOTE ((MLIST))) (QUOTE ((MLIST))) NIL T))
(DEFPROP $INTEGFACTOR T TRANSLATED)
(ADD2LNC (QUOTE $INTEGFACTOR) $PROPS)
(DEFMTRFUN ($INTEGFACTOR $ANY MDEFINE NIL NIL) ($M $N) NIL ((LAMBDA ($B1 $B2 $DMDX $DMDY $DNDX $DNDY $DD $%E_TO_NUMLOG) NIL (PROG NIL (SETQ $DMDY (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $M (TRD-MSYMEVAL $Y (QUOTE $Y))))))) (SETQ $DNDX (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $N (TRD-MSYMEVAL $X (QUOTE $X))))))) (COND ((LIKE (SETQ $DD (ADD* $DMDY (SIMPLIFY (LIST (QUOTE (MMINUS)) $DNDX)))) 0.) (RETURN 1.))) (SETQ $DMDX (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $M (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $DNDY (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $N (TRD-MSYMEVAL $Y (QUOTE $Y))))))) (COND ((AND (LIKE (ADD* $DMDX (SIMPLIFY (LIST (QUOTE (MMINUS)) $DNDY))) 0.) (LIKE (ADD* $DMDY $DNDX) 0.)) (RETURN (DIV 1. (ADD* (POWER $M 2.) (POWER $N 2.)))))) (COND (($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) (SETQ $B1 (SIMPLIFY ($RATSIMP (DIV $DD $N))))) (RETURN (SIMPLIFY ($EXP (SIMPLIFY ($INTEGRATE $B1 (TRD-MSYMEVAL $X (QUOTE $X))))))))) (RETURN (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (SETQ $B2 (SIMPLIFY ($RATSIMP (DIV $DD $M))))) (RETURN (SIMPLIFY ($EXP (SIMPLIFY ($INTEGRATE (SIMPLIFY (LIST (QUOTE (MMINUS)) $B2)) (TRD-MSYMEVAL $Y (QUOTE $Y)))))))) (T (RETURN NIL)))))) (QUOTE $B1) (QUOTE $B2) (QUOTE $DMDX) (QUOTE $DMDY) (QUOTE $DNDX) (QUOTE $DNDY) (QUOTE $DD) T))
(DEFPROP $EXACT T TRANSLATED)
(ADD2LNC (QUOTE $EXACT) $PROPS)
(DEFMTRFUN ($EXACT $ANY MDEFINE NIL NIL) ($M $N) NIL ((LAMBDA ($A) NIL (PROG NIL (SETQ $INTFACTOR (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $YOLD (QUOTE $YOLD)) (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) (TRD-MSYMEVAL $Q (QUOTE $Q))))) (SETQ $A (SIMPLIFY ($INTEGRATE (SIMPLIFY ($RATSIMP $M)) (TRD-MSYMEVAL $X (QUOTE $X))))) (SETQ $METHOD (QUOTE $EXACT)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY ($RATSIMP (ADD* $A (SIMPLIFY ($INTEGRATE (SIMPLIFY ($RATSIMP (ADD* $N (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($DIFF $A (TRD-MSYMEVAL $Y (QUOTE $Y))))))))) (TRD-MSYMEVAL $Y (QUOTE $Y))))))) (TRD-MSYMEVAL $%C (QUOTE $%C))))))) (QUOTE $A)))
(DEFPROP $SOLVEHOM T TRANSLATED)
(ADD2LNC (QUOTE $SOLVEHOM) $PROPS)
(DEFMTRFUN ($SOLVEHOM $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($QQ $A1 $A2) NIL (PROG NIL (SETQ $A1 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (MUL* (TRD-MSYMEVAL $X (QUOTE $X)) $QQ) (TRD-MSYMEVAL $Y (QUOTE $Y)) ($RHS $EQ)))))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $A1)) (RETURN NIL))) (SETQ $A2 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (DIV (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))) $QQ (SIMPLIFY ($INTEGRATE (DIV 1. (ADD* $A1 (SIMPLIFY (LIST (QUOTE (MMINUS)) $QQ)))) $QQ))))))) (SETQ $METHOD (QUOTE $HOMOGENEOUS)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (MUL* (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $X (QUOTE $X))) (SIMPLIFY ($EXP $A2))))))) (QUOTE $QQ) (QUOTE $A1) (QUOTE $A2)))
(DEFPROP $SOLVEBERNOULLI T TRANSLATED)
(ADD2LNC (QUOTE $SOLVEBERNOULLI) $PROPS)
(DEFMTRFUN ($SOLVEBERNOULLI $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($A1 $A2 $N) NIL (PROG NIL (SETQ $A1 (SIMPLIFY ($COEFF (SETQ $EQ (SIMPLIFY ($EXPAND ($RHS $EQ)))) (TRD-MSYMEVAL $Y (QUOTE $Y)) 1.))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $A1)) (RETURN NIL))) (SETQ $N (SIMPLIFY ($HIPOW (SIMPLIFY ($RATSIMP (ADD* $EQ (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A1 (TRD-MSYMEVAL $Y (QUOTE $Y)))))))) (TRD-MSYMEVAL $Y (QUOTE $Y))))) (SETQ $A2 (SIMPLIFY ($COEFF $EQ (TRD-MSYMEVAL $Y (QUOTE $Y)) $N))) (COND ((OR (NOT ($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $A2)) (NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $N)) (LIKE $N 0.) (NOT (LIKE $EQ (SIMPLIFY ($EXPAND (ADD* (MUL* $A1 (TRD-MSYMEVAL $Y (QUOTE $Y))) (MUL* $A2 (POWER (TRD-MSYMEVAL $Y (QUOTE $Y)) $N)))))))) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($INTEGRATE $A1 (TRD-MSYMEVAL $X (QUOTE $X))))) (SETQ $METHOD (QUOTE $BERNOULLI)) (SETQ $ODEINDEX $N) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* (SIMPLIFY ($EXP $A1)) (POWER (ADD* (MUL* (ADD* 1. (SIMPLIFY (LIST (QUOTE (MMINUS)) $N))) (SIMPLIFY ($INTEGRATE (MUL* $A2 (SIMPLIFY ($EXP (MUL* (ADD* $N -1.) $A1)))) (TRD-MSYMEVAL $X (QUOTE $X))))) (TRD-MSYMEVAL $%C (QUOTE $%C))) (DIV 1. (ADD* 1. (SIMPLIFY (LIST (QUOTE (MMINUS)) $N))))))))))) (QUOTE $A1) (QUOTE $A2) (QUOTE $N)))
(DEFPROP $GENHOM T TRANSLATED)
(ADD2LNC (QUOTE $GENHOM) $PROPS)
(DEFMTRFUN ($GENHOM $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($G $U $N $A1 $A2 $A3) NIL (PROG NIL (SETQ $G (DIV (MUL* ($RHS $EQ) (TRD-MSYMEVAL $X (QUOTE $X))) (TRD-MSYMEVAL $Y (QUOTE $Y)))) (SETQ $N (SIMPLIFY ($RATSIMP (DIV (MUL* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY ($DIFF $G (TRD-MSYMEVAL $X (QUOTE $X))))) (MUL* (TRD-MSYMEVAL $Y (QUOTE $Y)) (SIMPLIFY ($DIFF $G (TRD-MSYMEVAL $Y (QUOTE $Y))))))))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $N)) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (DIV $U (POWER (TRD-MSYMEVAL $X (QUOTE $X)) $N)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $G))))) (SETQ $A2 (SIMPLIFY ($INTEGRATE (DIV 1. (MUL* $U (ADD* $N $A1))) $U))) (COND ((NOT ($FREEOF (SIMPLIFY ($NOUNIFY (QUOTE $INTEGRATE))) $A2)) (RETURN NIL))) (SETQ $A3 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (MUL* (TRD-MSYMEVAL $Y (QUOTE $Y)) (POWER (TRD-MSYMEVAL $X (QUOTE $X)) $N)) $U $A2))))) (SETQ $METHOD (QUOTE $GENHOM)) (SETQ $ODEINDEX $N) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $X (QUOTE $X)) (MUL* (TRD-MSYMEVAL $%C (QUOTE $%C)) (SIMPLIFY ($EXP $A3)))))))) (QUOTE $G) (QUOTE $U) (QUOTE $N) (QUOTE $A1) (QUOTE $A2) (QUOTE $A3)))
(DEFPROP $HOM2 T TRANSLATED)
(ADD2LNC (QUOTE $HOM2) $PROPS)
(DEFMTRFUN ($HOM2 $ANY MDEFINE NIL NIL) ($A1 $A2 $A3) NIL ((LAMBDA ($AP $AQ $PT) NIL (PROG NIL (SETQ $AP (DIV $A2 $A1)) (SETQ $AQ (DIV $A3 $A1)) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $CC2 $AP $AQ (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $EXACT2 $A1 $A2 $A3))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) (COND ((LIKE (SETQ $PT (SIMPLIFY (MFUNCTION-CALL $PTTEST $AP))) NIL) (GO $END))) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $EULER2 $AP $AQ))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $BESSEL2 $AP $AQ))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) $END (RETURN (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $XCC2 $AP $AQ))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q)))) (T (RETURN NIL)))))) (QUOTE $AP) (QUOTE $AQ) (QUOTE $PT)))
(DEFPROP $CC2 T TRANSLATED)
(ADD2LNC (QUOTE $CC2) $PROPS)
(DEFMTRFUN ($CC2 $ANY MDEFINE NIL NIL) ($F $G $Y $X) NIL ((LAMBDA ($A $SIGN $RADEXPAND $ALPHA) NIL (PROG NIL (COND ((NOT (AND ($FREEOF $X $Y $F) ($FREEOF $X $Y $G))) (RETURN NIL))) (SETQ $METHOD (QUOTE $CONSTCOEFF)) (SETQ $A (ADD* (POWER $F 2.) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* 4. $G))))) (COND (($FREEOF (QUOTE $%I) $A) (SETQ $SIGN (SIMPLIFY ($ASKSIGN $A)))) (T (SETQ $RADEXPAND T) (SETQ $SIGN (TRD-MSYMEVAL $PNZ (QUOTE $PNZ))))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $ZERO (QUOTE $ZERO))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (MUL* (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (MUL* $F $X) 2.))))) (ADD* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) $X)))))))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $POS (QUOTE $POS))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY ($EXP (DIV (MUL* (ADD* (SIMPLIFY (LIST (QUOTE (MMINUS)) $F)) (SIMPLIFY (LIST (QUOTE (%SQRT)) $A))) $X) 2.)))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY ($EXP (DIV (MUL* (ADD* (SIMPLIFY (LIST (QUOTE (MMINUS)) $F)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY (LIST (QUOTE (%SQRT)) $A))))) $X) 2.)))))))))) (SETQ $A (SIMPLIFY (LIST (QUOTE (MMINUS)) $A))) (SETQ $ALPHA (DIV (MUL* $X (SIMPLIFY (LIST (QUOTE (%SQRT)) $A))) 2.)) (COND ((LIKE (TRD-MSYMEVAL $EXPONENTIALIZE NIL) NIL) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (MUL* (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (MUL* $F $X) 2.))))) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (LIST (QUOTE (%SIN)) $ALPHA))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%COS)) $ALPHA)))))))))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (MUL* (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (MUL* $F $X) 2.))))) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY ($EXP (MUL* (QUOTE $%I) $ALPHA)))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* (QUOTE $%I) $ALPHA))))))))))))) (QUOTE $A) (QUOTE $SIGN) (TRD-MSYMEVAL $ALL (QUOTE $ALL)) (QUOTE $ALPHA)))
(DEFPROP $EXACT2 T TRANSLATED)
(ADD2LNC (QUOTE $EXACT2) $PROPS)
(DEFMTRFUN ($EXACT2 $ANY MDEFINE NIL NIL) ($A1 $A2 $A3) NIL ((LAMBDA ($B1) NIL (PROG NIL (COND ((LIKE (SIMPLIFY ($RATSIMP (ADD* (SIMPLIFY ($DIFF $A1 (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($DIFF $A2 (TRD-MSYMEVAL $X (QUOTE $X)))))) $A3))) 0.) (SETQ $B1 (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($INTEGRATE (SIMPLIFY ($RATSIMP (DIV (ADD* $A2 (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($DIFF $A1 (TRD-MSYMEVAL $X (QUOTE $X))))))) $A1))) (TRD-MSYMEVAL $X (QUOTE $X)))))))))) (T (RETURN NIL))) (SETQ $METHOD (QUOTE $EXACT)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) $B1 (SIMPLIFY ($INTEGRATE (DIV 1. (MUL* $A1 $B1)) (TRD-MSYMEVAL $X (QUOTE $X))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) $B1))))))) (QUOTE $B1)))
(DEFPROP $XCC2 T TRANSLATED)
(ADD2LNC (QUOTE $XCC2) $PROPS)
(DEFMTRFUN ($XCC2 $ANY MDEFINE NIL NIL) ($AP $AQ) NIL ((LAMBDA ($D $B1 $Z $RADEXPAND) NIL (PROG NIL (COND ((LIKE $AQ 0.) (RETURN NIL))) (SETQ $D (SIMPLIFY ($RATSIMP (DIV (ADD* (SIMPLIFY ($DIFF $AQ (TRD-MSYMEVAL $X (QUOTE $X)))) (MUL* 2. $AP $AQ)) (MUL* 2. (POWER $AQ (RREMAINDER 3. 2.))))))) (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $D) (SETQ $B1 (SIMPLIFY (MFUNCTION-CALL $CC2 $D 1. (TRD-MSYMEVAL $Y (QUOTE $Y)) $Z)))) (T (RETURN NIL))) (SETQ $METHOD (QUOTE $XFORMTOCONSTCOEFF)) (RETURN (SIMPLIFY ($SUBSTITUTE (SIMPLIFY ($INTEGRATE (SIMPLIFY (LIST (QUOTE (%SQRT)) $AQ)) (TRD-MSYMEVAL $X (QUOTE $X)))) $Z $B1))))) (QUOTE $D) (QUOTE $B1) (QUOTE $Z) (TRD-MSYMEVAL $ALL (QUOTE $ALL))))
(DEFPROP $VARP T TRANSLATED)
(ADD2LNC (QUOTE $VARP) $PROPS)
(DEFMTRFUN ($VARP $ANY MDEFINE NIL NIL) ($SOLN $G) NIL ((LAMBDA ($Y1 $Y2 $Y3 $Y4 $WR $HEURISTIC) NIL (PROG NIL (SETQ $Y1 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) 1.)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) 0.))) ($RHS $SOLN)))))) (SETQ $Y2 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) 0.)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) 1.))) ($RHS $SOLN)))))) (SETQ $WR (ADD* (MUL* $Y1 (SIMPLIFY ($DIFF $Y2 (TRD-MSYMEVAL $X (QUOTE $X))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $Y2 (SIMPLIFY ($DIFF $Y1 (TRD-MSYMEVAL $X (QUOTE $X))))))))) (COND ((LIKE $WR 0.) (RETURN NIL))) (COND ((AND (LIKE (TRD-MSYMEVAL $METHOD (QUOTE $METHOD)) (TRD-MSYMEVAL $CONSTCOEFF (QUOTE $CONSTCOEFF))) (NOT ($FREEOF (QUOTE %SIN) $WR)) (NOT ($FREEOF (QUOTE %COS) $WR))) (SETQ $HEURISTIC T) (SETQ $WR (SIMPLIFY ($RATSIMP (SIMPLIFY ($TRIGREDUCE $WR))))))) (SETQ $Y3 (SIMPLIFY ($RATSIMP (DIV (MUL* $Y1 $G) $WR)))) (SETQ $Y4 (SIMPLIFY ($RATSIMP (DIV (MUL* $Y2 $G) $WR)))) (SETQ $YP (SIMPLIFY ($RATSIMP (ADD* (MUL* $Y2 (SIMPLIFY ($INTEGRATE $Y3 (TRD-MSYMEVAL $X (QUOTE $X))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $Y1 (SIMPLIFY ($INTEGRATE $Y4 (TRD-MSYMEVAL $X (QUOTE $X))))))))))) (COND ((LIKE $HEURISTIC T) (SETQ $YP (SIMPLIFY ($RATSIMP (SIMPLIFY ($TRIGREDUCE (TRD-MSYMEVAL $YP (QUOTE $YP))))))))) (SETQ $METHOD (QUOTE $VARIATIONOFPARAMETERS)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* ($RHS $SOLN) (TRD-MSYMEVAL $YP (QUOTE $YP)))))))) (QUOTE $Y1) (QUOTE $Y2) (QUOTE $Y3) (QUOTE $Y4) (QUOTE $WR) NIL))
(DEFPROP $REDUCE2 T TRANSLATED)
(ADD2LNC (QUOTE $REDUCE2) $PROPS)
(DEFMTRFUN ($REDUCE2 $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($B1 $QQ) NIL (PROG NIL (SETQ $B1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) $QQ)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) $QQ))) $EQ))) (COND (($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $B1) (RETURN (SIMPLIFY (MFUNCTION-CALL $NLX $EQ))))) (RETURN (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $B1) (RETURN (SIMPLIFY (MFUNCTION-CALL $NLY $EQ)))) (T (RETURN NIL)))))) (QUOTE $B1) (QUOTE $QQ)))
(DEFPROP $NLX T TRANSLATED)
(ADD2LNC (QUOTE $NLX) $PROPS)
(DEFMTRFUN ($NLX $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($DE $B $A1 $V) NIL (PROG NIL (SETQ $DE (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $V (TRD-MSYMEVAL $X (QUOTE $X)))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) $V))) $EQ))) (COND ((LIKE (SETQ $B (SIMPLIFY (MFUNCTION-CALL $ODE1A $DE $V (TRD-MSYMEVAL $X (QUOTE $X))))) NIL) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) $V (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1))))) $B))) (RETURN (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $NLXY $A1 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $METHOD (QUOTE $FREEOFY)) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q)))) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $B) (QUOTE $A1) (QUOTE $V)))
(DEFPROP $NLY T TRANSLATED)
(ADD2LNC (QUOTE $NLY) $PROPS)
(DEFMTRFUN ($NLY $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($DE $B $A1 $YZ $V) NIL (PROG NIL (SETQ $DE (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) (MUL* $V (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $V $YZ))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) $V)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $YZ))) $EQ))) (COND ((LIKE (SETQ $B (SIMPLIFY (MFUNCTION-CALL $ODE1A $DE $V $YZ))) NIL) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) $V (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) $YZ (TRD-MSYMEVAL $Y (QUOTE $Y)))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1))))) $B))) (RETURN (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $NLXY $A1 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $METHOD (QUOTE $FREEOFX)) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q)))) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $B) (QUOTE $A1) (QUOTE $YZ) (QUOTE $V)))
(DEFPROP $NLXY T TRANSLATED)
(ADD2LNC (QUOTE $NLXY) $PROPS)
(DEFMTRFUN ($NLXY $ANY MDEFINE NIL NIL) ($EQ $DE) NIL ((LAMBDA ($PROGRAMMODE $EQ1) NIL (PROG NIL (SETQ $EQ1 (SIMPLIFY ($SOLVE $EQ $DE))) (SETQ $EQ1 (SIMPLIFY ((LAMBDA (MAPLP RES) (SETQ RES (MAP1 (GETOPR (M-TLAMBDA ($ZZ) NIL (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $ODE1A $ZZ (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))) (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $Q (QUOTE $Q)))))))) $EQ1)) (COND ((ATOM RES) (LIST (QUOTE (MLIST)) RES)) ((EQ (CAAR RES) (QUOTE MLIST)) RES) (T (CONS (QUOTE (MLIST)) (CDR RES))))) T NIL))) (RETURN (COND ((= ($LENGTH $EQ1) 1.) (RETURN (SIMPLIFY ($FIRST $EQ1)))) (T (RETURN $EQ1)))))) T (QUOTE $EQ1)))
(DEFPROP $PTTEST T TRANSLATED)
(ADD2LNC (QUOTE $PTTEST) $PROPS)
(DEFMTRFUN ($PTTEST $ANY MDEFINE NIL NIL) ($A) NIL ((LAMBDA ($A1 $A2 $A3) NIL (PROG NIL (COND ((LIKE (SETQ $A1 (SIMPLIFY ($RATSIMP $A))) 0.) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($EXPAND (DIV 1. $A1)))) (COND ((LIKE (SETQ $A2 (SIMPLIFY ($COEFF $A1 (TRD-MSYMEVAL $X (QUOTE $X)) 1.))) 0.) (RETURN NIL))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $A2)) (RETURN NIL))) (SETQ $A3 (SIMPLIFY ($COEFF $A1 (TRD-MSYMEVAL $X (QUOTE $X)) 0.))) (RETURN (COND ((NOT (LIKE $A1 (ADD* (MUL* $A2 (TRD-MSYMEVAL $X (QUOTE $X))) $A3))) (RETURN NIL)) (T (RETURN (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV $A3 $A2))))))))) (QUOTE $A1) (QUOTE $A2) (QUOTE $A3)))
(DEFPROP $EULER2 T TRANSLATED)
(ADD2LNC (QUOTE $EULER2) $PROPS)
(DEFMTRFUN ($EULER2 $ANY MDEFINE NIL NIL) ($A $B) NIL ((LAMBDA ($DC $RP $IP $ALPHA $BETA $SIGN $RADEXPAND) NIL (PROG NIL (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (SETQ $BETA (SIMPLIFY ($RATSIMP (MUL* $B (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) 2.))))))) (RETURN NIL))) (SETQ $METHOD (QUOTE $EULER)) (SETQ $ALPHA (MUL* $A (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))) (SETQ $DC (SIMPLIFY ($RATSIMP (ADD* (POWER (ADD* $ALPHA -1.) 2.) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* 4. $BETA))))))) (SETQ $RP (SIMPLIFY ($RATSIMP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (ADD* $ALPHA -1.) 2.)))))) (SETQ $SIGN (SIMPLIFY ($ASKSIGN $DC))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $ZERO (QUOTE $ZERO))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) $RP) (ADD* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%LOG)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))))))))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $POS (QUOTE $POS))) (SETQ $IP (DIV (SIMPLIFY (LIST (QUOTE (%SQRT)) $DC)) 2.)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) (ADD* $RP $IP))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) (ADD* $RP (SIMPLIFY (LIST (QUOTE (MMINUS)) $IP))))))))))) (SETQ $DC (SIMPLIFY (LIST (QUOTE (MMINUS)) $DC))) (SETQ $IP (DIV (SIMPLIFY (LIST (QUOTE (%SQRT)) $DC)) 2.)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) $RP) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (LIST (QUOTE (%SIN)) (MUL* $IP (SIMPLIFY (LIST (QUOTE (%LOG)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%COS)) (MUL* $IP (SIMPLIFY (LIST (QUOTE (%LOG)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))))))))))))))) (QUOTE $DC) (QUOTE $RP) (QUOTE $IP) (QUOTE $ALPHA) (QUOTE $BETA) (QUOTE $SIGN) NIL))
(DEFPROP $BESSEL2 T TRANSLATED)
(ADD2LNC (QUOTE $BESSEL2) $PROPS)
(DEFMTRFUN ($BESSEL2 $ANY MDEFINE NIL NIL) ($A $B) NIL ((LAMBDA ($NU $B1 $INTP $RADEXPAND) NIL (PROG NIL (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (SETQ $B1 (SIMPLIFY ($RATSIMP (MUL* (ADD* 1. (SIMPLIFY (LIST (QUOTE (MMINUS)) $B))) (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) 2.))))))) (RETURN NIL))) (COND ((NOT (LIKE (SIMPLIFY ($RATSIMP (MUL* $A (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))))) 1.)) (RETURN NIL))) (SETQ $NU (SIMPLIFY (LIST (QUOTE (%SQRT)) $B1))) (SETQ $METHOD (QUOTE $BESSEL)) (COND ((LIKE $NU (RREMAINDER 1. 2.)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (DIV (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (LIST (QUOTE (%SIN)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%COS)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))) (SIMPLIFY (LIST (QUOTE (%SQRT)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY ($FEATUREP $NU (TRD-MSYMEVAL $INTEGER (QUOTE $INTEGER))))) (SETQ $INTP (QUOTE $Y))) (($NUMBERP $NU) (SETQ $INTP (QUOTE $N)))) $LOOP (COND ((NOT (OR (LIKE $INTP (QUOTE $Y)) (LIKE $INTP (QUOTE $N)))) (SETQ $INTP (SIMPLIFY ($READONLY (QUOTE &I/s) $NU (QUOTE |&an integer? Type Y or N.|)))) (GO $LOOP))) (COND ((LIKE $INTP (QUOTE $Y)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%J (QUOTE $%J)) $NU) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%J ARRAY) $NU))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%Y (QUOTE $%Y)) $NU) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%Y ARRAY) $NU))))))))))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%J (QUOTE $%J)) $NU) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%J ARRAY) $NU))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%J (QUOTE $%J)) (SIMPLIFY (LIST (QUOTE (MMINUS)) $NU))) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%J ARRAY) ((MMINUS) $NU)))))))))))) (QUOTE $NU) (QUOTE $B1) (QUOTE $INTP) (TRD-MSYMEVAL $ALL (QUOTE $ALL))))
(DEFPROP $IC1 T TRANSLATED)
(ADD2LNC (QUOTE $IC1) $PROPS)
(DEFMTRFUN ($IC1 $ANY MDEFINE NIL NIL) ($SOLN $XC $YC) NIL (PROGN (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XC)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YC)) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%C) (TRD-MSYMEVAL $%C (QUOTE $%C)))) (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (QUOTE $%C) ($RHS (SIMPLIFY (MFUNCTION-CALL $SOLVE1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XC $YC) $SOLN)) (TRD-MSYMEVAL $%C (QUOTE $%C)))))))) $SOLN))))))
(DEFPROP $BC2 T TRANSLATED)
(ADD2LNC (QUOTE $BC2) $PROPS)
(DEFMTRFUN ($BC2 $ANY MDEFINE NIL NIL) ($SOLN $XA $YA $XB $YB) NIL ((LAMBDA ($PROGRAMMODE $BACKSUBST $SINGSOLVE $TEMP) NIL (PROG NIL (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XB)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YB)) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K1) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)))) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K2) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)))) (SETQ $TEMP (SIMPLIFY ((LAMBDA (MAPLP RES) (SETQ RES (MAP1 (GETOPR (M-TLAMBDA&ENV (($ZZ) ($SOLN)) NIL (SIMPLIFY ($SUBSTITUTE $ZZ $SOLN)))) (SIMPLIFY ($SOLVE (LIST (QUOTE (MLIST)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XA $YA) $SOLN)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XB $YB) $SOLN))) (LIST (QUOTE (MLIST)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2))))))) (COND ((ATOM RES) (LIST (QUOTE (MLIST)) RES)) ((EQ (CAAR RES) (QUOTE MLIST)) RES) (T (CONS (QUOTE (MLIST)) (CDR RES))))) T NIL))) (RETURN (COND ((= ($LENGTH $TEMP) 1.) (RETURN (SIMPLIFY ($FIRST $TEMP)))) (T (RETURN $TEMP)))))) T T T (QUOTE $TEMP)))
(DEFPROP $IC2 T TRANSLATED)
(ADD2LNC (QUOTE $IC2) $PROPS)
(DEFMTRFUN ($IC2 $ANY MDEFINE NIL NIL) ($SOLN $XA $YA $DYA) NIL ((LAMBDA ($PROGRAMMODE $BACKSUBST $SINGSOLVE $TEMP) NIL (PROG NIL (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $DYA)) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K1) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)))) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K2) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)))) (SETQ $TEMP (ADD* ($LHS $SOLN) (SIMPLIFY (LIST (QUOTE (MMINUS)) ($RHS $SOLN))))) (SETQ $TEMP (SIMPLIFY ((LAMBDA (MAPLP RES) (SETQ RES (MAP1 (GETOPR (M-TLAMBDA&ENV (($ZZ) ($SOLN)) NIL (SIMPLIFY ($SUBSTITUTE $ZZ $SOLN)))) (SIMPLIFY ($SOLVE (LIST (QUOTE (MLIST)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XA $YA) $SOLN)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $DYA $XA) (SIMPLIFY (LIST (QUOTE (MEQUAL)) ($LHS $DYA) (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (SIMPLIFY ($SUBSTITUTE 0. ($LHS $DYA) (SIMPLIFY ($DIFF $TEMP ($LHS $XA))))) (SIMPLIFY ($DIFF $TEMP ($LHS $YA))))))))))) (LIST (QUOTE (MLIST)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2))))))) (COND ((ATOM RES) (LIST (QUOTE (MLIST)) RES)) ((EQ (CAAR RES) (QUOTE MLIST)) RES) (T (CONS (QUOTE (MLIST)) (CDR RES))))) T NIL))) (RETURN (COND ((= ($LENGTH $TEMP) 1.) (RETURN (SIMPLIFY ($FIRST $TEMP)))) (T (RETURN $TEMP)))))) T T T (QUOTE $TEMP)))
(DEFPROP $NOTEQN T TRANSLATED)
(ADD2LNC (QUOTE $NOTEQN) $PROPS)
(DEFMTRFUN ($NOTEQN $ANY MDEFINE NIL NIL) ($X) NIL (COND ((OR ($ATOM $X) (NOT (LIKE (SIMPLIFY ($INPART $X 0.)) (QUOTE &=)))) (DISPLAY-FOR-TR NIL NIL $X) (DISPLAY-FOR-TR NIL NIL (QUOTE |&Not an equation|)) (SIMPLIFY ($ERROR)))))
(DEFPROP $BOUNDTEST T TRANSLATED)
(ADD2LNC (QUOTE $BOUNDTEST) $PROPS)
(DEFMTRFUN ($BOUNDTEST $ANY MDEFINE NIL NIL) ($X $Y) NIL (COND ((NOT (LIKE $X $Y)) (DISPLAY-FOR-TR NIL NIL $X) (DISPLAY-FOR-TR NIL NIL (QUOTE |&Must not be bound|)) (SIMPLIFY ($ERROR)))))
(DEFPROP $FAILURE T TRANSLATED)
(ADD2LNC (QUOTE $FAILURE) $PROPS)
(DEFMTRFUN ($FAILURE $BOOLEAN MDEFINE NIL NIL) ($MSG $EQ) NIL (PROGN (COND ((NOT ($STATUS $FEATURE &ODE)) (DISPLAY-FOR-TR T NIL (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $YOLD (QUOTE $YOLD)) (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) $EQ))) (DISPLAY-FOR-TR NIL NIL $MSG))) NIL))
(SETQ $MSG1 (QUOTE |&Not a proper differential equation|))
(SETQ $MSG2 (QUOTE |&First order equation not linear in y'|))
(compile-forms-to-compile-queue)

307
src/jpg/plot.67 Normal file
View File

@@ -0,0 +1,307 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1981 Massachusetts Institute of Technology **
(macsyma-module plot)
(DECLARE (SPLITFILE GRAPH2)
(SPECIAL $RATPRINT $XAXIS $YAXIS LINEL $PLOTHEIGHT $NUMER $FLOAT
$BFLOAT ^W ^R TTY $CALCOMPNUM $MULTGRAPH $FLOAT2BF $%ENUMER)
(FLONUM LOW HIGH INC XLOW XHIGH XINC YLOW YHIGH YINC VAL
(ROUNDUP FLONUM) (FMEVAL))
(FIXNUM LINEL $PLOTHEIGHT I M N ORG)
(NOTYPE (POINTSUBST NOTYPE FLONUM FLONUM FIXNUM))
(*EXPR $FLOAT)
(*LEXPR MAP1)
(ARRAY* (NOTYPE PLOTARY 1)))
(DEFUN VERTCHAR MACRO (X)
(COND ((STATUS FEATURES ITS) ''/[) (T ''/|))) ; ascii 124.
(DEFMSPEC $PARAMPLOT (L) (SETQ L (CDR L))
(IF (NOT (MFBOUNDP '$PLOT)) (LOAD-FUNCTION '$PLOT T))
(IF (< (LENGTH L) 4) (MERROR "Too few arguments to PARAMPLOT"))
((LAMBDA (FUNLX FUNLY VAR ARG4 $NUMER $FLOAT $BFLOAT LOW HIGH INTFLG INC
$RATPRINT $FLOAT2BF $%ENUMER)
(SETQ L (CDDDDR L)
FUNLX (COND (($LISTP FUNLX) (CDR FUNLX)) (T (LIST FUNLX)))
FUNLY (COND (($LISTP FUNLY) (CDR FUNLY)) (T (LIST FUNLY))))
(COND ((NOT (= (LENGTH FUNLX) (LENGTH FUNLY)))
(MERROR "Arguments to PARAMPLOT are of unequal length"))
((NOT (NUMBERP (SETQ ARG4 (FMEVAL1 ARG4))))
(IF (NOT ($LISTP ARG4)) (MERROR "Invalid argument to PARAMPLOT:~%~M" ARG4))
(SETQ L (GRAPHOPTS L))
(GRAPH (DO ((FUNLX FUNLX (CDR FUNLX)) (XSETS)) ((NULL FUNLX) XSETS)
(SETQ XSETS
(NCONC XSETS
(NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR)
(LIST '(FMEVAL) (CAR FUNLX)))
ARG4))))))
(DO ((FUNLY FUNLY (CDR FUNLY)) (YSETS)) ((NULL FUNLY) YSETS)
(SETQ YSETS
(NCONC YSETS
(NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR)
(LIST '(FMEVAL) (CAR FUNLY)))
ARG4))))))
L '$DONE))
(T (IF (NULL L) (MERROR "Too few arguments to PARAMPLOT"))
(SETQ HIGH (FMEVAL (CAR L)) LOW ARG4 L (CDR L))
(SETQ L (GRAPHOPTS (COND ((AND L (EQ (CAR L) '$INTEGER))
(SETQ INTFLG T) (CDR L))
(T L))))
(COND (INTFLG (SETQ HIGH (FLOAT (FIX HIGH))
LOW (COND ((ZEROP (*DIF LOW (FIX LOW))) LOW)
(T (FLOAT (FIX (+$ LOW 0.999999))))))))
(SETQ INC (//$ (-$ HIGH LOW) (COND #+MULTICS ($MULTGRAPH (FLOAT $CALCOMPNUM))
(T (FLOAT (- LINEL 5))))))
(IF (NOT (PLUSP INC))
(MERROR "Invalid arguments to PARAMPLOT:~%~M"
(LIST '(MLIST SIMP) LOW HIGH)))
(SETQ INC (COND (INTFLG (FLOAT (FIX (+$ INC 0.999999))))
(T (ROUNDUP INC))))
(DO ((VAL LOW (+$ VAL INC))
(XSETS (DO ((FUNLX FUNLX (CDR FUNLX)) (LL NIL (CONS (LIST NIL) LL)))
((NULL FUNLX) LL)))
(YSETS (DO ((FUNLY FUNLY (CDR FUNLY)) (LL NIL (CONS (LIST NIL) LL)))
((NULL FUNLY) LL))))
((> VAL HIGH) (GRAPH (MAPCAR 'CDR XSETS) (MAPCAR 'CDR YSETS) L '$DONE))
(DO ((FUNLX FUNLX (CDR FUNLX)) (XSETS XSETS (CDR XSETS)))
((NULL FUNLX))
(RPLACD (CAR XSETS)
(CONS (FMEVAL (LIST '($EV) (CAR FUNLX)
(LIST '(MEQUAL) VAR
(COND (INTFLG (FIX VAL)) (T VAL)))))
(CDAR XSETS))))
(DO ((FUNLY FUNLY (CDR FUNLY)) (YSETS YSETS (CDR YSETS)))
((NULL FUNLY))
(RPLACD (CAR YSETS)
(CONS (FMEVAL (LIST '($EV) (CAR FUNLY)
(LIST '(MEQUAL) VAR
(COND (INTFLG (FIX VAL)) (T VAL)))))
(CDAR YSETS))))))))
(COND ((ATOM (CAR L)) (MEVAL (CAR L))) (T (CAR L)))
(COND ((ATOM (CADR L)) (MEVAL (CADR L))) (T (CADR L)))
(CADDR L) (CADDDR L) T T NIL 0.0 0.0 NIL 0.0 NIL T T))
(DEFMSPEC $MULTIGRAPH (L) (SETQ L (CDR L))
(IF (NOT (MFBOUNDP '$PLOT)) (LOAD-FUNCTION '$PLOT T))
((LAMBDA (ARG1 XSETS YSETS $NUMER $FLOAT $BFLOAT $FLOAT2BF $%ENUMER)
(IF (NOT ($LISTP ARG1)) (MERROR "Invalid first argument to MULTIGRAPH"))
(DO ((ARG1 (CDR ARG1) (CDR ARG1)) (LL) (XSET) (YSET))
((NULL ARG1))
(IF (OR (NOT ($LISTP (SETQ LL (MEVAL (CAR ARG1)))))
(NOT (= (LENGTH LL) 3))
(NOT ($LISTP (SETQ XSET (MEVAL (CADR LL)))))
(NOT ($LISTP (SETQ YSET (MEVAL (CADDR LL)))))
(NOT (= (LENGTH XSET) (LENGTH YSET))))
(MERROR "Invalid first argument to MULTIGRAPH"))
(SETQ XSETS (NCONC XSETS (NCONS (MAPCAR 'FMEVAL (CDR XSET))))
YSETS (NCONC YSETS (NCONS (MAPCAR 'FMEVAL (CDR YSET))))))
(GRAPH XSETS YSETS (GRAPHOPTS (CDR L)) '$DONE))
(MEVAL (CAR L)) NIL NIL T T NIL T T))
(DECLARE (SPLITFILE GRAPH))
(COND ((NOT (BOUNDP '$XAXIS)) (SETQ $XAXIS NIL)))
(COND ((NOT (BOUNDP '$YAXIS)) (SETQ $YAXIS NIL)))
(DEFMSPEC $PLOT (L) (SETQ L (CDR L))
(IF (< (LENGTH L) 3) (MERROR "Too few arguments to PLOT"))
((LAMBDA (FUNL VAR ARG3 $NUMER $FLOAT $BFLOAT LOW HIGH INTFLG INC $RATPRINT $FLOAT2BF $%ENUMER)
(SETQ L (CDDDR L) FUNL (COND (($LISTP FUNL) (CDR FUNL)) (T (LIST FUNL))))
(COND ((NOT (NUMBERP (SETQ ARG3 (FMEVAL1 ARG3))))
(IF (NOT ($LISTP ARG3)) (MERROR "Invalid argument to PLOT:~%~M" ARG3))
(SETQ L (GRAPHOPTS L))
(GRAPH (MAPCAR 'FMEVAL (CDR ARG3))
(DO ((FUNL FUNL (CDR FUNL)) (YSETS)) ((NULL FUNL) YSETS)
(SETQ YSETS
(NCONC YSETS
(NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR)
(LIST '(FMEVAL) (CAR FUNL)))
ARG3))))))
L (CONS '(MLIST) FUNL)))
(T (IF (NULL L) (MERROR "Too few arguments to PLOT"))
(SETQ HIGH (FMEVAL (CAR L)) LOW ARG3 L (CDR L))
(SETQ L (GRAPHOPTS (COND ((AND L (EQ (CAR L) '$INTEGER))
(SETQ INTFLG T) (CDR L))
(T L))))
(COND (INTFLG (SETQ HIGH (FLOAT (FIX HIGH))
LOW (COND ((ZEROP (*DIF LOW (FIX LOW))) LOW)
(T (FLOAT (FIX (+$ LOW 0.999999))))))))
(SETQ INC (//$ (-$ HIGH LOW) (COND #+MULTICS ($MULTGRAPH (FLOAT $CALCOMPNUM))
(T (FLOAT (- LINEL 5))))))
(IF (NOT (PLUSP INC))
(MERROR "Invalid arguments to PLOT:~%~M"
(LIST '(MLIST SIMP) LOW HIGH)))
(SETQ INC (COND (INTFLG (FLOAT (FIX (+$ INC 0.999999))))
(T (ROUNDUP INC))))
(DO ((VAL LOW (+$ VAL INC)) (XSET)
(YSETS (DO ((FUNL FUNL (CDR FUNL)) (LL NIL (CONS (LIST NIL) LL)))
((NULL FUNL) LL))))
((> VAL HIGH) (GRAPH XSET (MAPCAR 'CDR YSETS) L (CONS '(MLIST) FUNL)))
(SETQ XSET (CONS VAL XSET))
(DO ((FUNL FUNL (CDR FUNL)) (YSETS YSETS (CDR YSETS)))
((NULL FUNL))
(RPLACD (CAR YSETS)
(CONS (FMEVAL (LIST '($EV) (CAR FUNL)
(LIST '(MEQUAL) VAR
(COND (INTFLG (FIX VAL)) (T VAL)))))
(CDAR YSETS))))))))
(IF (AND (SYMBOLP (CAR L)) (NOT (EQ (CAR L) (CADR L))))
(MEVAL (CAR L))
(CAR L))
(CADR L) (CADDR L) T T NIL 0.0 0.0 NIL 0.0 NIL T T))
(DEFUN FMEVAL (X)
(COND ((FIXP (SETQ X (MEVAL X))) (FLOAT X))
((FLOATP X) X)
(($BFLOATP X) ($FLOAT X))
(T (MERROR "Not floating point:~%~M" X))))
(DEFUN FMEVAL1 (X)
(COND ((FIXP (SETQ X (MEVAL X))) (FLOAT X)) (($BFLOATP X) ($FLOAT X)) (T X)))
(DEFMSPEC $GRAPH (L) (SETQ L (CDR L))
((LAMBDA (ARG1 XSET YSET $NUMER $FLOAT $BFLOAT $FLOAT2BF $%ENUMER)
(SETQ L (CDR L))
(COND ((NOT ($LISTP ARG1)) (MERROR "Invalid first argument to GRAPH"))
(($LISTP (CADR ARG1))
(DO ARG1 (CDR ARG1) (CDR ARG1) (NULL ARG1)
(IF (OR (NOT ($LISTP (CAR ARG1))) (CDDDAR ARG1))
(MERROR "Invalid first argument to GRAPH"))
(SETQ XSET (CONS (FMEVAL (CADAR ARG1)) XSET)
YSET (CONS (FMEVAL (CADDAR ARG1)) YSET)))
(SETQ YSET (LIST YSET)))
(T (COND ((NOT ($LISTP (SETQ YSET (MEVAL (CAR L)))))
(MERROR "Invalid second argument to GRAPH"))
(($LISTP (CADR YSET)) (SETQ YSET (CDR YSET)))
(T (SETQ YSET (LIST YSET))))
(SETQ L (CDR L) XSET (MAPCAR 'FMEVAL (CDR ARG1))
YSET (DO ((YSET YSET (CDR YSET)) (YSETS)) ((NULL YSET) YSETS)
(COND ((NOT ($LISTP (CAR YSET)))
(MERROR "Invalid second argument to GRAPH"))
((NOT (= (LENGTH ARG1) (LENGTH (CAR YSET))))
(MERROR "Arguments to GRAPH are of unequal length")))
(SETQ YSETS (NCONC YSETS (NCONS (MAPCAR 'FMEVAL (CDAR YSET)))))))))
(GRAPH XSET YSET (GRAPHOPTS L) '$DONE))
(MEVAL (CAR L)) NIL NIL T T NIL T T))
(DEFUN GRAPHOPTS (L)
(IF (> (LENGTH L) 3) (MERROR "Too many arguments to GRAPH or PLOT"))
(DO ((L L (CDR L)) (CHARL) (XLABEL) (YLABEL))
((NULL L) (CONS CHARL (SUBST NIL '$FALSE (LIST XLABEL YLABEL))))
(COND (($LISTP (CAR L))
(IF CHARL (MERROR "Invalid argument to GRAPH or PLOT:~%~M" (CAR L)))
(SETQ CHARL (FULLSTRIP (CDAR L))))
(XLABEL (SETQ YLABEL (CAR L)))
(T (SETQ XLABEL (COND ((NULL (CAR L)) '$FALSE) (T (CAR L))))))))
(DEFUN GRAPH (XSET YSETS OPTL RETVAL)
((LAMBDA (1SETP CHARL XLABEL YLABEL XHIGH XLOW XINC YHIGH YLOW YINC)
(PROG (L)
(COND #+MULTICS
($MULTGRAPH
(RETURN (MULTPLOT (CAR CHARL) (STRIPDOLLAR XLABEL) (STRIPDOLLAR YLABEL)
(SETQ XSET (COND (1SETP XSET) (T (APPLY 'APPEND XSET))))
(APPLY 'APPEND YSETS) (LENGTH XSET) RETVAL)))
(T (SETQ L (COND (1SETP XSET) (T (APPLY 'APPEND XSET))))
(SETQ XLOW (APPLY 'MIN L) XHIGH (APPLY 'MAX L))
(SETQ XINC (ROUNDUP (//$ (-$ XHIGH XLOW) (FLOAT (- LINEL 5)))))
(SETQ L (APPLY 'APPEND YSETS) YLOW (APPLY 'MIN L) YHIGH (APPLY 'MAX L))
(SETQ YINC (ROUNDUP (//$ (-$ YHIGH YLOW) (FLOAT (- $PLOTHEIGHT 6)))))
(COND ((ZEROP XINC)
(PRINC (COND (XLABEL (MAKNAM (MAKSTRING XLABEL)))
(T '|X-coordinate|)))
(PRINC '| is constant value |) (PRINC XLOW) (RETURN '$DONE))
((ZEROP YINC)
(PRINC (COND (YLABEL (MAKNAM (MAKSTRING YLABEL)))
(T '|Y-coordinate|)))
(PRINC '| is constant value |) (PRINC YLOW) (RETURN '$DONE)))
(*ARRAY 'PLOTARY T (1+ $PLOTHEIGHT))
(COND (1SETP (SETQ XSET (POINTSUBST XSET XLOW XINC 5))))
(DO ((YSETS YSETS (CDR YSETS)) (CHARL CHARL (AND CHARL (CDR CHARL))))
((NULL YSETS))
(DO ((XSET (COND (1SETP XSET)
(T (PROG2 NIL (POINTSUBST (CAR XSET) XLOW XINC 5)
(SETQ XSET (CDR XSET)))))
(CDR XSET))
(YSET (POINTSUBST (CAR YSETS) YLOW YINC 6) (CDR YSET))
(CHAR (OR (AND CHARL (CAR CHARL)) '*)))
((NULL XSET))
(GRAPHINSERT (CAR XSET) (CAR YSET) CHAR)))
(COND ($XAXIS
(COND ((OR (PLUSP YLOW) (MINUSP YHIGH))
(MTELL "X-axis is off graph") (SLEEP 2))
(T (DO ((N LINEL (1- N))
(YCOORD (CAR (POINTSUBST (NCONS 0.0) YLOW YINC 6))))
((< N 5))
(GRAPHINSERT N YCOORD '|.|))))))
(COND ($YAXIS
(COND ((OR (PLUSP XLOW) (MINUSP XHIGH))
(MTELL "Y-axis is off graph") (SLEEP 2))
(T (DO ((N 6 (1+ N))
(XCOORD (CAR (POINTSUBST (NCONS 0.0) XLOW XINC 5))))
((> N $PLOTHEIGHT))
(GRAPHINSERT XCOORD N '|.|))))))
(STORE (PLOTARY 5) (DO ((N LINEL (1- N)) (L)) ((< N 4) L)
(SETQ L (CONS N (CONS '- L)))))
(STORE (PLOTARY 4)
(DO ((N 5 (+ N 2)) (I 0 (+ I 2)) (L)) ((> N LINEL) (NREVERSE L))
(SETQ L (CONS I (CONS N L))) (COND ((= I 8) (SETQ I -2)))))
(SETQ L (CONS NIL (APPEND '(X O R G =) (EXPLODEC XLOW)
'(/ Y O R G =) (EXPLODEC YLOW)
'(/ X D E L T A =) (EXPLODEC XINC)
'(/ Y D E L T A =) (EXPLODEC YINC))))
(STORE (PLOTARY 3) (GRAPHDO L))
(SETQ L (CONS NIL (APPEND '(X M A X =) (EXPLODEC XHIGH)
'(/ Y M A X =) (EXPLODEC YHIGH))))
(STORE (PLOTARY 2) (GRAPHDO L))
(DO ((N 6 (1+ N))) ((> N $PLOTHEIGHT))
(STORE (PLOTARY N) (CONS 4 (CONS (VERTCHAR) (PLOTARY N)))))
(DO ((N 6 (+ N 2)) (I 0 (+ I 2))) ((> N $PLOTHEIGHT))
(STORE (PLOTARY N) (CONS 3 (CONS I (PLOTARY N))))
(COND ((= I 8) (SETQ I -2))))
(AND YLABEL
(DO ((I (+ 7 (// $PLOTHEIGHT 2)) (1- I)) (YL (MAKSTRING YLABEL) (CDR YL)))
((OR (NULL YL) (= I 4)))
(STORE (PLOTARY I) (CONS 1 (CONS (CAR YL) (PLOTARY I))))))
(AND XLABEL (SETQ XLABEL (CONS NIL (MAKSTRING XLABEL)))
(DO ((N (- (// LINEL 2) 4) (1+ N)) (XL XLABEL (CDDR XL)))
((OR (NULL (CDR XL)) (> N LINEL))
(STORE (PLOTARY 1) (CDR XLABEL)))
(RPLACD XL (CONS N (CDR XL)))))
(CURSORPOS 'C)
(DO ((N $PLOTHEIGHT (1- N))) ((= N 0))
(TERPRI)
(DO ((I 1 (1+ I)) (L (PLOTARY N)))
((OR (> I LINEL) (NULL L)))
(COND ((= I (CAR L)) (PRINC (CADR L)) (SETQ L (CDDR L)))
(T (PRINC '/ )))))
(COND ((AND (NOT (ZEROP TTY)) (NULL ^W)) (TYI*)))
(TERPRI) (TERPRI) (*REARRAY 'PLOTARY) (RETURN '$DONE)))))
(FLOATP (CAR XSET)) (CAR OPTL) (CADR OPTL) (CADDR OPTL) 0.0 0.0 0.0 0.0 0.0 0.0))
(DEFUN POINTSUBST (SET LOW INC ORG)
(DO ((SET SET (CDR SET)) (L)) ((NULL SET) L)
(SETQ L (CONS (+ ORG (FIX (+$ 0.5 (//$ (-$ (CAR SET) LOW) INC)))) L))))
(DEFUN GRAPHINSERT (XCOORD YCOORD CHAR)
((LAMBDA (L)
(STORE (PLOTARY YCOORD)
(DO LL L (CDDR LL) NIL
(COND ((AND (CDR LL) (= XCOORD (CADR LL))) (RETURN (CDR L)))
((OR (NULL (CDR LL)) (NOT (> XCOORD (CADR LL))))
(RPLACD LL (NCONC (LIST XCOORD CHAR) (CDR LL)))
(RETURN (CDR L)))))))
(CONS NIL (PLOTARY YCOORD))))
(DEFUN ROUNDUP (INC)
(COND ((= INC 0.0) 0.0)
((> INC 10.0) (*$ 10.0 (ROUNDUP (//$ INC 10.0))))
((< INC 1.0) (//$ (ROUNDUP (*$ INC 10.0)) 10.0))
(T (*QUO (FIX (+$ (*$ INC 10.0) 0.999999)) 10.0))))
(DEFUN GRAPHDO (L)
(DO ((LL L (CDDR LL)) (N 1 (1+ N))) ((NULL (CDR LL)) (CDR L))
(RPLACD LL (CONS N (CDR LL)))))

2724
src/jpg/suprv.619 Normal file
View File

File diff suppressed because it is too large Load Diff

104
src/lisp/lock.mail Executable file
View File

@@ -0,0 +1,104 @@
MAXTUL 12/17/81 18:12:17
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK MAXTUL) MCLDMP /26) ((DSK LSPDMP) |CL.DMP| /1130))

JONL 12/24/81 17:12:24
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK JONL) TS ECL) ((DSK LSPDMP) |CL.DMP| /1130))

JONL 12/24/81 17:12:24
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK JONL) TS ECL) ((DSK LSPDMP) |CL.DMP| /1130))

JONL 12/24/81 17:12:24
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK JONL) TS ECL) ((DSK JONL) TS ECL) ((DSK LSPDMP) |CL.DMP| /1130))

JONL 12/25/81 9:12:25
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK LSPDMP) ECLDMP /1130) ((DSK LSPDMP) |CL.DMP| /1130))

JONL 12/25/81 9:12:25
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK LSPDMP) ECLDMP /1130) ((DSK LSPDMP) |CL.DMP| /1130))

MAXTUL 1/5/82 19:1:5
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK MAXTUL) MCLDMP /27) ((DSK LSPDMP) |CL.DMP| /1130))

MAXTUL 1/5/82 19:1:5
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK MAXTUL) MCLDMP /27) ((DSK LSPDMP) |CL.DMP| /1130))

JONL 1/27/82 12:1:27
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK LSPDMP) ECLDMP /1130) ((DSK LSPDMP) |CL.DMP| /1130))

WGD 1/30/82 22:1:30
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK FLAVOR) TS CLFLAV) ((DSK LSPDMP) |CL.DMP| /1130))

GJC 2/10/82 14:2:10
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK GJC) TS B))

GJC 2/10/82 15:2:10
(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK GJC) TS B))

JONL 2/17/82 21:2:17
(/2122 ((DSK LSPDMP) MACDMP /1047))

JONL 2/17/82 21:2:17
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131))

JONL 2/17/82 22:2:17
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131))

JONL 2/17/82 22:2:17
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131))

JONL 2/18/82 0:2:18
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131))

JONL 2/18/82 0:2:18
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131))

JONL 2/27/82 15:2:27
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) NADMP /1064))

JONL 2/27/82 15:2:27
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) NADMP /1066))

JONL 2/27/82 15:2:27
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) NACDMP /1131) ((DSK LSPDMP) |CL.DMP| /1131))

MAXTUL 5/30/82 22:5:30
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /28) ((DSK LSPDMP) |CL.DMP| /1131))

MAXTUL 9/8/82 17:9:8
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /29) ((DSK LSPDMP) |CL.DMP| /1131))

MAXTUL 9/8/82 18:9:8
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /29) ((DSK LSPDMP) |CL.DMP| /1131))

WGD 10/14/82 21:10:14
(/2122 ((DSK LSPDMP) SHBDMP |47.122|))

WGD 10/17/82 22:10:17
(/2122 ((DSK LSPDMP) SHBDMP |47.122|) ((DSK FLAVOR) TS NNFLAV))

WGD 10/17/82 22:10:17
(/2122 ((DSK LSPDMP) SHBDMP |45.122|) ((DSK FLAVOR) TS NNFLAV))

MAXTUL 3/22/83 0:3:22
(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /30) ((DSK LSPDMP) |CL.DMP| /1131))


ALAN 6/16/83 17:6:16
(/2138 ((DSK LSPDMP) MACDMP /1048))

ALAN 6/16/83 17:6:16
(/2138 ((DSK LSPDMP) SHBDMP |47.138|))

ALAN 6/16/83 18:6:16
(/2138 ((DSK LSPDMP) SHBDMP |47.138|) ((DSK LSPDMP) |CL.DMP| /1134))

ALAN 6/16/83 19:6:16
(/2138 ((DSK LSPDMP) MACDMP /1048) ((DSK LSPDMP) |CL.DMP| /1135))

MAXTUL 7/24/83 1:7:24
(/2138 ((DSK LSPDMP) MACDMP /1048) ((DSK MAXTUL) MCLDMP /31) ((DSK LSPDMP) |CL.DMP| /1135))

MAXTUL 7/24/83 2:7:24
(/2138 ((DSK LSPDMP) MACDMP /1048) ((DSK MAXTUL) MCLDMP /31) ((DSK LSPDMP) |CL.DMP| /1135))


55
src/macrak/logarc.27 Normal file
View File

@@ -0,0 +1,55 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module logarc)
;;; Logarc and Halfangles
(defmfun $logarc (exp)
(cond ((atom exp) exp)
((arcp (caar exp)) (logarc (caar exp) ($logarc (cadr exp))))
((eq (caar exp) '$atan2)
(logarc '%atan ($logarc (div (cadr exp) (caddr exp)))))
(t (recur-apply #'$logarc exp))))
(defmfun logarc (f x)
;;Gives logarithmic form of arc trig and hyperbolic functions
(let ((s (memq f '(%acos %atan %asinh %atanh))))
(cond
((memq f '(%acos %asin))
(mul (min%i)
(take '(%log)
(add (mul (if s '$%i 1)
(root (add 1 (neg (power x 2))) 2))
(mul (if s 1 '$%i) x)))))
((memq f '(%atan %acot))
(mul (i//2)
(take '(%log) (div (add 1 (morp s (mul '$%i x)))
(add (mul '$%i x) (porm s 1))))))
((memq f '(%asinh %acosh))
(take '(%log) (add x (root (add (power x 2) (porm s 1)) 2))))
((memq f '(%atanh %acoth))
(mul (half) (take '(%log) (div (add 1 x) (morp s (add x -1))))))
((memq f '(%asec %acsc %asech %acsch))
(logarc (get (get (get f '$inverse) 'recip) '$inverse) (inv x)))
(t (merror "Bad argument to Logarc")))))
(defun halfangle (f a)
(and (mtimesp a)
(ratnump (cadr a))
(equal (caddr (cadr a)) 2)
(halfangleaux f (mul 2 a))))
(defun halfangleaux (f a) ;; f=function; a=twice argument
(let ((sw (memq f '(%cos %cot %coth %cosh))))
(cond ((memq f '(%sin %cos))
(power (div (add 1 (porm sw (take '(%cos) a))) 2) (1//2)))
((memq f '(%tan %cot))
(div (add 1 (porm sw (take '(%cos) a))) (take '(%sin) a)))
((memq f '(%sinh %cosh))
(power (div (add (take '(%cosh) a) (porm sw 1)) 2) (1//2)))
((memq f '(%tanh %coth))
(div (add (take '(%cosh) a) (porm sw 1)) (take '(%sinh) a)))
((memq f '(%sec %csc %sech %csch))
(inv (halfangleaux (get f 'recip) a))))))

509
src/macrak/rpart.263 Normal file
View File

@@ -0,0 +1,509 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module rpart)
;;; Complex variable utilities
;;;
;;; Macsyma functions: $realpart $imagpart $rectform $polarform
;;; $cabs $carg
;;; Utility functions: trisplit risplit absarg cabs andmapc andmapcar
(load-macsyma-macros rzmac)
(declare (special negp* $%emode $radexpand rp-polylogp
$domain $m1pbranch $logarc rischp $keepfloat)
(*lexpr $expand)
(genprefix ~rp))
(defmvar implicit-real nil "If t RPART assumes radicals and logs
of real quantities are real and doesn't ask sign questions")
(defmvar generate-atan2 t "Controls whether RPART will generate ATAN's
or ATAN2's, default is to make ATAN2's")
(defmfun $realpart (xx) (car (trisplit xx)))
(defmfun $imagpart (xx) (cdr (trisplit xx)))
;;;Rectform gives a result of the form a+b*%i.
(defmfun $rectform (xx)
(let ((ris (trisplit xx)))
(add (car ris) (mul (cdr ris) '$%i))))
;;;Polarform gives a result of the form a*%e^(%i*b).
(defmfun $polarform (xx)
(cond ((and (not (atom xx)) (memq (caar xx) '(mequal mlist $matrix)))
(cons (car xx) (mapcar '$polarform (cdr xx))))
(t ((lambda (aas $%emode)
(mul (car aas) (powers '$%e (mul '$%i (cdr aas)))))
(absarg xx) nil))))
;;; Cabs gives the complex absolute value. Nota bene: an expression may
;;; be syntactically real without being real (e.g. sqrt(x), x<0). Thus
;;; Cabs must lead an independent existence from Abs.
(defmfun $cabs (xx) (cabs xx))
;;; Carg gives the complex argument.
(defmfun $carg (xx) (cdr (absarg xx)))
(defvar absflag nil)
;; The function of Absflag is to communicate to Absarg that only the absolute
;; value part of the result is wanted. This allows Absarg to avoid asking
;; questions irrelevant to the absolute value. For instance, Cabs(x) is
;; invariably Abs(x), while the complex phase may be 0 or %pi. Note also
;; the steps taken in Absarg to assure that Asksign's will happen before Sign's
;; as often as possible, so that, for instance, Abs(x) can be simplified to
;; x or -x if the sign of x must be known for some other reason. These
;; techniques, however, are not perfect.
;; The internal cabs, used by other Macsyma programs.
(defmfun cabs (xx) (let ((absflag t)) (car (absarg xx))))
;; Some objects can only appear at the top level of a legal simplified
;; expression: CRE forms and equations in particular.
(defmfun trisplit (el) ;Top level of risplit
(cond ((atom el) (risplit el))
((specrepp el) (trisplit (specdisrep el)))
((eq (caar el) 'mequal) (dot-sp-ri (cdr el) '(mequal simp)))
(t (risplit el))))
;;; Auxiliaries
;; These are Macsyma equivalents to (mapcar 'trisplit ...). They must
;; differ from other maps for two reasons: the lists are Macsyma lists,
;; and therefore prefixed with list indicators; and the results must
;; be separated: ((a . b) (c . d)) becomes something like ([a,c].[b,d]).
(defun dsrl (el) (dot-sp-ri (cdr el) '(mlist simp)))
(defun dot-sp-ri (el ind)
(dot--ri (mapcar 'trisplit el) ind))
;; Dot--ri does the ((a.b)(c.d))->([a,c].[b,d]) transformation with
;; minimal Cons'ing.
(defun dot--ri (el ind)
(do ((i el (cdr i)) (k))
((null i) (cons (cons ind (nreverse k)) (cons ind el)))
((lambda (cdari) (setq k (rplacd (car i) k))
(rplaca i cdari))
(cdar i))))
(defun risplit-mplus (l)
(do ((rpart) (ipart) (m (cdr l) (cdr m)))
((null m) (cons (addn rpart t) (addn ipart t)))
((lambda (sp)
(cond ((=0 (car sp)))
(t (setq rpart (cons (car sp) rpart))))
(cond ((=0 (cdr sp)))
(t (setq ipart (cons (cdr sp) ipart)))))
(risplit (car m)))))
(defun risplit-times (l)
((lambda (risl)
(cond ((null (cdr risl)) (cons (muln (car risl) t) 0))
(t (do ((rpart 1) (ipart 0) (m (cdr risl) (cdr m)))
((null m)
(cons (muln (cons rpart (car risl)) t)
(muln (cons ipart (car risl)) t)))
(psetq rpart (sub (mul rpart (caar m))
(mul ipart (cdar m)))
ipart (add (mul ipart (caar m))
(mul rpart (cdar m))))))))
(do ((purerl nil) (compl nil) (l (cdr l) (cdr l)))
((null l) (cons purerl compl))
;;This is what Risl is bound to
((lambda (sp)
(cond ((=0 (cdr sp)) (setq purerl (rplacd sp purerl)))
((or (atom (car sp)) (atom (cdr sp)))
(setq compl (cons sp compl)))
((and (eq (caaar sp) 'mtimes)
;;;Try risplit z/w and notice denominator. If this check were not made,
;;; the real and imaginary parts would not each be over a common denominator.
(eq (caadr sp) 'mtimes)
((lambda (nr ni)
(cond ((equal (car nr) (car ni))
(setq
purerl (cons (car nr) purerl)
compl
(cons (cons (muln (nreverse (cdr nr)) t)
(muln (nreverse (cdr ni)) t))
compl)))
(t (nreverse nr) (nreverse ni) nil)))
(nreverse (cdar sp))
(nreverse (cddr sp)))))
(t (setq compl (cons sp compl)))))
(risplit (car l))))))
(defun risplit-expt (l)
((lambda (pow $radexpand ris) ; Don't want 'simplifications' like
(cond ; Sqrt(-x) -> %i*sqrt(x)
((eq (typep pow) 'fixnum)
((lambda (sp)
(cond ((= pow -1)
((lambda (a2+b2)
(cons (div (car sp) a2+b2)
(mul -1 (div (cdr sp) a2+b2))))
(spabs sp)))
((> (abs pow) $maxposex)
(cond ((=0 (cdr sp)) (cons (powers (car sp) pow) 0))
(t ((lambda (abs^n natan)
(cons (mul abs^n
(take '(%cos) natan))
(mul abs^n (take '(%sin) natan))))
(powers (add (powers (car sp) 2)
(powers (cdr sp) 2))
(*red pow 2))
(mul pow (genatan (cdr sp) (car sp)))))))
((> pow 0) (expanintexpt sp pow))
(t ((lambda (abbas basspli)
(cons (div (car basspli) abbas)
(neg (div (cdr basspli) abbas))))
(powers (spabs sp) (- pow))
(expanintexpt sp (- pow))))))
(risplit (cadr l))))
((and (ratnump pow)
(eq (typep (cadr pow)) 'fixnum)
(not (< (cadr pow) (- $maxnegex)))
(not (> (cadr pow) $maxposex))
(prog2 (setq ris (risplit (cadr l)))
(or (= (caddr pow) 2) (=0 (cdr ris)))))
(cond ((=0 (cdr ris))
(caseq (cond ((mnegp (car ris)) '$negative)
(implicit-real '$positive)
(t (asksign (car ris))))
($negative (risplit (mul2 (power -1 pow) (power (neg (car ris)) pow))))
($zero (cons (power 0 pow) 0))
(t (cons (power (car ris) pow) 0))))
(t ((lambda (abs2 n pos?)
((lambda (abs)
(divcarcdr
(expanintexpt
(cons (power (add abs (car ris)) (1//2))
(porm ((lambda (a b) (cond (a (not b)) (b t))) ;Xor
pos? (eq (asksign (cdr ris)) '$negative))
(power (sub abs (car ris)) (1//2))))
n)
(cond (pos? (power 2 (div n 2)))
(t (power (mul 2 abs2) (div n 2))))))
(power abs2 (1//2))))
(spabs ris) (abs (cadr pow)) (> (cadr pow) -1)))))
((and (floatp (setq ris (cadr l))) (floatp pow))
(risplit ((lambda ($numer) (exptrl ris pow)) t)))
(t ((lambda (sp aa)
;;If all else fails, we use the trigonometric form.
(cond ((and (=0 (cdr sp)) (=0 (cdr aa))) (cons l 0))
(t ((lambda (pre post)
(cons (mul pre (take '(%cos) post))
(mul pre (take '(%sin) post))))
(mul (powers '$%e (mul (cdr aa) (mul (cdr sp) -1)))
(powers (car aa) (car sp)))
(add (mul (cdr sp) (take '(%log) (car aa)))
(mul (car sp) (cdr aa)))))))
(risplit (caddr l)) (absarg1 (cadr l))))))
(caddr l) nil nil))
(defun risplit-noun (l)
(cons (simplify (list '(%realpart) l)) (simplify (list '(%imagpart) l))))
(defun absarg1 (arg)
(let (arg1 ($keepfloat t))
(cond ((or (free arg '$%i)
(free (setq arg1 (sratsimp arg)) '$%i))
(if arg1 (setq arg arg1))
(if implicit-real
(cons arg 0)
(unwind-protect
(prog2 (assume `(($notequal) ,arg 0))
(absarg arg))
(forget `(($notequal) ,arg 0)))))
(t (absarg arg)))))
;;; Main function
;;; Takes an expression and returns the dotted pair
;;; (<Real part> . <imaginary part>).
(defun risplit (l)
(let (($domain '$complex) ($m1pbranch t) $logarc op)
(cond
((atom l) (cond ((eq l '$%i) (cons 0 1))
((decl-complexp l) (risplit-noun l))
(t (cons l 0))))
((eq (caar l) 'rat) (cons l 0))
((eq (caar l) 'mplus) (risplit-mplus l))
((eq (caar l) 'mtimes) (risplit-times l))
((eq (caar l) 'mexpt) (risplit-expt l))
((eq (caar l) '%log)
(let ((aa (absarg1 (cadr l))))
(rplaca aa (take '(%log) (car aa)))))
((eq (caar l) 'bigfloat) (cons l 0)) ;All numbers are real.
((and (memq (caar l) '(%integrate %derivative %laplace %sum))
(freel (cddr l) '$%i))
(let ((ris (risplit (cadr l))))
(cons (simplify (list* (ncons (caar l)) (car ris) (cddr l)))
(simplify (list* (ncons (caar l)) (cdr ris) (cddr l))))))
(((lambda (ass)
;;;This clause handles the very similar trigonometric and hyperbolic functions.
;;; It is driven by the table at the end of the lambda.
(and ass
((lambda (ri)
(cond ((=0 (cdr ri)) ;Pure real case.
(cons (take (list (car ass)) (car ri)) 0))
(t (cons (mul (take (list (car ass)) (car ri))
(take (list (cadr ass)) (cdr ri)))
(negate-if (eq (caar l) '%cos)
(mul (take (list (caddr ass))
(car ri))
(take (list (cdddr ass))
(cdr ri))))))))
(risplit (cadr l)))))
(assq (caar l)
'((%sin %cosh %cos . %sinh)
(%cos %cosh %sin . %sinh)
(%sinh %cos %cosh . %sin)
(%cosh %cos %sinh . %sin)))))
((memq (caar l) '(%tan %tanh))
((lambda (sp)
;;;The similar tan and tanh cases.
(cond ((=0 (cdr sp)) (cons l 0))
(t
((lambda (2rl 2im)
((lambda (denom)
(cond ((eq (caar l) '%tan)
(cons (mul (take '(%sin) 2rl) denom)
(mul (take '(%sinh) 2im) denom)))
(t (cons (mul (take '(%sinh) 2rl) denom)
(mul (take '(%sin) 2im) denom)))))
(inv (cond ((eq (caar l) '%tan)
(add (take '(%cosh) 2im) (take '(%cos) 2rl)))
(t (add (take '(%cos) 2im) (take '(%cosh) 2rl)))))))
(mul (car sp) 2)
(mul (cdr sp) 2)) )))
(risplit (cadr l))))
((and (memq (caar l) '(%atan %csc %sec %cot %csch %sech %coth))
(=0 (cdr (risplit (cadr l)))))
(cons l 0))
((and (eq (caar l) '$atan2) (=0 (cdr (risplit (div (cadr l) (caddr l))))))
(cons l 0))
((or (arcp (caar l)) (eq (caar l) '$atan2))
(let ((ans (risplit ((lambda ($logarc) (ssimplifya l)) t))))
(cond ((eq (caar l) '$atan2)
(setq ans (cons (sratsimp (car ans)) (sratsimp (cdr ans))))))
(cond ((and (free l '$%i) (=0 (cdr ans))) (cons l 0)) (t ans))))
((eq (caar l) '%plog)
; (princ '|Warning: Principal value not guaranteed for Plog in Rectform/
;|)
(risplit (cons '(%log) (cdr l))))
((memq (caar l) '(%realpart %imagpart mabs)) (cons l 0))
((eq (caar l) '%erf)
(let ((ris (risplit (cadr l))) orig cc)
(setq orig (simplify (list '(%erf) (add (car ris) (mul '$%i (cdr ris))))))
(setq cc (simplify (list '(%erf) (sub (car ris) (mul '$%i (cdr ris))))))
(cons (div (add orig cc) 2) (div (sub orig cc) (mul 2 '$%i)))))
;;; ^ All the above are guaranteed pure real.
;;; The handling of lists and matrices below has to be thought through.
((eq (caar l) 'mlist) (dsrl l))
((eq (caar l) '$matrix)
(dot--ri (mapcar 'dsrl (cdr l)) '($matrix simp)))
((memq (caar l) '(mlessp mleqp mgreaterp mgeqp))
(let ((ris1 (risplit (cadr l))) (ris2 (risplit (caddr l))))
(cons (simplify (list (ncons (caar l)) (car ris1) (car ris2)))
(simplify (list (ncons (caar l)) (cdr ris1) (cdr ris2))))))
;;;The Coversinemyfoot clause covers functions which can be converted
;;; to functions known by risplit, such as the more useless trigonometrics.
(((lambda (foot) (and foot (risplit foot)))
(coversinemyfoot l)))
;;; A MAJOR ASSUMPTION:
;;; All random functions are pure real, regardless of argument.
;;; This is evidently assumed by some of the integration functions.
;;; Perhaps the best compromise is to return 'realpart/'imagpart
;;; under the control of a switch set by the integrators. First
;;; all such dependencies must be found in the integ
((and rp-polylogp (mqapplyp l) (eq (subfunname l) '$li)) (cons l 0))
((prog2 (setq op (if (eq (caar l) 'mqapply) (caaadr l) (caar l)))
(decl-complexp op))
(risplit-noun l))
((and (eq (caar l) '%product) (not (free (cadr l) '$%i)))
(risplit-noun l))
(t (cons l 0)))))
(defun coversinemyfoot (l)
(prog (recip)
(cond ((not (memq (caar l) '(%csc %sec %cot %csch %sech %coth))))
((null (setq recip (get (caar l) 'recip))))
(t (return (div 1 (cons (list recip) (cdr l))))))))
(defun powers (c d)
(cond ((=1 d) c)
((equal d 0) 1) ;equal to preclude 0^(pdl 0)->0:
((=0 c) 0) ; see comment before =0.
((=1 c) 1)
(t (power c d))))
(defun spabs (sp) (add (powers (car sp) 2) (powers (cdr sp) 2)))
(progn (setq negp* '(nil nil t t)
negp* (nconc negp* negp*))
0)
(defun divcarcdr (a b) (cons (div (car a) b) (div (cdr a) b)))
(declare (notype (expanintexpt notype fixnum)))
;Expand bas^n, where bas is (<real part> . <imaginary part>)
(defun expanintexpt (bas n)
(cond ((= n 1) bas)
(t (do ((rp (car bas))
(ip (cdr bas))
(c 1 (quotient (times c ex) i))
(ex n (1- ex)) (i 1 (1+ i))
(rori t (not rori)) (negp negp* (cdr negp))
(rpt nil) (ipt nil))
((< ex 0) (cons (addn rpt t) (addn ipt t)))
(declare (fixnum ex i))
(set-either rpt ipt
rori
(cons (negate-if (car negp)
(mul c
(powers rp ex)
(powers ip (1- i))))
(cond (rori rpt) (t ipt))))))))
;;; Subtract out multiples of 2*%pi with a minimum of consing.
;;; Attempts to reduce to interval (-pi,pi].
(defun 2pistrip (exp)
(cond ((atom exp) exp)
((eq (caar exp) 'mtimes)
(cond ((and (mnump (cadr exp))
(eq (caddr exp) '$%pi)
(null (cdddr exp)))
(cond ((fixp (cadr exp)) ;5*%pi
(mul (abs (remainder (cadr exp) 2)) '$%pi))
;Neither 0 nor 1 appears as a coef
((eq 'rat (caaadr exp)) ;5/2*%pi
(mul (list* '(rat simp)
(sub1 (remainder (add1 (cadadr exp))
(times 2 (caddadr exp))))
(cddadr exp))
'$%pi))
(t exp)))
(t exp)))
((eq (caar exp) 'mplus)
((lambda (res)
(cond ((eq res (cdr exp)) exp) (t (addn res t))))
(2pirec (cdr exp))))
(t exp)))
(defun 2pirec (fm) ;Takes a list of exprs
(cond ((null (cdr fm)) ;If monad, just return.
((lambda (2pf)
(cond ((eq 2pf (car fm)) fm)
((=0 2pf) nil)
(t (list 2pf))))
(2pistrip (car fm))))
(t ((lambda (2pfma 2pfmd)
(cond ((or (null 2pfmd) (=0 2pfmd)) 2pfma)
((and (eq 2pfmd (cdr fm)) (eq 2pfma (car fm))) fm)
(t (cons 2pfma 2pfmd))))
(2pistrip (car fm)) (2pirec (cdr fm))))))
;;; Rectify into polar form; Arguments similar to risplit
(defun argnum (n) (cond ((minusp n) (simplify '$%pi)) (t 0)))
(defun absarg (l)
(setq l ($expand l))
(cond ((atom l)
(cond ((eq l '$%i)
(cons 1 (simplify '((mtimes) ((rat simp) 1 2) $%pi))))
((numberp l)
(cons (abs l) (argnum l)))
((memq l '($%e $%pi)) (cons l 0))
(absflag (cons (take '(mabs) l) 0))
(t ((lambda (gs)
(cond ((eq gs '$positive) (cons l 0))
((eq gs '$zero) (cons 0 0))
((eq gs '$negative)
(cons (neg l) (simplify '$%pi)))
(t (cons (take '(mabs) l) 0))))
(cond ((eq rischp l) '$positive) (t (asksign l)))))))
((memq (caar l) '(rat bigfloat))
(cons (list (car l) (abs (cadr l)) (caddr l))
(argnum (cadr l))))
((eq (caar l) 'mtimes)
(do ((n (cdr l) (cdr n))
(abars)
(argl () (cons (cdr abars) argl))
(absl () (rplacd abars absl)))
(())
(cond ((not n)
(return (cons (muln absl t)
(2pistrip (addn argl t))))))
(setq abars (absarg (car n)))))
((eq (caar l) 'mexpt)
(let ((aa (absarg (cadr l)))
(sp (risplit (caddr l)))
($radexpand nil))
(cons (mul (powers (car aa) (car sp))
(powers '$%e (neg (mul (cdr aa) (cdr sp)))))
(add (mul (cdr aa) (car sp))
(mul (cdr sp) (take '(%log) (car aa)))))))
((and (memq (caar l) '(%tan %tanh))
(not (=0 (cdr (risplit (cadr l))))))
((lambda (sp)
((lambda (2frst 2scnd)
(cond ((eq (caar l) '%tanh)
(psetq 2frst 2scnd 2scnd 2frst)))
(cons ((lambda (cosh cos)
(root (div (add cosh (neg cos))
(add cosh cos))
2))
(take '(%cosh) 2frst)
(take '(%cos) 2scnd))
(take '(%atan)
(cond ((eq (caar l) '%tan)
(div (take '(%sinh) 2frst)
(take '(%sin) 2scnd)))
(t (div (take '(%sin) 2frst)
(take '(%sinh) 2scnd)))))))
(mul (cdr sp) 2)
(mul (car sp) 2)))
(risplit (cadr l))))
((specrepp l) (absarg (specdisrep l)))
(((lambda (foot)
(and foot (not (=0 (cdr (risplit (cadr l))))) (absarg foot)))
(coversinemyfoot l)))
(t (let ((ris (trisplit l)))
(xcons
;;; Arguments must be in this order so that the side-effect of the Atan2,
;;; that is, determining the Asksign of the argument, can happen before
;;; Take Mabs does its Sign. Blame JPG for noticing this lossage.
(if absflag 0 (genatan (cdr ris) (car ris)))
(cond ((equal (car ris) 0) (absarg-mabs (cdr ris)))
((equal (cdr ris) 0) (absarg-mabs (car ris)))
(t (powers ($expand (add (powers (car ris) 2)
(powers (cdr ris) 2))
1 0)
(half)))))))))
(defun genatan (num den)
(let ((arg (take '($atan2) num den)))
(if (or generate-atan2 (free arg '$atan2))
arg
(take '(%atan) (m// num den)))))
(defun absarg-mabs (l)
(if (eq (csign l) t)
(if (memq (caar l) '(mabs %cabs)) l (list '(%cabs simp) l))
(take '(mabs) l)))

312
src/maxdoc/dcl.autold Executable file
View File

@@ -0,0 +1,312 @@
;;; -*- Mode: Lisp; Package: Macsyma-II; -*-
;;; Macsyma Autoload Declarations
;;; Created by KMP at 11/17/80 3:16:46
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RATLAP FASL) 'AUTOLOAD)))
'(CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) ROMBRG FASL) 'AUTOLOAD)))
'($ROMBERG_SUBR $ROMBERG))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) NUMAPL FASL) 'AUTOLOAD)))
'(FMAPPLY MACSYMACALLP SUBRCALL$P SUBRCALLP))
(DEFPROP $FASMAK ((DSK MACSYM) FASMAK FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X 'NIL 'AUTOLOAD)))
'($PLOTRESET $PLOTINIT $KILLPLOTS $LOADPLOTS $SAVEPLOTS $NAMEPLOT
$OLDNAMEPLOT $REPLOT4 $REPLOT $LABEL $GRAPH3D $GRAPH2 $PARAMPLOT2
$CONTOURPLOT2 $PLOT3D $PLOT2))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X 'NIL 'AUTOLOAD)))
'($RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES $PRINTFILE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) OUTEX FASL) 'AUTOLOAD)))
'($MAP_OVER_INDEX_FILE $READ_NTH_OBJECT
$NUMBER_OF_OBJECTS_IN_INDEX_FILE OUTEX-HOOK-EXP $OPEN_INDEX_FILE
$MAKE_INDEX_FILE))
(DEFPROP SOLVEQUARTIC NIL AUTOLOAD)
(DEFPROP $SUBLIS ((DSK MACSYM) SUBLIS FASL) AUTOLOAD)
(DEFPROP $GETCHARN ((DSK MACSYM) CHAR FASL) AUTOLOAD)
(DEFPROP SUBSTITUTE NIL AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) BUILDQ FASL) 'AUTOLOAD)))
'(MBUILDQ-SUBST $BUILDQ))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) INMIS FASL) 'AUTOLOAD)))
'($RESET $LISTOFVARS $UNKNOWN))
(DEFPROP $OPTIONS ((DSK MACSYM) OPTION FASL) AUTOLOAD)
(DEFPROP $PRIMER ((DSK MACSYM) PRIMER FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) SCS FASL) 'AUTOLOAD)))
'($FACOUT $DISTRIB $SCSIMP))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) METER FASL) 'AUTOLOAD)))
'($TIME $RESETCLOCK $PRINTCLOCK $UNCLOCK $CLOCK))
(DEFPROP $OPTIMIZE ((DSK MACSYM) OPTIM FASL) AUTOLOAD)
(DEFPROP $ZEROEQUIV ((DSK MACSYM) ZERO FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) POIS2 FASL) 'AUTOLOAD)))
'($POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS
$OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP
$POISSUBST))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) POIS3 FASL) 'AUTOLOAD)))
'($POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS
$OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP
$POISSUBST))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) TLIMIT FASL) 'AUTOLOAD)))
'($TLDEFINT $TLIMIT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) LINNEW FASL) 'AUTOLOAD)))
'($TMINVERSE $TMLIN $TMLINSOLVE $TMNEWDET))
(DEFPROP $EZGCD ((DSK MACSYM) EZGCD FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) NUMTH FASL) 'AUTOLOAD)))
'($GCFACTOR $JACOBI $TOTIENT $PRIME $DIVSUM))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X 'NIL 'AUTOLOAD)))
'($SUBLIST $MAKELIST))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MAXOUT) PLOT FASL) 'AUTOLOAD)))
'($GRAPH $PLOT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) NEWDET FASL) 'AUTOLOAD)))
'($PERMANENT $NEWDET))
(DEFPROP $PADE ((DSK MACSYM) PADE FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) NISIMP FASL) 'AUTOLOAD)))
'($LETSIMP $LETRULES $REMLET $LET))
(DEFPROP $ALLROOTS ((DSK MACSYM) CPOLY FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) SUMCON FASL) 'AUTOLOAD)))
'($NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) FORTRA FASL) 'AUTOLOAD)))
'($FORTMX $FORTRAN))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) NALGFA FASL) 'AUTOLOAD)))
'($ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE $DISCR $BDISCR $ALGFAC))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) GRIND FASL) 'AUTOLOAD)))
'(MSTRING $GRIND))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) MTREE FASL) 'AUTOLOAD)))
'($APPLY_NOUNS MTREE-SUBST))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) MATCOM FASL) 'AUTOLOAD)))
'($DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE))
(DEFPROP DIMENSION-SUPERSCRIPT NIL AUTOLOAD)
(DEFPROP $LOGCONTRACT ((DSK MAXOUT) LOGCON FASL) AUTOLOAD)
(DEFPROP $TRIGREDUCE ((DSK MACSYM) TRGRED FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RPART FASL) 'AUTOLOAD)))
'(TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART $REALPART))
(DEFPROP $NTERMS ((DSK MAXOUT) NTERMS FASL) AUTOLOAD)
(DEFPROP $COMBINE NIL AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) LOGARC FASL) 'AUTOLOAD)))
'(LOGARC $LOGARC))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) MATRUN FASL) 'AUTOLOAD)))
'(PART* PART+ $REMRULE $APPLYB2 $APPLY2 $APPLYB1 $APPLY1 $DISPRULE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) SERIES FASL) 'AUTOLOAD)))
'($ABSCONVERGE $CONVERGE $POWERSERIES))
(DEFPROP $APROPOS ((DSK MACSYM) APROPO FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X 'NIL 'AUTOLOAD)))
'(GET-OUT GET-FLIST))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) DSKFN FASL) 'AUTOLOAD)))
'($RESTORE $REMFILE $FASSAVE $STORE $SAVE $UNSTORE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) CSIMP FASL) 'AUTOLOAD)))
'($LHS $RHS $PARTITION $DEMOIVRE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X 'NIL 'AUTOLOAD)))
'($SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET $ELEMENTS
$EMPTYP $UNIVERSE $MAKE_UNIVERSE $SETDIFF $SYMDIFF $INTERSECTION
$UNION $ORDINAL ${))
(DEFPROP $RESIDUE ((DSK MACSYM) RESIDU FASL) AUTOLOAD)
(DEFPROP $ALGSYS ((DSK MACSYM) ALGSYS FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) MATRIX FASL) 'AUTOLOAD)))
'($TRANSPOSE $SETELMX $ROW $MINOR $COL $TRIANGULARIZE $RANK $ECHELON
$INVERTMX $DIAGMATRIX $IDENT $EMATRIX $DETERMINANT $CHARPOLY $MATRIXP
$AUGCOEFMATRIX $COEFMATRIX $SUBMATRIX))
(DEFPROP *MERROR ((DSK MACSYM) MERROR FASL) AUTOLOAD)
(DEFPROP $MOD NIL AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) NFORMA FASL) 'AUTOLOAD)))
'(NFORMAT-ALL NFORMAT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) GRAM FASL) 'AUTOLOAD)))
'(DEFINE-SYMBOL RBP LBP ASSOL CPUT A-ATOM))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) COMPAR FASL) 'AUTOLOAD)))
'(RGRP $FEATUREP LIKE $SIGN $ASKSIGN $COMPARE FORGET MLEARN LEARN
ASSUME MEVALP IS $KILLCONTEXT $NEWCONTEXT $MIN $MAX $FACTS
$DEACTIVATE $ACTIVATE $CONTEXT MOR MAND MNOT $FORGET $ASSUME $IS
$SUPCONTEXT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) TRIGI FASL) 'AUTOLOAD)))
'(ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH SINH
ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP MZEROP
EXPONENTIALIZE $EXPONENTIALIZE ARCP TRIGP SQ-SUMSQ SQRTX^2-1
SQRT1+X^2 SQRT1-X^2))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) DB FASL) 'AUTOLOAD)))
'(FETCH KILL UNTRUE FACT TRUE* KINDP FACTP TRUEP CONTEXT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) MLISP FASL) 'AUTOLOAD)))
'($BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH $ACSC
$ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH $COSH $SINH
$CSC $SEC $COT $TAN $COS $SIN $LOG $SQRT DSKRAT MFILEP AUTOLDCHK
BIGFLOATM* ADD2LNC RAT $EXP MRETURN OPTIONP $FUNMAKE MAPPLY1 MOPP1
MOPP ARRSTORE MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE
REMARRELEM REMPROPCHK REMOVE1 $PUT $REM $GET FUNCER $MAPATOM MMAPEV
NUMERSET MSETCHK MSETERR $SUBVARP MQUOTEP MSETQP MEVALATOMS MSET
MUNBIND MBIND MARGS MOP MEVAL2 MEVAL1 MEVAL MAPPLY $ALLBUT $MATRIX
OUTERMAP1 FMAPL1 DSKSETQ $SUBVAR MGO MPROG MDOIN MDO MCOND $DISPFUN
$APPLY MDEFINE $DEFINE $ARRAY MDEFPROP $REMVALUE $REMARRAY
$REMFUNCTION $REMOVE $DECLARE $QPUT $OUTERMAP $FULLMAPL $MATRIXMAP
$FULLMAP $MAPLIST $MAP MQUOTE $EV MSETQ $LOCAL))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) COMM FASL) 'AUTOLOAD)))
'($LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP $ATOM
$LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK $MEMBER $ENDCONS
$CONS $LISTP LISTERCHK GETOPR GETOP $DISPTERMS MEMALIKE $TRUNC
REMSIMP DELSIMP NTHELEM UNION* SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF
$DEL RECUR-APPLY SUBST0 SUBSTITUTE $COEFF $DELETE $REST $APPEND
$INPART $PART $DISPFORM $DISP $LDISP $DIFF $DEPENDS $SUBSTITUTE
$SUBSTINPART $SUBSTPART $DISPLAY $LDISPLAY $GRADEF $DEPENDENCIES))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) OPERS FASL) 'AUTOLOAD)))
'(SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2 DIV* DIV
MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) UTILS FASL) 'AUTOLOAD)))
'(LOG2 ASSQR FIRSTN NXTTOLAST RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC
ANDMAPC MAP2C))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) ASUM FASL) 'AUTOLOAD)))
'($GENFACT $SUM $DEFTAYLOR))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) ERMSGM FASL) 'AUTOLOAD)))
'(CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) MFORMT FASL) 'AUTOLOAD)))
'(DISPLAF *MFORMAT))
(DEFPROP $DESCRIBE ((DSK MACSYM) DESCRI FASL) AUTOLOAD)
(DEFPROP $BFLOAT ((DSK MACSYM) FLOAT FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) ASKP FASL) 'AUTOLOAD)))
'(ASK-INTEGER $ASKINTEGER))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RESULT FASL) 'AUTOLOAD)))
'($BEZOUT $DISCRIMINANT $RESULTANT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) POLYRZ FASL) 'AUTOLOAD)))
'($NROOTS $REALROOTS))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) LAPLAC FASL) 'AUTOLOAD)))
'($ILT $LAPLACE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) SYNEX FASL) 'AUTOLOAD)))
'($NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) MMACRO FASL) 'AUTOLOAD)))
'(SIMPMDEFMACRO (MMACROEXPANDED MACRO) MMACRO-APPLY $MACROEXPAND1
$MACROEXPAND MDEFMACRO))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) TRANSS FASL) 'AUTOLOAD)))
'($TRANSLATE $TRANSLATE_FILE $COMPFILE))
(DEFPROP $POLYDECOMP NIL AUTOLOAD)
(DEFPROP $RISCH ((DSK MACSYM) RISCH FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) DISPLA FASL) 'AUTOLOAD)))
'(CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT
DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX
DIMENSION-PREFIX MAKESTRING DIMENSION-ATOM DISPLA))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) SUPRV FASL) 'AUTOLOAD)))
'($DSKGC $PAGEPAUSE $FILEDEFAULTS $DDT $LOGOUT $QUIT $TO_LISP $THROW
$UUO $%TH $POISLIM $FPPREC DOLLARIFY-NAME $VERBIFY $NOUNIFY PRINL
ERLIST1 ERREXP NONVARCHK NONSYMCHK FEXPRCHK ASCII-NUMBERP ALPHABETP
ERRBREAK $DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 FILEPRINT
CARFILE MTRUENAME TRUEFNAME LOADFILE $SET_FILEDEFAULTS FILENAMEL
MFBOUNDP DOLLARIFY FIND0 LOAD-FUNCTION FIND-FUNCTION $BOTHCASES
$BREAK $ERROR $RANDOM $READONLY $READ $PRINT $ALLOC $SSTATUS $STATUS
$DELFILE $CLOSEFILE $APPENDFILE $WRITEFILE $TIME $CATCH $ERRCATCH
$LABELS $STRINGOUT $STRING $ALIAS $PLAYBACK $TOBREAK $KILL $DEMO
$BATCH $BATCON $SETUP_AUTOLOAD $LOADFILE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) NRAT4 FASL) 'AUTOLOAD)))
'($RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST $FREEOF $RATCOEF))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X 'NIL 'AUTOLOAD)))
'($CLEARSCREEN $PAUSE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) LIMIT FASL) 'AUTOLOAD)))
'($LDEFINT $LIMIT))
(DEFPROP $TRIGEXPAND NIL AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RAT3B FASL) 'AUTOLOAD)))
'(RATQUOTIENT RATREDUCE RATPLUS RATEXPT RATTIMES RATMINUS RATFACT
RATDIF RATABS RATDERIVATIVE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RAT3C FASL) 'AUTOLOAD)))
'(PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RAT3D FASL) 'AUTOLOAD)))
'(PABS $NTHROOT $INRT $ISQRT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RAT3A FASL) 'AUTOLOAD)))
'(PTIMES PQUOTIENT PMOD PMINUSP PMINUS PDERIVATIVE PDIFFERENCE PPLUS))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) RAT3E FASL) 'AUTOLOAD)))
'($RATDISREP RATIONALIZE RATF $RATEXPAND $GFACTOR $SQFR $TOTALDISREP
$SHOWRATVARS $PRINTVARLIST $RATDENOM $RATNUMER POINTERGP $CONTENT
$GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR $FACTOR $RATSIMP $RAT
$FULLRATSIMP $RATVARS $TELLRAT))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) SIMP FASL) 'AUTOLOAD)))
'(SIMPARGS1 BPROG SIMPNRT ALIKE ALIKE1 SIMPMQAPPLY $ORDERGREATP
$ORDERLESSP SIMPMATRIX SIMPEXPT EXPTRL SIMPSIGNUM SIMPDERIV INFSIMP
SIMPMDEF SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT
SIMPTIMES SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS TIMESK ADDK
SIMPARGS SSIMPLIFYA EQTEST SIMPLIFYA FREEARGS FREE CONSTFUN
$NONSCALARP $SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS
SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK WNA-ERR TWOARGCHK
ONEARGCHK TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP $RATP
$RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP $NUMBERP SIMPCHECK
SRATSIMP RATDISREP MQAPPLYP MNEGP MLOGP MNCEXPTP MNCTIMESP MEXPTP
MTIMESP MPLUSP RATNUMP EVEN MNUMP $BFLOATP MINUS1P1 ZEROP1 ONEP1 ONEP
$INTEGRATE $EXPAND $MULTTHRU))
(DEFPROP $PFET NIL AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) TRMODE FASL) 'AUTOLOAD)))
'(CHEKVALUE $MODEDECLARE $MODE_IDENTITY $DEFINE_VARIABLE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) HAYAT FASL) 'AUTOLOAD)))
'($TAYLORINFO $TAYLOR))
(DEFPROP DSKRAT NIL AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X 'NIL 'AUTOLOAD)))
'($GETCHAR $CONCAT))
(DEFPROP $XTHRU NIL AUTOLOAD)
(DEFPROP $MOD NIL AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) SOLVE FASL) 'AUTOLOAD)))
'($LINSOLVE $SOLVE))
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) ACALL FASL) 'AUTOLOAD)))
'(MAPPLY-TR INSURE-ARRAY-PROPS $ARRAYSETAPPLY $ARRAYAPPLY
DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL))
(DEFPROP $TR_WARNINGS_GET ((DSK MACSYM) FCALL FASL) AUTOLOAD)
(MAPC (FUNCTION (LAMBDA (X)
(PUTPROP X '((DSK MACSYM) TRANSL FASL) 'AUTOLOAD)))
'(TRANSLATE-MACEXPR-TOPLEVEL TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION))

887
src/maxdoc/dcl.fctns Normal file
View File

@@ -0,0 +1,887 @@
;; -*- Mode: Lisp; Package: Macsyma -*-
;; Declaration file for external functions known throughout Macsyma.
;; This file was generated by DEFINE version NIL.
;; Declarations for RAT;RATLAP >, inserted manually 11/10/80 by CWH.
(DECLARE (COMMENT RATLAP))
(DECLARE (*EXPR CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR))
;; Declarations for MAXSRC;FASMAK 2, compiled 6/19/80 2:08 by GJC.
(DECLARE (COMMENT FASMAK))
(DECLARE (*FEXPR $FASMAK))
;; Declarations for RAB;PSOLVE 19, compiled 7/25/80 0:42 by CWH.
(DECLARE (COMMENT PSOLVE))
(DECLARE (*EXPR SOLVEQUARTIC))
;; Declarations for MAXSRC;CHAR 2, compiled 8/11/80 15:55 by GJC.
(DECLARE (COMMENT CHAR))
(DECLARE (*EXPR $GETCHARN))
;; Declarations for JPG;PLOT 63, compiled 9/3/80 2:04 by JPG.
(DECLARE (COMMENT PLOT))
(DECLARE (*FEXPR $GRAPH $PLOT))
;; Declarations for MAXSRC;MTREE 1, compiled 9/11/80 20:14 by GJC.
(DECLARE (COMMENT MTREE))
(DECLARE (*EXPR $APPLY_NOUNS MTREE-SUBST))
;; Declarations for JPG;DISP1 1, compiled 9/14/80 12:42 by JPG.
(DECLARE (COMMENT DISP1))
(DECLARE (*EXPR DIMENSION-SUPERSCRIPT))
;; Declarations for JPG;AC 1, compiled 10/14/80 5:58 by JPG.
(DECLARE (COMMENT AC))
(DECLARE (*EXPR $COMBINE))
;; Declarations for MAXSRC;MESRUN 9, compiled 10/23/80 3:47 by GJC.
(DECLARE (COMMENT MESRUN))
(DECLARE (*EXPR GET-OUT GET-FLIST))
;; Declarations for MAXSRC;SETS 10, compiled 10/28/80 23:37 by GJC.
(DECLARE (COMMENT SETS))
(DECLARE (*EXPR $SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET
$ELEMENTS $EMPTYP $UNIVERSE $MAKE_UNIVERSE))
(DECLARE (*LEXPR $SETDIFF $SYMDIFF $INTERSECTION $UNION $ORDINAL ${))
;; Declarations for RZ;COMBIN 139, compiled 11/8/80 3:11 by JPG.
(DECLARE (COMMENT COMBIN))
(DECLARE (*EXPR $POLYDECOMP))
;; Declarations for RAB;OUTMIS 289, compiled 11/10/80 6:19 by JPG.
(DECLARE (COMMENT OUTMIS))
(DECLARE (*EXPR $CLEARSCREEN))
(DECLARE (*LEXPR $PAUSE))
;; Declarations for MRG;TRIGO 326, compiled 11/10/80 15:48 by JPG.
(DECLARE (COMMENT TRIGO))
(DECLARE (*EXPR $TRIGEXPAND))
;; Declarations for PAULW;CSIMP2 46, compiled 11/14/80 4:53 by JPG.
(DECLARE (COMMENT CSIMP2))
(DECLARE (*EXPR $XTHRU))
;; Declarations for MAXSRC;FCALL 36, compiled 11/15/80 19:08 by KMP.
(DECLARE (COMMENT FCALL))
(DECLARE (*EXPR $TR_WARNINGS_GET))
;; Declarations for RAT;RATOUT 62, compiled 11/18/80 17:09 by BMT.
(DECLARE (COMMENT RATOUT))
(DECLARE (*EXPR $PFET))
;; Declarations for DAS;MSTUFF 18, compiled 11/20/80 4:26 by JPG0.
(DECLARE (COMMENT MSTUFF))
(DECLARE (*EXPR $SUBLIST))
(DECLARE (*FEXPR $MAKELIST))
;; Declarations for SHARE;FILEOP 18, compiled 11/26/80 3:00 by JPG.
(DECLARE (COMMENT FILEOP))
(DECLARE (*FEXPR $RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES
$PRINTFILE))
;; Declarations for RAT;RESULT 20, compiled 12/9/80 21:41 by BMT.
(DECLARE (COMMENT RESULT))
(DECLARE (*EXPR $BEZOUT $DISCRIMINANT $RESULTANT))
;; Declarations for ELLEN;OPTION 87, compiled 12/11/80 6:40 by JPG.
(DECLARE (COMMENT OPTION))
(DECLARE (*FEXPR $OPTIONS))
;; Declarations for MAXSRC;NUMAPL 9, compiled 1/12/81 19:20 by GJC.
(DECLARE (COMMENT NUMAPL))
(DECLARE (*EXPR MACSYMACALLP SUBRCALL$P SUBRCALLP))
(DECLARE (*LEXPR FMAPPLY))
;; Declarations for JPG;F293 9, compiled 1/13/81 4:32 by JPG.
(DECLARE (COMMENT F293))
(DECLARE (*EXPR DEFINE-SYMBOL))
;; Declarations for MAXSRC;OUTEX1 30 (OUTEX split), compiled 1/30/81 23:12 by GJC.
(DECLARE (COMMENT OUTEX1))
(DECLARE (*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE))
;; Declarations for MAXSRC;OUTEX2 30 (OUTEX split), compiled 1/30/81 23:13 by GJC.
(DECLARE (COMMENT OUTEX2))
(DECLARE (*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT
$NUMBER_OF_OBJECTS_IN_INDEX_FILE $OPEN_INDEX_FILE))
;; Declarations for MAXSRC;OUTEX 36, compiled 2/6/81 0:16 by GJC.
(DECLARE (COMMENT OUTEX))
(DECLARE (*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE))
;; Declarations for MAXSRC;OUTEY 36 (OUTEX split), compiled 2/6/81 0:17 by GJC.
(DECLARE (COMMENT OUTEY))
(DECLARE (*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $INDEX_FILE_DIM
$OPEN_INDEX_FILE))
;; Declarations for JPG;F294 20, compiled 2/8/81 8:02 by JPG.
(DECLARE (COMMENT F294))
(DECLARE (*EXPR MMINUSP*))
;; Declarations for JPG;GRAPH2 65 (PLOT split), compiled 2/12/81 6:49 by JPG.
(DECLARE (COMMENT GRAPH2))
(DECLARE (*FEXPR $MULTIGRAPH $PARAMPLOT))
;; Declarations for JPG;GRAPH 65 (PLOT split), compiled 2/12/81 6:49 by JPG.
(DECLARE (COMMENT GRAPH))
(DECLARE (*FEXPR $GRAPH $PLOT))
;; Declarations for MAXSRC;MTAGS 9, compiled 2/17/81 19:33 by GJC.
(DECLARE (COMMENT MTAGS))
(DECLARE (*EXPR $TAG_FILE_INSERT))
;; Declarations for ELLEN;PRIMER 223, compiled 3/2/81 6:15 by JPG.
(DECLARE (COMMENT PRIMER))
(DECLARE (*FEXPR $PRIMER))
;; Declarations for MAXSRC;SUSPEN 13, compiled 3/15/81 23:01 by GJC.
(DECLARE (COMMENT SUSPEN))
(DECLARE (*LEXPR $SUSPEND))
;; Declarations for RZ;PRODCT 144 (COMBIN split), compiled 4/9/81 7:50 by JPG.
(DECLARE (COMMENT PRODCT))
(DECLARE (*FEXPR $PRODUCT))
;; Declarations for JPG;F296 41, compiled 4/29/81 7:02 by JPG.
(DECLARE (COMMENT F296))
(DECLARE (*EXPR *MERROR-1))
;; Declarations for MAXSRC;DESCRI 51, compiled 4/30/81 6:42 by JPG.
(DECLARE (COMMENT DESCRI))
(DECLARE (*EXPR MDESCRIBE))
(DECLARE (*FEXPR $DESCRIBE))
;; Declarations for MAXSRC;TRMODE 63, compiled 5/5/81 6:24 by JPG.
(DECLARE (COMMENT TRMODE))
(DECLARE (*EXPR FLUIDIZE ASS-EQ-SET ASSIGN-MODE-CHECK))
(DECLARE (*LEXPR CHEKVALUE ASS-EQ-REF))
;; Declarations for MEM;RES 30, compiled 6/9/81 16:48 by MEM.
(DECLARE (COMMENT RES))
(DECLARE (*EXPR $ISIMPTEST $RSIMPTEST $ITEFFA $RTEFFA $TEFFS $IRES $RRES $NUPP
$NUP $NU))
;; Declarations for TRANSL;TRDEBG 8, compiled 6/19/81 5:15 by JPG.
(DECLARE (COMMENT TRDEBG))
(DECLARE (*EXPR $DEBUG))
(DECLARE (*LEXPR $LISPDEBUGMODE $DEBUGPRINTMODE))
;; Declarations for RAT;MATCOM 94, compiled 6/21/81 10:46 by JPG.
(DECLARE (COMMENT MATCOM))
(DECLARE (*FEXPR $DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE))
;; Declarations for JPG;F297 16, compiled 6/22/81 7:18 by JPG.
(DECLARE (COMMENT F297))
(DECLARE (*EXPR NEVERSET))
;; Declarations for TRANSL;TRANSL 1145, compiled 6/26/81 18:44 by GJC.
(DECLARE (COMMENT TRANSL))
(DECLARE (*EXPR TRANSLATE-MACEXPR-TOPLEVEL
TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION))
;; Declarations for MAXSRC;EXAMPL 56 (DESCRI split), compiled 7/1/81 1:54 by ELLEN.
(DECLARE (COMMENT EXAMPL))
(DECLARE (*FEXPR $HELP))
;; Declarations for JPG;MAPF 47 (COMM2 split), compiled 7/2/81 3:18 by JPG.
(DECLARE (COMMENT MAPF))
(DECLARE (*FEXPR $SCANMAP))
;; Declarations for MAXSRC;SYNEX 9, compiled 7/3/81 9:03 by JPG.
(DECLARE (COMMENT SYNEX))
(DECLARE (*LEXPR $NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX))
;; Declarations for MAXSRC;PROPFN 305 (OUTMIS split), compiled 7/6/81 5:21 by JPG.
(DECLARE (COMMENT PROPFN))
(DECLARE (*FEXPR $PRINTPROPS $PROPVARS $PROPERTIES))
;; Declarations for ZZ;APROPO 28, compiled 7/9/81 5:19 by JPG.
(DECLARE (COMMENT APROPO))
(DECLARE (*FEXPR $APROPOS))
;; Declarations for MAXSRC;NDIFFQ 5, compiled 7/14/81 23:23 by GJC.
(DECLARE (COMMENT NDIFFQ))
(DECLARE (*EXPR $MAP_FLOAT_ARRAY $INIT_FLOAT_ARRAY))
;; Declarations for TRANSL;TRPROP 1, compiled 7/15/81 1:48 by GJC.
(DECLARE (COMMENT TRPROP))
(DECLARE (*EXPR META-FSET META-MPUTPROP META-PUTPROP META-ADD2LNC))
;; Declarations for MAXSRC;DOVER 1, compiled 8/7/81 23:36 by GJC.
(DECLARE (COMMENT DOVER))
(DECLARE (*LEXPR $DOVER_FILE $DOVARD_FILE))
;; Declarations for MAXSRC;ERMSGM 11, compiled 8/18/81 6:27 by JPG.
(DECLARE (COMMENT ERMSGM))
(DECLARE (*EXPR CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX))
;; Declarations for MAXDEV;ATST 33, compiled 8/22/81 10:04 by JPG.
(DECLARE (COMMENT ATST))
(DECLARE (*EXPR $SPECINT))
;; Declarations for JPG;F298 13, compiled 9/9/81 4:14 by JPG.
(DECLARE (COMMENT F298))
(DECLARE (*EXPR $ERRORMSG RATCOEFF))
;; Declarations for TRANSL;MCOMPI 145, compiled 9/21/81 10:49 by GJC.
(DECLARE (COMMENT MCOMPI))
(DECLARE (*LEXPR $COMPILE_LISP_FILE))
;; Declarations for JPG;NF299 33, compiled 12/31/81 16:17 by JPG.
(DECLARE (COMMENT NF299))
(DECLARE (*EXPR DECL-COMPLEXP))
;; Declarations for JPG;F299 33, compiled 12/31/81 16:26 by JPG.
(DECLARE (COMMENT F299))
(DECLARE (*EXPR DECL-COMPLEXP))
;; Declarations for TRANSL;TRANSS 79, compiled 1/22/82 6:51 by JPG.
(DECLARE (COMMENT TRANSS))
(DECLARE (*LEXPR $TRANSLATE_FILE))
;; Declarations for MAXSRC;NUMER 17, compiled 2/12/82 16:13 by JPG.
(DECLARE (COMMENT NUMER))
(DECLARE (*EXPR MAKE-TRAMP$))
(DECLARE (*LEXPR GET-ARRAY))
;; Declarations for MAXSRC;DESCR 68 (DESCRI split), compiled 3/19/82 7:07 by JPG.
(DECLARE (COMMENT DESCR))
(DECLARE (*EXPR MDESCRIBE))
;; Declarations for TRANSL;ACALL 66, compiled 4/3/82 14:52 by GJC.
(DECLARE (COMMENT ACALL))
(DECLARE (*EXPR MAKE-ALAMBDA APPLICATION-OPERATOR MAYBE-BOOLE-CHECK
IS-BOOLE-CHECK ASSIGN-CHECK MAPPLY-TR INSURE-ARRAY-PROPS
$ARRAYSETAPPLY $ARRAYAPPLY INTERVAL-ERROR))
(DECLARE (*LEXPR MAPLIST_TR DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL))
;; Declarations for JPG;BOPTIM 5, compiled 4/27/82 4:46 by JPG.
(DECLARE (COMMENT BOPTIM))
(DECLARE (*EXPR $OPTIMIZE))
;; Declarations for JPG;AOPTIM 14, compiled 5/5/82 6:47 by JPG.
(DECLARE (COMMENT AOPTIM))
(DECLARE (*EXPR $COLLAPSE $OPTIMIZE))
;; Declarations for JPG;ADSKFN 9, compiled 5/10/82 4:53 by JPG0.
(DECLARE (COMMENT ADSKFN))
(DECLARE (*EXPR I-$STORE I-$UNSTORE))
;; Declarations for JPG;F302 12, compiled 10/23/82 0:58 by JPG.
(DECLARE (COMMENT F302))
(DECLARE (*LEXPR $KILLCONTEXT))
;; Declarations for MAXSRC;MTRACE 42, compiled 10/28/82 7:02 by JPG.
(DECLARE (COMMENT MTRACE))
(DECLARE (*EXPR $UNTRACE_IT $TRACE_IT))
;; Declarations for JM;RISCH 436, compiled 11/16/82 6:35 by JPG.
(DECLARE (COMMENT RISCH))
(DECLARE (*EXPR $RISCH))
;; Declarations for RAT;LESFAC 148, compiled 12/15/82 3:41 by JPG0.
(DECLARE (COMMENT LESFAC))
(DECLARE (*EXPR LOWDEG))
;; Declarations for MAXSRC;AR 15, compiled 1/13/83 2:01 by JPG.
(DECLARE (COMMENT AR))
(DECLARE (*EXPR ARRSTORE-EXTEND MEVAL1-EXTEND $ARRAY_DIMENSION_N
$ARRAY_NUMBER_OF_DIMENSIONS DIMENSION-ARRAY-OBJECT))
(DECLARE (*LEXPR $MAKE_ARRAY))
;; Declarations for JPG;F303 2, compiled 1/31/83 1:27 by JPG.
(DECLARE (COMMENT F303))
(DECLARE (*EXPR $BOTHCOEF))
;; Declarations for RAT;POIS2 74, compiled 2/4/83 4:15 by JPG.
(DECLARE (COMMENT POIS2))
(DECLARE (*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS
$OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP))
(DECLARE (*LEXPR $POISSUBST))
;; Declarations for RAT;POIS3 66, compiled 2/4/83 4:18 by JPG.
(DECLARE (COMMENT POIS3))
(DECLARE (*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS
$OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP))
(DECLARE (*LEXPR $POISSUBST))
;; Declarations for TENSOR;ITENSR 119, compiled 2/25/83 5:38 by JPG.
(DECLARE (COMMENT ITENSR))
(DECLARE (*EXPR $CHANGENAME $INDICES2 $COMPONENTS $INDEXED $REMCOMPS $FLUSHND
$INDICES $LC $SHOW $KDELTA $UNDIFF $CONTRACT $CURVATURE $CHR2
$CHR1 $METRIC $DUMMY))
(DECLARE (*LEXPR $REMCOORD $COORD $ENTERTENSOR $RENAME $FLUSHD $FLUSH $LORENTZ
$COVDIFF $DEFCON))
;; Declarations for ELL;HYPGEO 10, compiled 4/2/83 5:27 by JPG.
(DECLARE (COMMENT HYPGEO))
(DECLARE (*EXPR $SPECINT))
;; Declarations for MRG;DISPLA 777, compiled 5/25/83 3:46 by JPG0.
(DECLARE (COMMENT DISPLA))
(DECLARE (*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO
DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX
DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING
DIMENSION-STRING DIMENSION-ATOM DISPLA))
;; Declarations for MRG;GRAM 488, compiled 5/25/83 3:51 by JPG0.
(DECLARE (COMMENT GRAM))
(DECLARE (*EXPR DEFINE-SYMBOL RBP LBP))
;; Declarations for RAT;EZGCD 262, compiled 6/14/83 4:54 by JPG.
(DECLARE (COMMENT EZGCD))
(DECLARE (*LEXPR $EZGCD))
;; Declarations for ELL;HYP 98, compiled 6/28/83 9:30 by JPG.
(DECLARE (COMMENT HYP))
(DECLARE (*EXPR HGFSIMP-EXEC $HGFRED))
;; Declarations for CFFK;TEKPLT 171, compiled 7/15/83 15:00 by CFFK.
(DECLARE (COMMENT TEKPLT))
(DECLARE (*EXPR $GMARK $GVPRINT $GHPRINT $GTERPRI $EXITGRAPH $ENTERGRAPH
$CLEAR $DRAWSYMBOL3 $LINE3 $VECTOR3 $POINT3 $SETPOINT3 $SIZE
$SCREENSIZE1 $SCREENSIZE $DEFINESYMBOL $DRAWSYMBOL $LINE
$VECTOR $POPDASH $PUSHDASH $CHANGEDASH $DEFINEDASH $POINT
$SETPOINT))
;; Declarations for RZ;SUM 166 (COMBIN split), compiled 12/17/83 10:43 by JPG.
(DECLARE (COMMENT SUM))
(DECLARE (*EXPR SIMPSUM2))
;; Declarations for CFFK;APLOT2 300, compiled 2/25/84 12:24 by JPG.
(DECLARE (COMMENT APLOT2))
(DECLARE (*EXPR $PLOTRESET $PLOTINIT))
;; Declarations for LPH;FORTRN 70, compiled 4/12/84 18:08 by JPG.
(DECLARE (COMMENT FORTRN))
(DECLARE (*LEXPR $FORTMX))
;; Declarations for JPG;F304 41, compiled 7/23/85 14:28 by JPG.
(DECLARE (COMMENT F304))
(DECLARE (*EXPR SUBSTITUTE))
;; Declarations for MRG;NFORMA 15, compiled 1/28/18 8:47 by EJS.
(DECLARE (COMMENT NFORMA))
(DECLARE (*EXPR NFORMAT-ALL NFORMAT))
;; Declarations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS.
(DECLARE (COMMENT COMPAR))
(DECLARE (*EXPR DECLAREKIND RGRP $FEATUREP SIGN MNQP MGQP MGRP MEQP LIKE $SIGN
CSIGN ASKSIGN-P-OR-N $ASKSIGN MAXIMIN MINIMUM MAXIMUM $COMPARE
RESTORE-FACTS FORGET LEARN ASSUME PRED-REVERSE PRE-ERR MEVALP2
MEVALP IS $KILLCONTEXT $NEWCONTEXT))
(DECLARE (*LEXPR $MIN $MAX $FACTS $DEACTIVATE $ACTIVATE $CONTEXT))
;; Declarations for MRG;TRIGI 343, compiled 1/28/18 8:53 by EJS.
(DECLARE (COMMENT TRIGI))
(DECLARE (*EXPR ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH
SINH ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP*
MMINUSP EXPONENTIALIZE $EXPONENTIALIZE RREMAINDER RTIMES
RDIFFERENCE RPLUS SIMP-%ATAN SIMP-%SEC SIMP-%CSC SIMP-%COT
SIMP-%TAN SIMP-%COS SIMP-%SIN ARCP TRIGP SQ-SUMSQ SQRTX^2-1
SQRT1+X^2 SQRT1-X^2))
;; Declarations for MRG;DB 1145, compiled 1/28/18 9:50 by EJS.
(DECLARE (COMMENT DB))
(DECLARE (*EXPR KILLC CONTEXTMARK KCNTXT CNTXT KILLFRAME REMOV UNKIND))
(DECLARE (*LEXPR CONTEXT DEACTIVATE ACTIVATE))
;; Declarations for MRG;GRIND 150, compiled 1/28/18 9:50 by EJS.
(DECLARE (COMMENT GRIND))
(DECLARE (*EXPR MSTRING))
;; Declarations for JPG;MLISP 613, compiled 1/28/18 9:52 by EJS.
(DECLARE (COMMENT MLISP))
(DECLARE (*EXPR $BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH
$ACSC $ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH
$COSH $SINH $CSC $SEC $COT $TAN $COS $SIN $LOG |''MAKE-FUN|
DSKRAT MFILEP BIGFLOATM* ADD2LNC $SQRT $EXP RAT MRETURN
OPTIONP MCONS-OP-ARGS $FUNMAKE MOPP1 MOPP MSPECFUNP ARRSTORE
MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE REMARRELEM
I-$REMVALUE REMPROPCHK REMOVE1 I-$REMOVE $PUT $REM $GET FUNCER
$MAPATOM MMAPEV NEVERSET NUMERSET MSETCHK MSETERR $SUBVARP
MQUOTEP MSETQP MEVALATOMS MSET MUNBIND MBIND MARGS MOP MEVAL2
MEVAL1 MEVAL MEVALN MAPPLY))
(DECLARE (*LEXPR $ALLBUT $MATRIX OUTERMAP1 FMAPL1 MCALL))
(DECLARE (*FEXPR DSKSETQ MDEFPROP))
;; Declarations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS.
(DECLARE (COMMENT SUPRV))
(DECLARE (*EXPR MACHERRFUN IOLFUN TTYRETFUN TTYINTFUN TTYINTFUNSETUP $DSKGC
I-$ALLOC $PAGEPAUSE MORE-FUN MTERPRI MFILE-OUT FILEPRINT
FILESTRIP $DDT $LOGOUT $QUIT $TO_LISP COMPUTIME TIMEORG $THROW
$UUO GETLABCHARN GETLABELS* GETLABELS $%TH $POISLIM $FPPREC
CASIFY-EXPLODEN STRMEVAL MAKSTRING DOLLARIFY-NAME AMPERCHK
$VERBIFY $NOUNIFY FULLSTRIP1 FULLSTRIP STRIPDOLLAR REMALIAS
ALIAS RETRIEVE PRINL NONVARCHK NONSYMCHK FEXPRCHECK ERRBREAK
$DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 CARFILE
MTRUENAME TRUEFNAME LOADFILE FILENAMEL MFBOUNDP DOLLARIFY
LOAD-FILE FIND0 LOAD-FUNCTION FIND-FUNCTION REPRINT RUBOUT*
FORMFEED $BOTHCASES TYI* ADDLABEL MEXPLODEN PRINTLABEL
MAKELABEL MEVAL*))
(DECLARE (*LEXPR $FILEDEFAULTS $BREAK $RANDOM $READONLY $READ $PRINT))
;; Declarations for JPG;COMM 395, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT COMM))
(DECLARE (*EXPR $LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP
$ATOM $LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK
$MEMBER $ENDCONS $CONS $LISTP LISTERCHK GETOPR GETOP MPART
PART1 $DISPTERMS ELABEL $TRUNC REMSIMP DELSIMP NTHELEM UNION*
SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF $DEL I-$DEPENDENCIES
RECUR-APPLY SUBST0 SUBSTITUTE))
(DECLARE (*LEXPR $COEFF $DELETE $REST $APPEND $INPART $PART $DISPFORM $DISP
$LDISP $DIFF $DEPENDS $SUBSTITUTE))
;; Declarations for JPG;DSKFN 169, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT DSKFN))
(DECLARE (*EXPR I-$STORE I-$UNSTORE))
;; Declarations for PAULW;CSIMP 299, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT CSIMP))
(DECLARE (*EXPR $LHS $RHS $PARTITION $DEMOIVRE))
;; Declarations for PAULW;MAT 286, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT MAT))
(DECLARE (*EXPR DISPLINE MAKE-PARAM))
;; Declarations for PAULW;MATRIX 320, compiled 1/28/18 11:39 by EJS.
(DECLARE (COMMENT MATRIX))
(DECLARE (*EXPR $TRANSPOSE $SETELMX $ROW $MINOR))
(DECLARE (*LEXPR $SUBMATRIX))
;; Declarations for RAT;FACTOR 472, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT FACTOR))
(DECLARE (*EXPR TESTDIVIDE CFACTORW))
;; Declarations for RAT;RAT3A 258, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3A))
(DECLARE (*EXPR PTIMES PQUOTIENT PMOD PMINUS PMINUSP PDERIVATIVE PDIFFERENCE
PPLUS POINTERGP))
;; Declarations for RAT;RAT3B 95, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3B))
(DECLARE (*EXPR RATQUOTIENT RATPLUS RATEXPT RATTIMES RATREDUCE RATMINUS
RATFACT RATDIF RATDERIVATIVE))
;; Declarations for RAT;RAT3C 302, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3C))
(DECLARE (*EXPR PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK))
;; Declarations for RAT;RAT3D 264, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3D))
(DECLARE (*EXPR PABS $NTHROOT $INRT $ISQRT))
;; Declarations for RAT;RAT3E 546, compiled 1/28/18 11:50 by EJS.
(DECLARE (COMMENT RAT3E))
(DECLARE (*EXPR $RATDISREP $RATEXPAND RATIONALIZE RATF RATREP* RATREP RATSETUP
$GFACTOR $SQFR $TOTALDISREP $SHOWRATVARS $PRINTVARLIST
$RATDENOM $RATNUMER))
(DECLARE (*LEXPR $CONTENT $GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR
$FACTOR $RATSIMP $RAT $FULLRATSIMP $RATVARS $TELLRAT
$UNTELLRAT))
;; Declarations for RAT;NRAT4 265, compiled 1/28/18 11:50 by EJS.
(DECLARE (COMMENT NRAT4))
(DECLARE (*EXPR $RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST RATCOEFF))
(DECLARE (*LEXPR $FREEOF $RATCOEF))
;; Declarations for MAXSRC;OPERS 75, compiled 1/28/18 11:51 by EJS.
(DECLARE (COMMENT OPERS))
(DECLARE (*EXPR SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2
DIV* DIV MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2))
;; Declarations for MAXSRC;UTILS 26, compiled 1/28/18 11:51 by EJS.
(DECLARE (COMMENT UTILS))
(DECLARE (*EXPR ASCII-NUMBERP ALPHABETP CPUT A-ATOM DOT2L FSET LOG2 ASSQR
FIRSTN RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC ANDMAPC MAP2C))
(DECLARE (*LEXPR CONCAT *MAKE-LIST))
;; Declarations for MAXSRC;MUTILS 11, compiled 1/28/18 11:51 by EJS.
(DECLARE (COMMENT MUTILS))
(DECLARE (*EXPR MEMALIKE ASSOLIKE ASSOL))
;; Declarations for JM;SIMP 834, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT SIMP))
(DECLARE (*EXPR NTHKDR *KAR SIMPARGS1 KDR KAR MATCHERR BPROG RATDENOMINATOR
RATNUMERATOR SIMPNRT EXPAND1 ALIKE ALIKE1 GREAT DECL-REALP
DECL-COMPLEXP SIMPMQAPPLY $ORDERGREATP $ORDERLESSP SIMPMATRIX
SIMPEXPT EXPTRL SIMPSIGNUM SIGNUM1 SIMPDERIV INFSIMP SIMPMDEF
SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT SIMPTIMES
SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS FPCOFRAT TIMESK ADDK
SIMPARGS SSIMPLIFYA RESIMPLIFY EQTEST SIMPLIFYA FREEARGS FREEL
FREE ISINOP CONSTFUN MXORLISTP MEQUALP MBAGP $NONSCALARP
$SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS
SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK IMPROPER-ARG-ERR
WNA-ERR TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP
SPECREPCHECK $RATP $RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP
$NUMBERP MRATCHECK SIMPCHECK SRATSIMP RATDISREP MQAPPLYP MNEGP
MMMINUSP MLOGP MNCEXPTP MNCTIMESP MEXPTP MTIMESP MPLUSP
RATNUMP EVEN MNUMP $BFLOATP ZEROP1 ONEP1 ONEP))
(DECLARE (*LEXPR $INTEGRATE $EXPAND $MULTTHRU))
;; Declarations for MAXSRC;INMIS 98, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT INMIS))
(DECLARE (*EXPR $RESET $LISTOFVARS $UNKNOWN))
;; Declarations for RZ;ASUM 271, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT ASUM))
(DECLARE (*EXPR TOTAL-NARY RASSOCIATIVE LASSOCIATIVE NARY1 ANTISYM
COMMUTATIVE1 ODDFUN EVENFUN DO%SUM DOSUM SIMPSUM SIMPGFACT
SIMPFACT))
(DECLARE (*LEXPR $GENFACT))
;; Declarations for MAXSRC;MERROR 47, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT MERROR))
(DECLARE (*EXPR *ERRRJF-1 *MERROR-5 *MERROR-4 *MERROR-3 *MERROR-2 *MERROR-1
FSTRINGC READ-ONLY-ASSIGN $ERRORMSG))
(DECLARE (*LEXPR ERRRJF MERROR $ERROR))
;; Declarations for MAXSRC;MFORMT 27, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT MFORMT))
(DECLARE (*EXPR MTELL5 MTELL4 MTELL3 MTELL2 MTELL1 *MFORMAT-5 *MFORMAT-4
*MFORMAT-3 *MFORMAT-2 DISPLAF))
(DECLARE (*LEXPR MTELL MFORMAT))
;; Declarations for MRG;FORTRA 64, compiled 1/28/18 11:53 by EJS.
(DECLARE (COMMENT FORTRA))
(DECLARE (*LEXPR $FORTMX))
;; Declarations for MRG;SCS 60, compiled 1/28/18 11:56 by EJS.
(DECLARE (COMMENT SCS))
(DECLARE (*EXPR $FACOUT $DISTRIB))
(DECLARE (*LEXPR $SCSIMP))
;; Declarations for MRG;OPTIM 14, compiled 1/28/18 11:56 by EJS.
(DECLARE (COMMENT OPTIM))
(DECLARE (*EXPR $COLLAPSE $OPTIMIZE))
;; Declarations for JM;SININT 140, compiled 1/28/18 11:56 by EJS.
(DECLARE (COMMENT SININT))
(DECLARE (*EXPR RATINT))
;; Declarations for JM;ZERO 23, compiled 1/28/18 11:57 by EJS.
(DECLARE (COMMENT ZERO))
(DECLARE (*EXPR $ZEROEQUIV))
;; Declarations for RAT;MATRUN 80, compiled 1/28/18 11:57 by EJS.
(DECLARE (COMMENT MATRUN))
(DECLARE (*EXPR APPLY2HACK APPLY2 APPLY1HACK APPLY1 PART* PART+ FINDBASE
FINDEXPON FINDFUN FINDBE $REMRULE))
;; Declarations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS.
(DECLARE (COMMENT FLOAT))
(DECLARE (*EXPR FPENTIER *FPATAN ATANBIGFLOAT RATBIGFLOAT ADDBIGFLOAT $BFLOAT
FP2FLO))
;; Declarations for RAT;SOLVE 401, compiled 1/28/18 12:09 by EJS.
(DECLARE (COMMENT SOLVE))
(DECLARE (*EXPR $LINSOLVE))
(DECLARE (*LEXPR $SOLVE))
;; Declarations for JIM;TLIMIT 47, compiled 1/28/18 21:24 by EJS.
(DECLARE (COMMENT TLIMIT))
(DECLARE (*EXPR $TLDEFINT))
(DECLARE (*LEXPR $TLIMIT))
;; Declarations for JIM;LIMIT 273, compiled 1/28/18 21:24 by EJS.
(DECLARE (COMMENT LIMIT))
(DECLARE (*EXPR $LDEFINT))
(DECLARE (*LEXPR $LIMIT))
;; Declarations for JIM;ASKP 85, compiled 1/28/18 21:24 by EJS.
(DECLARE (COMMENT ASKP))
(DECLARE (*EXPR ASK-INTEGER))
(DECLARE (*LEXPR $ASKINTEGER))
;; Declarations for PAULW;RESIDU 105, compiled 1/28/18 21:25 by EJS.
(DECLARE (COMMENT RESIDU))
(DECLARE (*EXPR $RESIDUE))
;; Declarations for PAULW;LINNEW 27, compiled 1/28/18 21:28 by EJS.
(DECLARE (COMMENT LINNEW))
(DECLARE (*EXPR $TMINVERSE $TMLIN))
(DECLARE (*LEXPR $TMLINSOLVE $TMNEWDET))
;; Declarations for MACRAK;RPART 263, compiled 1/28/18 21:34 by EJS.
(DECLARE (COMMENT RPART))
(DECLARE (*EXPR TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART
$REALPART))
;; Declarations for MACRAK;LOGARC 27, compiled 1/28/18 21:35 by EJS.
(DECLARE (COMMENT LOGARC))
(DECLARE (*EXPR LOGARC $LOGARC))
;; Declarations for RZ;SERIES 133, compiled 1/28/18 21:35 by EJS.
(DECLARE (COMMENT SERIES))
(DECLARE (*EXPR $POWERSERIES))
;; Declarations for RZ;NUMTH 47, compiled 1/28/18 21:35 by EJS.
(DECLARE (COMMENT NUMTH))
(DECLARE (*EXPR $GCFACTOR $JACOBI $TOTIENT $PRIME))
(DECLARE (*LEXPR $DIVSUM))
;; Declarations for RAT;HAYAT 386, compiled 1/28/18 21:37 by EJS.
(DECLARE (COMMENT HAYAT))
(DECLARE (*EXPR $TAYLORINFO))
(DECLARE (*LEXPR $TAYLOR))
;; Declarations for RZ;TRGRED 88, compiled 1/28/18 21:37 by EJS.
(DECLARE (COMMENT TRGRED))
(DECLARE (*LEXPR $TRIGREDUCE))
;; Declarations for RAT;NEWDET 12, compiled 1/28/18 21:37 by EJS.
(DECLARE (COMMENT NEWDET))
(DECLARE (*LEXPR $PERMANENT $NEWDET))
;; Declarations for RAT;POLYRZ 93, compiled 1/28/18 21:37 by EJS.
(DECLARE (COMMENT POLYRZ))
(DECLARE (*LEXPR $NROOTS $REALROOTS))
;; Declarations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT ALGSYS))
(DECLARE (*EXPR MYCABS $ALGSYS))
;; Declarations for RAT;NALGFA 67, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT NALGFA))
(DECLARE (*EXPR $ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE))
(DECLARE (*LEXPR $BDISCR $ALGFAC))
;; Declarations for MAXSRC;LAPLAC 202, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT LAPLAC))
(DECLARE (*EXPR $ILT $LAPLACE))
;; Declarations for CFFK;CPOLY 64, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT CPOLY))
(DECLARE (*EXPR $ALLROOTS))
;; Declarations for RAT;PADE 42, compiled 1/28/18 21:42 by EJS.
(DECLARE (COMMENT PADE))
(DECLARE (*EXPR $PADE))
;; Declarations for MAXSRC;SUMCON 18, compiled 1/28/18 21:42 by EJS.
(DECLARE (COMMENT SUMCON))
(DECLARE (*EXPR $NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT))
;; Declarations for MAXSRC;SUBLIS 11, compiled 1/28/18 21:46 by EJS.
(DECLARE (COMMENT SUBLIS))
(DECLARE (*EXPR $SUBLIS))
;; Declarations for REH;MMACRO 50, compiled 1/28/18 21:47 by EJS.
(DECLARE (COMMENT MMACRO))
(DECLARE (*EXPR SIMPMDEFMACRO MMACRO-APPLY))
;; Declarations for REH;BUILDQ 9, compiled 1/28/18 21:47 by EJS.
(DECLARE (COMMENT BUILDQ))
(DECLARE (*EXPR MBUILDQ-SUBST))
;; Declarations for JPG;DIFF2 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT DIFF2))
(DECLARE (*EXPR STOTALDIFF DIFFNCEXPT DIFFLAPLACE DIFFSUM DIFFINT))
;; Declarations for JPG;AT 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT AT))
(DECLARE (*EXPR $AT $ATVALUE))
;; Declarations for JPG;LOGCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT LOGCON))
(DECLARE (*EXPR $LOGCONTRACT))
;; Declarations for JPG;NTERMS 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT NTERMS))
(DECLARE (*EXPR $NTERMS))
;; Declarations for JPG;ARITHF 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT ARITHF))
(DECLARE (*EXPR $FIBTOPHI))
;; Declarations for JPG;DERIVD 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT DERIVD))
(DECLARE (*EXPR $DERIVDEGREE))
;; Declarations for JPG;BOX 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT BOX))
(DECLARE (*EXPR BOX))
(DECLARE (*LEXPR $REMBOX $BOX $LPART $DPART))
;; Declarations for JPG;GENMAT 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT GENMAT))
(DECLARE (*EXPR $COPYLIST $COPYMATRIX))
(DECLARE (*LEXPR $GENMATRIX))
;; Declarations for JPG;ADDROW 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT ADDROW))
(DECLARE (*LEXPR $ADDCOL $ADDROW))
;; Declarations for JPG;ARRAYF 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT ARRAYF))
(DECLARE (*EXPR $ARRAYMAKE))
;; Declarations for JPG;ALIAS 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT ALIAS))
(DECLARE (*EXPR $UNORDER))
;; Declarations for JPG;CONCAT 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT CONCAT))
(DECLARE (*EXPR $GETCHAR))
(DECLARE (*LEXPR $CONCAT))
;; Declarations for JPG;TTYINI 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT TTYINI))
(DECLARE (*EXPR $TTY_INIT))
;; Declarations for PAULW;PLOG 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT PLOG))
(DECLARE (*EXPR SIMPPLOG))
;; Declarations for PAULW;BINOML 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT BINOML))
(DECLARE (*EXPR BINOCOMP SIMPBINOCOEF))
;; Declarations for PAULW;GAMMA 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT GAMMA))
(DECLARE (*EXPR SIMPGAMMA SIMPBETA))
;; Declarations for PAULW;ERF 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT ERF))
(DECLARE (*EXPR ERF SIMPERF))
;; Declarations for PAULW;EMATRI 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT EMATRIX))
(DECLARE (*EXPR $EMATRIX $ZEROMATRIX))
;; Declarations for PAULW;COEFM 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT COEFM))
(DECLARE (*EXPR $AUGCOEFMATRIX $COEFMATRIX))
;; Declarations for PAULW;ENTERM 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT ENTERM))
(DECLARE (*EXPR $ENTERMATRIX))
;; Declarations for PAULW;XTHRU 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT XTHRU))
(DECLARE (*EXPR $XTHRU))
;; Declarations for RAT;SCUBIC 19 (PSOLVE split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT SCUBIC))
(DECLARE (*EXPR SOLVECUBIC))
;; Declarations for RAT;SQUART 19 (PSOLVE split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT SQUART))
(DECLARE (*EXPR SOLVEQUARTIC))
;; Declarations for MAXSRC;STATUS 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT STATUS))
(DECLARE (*EXPR $TIMEDATE $WHO))
;; Declarations for MAXSRC;ISOLAT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT ISOLAT))
(DECLARE (*EXPR $REVEAL $PICKAPART $ISOLATE))
;; Declarations for MAXSRC;CHANGV 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT CHANGV))
(DECLARE (*EXPR $CHANGEVAR))
;; Declarations for MAXSRC;FACSUM 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT FACSUM))
(DECLARE (*EXPR $GFACTORSUM $FACTORSUM))
;; Declarations for MAXSRC;COMBF 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT COMBF))
(DECLARE (*EXPR $COMBINE))
;; Declarations for MAXSRC;FACOUT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT FACOUT))
(DECLARE (*LEXPR $FACTOROUT))
;; Declarations for MAXSRC;SCREEN 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT SCREEN))
(DECLARE (*EXPR $CLEARSCREEN))
(DECLARE (*LEXPR $PAUSE))
;; Declarations for RZ;MINFCT 152 (COMBIN split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT MINFCT))
(DECLARE (*EXPR $FACTCOMB $MINFACTORIAL $MAKEGAMMA $MAKEFACT))
;; Declarations for RZ;EULBRN 152 (COMBIN split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT EULBRN))
(DECLARE (*EXPR $BERNPOLY SIMPBERN $BERN SIMPEULER $EULER))
;; Declarations for RZ;ZETA 152 (COMBIN split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT ZETA))
(DECLARE (*EXPR $FIB $ZETA))
;; Declarations for RZ;CFFUN 152 (COMBIN split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT CFFUN))
(DECLARE (*EXPR $CFEXPAND $QUNIT $CFDISREP))
;; Declarations for RZ;TAYRAT 152 (COMBIN split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT TAYRAT))
(DECLARE (*EXPR $TAYTORAT))
;; Declarations for RZ;DECOMP 152 (COMBIN split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT DECOMP))
(DECLARE (*EXPR $POLYDECOMP))
;; Declarations for MRG;HYPER 330 (TRIGO split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT HYPER))
(DECLARE (*EXPR SIMP-%SECH SIMP-%CSCH SIMP-%COTH SIMP-%TANH SIMP-%COSH
SIMP-%SINH))
;; Declarations for MRG;ATRIG 330 (TRIGO split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT ATRIG))
(DECLARE (*EXPR SIMP-%ASEC SIMP-%ACSC SIMP-%ACOT SIMP-%ACOS SIMP-%ASIN))
;; Declarations for MRG;AHYPER 330 (TRIGO split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT AHYPER))
(DECLARE (*EXPR SIMP-%ASECH SIMP-%ACSCH SIMP-%ACOTH SIMP-%ATANH SIMP-%ACOSH
SIMP-%ASINH))
;; Declarations for MRG;TRIGEX 330 (TRIGO split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT TRIGEX))
(DECLARE (*EXPR TRIGEXPAND $TRIGEXPAND))
;; Declarations for RAT;FASTT 64 (RATOUT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT FASTT))
(DECLARE (*EXPR $FASTTIMES))
;; Declarations for RAT;RATWT 64 (RATOUT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT RATWT))
(DECLARE (*LEXPR $RATWEIGHT))
;; Declarations for RAT;HORNER 64 (RATOUT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT HORNER))
(DECLARE (*LEXPR $HORNER))
;; Declarations for RAT;PFRAC 64 (RATOUT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT PFRAC))
(DECLARE (*EXPR $PARTFRAC))
;; Declarations for RAT;RATDIF 64 (RATOUT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT RATDIF))
(DECLARE (*EXPR $RATDIFF))
;; Declarations for RAT;PFET 64 (RATOUT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT PFET))
(DECLARE (*EXPR $PFET))
;; Declarations for RAT;MRESUL 30 (RESULT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT MRESUL))
(DECLARE (*EXPR RESULTANT $RESULTANT $POLY_DISCRIMINANT))
;; Declarations for RAT;BEZOUT 30 (RESULT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT BEZOUT))
(DECLARE (*EXPR $BEZOUT))
;; Declarations for DAS;MSORT 21 (MSTUFF split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT MSORT))
(DECLARE (*LEXPR $SORT))
;; Declarations for DAS;MAKEL 21 (MSTUFF split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT MAKEL))
(DECLARE (*EXPR $SUBLIST))
;; Declarations for MAXSRC;MLOAD 121, compiled 1/30/18 22:44 by EJS.
(DECLARE (COMMENT MLOAD))
(DECLARE (*EXPR MFILENAME-ONLYP $FILE_TYPE $LOAD $BATCHLOAD CALL-BATCH1
OPEN-IN-DSK OPEN-OUT-DSK LOAD-AND-TELL $LISTP_CHECK))
(DECLARE (*LEXPR $FILENAME_MERGE $FILE_SEARCH))

37
src/maxdoc/dcl.fexpr Executable file
View File

@@ -0,0 +1,37 @@
; *FEXPR declarations are fake, actually these are
; all DEFMSPEC's and this information is used only
; by the Macsyma->Lisp translator. -gjc
(*FEXPR
$TRACE_OPTIONS $DEFINE_VARIABLE $FULLMAPL $PRIMER MCOND
$DEMO $LETSIMP $GRADEF $MAKEATOMIC $DEPENDENCIES
$LDISPLAY $APPENDFILE $STORE $COMPFILE $OUTERMAP
$PROPVARS $QPUT $APPLYB2 $MAIL $FASSAVE
$REMARRAY $BATCON $EXAMPLE $GRAPH2 $OPTIONS
$APPLYB1 $LOADFILE $HELP $REPLOT4 $MATRIXMAP
$TIMER $NAMEPLOT $LOADPLOTS $SUBSTPART $ORDERLESS
MDOIN $PRINTFILE $DESCRIBE $COMPILE $DELFILE
$TELLSIMPAFTER $CATCH $DISPRULE $APPLY $ALARMCLOCK
$SSTATUS $BATCH $PRINTPROPS $MACROEXPAND $LET
$CONTOURPLOT2 $DEFTAYLOR $DEFMATCH MOR $DECLARE
$STRING $INTERPOLATE $ALIAS $TOBREAK $EVAL_WHEN
$MACROEXPAND1 $LABELS $UNTRACE $ASSUME $WRITEFILE
MPROG $EV $UNTIMER $REMCON $SUBSTINPART
$TELLSIMP MQUOTE $CF $REMOVE $CLOSEFILE
$APROPOS $PARAMPLOT $ORDERGREAT MNOT $RENAMEFILE
$MAKELIST $APPLY2 $IS $PARAMPLOT2 $NUMERVAL
$HARDCOPY $MATCHDECLARE $MAP $LOCAL $TIME
$NAMEFILE $APPLY1 $SUBVAR $DISPLAY $SEND
$BUILDQ $DEFINE $FILELIST $ARRAYINFO $MODE_IDENTITY
$FILELENGTH $MAPLIST $RESTORE $FUNDEF $ALLOC
$ERRCATCH $SAVEPLOTS MGO $LETRULES $FORTRAN
$LABEL MPROGN $REMFILE $SCANMAP MDO
$TRANSLATE $ARRAY $LISTFILES $ROMBERG $FORGET
$PLAYBACK $BUG $DEFRULE MSPEC-HOOK $TRACE
MAND $REMLET $STRINGOUT $REMFUNCTION $SAVE
$UNSTORE $MODEDECLARE $TIMER_INFO $STATUS $PROPERTIES
MSETQ $PLOT3D $GRAPH $PLOT $QLISTFILES
$SETUP_AUTOLOAD $SUPCONTEXT $KILL $PLOTMODE $GRIND
$GRAPH3D $PLOT2 $SUM MLOCAL $REMVALUE
$PRODUCT $DISPFUN MDEFINE $REPLOT $FULLMAP
$KILLPLOTS $MULTIGRAPH MDEFMACRO)

296
src/maxdoc/dcl.lispm Executable file
View File

@@ -0,0 +1,296 @@
(DEFPROP DCL "12//7//81 0:57:08" VERSION)
(*EXPR CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR)
(*FEXPR $FASMAK)
(*EXPR SOLVEQUARTIC)
(*EXPR $GETCHARN)
(*EXPR $FACOUT $DISTRIB)
(*LEXPR $SCSIMP)
(*FEXPR $GRAPH $PLOT)
(*EXPR $APPLY_NOUNS MTREE-SUBST)
(*EXPR DIMENSION-SUPERSCRIPT)
(*EXPR $COMBINE)
(*EXPR LOGARC $LOGARC)
(*EXPR GET-OUT GET-FLIST)
(*EXPR $SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET $ELEMENTS $EMPTYP $UNIVERSE $MAKE_UNIVERSE)
(*LEXPR $SETDIFF $SYMDIFF $INTERSECTION $UNION $ORDINAL ${)
(*LEXPR $NROOTS $REALROOTS)
(*EXPR $POLYDECOMP)
(*EXPR $CLEARSCREEN)
(*LEXPR $PAUSE)
(*EXPR $TRIGEXPAND)
(*EXPR $XTHRU)
(*EXPR $TR_WARNINGS_GET)
(*EXPR $PFET)
(*EXPR $SUBLIST)
(*FEXPR $MAKELIST)
(*FEXPR $RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES $PRINTFILE)
(*EXPR $TLDEFINT)
(*LEXPR $TLIMIT)
(*EXPR $BEZOUT $DISCRIMINANT $RESULTANT)
(*FEXPR $OPTIONS)
(*EXPR MBUILDQ-SUBST)
(*FEXPR $BUILDQ)
(*EXPR MACSYMACALLP SUBRCALL$P SUBRCALLP)
(*LEXPR FMAPPLY)
(*EXPR DEFINE-SYMBOL)
(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE)
(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $NUMBER_OF_OBJECTS_IN_INDEX_FILE $OPEN_INDEX_FILE)
(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE)
(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $INDEX_FILE_DIM $OPEN_INDEX_FILE)
(*EXPR MMINUSP*)
(*EXPR LOWDEG)
(*EXPR $ZEROEQUIV)
(*EXPR SIMP-%SECH SIMP-%CSCH SIMP-%COTH SIMP-%TANH SIMP-%COSH SIMP-%SINH)
(*EXPR SIMP-%ASEC SIMP-%ACSC SIMP-%ACOT SIMP-%ACOS SIMP-%ASIN)
(*EXPR SIMP-%ASECH SIMP-%ACSCH SIMP-%ACOTH SIMP-%ATANH SIMP-%ACOSH SIMP-%ASINH)
(*EXPR TRIGEXPAND $TRIGEXPAND)
(*FEXPR $MULTIGRAPH $PARAMPLOT)
(*FEXPR $GRAPH $PLOT)
(*EXPR $TAG_FILE_INSERT)
(*FEXPR $PRIMER)
(*EXPR $SUBLIS)
(*LEXPR $SUSPEND)
(*EXPR ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH SINH ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP* MMINUSP EXPONENTIALIZE $EXPONENTIALIZE RREMAINDER RTIMES RDIFFERENCE RPLUS SIMP-%ATAN SIMP-%SEC SIMP-%CSC SIMP-%COT SIMP-%TAN SIMP-%COS SIMP-%SIN ARCP TRIGP SQ-SUMSQ SQRTX^2-1 SQRT1+X^2 SQRT1-X^2)
(*FEXPR $PRODUCT)
(*EXPR $LHS $RHS $PARTITION $DEMOIVRE)
(*EXPR *MERROR-1)
(*EXPR PTIMES PQUOTIENT PMOD PMINUS PMINUSP PDERIVATIVE PDIFFERENCE PPLUS POINTERGP)
(*EXPR MDESCRIBE)
(*FEXPR $DESCRIBE)
(*EXPR $TMINVERSE $TMLIN)
(*LEXPR $TMLINSOLVE $TMNEWDET)
(*LEXPR $PERMANENT $NEWDET)
(*EXPR $ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE)
(*LEXPR $BDISCR $ALGFAC)
(*EXPR FLUIDIZE ASS-EQ-SET ASSIGN-MODE-CHECK)
(*LEXPR CHEKVALUE ASS-EQ-REF)
(*LEXPR $TRANSLATE_FILE)
(*EXPR RATQUOTIENT RATPLUS RATEXPT RATTIMES RATREDUCE RATMINUS RATFACT RATDIF RATDERIVATIVE)
(*EXPR TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART $REALPART)
(*EXPR APPLY2HACK APPLY2 APPLY1HACK APPLY1 PART* PART+ FINDBASE FINDEXPON FINDFUN FINDBE $REMRULE)
(*FEXPR $APPLYB2 $APPLY2 $APPLYB1 $APPLY1 $DISPRULE)
(*EXPR $UNTRACE_IT $TRACE_IT)
(*EXPR $RESET $LISTOFVARS $UNKNOWN)
(*EXPR MAKE-TRAMP$)
(*LEXPR GET-ARRAY)
(*EXPR $ISIMPTEST $RSIMPTEST $ITEFFA $RTEFFA $TEFFS $IRES $RRES $NUPP $NUP $NU)
(*EXPR $DEBUG)
(*LEXPR $LISPDEBUGMODE $DEBUGPRINTMODE)
(*LEXPR $SORT)
(*EXPR $SUBLIST)
(*FEXPR $MAKELIST)
(*FEXPR $DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE)
(*EXPR NEVERSET)
(*EXPR DEFINE-SYMBOL RBP LBP)
(*EXPR TOTAL-NARY RASSOCIATIVE LASSOCIATIVE NARY1 ANTISYM COMMUTATIVE1 ODDFUN EVENFUN DO%SUM DOSUM SIMPSUM SIMPGFACT SIMPFACT)
(*LEXPR $GENFACT)
(*FEXPR $SUM $DEFTAYLOR)
(*EXPR TRANSLATE-MACEXPR-TOPLEVEL TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION)
(*EXPR MTELL5 MTELL4 MTELL3 MTELL2 MTELL1 DISPLAF *MFORMAT-5 *MFORMAT-4 *MFORMAT-3 *MFORMAT-2)
(*LEXPR MTELL MFORMAT)
(*EXPR TESTDIVIDE CFACTORW)
(*LEXPR $TRIGREDUCE)
(*EXPR PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK)
(*EXPR $RATDISREP $RATEXPAND RATIONALIZE RATF RATREP* RATREP $GFACTOR $SQFR $TOTALDISREP $SHOWRATVARS $PRINTVARLIST $RATDENOM $RATNUMER)
(*LEXPR $CONTENT $GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR $FACTOR $RATSIMP $RAT $FULLRATSIMP $RATVARS $TELLRAT $UNTELLRAT)
(*EXPR MEMALIKE ASSOLIKE ASSOL)
(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP)
(*LEXPR $POISSUBST)
(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP)
(*LEXPR $POISSUBST)
(*EXPR $ILT $LAPLACE)
(*EXPR $FASTTIMES)
(*LEXPR $RATWEIGHT)
(*LEXPR $HORNER)
(*EXPR $PARTFRAC)
(*EXPR $RATDIFF)
(*EXPR $PFET)
(*EXPR $RESULTANT $DISCRIMINANT)
(*EXPR $BEZOUT)
(*EXPR $PADE)
(*FEXPR $HELP)
(*FEXPR $SCANMAP)
(*LEXPR $NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX)
(*FEXPR $PRINTPROPS $PROPVARS $PROPERTIES)
(*EXPR DISPLINE MAKE-PARAM)
(*EXPR PABS $NTHROOT $INRT $ISQRT)
(*EXPR SIMPPLOG)
(*EXPR BINOCOMP SIMPBINOCOEF)
(*EXPR SIMPGAMMA SIMPBETA)
(*EXPR ERF SIMPERF)
(*EXPR $EMATRIX $ZEROMATRIX)
(*EXPR $AUGCOEFMATRIX $COEFMATRIX)
(*EXPR $ENTERMATRIX)
(*EXPR $XTHRU)
(*FEXPR $APROPOS)
(*EXPR $MAP_FLOAT_ARRAY $INIT_FLOAT_ARRAY)
(*EXPR ASCII-NUMBERP ALPHABETP CPUT A-ATOM DOT2L FSET LOG2 ASSQR FIRSTN RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC ANDMAPC MAP2C)
(*LEXPR CONCAT *MAKE-LIST)
(*EXPR META-FSET META-MPUTPROP META-PUTPROP META-ADD2LNC)
(*EXPR $CHANGENAME $INDICES2 $COMPONENTS $INDEXED $REMCOMPS $FLUSHND $INDICES $LC $SHOW $KDELTA $UNDIFF $CONTRACT $RIEMANN $CHR2 $CHR1 $METRIC $DUMMY)
(*LEXPR $REMCOORD $COORD $ENTERTENSOR $RENAME $FLUSHD $FLUSH $LORENTZ $COVDIFF $DEFCON)
(*FEXPR $REMCON $DISPCON)
(*LEXPR $FORTMX)
(*LEXPR $DOVER_FILE $DOVARD_FILE)
(*EXPR $PLOTRESET $PLOTINIT)
(*EXPR KILLC CONTEXTMARK KCNTXT CNTXT KILLFRAME REMOV UNKIND KILL UNTRUE DOUTERN DINTERN DINTERNP REMF ADDF DATUM PAR KIND FACT TRUE* KINDP ISP FALSEP TRUEP CLEAR VISIBLEP UNMRK MARKP MARK)
(*LEXPR CONTEXT DEACTIVATE ACTIVATE)
(*EXPR CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX)
(*EXPR $SPECINT $LAPINT)
(*EXPR $GCFACTOR $JACOBI $TOTIENT $PRIME)
(*LEXPR $DIVSUM)
(*EXPR SIMPMDEFMACRO MMACRO-APPLY)
(*EXPR HGFSIMP-EXEC $HGFRED)
(*EXPR $SPECINT)
(*EXPR $LDEFINT)
(*LEXPR $LIMIT)
(*EXPR $ERRORMSG RATCOEFF)
(*EXPR STOTALDIFF DIFFNCEXPT DIFFLAPLACE DIFFSUM DIFFINT)
(*EXPR $AT $ATVALUE)
(*EXPR $LOGCONTRACT)
(*EXPR $NTERMS)
(*EXPR $FIBTOPHI)
(*EXPR $DERIVDEGREE)
(*EXPR BOX)
(*LEXPR $REMBOX $BOX $LPART $DPART)
(*EXPR $COPYLIST $COPYMATRIX)
(*LEXPR $GENMATRIX)
(*LEXPR $ADDCOL $ADDROW)
(*EXPR $ARRAYMAKE)
(*EXPR $UNORDER)
(*EXPR $GETCHAR)
(*LEXPR $CONCAT)
(*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING DIMENSION-STRING DIMENSION-ATOM DISPLA)
(*EXPR NFORMAT-ALL NFORMAT)
(*EXPR MSTRING)
(*EXPR $LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP $ATOM $LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK $MEMBER $ENDCONS $CONS $LISTP LISTERCHK GETOPR GETOP MPART PART1 $DISPTERMS ELABEL $TRUNC REMSIMP DELSIMP NTHELEM UNION* SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF $DEL I-$DEPENDENCIES RECUR-APPLY SUBST0 SUBSTITUTE)
(*LEXPR $COEFF $DELETE $REST $APPEND $INPART $PART $DISPFORM $DISP $LDISP $DIFF $DEPENDS $SUBSTITUTE)
(*EXPR $TRANSPOSE $SETELMX $ROW $MINOR $COL $TRIANGULARIZE $RANK ONEN $ECHELON $INVERTMX $DIAGMATRIX $IDENT $DETERMINANT $CHARPOLY $MATRIXP)
(*LEXPR $SUBMATRIX)
(*EXPR $RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST RATCOEFF)
(*LEXPR $FREEOF $RATCOEF)
(*EXPR SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2 DIV* DIV MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2)
(*EXPR NTHKDR *KAR SIMPARGS1 KDR KAR MATCHERR BPROG RATDENOMINATOR RATNUMERATOR SIMPNRT EXPAND1 ALIKE ALIKE1 GREAT SIMPMQAPPLY $ORDERGREATP $ORDERLESSP SIMPMATRIX SIMPEXPT EXPTRL SIMPSIGNUM SIGNUM1 SIMPDERIV INFSIMP SIMPMDEF SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT SIMPTIMES SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS FPCOFRAT TIMESK ADDK SIMPARGS SSIMPLIFYA EQTEST SIMPLIFYA FREEARGS FREEL FREE ISINOP CONSTFUN MXORLISTP MEQUALP MBAGP $NONSCALARP $SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK IMPROPER-ARG-ERR WNA-ERR TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP $RATP $RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP $NUMBERP MRATCHECK SIMPCHECK SRATSIMP RATDISREP MQAPPLYP MNEGP MMMINUSP MLOGP MNCEXPTP MNCTIMESP MEXPTP MTIMESP MPLUSP RATNUMP EVEN MNUMP $BFLOATP ZEROP1 ONEP1 ONEP)
(*LEXPR $INTEGRATE $EXPAND $MULTTHRU)
(*FEXPR RETLIST MATCOEF)
(*EXPR $POWERSERIES)
(*EXPR MYCABS $ALGSYS)
(*EXPR MFILENAME-ONLYP $FILE_TYPE $LOAD $BATCHLOAD CALL-BATCH1 OPEN-IN-DSK OPEN-OUT-DSK LOAD-AND-TELL $LISTP_CHECK)
(*LEXPR $FILENAME_MERGE $FILE_SEARCH)
(*EXPR I-$STORE I-$UNSTORE)
(*EXPR RATINT)
(*EXPR $OPTIMIZE)
(*EXPR ARRSTORE-EXTEND MEVAL1-EXTEND $ARRAY_DIMENSION_N $ARRAY_NUMBER_OF_DIMENSIONS DIMENSION-ARRAY-OBJECT)
(*LEXPR $MAKE_ARRAY)
(*LEXPR $COMPILE_LISP_FILE)
(*EXPR $TIMEDATE $WHO)
(*EXPR $REVEAL $PICKAPART $ISOLATE)
(*EXPR $CHANGEVAR)
(*EXPR $GFACTORSUM $FACTORSUM)
(*EXPR $COMBINE)
(*LEXPR $FACTOROUT)
(*EXPR $CLEARSCREEN)
(*LEXPR $PAUSE)
(*EXPR $FACTCOMB $MINFACTORIAL $MAKEGAMMA $MAKEFACT)
(*EXPR $BERNPOLY SIMPBERN $BERN SIMPEULER $EULER)
(*EXPR $FIB $ZETA)
(*EXPR $CFEXPAND $QUNIT $CFDISREP)
(*EXPR $TAYTORAT)
(*EXPR $POLYDECOMP)
(*EXPR $LINSOLVE)
(*LEXPR $SOLVE)
(*LEXPR $EZGCD)
(*EXPR $NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT)
(*EXPR APPLICATION-OPERATOR IS-BOOLE-CHECK ASSIGN-CHECK MAPPLY-TR INSURE-ARRAY-PROPS $ARRAYSETAPPLY $ARRAYAPPLY INTERVAL-ERROR)
(*LEXPR DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL)
(*EXPR $TAYLORINFO)
(*LEXPR $TAYLOR)
(*EXPR $RISCH)
(*EXPR $SCALARP)
(*EXPR $RESIDUE)
(*EXPR DECLAREKIND RGRP $FEATUREP SIGN MNQP MGQP MGRP MEQP LIKE $SIGN ASKSIGN-P-OR-N $ASKSIGN MAXIMIN MINIMUM MAXIMUM $COMPARE RESTORE-FACTS FORGET LEARN ASSUME PRED-REVERSE PRE-ERR MEVALP2 MEVALP IS $KILLCONTEXT $NEWCONTEXT)
(*LEXPR $MIN $MAX $FACTS $DEACTIVATE $ACTIVATE $CONTEXT)
(*EXPR $GMARK $GVPRINT $GHPRINT $GTERPRI $EXITGRAPH $ENTERGRAPH $CLEAR $DRAWSYMBOL3 $LINE3 $VECTOR3 $POINT3 $SETPOINT3 $SIZE $SCREENSIZE1 $SCREENSIZE $DEFINESYMBOL $DRAWSYMBOL $LINE $VECTOR $POPDASH $PUSHDASH $CHANGEDASH $DEFINEDASH $POINT $SETPOINT)
(*EXPR MACHERRFUN IOLFUN TTYRETFUN TTYINTFUN TTYINTFUNSETUP $DSKGC I-$ALLOC $PAGEPAUSE MORE-FUN MTERPRI MFILE-OUT FILEPRINT FILESTRIP $DDT $LOGOUT $QUIT $TO_LISP COMPUTIME TIMEORG $THROW $UUO GETLABCHARN GETLABELS* GETLABELS $%TH $POISLIM $FPPREC CASIFY-EXPLODEN STRMEVAL MAKSTRING DOLLARIFY-NAME AMPERCHK $VERBIFY $NOUNIFY FULLSTRIP1 FULLSTRIP STRIPDOLLAR REMALIAS ALIAS RETRIEVE PRINL NONVARCHK NONSYMCHK FEXPRCHECK ERRBREAK $DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 CARFILE MTRUENAME TRUEFNAME LOADFILE FILENAMEL MFBOUNDP DOLLARIFY LOAD-FILE FIND0 LOAD-FUNCTION FIND-FUNCTION REPRINT RUBOUT* FORMFEED $BOTHCASES TYI* ADDLABEL MEXPLODEN PRINTLABEL MAKELABEL MEVAL*)
(*LEXPR $FILEDEFAULTS $BREAK $RANDOM $READONLY $READ $PRINT)
(*EXPR MDESCRIBE)
(*EXPR ASK-INTEGER)
(*LEXPR $ASKINTEGER)
(*EXPR *ERRRJF-1 *MERROR-5 *MERROR-4 *MERROR-3 *MERROR-2 *MERROR-1 FSTRINGC READ-ONLY-ASSIGN $ERRORMSG)
(*LEXPR ERRRJF MERROR $ERROR)
(*EXPR FPENTIER *FPATAN ATANBIGFLOAT RATBIGFLOAT ADDBIGFLOAT $BFLOAT FP2FLO)
(*EXPR $ALLROOTS)
(*EXPR $BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH $ACSC $ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH $COSH $SINH $CSC $SEC $COT $TAN $COS $SIN $LOG |''MAKE-FUN| DSKRAT MFILEP BIGFLOATM* ADD2LNC $SQRT $EXP RAT MRETURN OPTIONP MCONS-OP-ARGS $FUNMAKE MOPP1 MOPP ARRSTORE MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE REMARRELEM I-$REMVALUE REMPROPCHK REMOVE1 I-$REMOVE $PUT $REM $GET FUNCER $MAPATOM MMAPEV NEVERSET NUMERSET MSETCHK MSETERR $SUBVARP MQUOTEP MSETQP MEVALATOMS MSET MUNBIND MBIND MARGS MOP MEVAL2 MEVAL1 MEVAL MEVALN MAPPLY)
(*LEXPR $ALLBUT $MATRIX OUTERMAP1 FMAPL1 MCALL)
(*FEXPR DSKSETQ MDEFPROP)
(SPECIAL $USER_MESFILE DUMPING USER-MESFILE MASTER-MESFILE)
(SPECIAL $UNIVERSE $DISPLAYSET)
(SPECIAL $TR_WARN_BAD_FUNCTION_CALLS)
(SPECIAL $RESULTANT)
(SPECIAL $ROMBERGIT_USED $ROMBERGABS $ROMBERGTOL $ROMBERGMIN $ROMBERGIT)
(FIXNUM $ROMBERGIT_USED $ROMBERGMIN $ROMBERGIT)
(FLONUM $ROMBERGABS $ROMBERGTOL)
(SPECIAL $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE)
(FIXNUM $TRACE_MAX_INDENT $TRACE_MAX_INDENT)
(SPECIAL $TR_FLOAT_CAN_BRANCH_COMPLEX)
(SPECIAL $SUBLIS_APPLY_LAMBDA)
(SPECIAL $SUSPEND)
(SPECIAL -SQRT3//2 SQRT3//2 -SQRT2//2 SQRT2//2 %PI//2 %PI//4 -1//2 1//2 $HALFANGLES $LOGARC $EXPONENTIALIZE $TRIGSIGN $TRIGEXPANDTIMES $TRIGEXPANDPLUS $TRIGEXPAND $TRIGINVERSES $%IARGS $%PIARGS)
(SPECIAL $GAMMALIM $SUMSPLITFACT HALF%PI3 %PI2 HALF%PI FOURTH%PI %P%I)
(SPECIAL ERRRJFFLAG HMODULUS MODULUS)
(SPECIAL $POINTBOUND)
(SPECIAL $MODE_CHECK_ERRORP $MODE_CHECK_WARNP $MODE_CHECKP)
(SPECIAL $TR_GEN_TAGS $TR_STATE_VARS $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED $COMPGRIND TRANSL-FILE $TR_WINDY $TR_FILE_TTY_MESSAGESP $TR_OUTPUT_FILE_DEFAULT *TRANSL-FILE-DEBUG*)
(SPECIAL $RATALGDENOM $RATWTLVL)
(SPECIAL GENERATE-ATAN2 IMPLICIT-REAL)
(SPECIAL $MAXAPPLYHEIGHT $MAXAPPLYDEPTH)
(SPECIAL $TIMER_DEVALUE $TIMER $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE_SAFETY $TRACE)
(FIXNUM $TRACE_MAX_INDENT)
(SPECIAL $LISTCONSTVARS)
(SPECIAL TRAMP3$ TRAMP2$ TRAMP1$)
(SPECIAL $PARSEWINDOW)
(FIXNUM $PARSEWINDOW)
(SPECIAL $PRODHACK $SUMHACK $SIMPSUM $ZEROBERN $GENINDEX $GENSUMNUM $CAUCHYSUM)
(SPECIAL $TR_BOUND_FUNCTION_APPLYP $TR_OPTIMIZE_MAX_LOOP *$ANY-MODES* *TR-WARN-BREAK* $TR_PREDICATE_BRAIN_DAMAGE $TR_NUMER $TR_ARRAY_AS_REF $TR_FUNCTION_CALL_DEFAULT *WARNED-MODE-VARS* *WARNED-FEXPRS* *WARNED-UN-DECLARED-VARS* $TR_WARN_UNDEFINED_VARIABLE $TR_WARN_MODE $TR_WARN_FEXPR $TR_WARN_MEVAL $TR_WARN_UNDECLARED TR-UNIQUE TR-ABORT *TRANSL-DEBUG* *TRANSL-BACKTRACE* TRANSLATE-TIME-EVALABLES SPECIALS ASSIGNS NEED-PROG? RETURN-MODE RETURNS INSIDE-MPROG TR-PROGRET FEXPRS EXPRS LEXPRS ARRAYS LOCAL TSTACK $SPECIAL $TRANSCOMPILE $TR_SEMICOMPILE $TRANSBIND)
(SPECIAL $NEWFAC $NALGFAC SMALLPRIMES ALPHA MM* MPLC* MINPOLY* *MX* *MIN* GAUSS)
(SPECIAL *ALPHA BIGPRIMES $GCD *GCDL*)
(SPECIAL $RATDENOMDIVIDE $RATEXPAND $RATEPSILON $RATPRINT FR-FACTOR ADN* INRATSIMP TELLRATLIST $FACEXPAND $RATVARS $ALGEBRAIC $RATFAC $RATWEIGHTS $NOREPEAT $DONTFACTOR $FACTORFLAG $KEEPFLOAT *RATWEIGHTS *FNEWVARSW VARLIST GENPAIRS GENVAR)
(SPECIAL $RESULTANT)
(SPECIAL $LINSOLVE_PARAMS $%RNUM $BACKSUBST $SPARSE $GLOBALSOLVE)
(SPECIAL $HOMOG_HACK $SAVEFACTORS $BERLEFACT $INTFACLIM LOW* ALGFAC* *IRREDS)
(SPECIAL $BETA_ARGS_SUM_TO_INTEGER)
(SPECIAL META-PROP-L META-PROP-P)
(SPECIAL $FORTFLOAT $FORTINDENT $FORTSPACES)
(FIXNUM $FORTINDENT)
(SPECIAL $MAXPRIME)
(SPECIAL $MACROEXPANSION)
(SPECIAL PRESERVE-DIRECTION LIMIT-ANSWERS SIMPLIMPLUS-PROBLEMS RD* INFINITESIMALS REAL-INFINITIES INFINITIES)
(SPECIAL $SUPERLOGCON $LOGCONCOEFFP)
(SPECIAL $ROOTSCONMODE)
(SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR $BOXCHAR DISPLAYP STRINGDISP $FPTRUNC $NOUNDISP $DERIVABBREV $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY)
(SPECIAL $NEGSUMDISPFLAG $SQRTDISPFLAG $EXPTDISPFLAG $%EDISPFLAG $PFEFORMAT $POWERDISP)
(SPECIAL $VECT_CROSS)
(SPECIAL $MATRIX_ELEMENT_TRANSPOSE $MATRIX_ELEMENT_ADD $MATRIX_ELEMENT_MULT $RATMX)
(SPECIAL DERIVSIMP ERRORSW DOSIMP $MAXNEGEX $MAXPOSEX $EXPON $EXPOP $MX0SIMP $DOMXTIMES $DOMXPLUS $DOMXEXPT $DOSCMXPLUS $NUMER_PBRANCH $SUMEXPAND $SIMP $NUMER $NEGDISTRIB $FLOAT)
(FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP)
(SPECIAL ALGNOTEXACT $ALGEXACT REALONLYRATNUM $REALONLY $%RNUM_LIST)
(SPECIAL $FILE_TYPES $FILE_SEARCH *IN-MACSYMA-INDEXER* *IN-TRANSLATE-FILE* *IN-$BATCHLOAD*)
(SPECIAL $LET_RULE_PACKAGES $CURRENT_LET_RULE_PACKAGE $DEFAULT_LET_RULE_PACKAGE $LETRAT $LETVARSIMP)
(SPECIAL $INTEGRATION_CONSTANT_COUNTER)
(SPECIAL $OPTIMPREFIX)
(SPECIAL $TO_CALL_LISP_COMPILER)
(SPECIAL $ISOLATE_WRT_TIMES $EXPTISOLATE)
(SPECIAL $SOLVERADCAN $SOLVETRIGWARN $SOLVENULLWARN $SOLVEFACTORS $SOLVEEXPLICIT $SOLVEDECOMPOSES $SAVEFACTORS $PROGRAMMODE $SOLVE_INCONSISTENT_ERROR $LINSOLVEWARN $MULTIPLICITIES $BREAKUP)
(SPECIAL $TAYLOR_LOGEXPAND $TAYLOR_TRUNCATE_POLYNOMIALS $MAXTAYORDER)
(SPECIAL $ERFFLAG $LIFLAG)
(SPECIAL LIMITP $ASKEXP $SIGNBFLOAT $PREDERROR SIGN-IMAG-ERRP $ACTIVECONTEXTS $CONTEXTS $CONTEXT)
(SPECIAL $SHOWTIME $FILE_STRING_PRINT $CHANGE_FILEDEFAULTS ALIASLIST $MOREWAIT $TTYINTFUN $TTYINTNUM USER-TIMESOFAR CASEP $DIREC $LINENUM $LINECHAR $OUTCHAR $INCHAR $%)
(FIXNUM $LINENUM)
(SPECIAL DEFINTDEBUG)
(SPECIAL $ERROR_SYMS $ERROR_SIZE $ERROR)
(SPECIAL BIGFLOAT%PI BIGFLOAT%E BFMHALF BFHALF BIGFLOATONE BIGFLOATZERO $FPPREC $FPPRINTPREC $BFTRUNC $BFTORAT $FLOAT2BF)
(FIXNUM $FPPRINTPREC)
(SPECIAL $ASSUMESCALAR $DOTIDENT $SCALARMATRIXP $DOMXNCTIMES $DOSCMXOPS $DOMXMXOPS $DOALLMXOPS $DOTASSOC $DOTEXPTSIMP $DOTDISTRIB $DOTSCRULES $DOT1SIMP $DOT0NSCSIMP $DOT0SIMP $DOTCONSTRULES)
(SPECIAL $FLOATOPTIONS $FLOATWIDTH $FLOATPREC $FLOATFRAC $FLOATINT $FLOATFORMAT)
(SPECIAL $SETCHECK MUNBINDP)

303
src/maxdoc/dcl.load Executable file
View File

@@ -0,0 +1,303 @@
(DEFPROP DCL "5//29//82 8:19:42" VERSION)
(*EXPR CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR)
(*FEXPR $FASMAK)
(*EXPR SOLVEQUARTIC)
(*EXPR $GETCHARN)
(*EXPR $FACOUT $DISTRIB)
(*LEXPR $SCSIMP)
(*FEXPR $GRAPH $PLOT)
(*EXPR $APPLY_NOUNS MTREE-SUBST)
(*EXPR DIMENSION-SUPERSCRIPT)
(*EXPR $COMBINE)
(*EXPR GET-OUT GET-FLIST)
(*EXPR $SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET $ELEMENTS $EMPTYP $UNIVERSE $MAKE_UNIVERSE)
(*LEXPR $SETDIFF $SYMDIFF $INTERSECTION $UNION $ORDINAL ${)
(*LEXPR $NROOTS $REALROOTS)
(*EXPR $POLYDECOMP)
(*EXPR $CLEARSCREEN)
(*LEXPR $PAUSE)
(*EXPR $TRIGEXPAND)
(*EXPR $XTHRU)
(*EXPR $TR_WARNINGS_GET)
(*EXPR $PFET)
(*EXPR $SUBLIST)
(*FEXPR $MAKELIST)
(*FEXPR $RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES $PRINTFILE)
(*EXPR $TLDEFINT)
(*LEXPR $TLIMIT)
(*EXPR $BEZOUT $DISCRIMINANT $RESULTANT)
(*FEXPR $OPTIONS)
(*EXPR MBUILDQ-SUBST)
(*FEXPR $BUILDQ)
(*EXPR MACSYMACALLP SUBRCALL$P SUBRCALLP)
(*LEXPR FMAPPLY)
(*EXPR DEFINE-SYMBOL)
(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE)
(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $NUMBER_OF_OBJECTS_IN_INDEX_FILE $OPEN_INDEX_FILE)
(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE)
(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $INDEX_FILE_DIM $OPEN_INDEX_FILE)
(*EXPR MMINUSP*)
(*EXPR LOWDEG)
(*EXPR SIMP-%SECH SIMP-%CSCH SIMP-%COTH SIMP-%TANH SIMP-%COSH SIMP-%SINH)
(*EXPR SIMP-%ASEC SIMP-%ACSC SIMP-%ACOT SIMP-%ACOS SIMP-%ASIN)
(*EXPR SIMP-%ASECH SIMP-%ACSCH SIMP-%ACOTH SIMP-%ATANH SIMP-%ACOSH SIMP-%ASINH)
(*EXPR TRIGEXPAND $TRIGEXPAND)
(*FEXPR $MULTIGRAPH $PARAMPLOT)
(*FEXPR $GRAPH $PLOT)
(*EXPR $TAG_FILE_INSERT)
(*FEXPR $PRIMER)
(*LEXPR $SUSPEND)
(*FEXPR $PRODUCT)
(*EXPR $LHS $RHS $PARTITION $DEMOIVRE)
(*EXPR *MERROR-1)
(*EXPR MDESCRIBE)
(*FEXPR $DESCRIBE)
(*EXPR $TMINVERSE $TMLIN)
(*LEXPR $TMLINSOLVE $TMNEWDET)
(*LEXPR $PERMANENT $NEWDET)
(*EXPR $ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE)
(*LEXPR $BDISCR $ALGFAC)
(*EXPR FLUIDIZE ASS-EQ-SET ASSIGN-MODE-CHECK)
(*LEXPR CHEKVALUE ASS-EQ-REF)
(*EXPR RATQUOTIENT RATPLUS RATEXPT RATTIMES RATREDUCE RATMINUS RATFACT RATDIF RATDERIVATIVE)
(*EXPR $UNTRACE_IT $TRACE_IT)
(*EXPR $ISIMPTEST $RSIMPTEST $ITEFFA $RTEFFA $TEFFS $IRES $RRES $NUPP $NUP $NU)
(*EXPR $DEBUG)
(*LEXPR $LISPDEBUGMODE $DEBUGPRINTMODE)
(*LEXPR $SORT)
(*EXPR $SUBLIST)
(*FEXPR $MAKELIST)
(*FEXPR $DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE)
(*EXPR NEVERSET)
(*EXPR TRANSLATE-MACEXPR-TOPLEVEL TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION)
(*LEXPR $TRIGREDUCE)
(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP)
(*LEXPR $POISSUBST)
(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP)
(*LEXPR $POISSUBST)
(*EXPR $ILT $LAPLACE)
(*EXPR $PADE)
(*FEXPR $HELP)
(*FEXPR $SCANMAP)
(*LEXPR $NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX)
(*FEXPR $PRINTPROPS $PROPVARS $PROPERTIES)
(*EXPR DISPLINE MAKE-PARAM)
(*EXPR SIMPPLOG)
(*EXPR BINOCOMP SIMPBINOCOEF)
(*EXPR SIMPGAMMA SIMPBETA)
(*EXPR ERF SIMPERF)
(*EXPR $EMATRIX $ZEROMATRIX)
(*EXPR $AUGCOEFMATRIX $COEFMATRIX)
(*EXPR $ENTERMATRIX)
(*EXPR $XTHRU)
(*FEXPR $APROPOS)
(*EXPR $MAP_FLOAT_ARRAY $INIT_FLOAT_ARRAY)
(*EXPR ASCII-NUMBERP ALPHABETP CPUT A-ATOM DOT2L FSET LOG2 ASSQR FIRSTN RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC ANDMAPC MAP2C)
(*LEXPR CONCAT *MAKE-LIST)
(*EXPR META-FSET META-MPUTPROP META-PUTPROP META-ADD2LNC)
(*LEXPR $FORTMX)
(*LEXPR $DOVER_FILE $DOVARD_FILE)
(*EXPR CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX)
(*EXPR $SPECINT $LAPINT)
(*EXPR $GCFACTOR $JACOBI $TOTIENT $PRIME)
(*LEXPR $DIVSUM)
(*EXPR SIMPMDEFMACRO MMACRO-APPLY)
(*EXPR HGFSIMP-EXEC $HGFRED)
(*EXPR $SPECINT)
(*EXPR $ERRORMSG RATCOEFF)
(*EXPR $RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST RATCOEFF)
(*LEXPR $FREEOF $RATCOEF)
(*EXPR SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2 DIV* DIV MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2)
(*EXPR $POWERSERIES)
(*EXPR RATINT)
(*EXPR ARRSTORE-EXTEND MEVAL1-EXTEND $ARRAY_DIMENSION_N $ARRAY_NUMBER_OF_DIMENSIONS DIMENSION-ARRAY-OBJECT)
(*LEXPR $MAKE_ARRAY)
(*LEXPR $COMPILE_LISP_FILE)
(*LEXPR $EZGCD)
(*EXPR $NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT)
(*EXPR $TAYLORINFO)
(*LEXPR $TAYLOR)
(*EXPR $RISCH)
(*EXPR $RESIDUE)
(*EXPR ASK-INTEGER)
(*LEXPR $ASKINTEGER)
(*EXPR $ALLROOTS)
(*EXPR LOGARC $LOGARC)
(*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING DIMENSION-STRING DIMENSION-ATOM DISPLA)
(*EXPR $LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP $ATOM $LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK $MEMBER $ENDCONS $CONS $LISTP LISTERCHK GETOPR GETOP MPART PART1 $DISPTERMS ELABEL $TRUNC REMSIMP DELSIMP NTHELEM UNION* SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF $DEL I-$DEPENDENCIES RECUR-APPLY SUBST0 SUBSTITUTE)
(*LEXPR $COEFF $DELETE $REST $APPEND $INPART $PART $DISPFORM $DISP $LDISP $DIFF $DEPENDS $SUBSTITUTE)
(*EXPR DECLAREKIND RGRP $FEATUREP SIGN MNQP MGQP MGRP MEQP LIKE $SIGN CSIGN ASKSIGN-P-OR-N $ASKSIGN MAXIMIN MINIMUM MAXIMUM $COMPARE RESTORE-FACTS FORGET LEARN ASSUME PRED-REVERSE PRE-ERR MEVALP2 MEVALP IS $KILLCONTEXT $NEWCONTEXT)
(*LEXPR $MIN $MAX $FACTS $DEACTIVATE $ACTIVATE $CONTEXT)
(*EXPR NTHKDR *KAR SIMPARGS1 KDR KAR MATCHERR BPROG RATDENOMINATOR RATNUMERATOR SIMPNRT EXPAND1 ALIKE ALIKE1 GREAT DECL-REALP DECL-COMPLEXP SIMPMQAPPLY $ORDERGREATP $ORDERLESSP SIMPMATRIX SIMPEXPT EXPTRL SIMPSIGNUM SIGNUM1 SIMPDERIV INFSIMP SIMPMDEF SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT SIMPTIMES SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS FPCOFRAT TIMESK ADDK SIMPARGS SSIMPLIFYA EQTEST SIMPLIFYA FREEARGS FREEL FREE ISINOP CONSTFUN MXORLISTP MEQUALP MBAGP $NONSCALARP $SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK IMPROPER-ARG-ERR WNA-ERR TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP SPECREPCHECK $RATP $RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP $NUMBERP MRATCHECK SIMPCHECK SRATSIMP RATDISREP MQAPPLYP MNEGP MMMINUSP MLOGP MNCEXPTP MNCTIMESP MEXPTP MTIMESP MPLUSP RATNUMP EVEN MNUMP $BFLOATP ZEROP1 ONEP1 ONEP)
(*LEXPR $INTEGRATE $EXPAND $MULTTHRU)
(*EXPR NFORMAT-ALL NFORMAT)
(*EXPR DEFINE-SYMBOL RBP LBP)
(*EXPR ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH SINH ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP* MMINUSP EXPONENTIALIZE $EXPONENTIALIZE RREMAINDER RTIMES RDIFFERENCE RPLUS SIMP-%ATAN SIMP-%SEC SIMP-%CSC SIMP-%COT SIMP-%TAN SIMP-%COS SIMP-%SIN ARCP TRIGP SQ-SUMSQ SQRTX^2-1 SQRT1+X^2 SQRT1-X^2)
(*EXPR KILLC CONTEXTMARK KCNTXT CNTXT KILLFRAME REMOV UNKIND KILL UNTRUE DOUTERN DINTERN DINTERNP REMF ADDF DATUM PAR KIND FACT TRUE* KINDP ISP FALSEP TRUEP CLEAR VISIBLEP UNMRK MARKP MARK)
(*LEXPR CONTEXT DEACTIVATE ACTIVATE)
(*EXPR MSTRING)
(*EXPR PTIMES PQUOTIENT PMOD PMINUS PMINUSP PDERIVATIVE PDIFFERENCE PPLUS POINTERGP)
(*EXPR PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK)
(*EXPR PABS $NTHROOT $INRT $ISQRT)
(*EXPR MEMALIKE ASSOLIKE ASSOL)
(*EXPR MFILENAME-ONLYP $FILE_TYPE $LOAD $BATCHLOAD CALL-BATCH1 OPEN-IN-DSK OPEN-OUT-DSK LOAD-AND-TELL $LISTP_CHECK)
(*LEXPR $FILENAME_MERGE $FILE_SEARCH)
(*EXPR $RESET $LISTOFVARS $UNKNOWN)
(*EXPR TOTAL-NARY RASSOCIATIVE LASSOCIATIVE NARY1 ANTISYM COMMUTATIVE1 ODDFUN EVENFUN DO%SUM DOSUM SIMPSUM SIMPGFACT SIMPFACT)
(*LEXPR $GENFACT)
(*EXPR *ERRRJF-1 *MERROR-5 *MERROR-4 *MERROR-3 *MERROR-2 *MERROR-1 FSTRINGC READ-ONLY-ASSIGN $ERRORMSG)
(*LEXPR ERRRJF MERROR $ERROR)
(*EXPR MYCABS $ALGSYS)
(*EXPR DECL-COMPLEXP)
(*EXPR DECL-COMPLEXP)
(*EXPR TESTDIVIDE CFACTORW)
(*EXPR FPENTIER *FPATAN ATANBIGFLOAT RATBIGFLOAT ADDBIGFLOAT $BFLOAT FP2FLO)
(*LEXPR $TRANSLATE_FILE)
(*EXPR $ZEROEQUIV)
(*EXPR $SUBLIS)
(*EXPR $PLOTRESET $PLOTINIT)
(*EXPR MAKE-TRAMP$)
(*LEXPR GET-ARRAY)
(*EXPR $TIMEDATE $WHO)
(*EXPR $REVEAL $PICKAPART $ISOLATE)
(*EXPR $CHANGEVAR)
(*EXPR $GFACTORSUM $FACTORSUM)
(*EXPR $COMBINE)
(*LEXPR $FACTOROUT)
(*EXPR $CLEARSCREEN)
(*LEXPR $PAUSE)
(*EXPR $CHANGENAME $INDICES2 $COMPONENTS $INDEXED $REMCOMPS $FLUSHND $INDICES $LC $SHOW $KDELTA $UNDIFF $CONTRACT $CURVATURE $CHR2 $CHR1 $METRIC $DUMMY)
(*LEXPR $REMCOORD $COORD $ENTERTENSOR $RENAME $FLUSHD $FLUSH $LORENTZ $COVDIFF $DEFCON)
(*EXPR $RESULTANT $POLY_DISCRIMINANT)
(*EXPR $BEZOUT)
(*EXPR $LDEFINT)
(*LEXPR $LIMIT)
(*EXPR MDESCRIBE)
(*EXPR $GMARK $GVPRINT $GHPRINT $GTERPRI $EXITGRAPH $ENTERGRAPH $CLEAR $DRAWSYMBOL3 $LINE3 $VECTOR3 $POINT3 $SETPOINT3 $SIZE $SCREENSIZE1 $SCREENSIZE $DEFINESYMBOL $DRAWSYMBOL $LINE $VECTOR $POPDASH $PUSHDASH $CHANGEDASH $DEFINEDASH $POINT $SETPOINT)
(*EXPR MAKE-ALAMBDA APPLICATION-OPERATOR MAYBE-BOOLE-CHECK IS-BOOLE-CHECK ASSIGN-CHECK MAPPLY-TR INSURE-ARRAY-PROPS $ARRAYSETAPPLY $ARRAYAPPLY INTERVAL-ERROR)
(*LEXPR MAPLIST_TR DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL)
(*EXPR $RATDISREP $RATEXPAND RATIONALIZE RATF RATREP* RATREP RATSETUP $GFACTOR $SQFR $TOTALDISREP $SHOWRATVARS $PRINTVARLIST $RATDENOM $RATNUMER)
(*LEXPR $CONTENT $GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR $FACTOR $RATSIMP $RAT $FULLRATSIMP $RATVARS $TELLRAT $UNTELLRAT)
(*EXPR $FASTTIMES)
(*LEXPR $RATWEIGHT)
(*LEXPR $HORNER)
(*EXPR $PARTFRAC)
(*EXPR $RATDIFF)
(*EXPR $PFET)
(*EXPR $LINSOLVE)
(*LEXPR $SOLVE)
(*EXPR MACHERRFUN IOLFUN TTYRETFUN TTYINTFUN TTYINTFUNSETUP $DSKGC I-$ALLOC $PAGEPAUSE MORE-FUN MTERPRI MFILE-OUT FILEPRINT FILESTRIP $DDT $LOGOUT $QUIT $TO_LISP COMPUTIME TIMEORG $THROW $UUO GETLABCHARN GETLABELS* GETLABELS $%TH $POISLIM $FPPREC CASIFY-EXPLODEN STRMEVAL MAKSTRING DOLLARIFY-NAME AMPERCHK $VERBIFY $NOUNIFY FULLSTRIP1 FULLSTRIP STRIPDOLLAR REMALIAS ALIAS RETRIEVE PRINL NONVARCHK NONSYMCHK FEXPRCHECK ERRBREAK $DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 CARFILE MTRUENAME TRUEFNAME LOADFILE FILENAMEL MFBOUNDP DOLLARIFY LOAD-FILE FIND0 LOAD-FUNCTION FIND-FUNCTION REPRINT RUBOUT* FORMFEED $BOTHCASES TYI* ADDLABEL MEXPLODEN PRINTLABEL MAKELABEL MEVAL*)
(*LEXPR $FILEDEFAULTS $BREAK $RANDOM $READONLY $READ $PRINT)
(*EXPR $OPTIMIZE)
(*EXPR TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART $REALPART)
(*EXPR $BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH $ACSC $ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH $COSH $SINH $CSC $SEC $COT $TAN $COS $SIN $LOG |''MAKE-FUN| DSKRAT MFILEP BIGFLOATM* ADD2LNC $SQRT $EXP RAT MRETURN OPTIONP MCONS-OP-ARGS $FUNMAKE MOPP1 MOPP MSPECFUNP ARRSTORE MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE REMARRELEM I-$REMVALUE REMPROPCHK REMOVE1 I-$REMOVE $PUT $REM $GET FUNCER $MAPATOM MMAPEV NEVERSET NUMERSET MSETCHK MSETERR $SUBVARP MQUOTEP MSETQP MEVALATOMS MSET MUNBIND MBIND MARGS MOP MEVAL2 MEVAL1 MEVAL MEVALN MAPPLY)
(*LEXPR $ALLBUT $MATRIX OUTERMAP1 FMAPL1 MCALL)
(*FEXPR DSKSETQ MDEFPROP)
(*EXPR $COLLAPSE $OPTIMIZE)
(*EXPR $FACTCOMB $MINFACTORIAL $MAKEGAMMA $MAKEFACT)
(*EXPR $BERNPOLY SIMPBERN $BERN SIMPEULER $EULER)
(*EXPR $FIB $ZETA)
(*EXPR $CFEXPAND $QUNIT $CFDISREP)
(*EXPR $TAYTORAT)
(*EXPR $POLYDECOMP)
(*EXPR I-$STORE I-$UNSTORE)
(*EXPR APPLY2HACK APPLY2 APPLY1HACK APPLY1 PART* PART+ FINDBASE FINDEXPON FINDFUN FINDBE $REMRULE)
(*EXPR STOTALDIFF DIFFNCEXPT DIFFLAPLACE DIFFSUM DIFFINT)
(*EXPR $AT $ATVALUE)
(*EXPR $LOGCONTRACT)
(*EXPR $NTERMS)
(*EXPR $FIBTOPHI)
(*EXPR $DERIVDEGREE)
(*EXPR BOX)
(*LEXPR $REMBOX $BOX $LPART $DPART)
(*EXPR $COPYLIST $COPYMATRIX)
(*LEXPR $GENMATRIX)
(*LEXPR $ADDCOL $ADDROW)
(*EXPR $ARRAYMAKE)
(*EXPR $UNORDER)
(*EXPR $GETCHAR)
(*LEXPR $CONCAT)
(*EXPR $TTY_INIT)
(*EXPR $TRANSPOSE $SETELMX $ROW $MINOR $COL $TRIANGULARIZE $RANK POWERX BBSORT ONEN $ECHELON $INVERTMX $DIAGMATRIX $IDENT $DETERMINANT $CHARPOLY $MATRIXP)
(*LEXPR $SUBMATRIX)
(*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING DIMENSION-STRING DIMENSION-ATOM DISPLA)
(*EXPR I-$STORE I-$UNSTORE)
(*EXPR MTELL5 MTELL4 MTELL3 MTELL2 MTELL1 *MFORMAT-5 *MFORMAT-4 *MFORMAT-3 *MFORMAT-2 DISPLAF)
(*LEXPR MTELL MFORMAT)
(*EXPR $COLLAPSE $OPTIMIZE)
(SPECIAL $USER_MESFILE DUMPING USER-MESFILE MASTER-MESFILE)
(SPECIAL $UNIVERSE $DISPLAYSET)
(SPECIAL $TR_WARN_BAD_FUNCTION_CALLS)
(SPECIAL $RESULTANT)
(SPECIAL $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE)
(FIXNUM $TRACE_MAX_INDENT $TRACE_MAX_INDENT)
(SPECIAL $TR_FLOAT_CAN_BRANCH_COMPLEX)
(SPECIAL $SUSPEND)
(SPECIAL $GAMMALIM $SUMSPLITFACT HALF%PI3 %PI2 HALF%PI FOURTH%PI %P%I)
(SPECIAL $MODE_CHECK_ERRORP $MODE_CHECK_WARNP $MODE_CHECKP)
(SPECIAL $RATALGDENOM $RATWTLVL)
(SPECIAL $TIMER_DEVALUE $TIMER $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE_SAFETY $TRACE)
(FIXNUM $TRACE_MAX_INDENT)
(SPECIAL $TR_BOUND_FUNCTION_APPLYP $TR_OPTIMIZE_MAX_LOOP *$ANY-MODES* *TR-WARN-BREAK* $TR_PREDICATE_BRAIN_DAMAGE $TR_NUMER $TR_ARRAY_AS_REF $TR_FUNCTION_CALL_DEFAULT *WARNED-MODE-VARS* *WARNED-FEXPRS* *WARNED-UN-DECLARED-VARS* $TR_WARN_UNDEFINED_VARIABLE $TR_WARN_MODE $TR_WARN_FEXPR $TR_WARN_MEVAL $TR_WARN_UNDECLARED TR-UNIQUE TR-ABORT *TRANSL-DEBUG* *TRANSL-BACKTRACE* TRANSLATE-TIME-EVALABLES SPECIALS ASSIGNS NEED-PROG? RETURN-MODE RETURNS INSIDE-MPROG TR-PROGRET FEXPRS EXPRS LEXPRS ARRAYS LOCAL TSTACK $SPECIAL $TRANSCOMPILE $TR_SEMICOMPILE $TRANSBIND)
(SPECIAL $LINSOLVE_PARAMS $%RNUM $BACKSUBST $SPARSE $GLOBALSOLVE)
(SPECIAL $BETA_ARGS_SUM_TO_INTEGER)
(SPECIAL META-PROP-L META-PROP-P)
(SPECIAL $FORTFLOAT $FORTINDENT $FORTSPACES)
(FIXNUM $FORTINDENT)
(SPECIAL $MAXPRIME)
(SPECIAL $MACROEXPANSION)
(SPECIAL $TO_CALL_LISP_COMPILER)
(SPECIAL $TAYLOR_LOGEXPAND $TAYLOR_TRUNCATE_POLYNOMIALS $MAXTAYORDER)
(SPECIAL $ERFFLAG $LIFLAG)
(SPECIAL DEFINTDEBUG)
(SPECIAL $FLOATOPTIONS $FLOATWIDTH $FLOATPREC $FLOATFRAC $FLOATINT $FLOATFORMAT)
(SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR $BOXCHAR DISPLAYP STRINGDISP $FPTRUNC $NOUNDISP $DERIVABBREV $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY)
(SPECIAL $VECT_CROSS)
(SPECIAL LIMITP $ASKEXP $SIGNBFLOAT $PREDERROR SIGN-IMAG-ERRP $ACTIVECONTEXTS $CONTEXTS $CONTEXT)
(SPECIAL DERIVSIMP ERRORSW DOSIMP $MAXNEGEX $MAXPOSEX $EXPON $EXPOP $MX0SIMP $DOMXTIMES $DOMXPLUS $DOMXEXPT $DOSCMXPLUS $NUMER_PBRANCH $SUMEXPAND $SIMP $NUMER $NEGDISTRIB $FLOAT)
(FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP)
(SPECIAL $NEGSUMDISPFLAG $SQRTDISPFLAG $EXPTDISPFLAG $%EDISPFLAG $PFEFORMAT $POWERDISP)
(SPECIAL $PARSEWINDOW)
(FIXNUM $PARSEWINDOW)
(SPECIAL -SQRT3//2 SQRT3//2 -SQRT2//2 SQRT2//2 %PI//2 %PI//4 -1//2 1//2 $HALFANGLES $LOGARC $EXPONENTIALIZE $TRIGSIGN $TRIGEXPANDTIMES $TRIGEXPANDPLUS $TRIGEXPAND $TRIGINVERSES $%IARGS $%PIARGS)
(SPECIAL ERRRJFFLAG HMODULUS MODULUS)
(SPECIAL *ALPHA BIGPRIMES $GCD *GCDL*)
(SPECIAL $HOMOG_HACK $SAVEFACTORS $BERLEFACT $INTFACLIM LOW* ALGFAC* *IRREDS)
(SPECIAL $FILE_TYPES $FILE_SEARCH *IN-MACSYMA-INDEXER* *IN-TRANSLATE-FILE* *IN-$BATCHLOAD*)
(SPECIAL $LISTCONSTVARS)
(SPECIAL $PRODHACK $SUMHACK $SIMPSUM $ZEROBERN $GENINDEX $GENSUMNUM $CAUCHYSUM)
(SPECIAL $POINTBOUND)
(SPECIAL $ERROR_SYMS $ERROR_SIZE $ERRORMSG $ERROR)
(SPECIAL ALGNOTEXACT $ALGEXACT REALONLYRATNUM $REALONLY $%RNUM_LIST)
(SPECIAL $NEWFAC $NALGFAC SMALLPRIMES ALPHA MM* MPLC* MINPOLY* *MX* *MIN* GAUSS)
(SPECIAL BIGFLOAT%PI BIGFLOAT%E BFMHALF BFHALF BIGFLOATONE BIGFLOATZERO $FPPREC $FPPRINTPREC $BFTRUNC $BFTORAT $FLOAT2BF)
(FIXNUM $FPPRINTPREC)
(SPECIAL $TR_GEN_TAGS $TR_STATE_VARS $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED $COMPGRIND TRANSL-FILE $TR_WINDY $TR_FILE_TTY_MESSAGESP $TR_OUTPUT_FILE_DEFAULT *TRANSL-FILE-DEBUG*)
(SPECIAL $SUBLIS_APPLY_LAMBDA)
(SPECIAL $ROMBERGIT_USED $ROMBERGABS $ROMBERGTOL $ROMBERGMIN $ROMBERGIT)
(FIXNUM $ROMBERGIT_USED $ROMBERGMIN $ROMBERGIT)
(FLONUM $ROMBERGABS $ROMBERGTOL)
(SPECIAL $QUANC8_RELERR $QUANC8_ABSERR $QUANC8_ERREST $QUANC8_FLAG)
(SPECIAL TRAMP3$ TRAMP2$ TRAMP1$)
(SPECIAL $ISOLATE_WRT_TIMES $EXPTISOLATE)
(SPECIAL $LET_RULE_PACKAGES $CURRENT_LET_RULE_PACKAGE $DEFAULT_LET_RULE_PACKAGE $LETRAT $LETVARSIMP)
(SPECIAL $RESULTANT)
(SPECIAL PRESERVE-DIRECTION LIMIT-ANSWERS SIMPLIMPLUS-PROBLEMS RD* INFINITESIMALS REAL-INFINITIES INFINITIES)
(SPECIAL $RATDENOMDIVIDE $RATEXPAND $RATEPSILON $RATPRINT FR-FACTOR ADN* INRATSIMP TELLRATLIST $FACEXPAND $RATVARS $ALGEBRAIC $RATFAC $RATWEIGHTS $NOREPEAT $DONTFACTOR $FACTORFLAG $KEEPFLOAT FACTORRESIMP *RATWEIGHTS *FNEWVARSW VARLIST GENPAIRS GENVAR)
(SPECIAL $SOLVERADCAN $SOLVETRIGWARN $SOLVENULLWARN $SOLVEFACTORS $SOLVEEXPLICIT $SOLVEDECOMPOSES $PROGRAMMODE $SOLVE_INCONSISTENT_ERROR $LINSOLVEWARN $MULTIPLICITIES $BREAKUP)
(SPECIAL $INTEGRATION_CONSTANT_COUNTER)
(SPECIAL $SHOWTIME $FILE_STRING_PRINT $CHANGE_FILEDEFAULTS ALIASLIST $MOREWAIT $TTYINTFUN $TTYINTNUM USER-TIMESOFAR CASEP $DIREC $LINENUM $LINECHAR $OUTCHAR $INCHAR $%)
(FIXNUM $LINENUM)
(SPECIAL $OPTIMPREFIX)
(SPECIAL GENERATE-ATAN2 IMPLICIT-REAL)
(SPECIAL $SETCHECK MUNBINDP)
(SPECIAL $OPTIMWARN $OPTIMPREFIX)
(SPECIAL $MAXAPPLYHEIGHT $MAXAPPLYDEPTH)
(SPECIAL $SUPERLOGCON $LOGCONCOEFFP)
(SPECIAL $ROOTSCONMODE)
(SPECIAL $ASSUMESCALAR $DOTIDENT $SCALARMATRIXP $DOMXNCTIMES $DOSCMXOPS $DOMXMXOPS $DOALLMXOPS $DOTASSOC $DOTEXPTSIMP $DOTDISTRIB $DOTSCRULES $DOT1SIMP $DOT0NSCSIMP $DOT0SIMP $DOTCONSTRULES)
(SPECIAL $MATRIX_ELEMENT_TRANSPOSE $MATRIX_ELEMENT_ADD $MATRIX_ELEMENT_MULT $RATMX TOP* $DETOUT *RANK*)
(SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR $BOXCHAR DISPLAYP STRINGDISP $NOUNDISP $DERIVABBREV $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY)
(SPECIAL $OPTIMWARN $OPTIMPREFIX)
(*FEXPR $TRACE_OPTIONS $DEFINE_VARIABLE $FULLMAPL $PRIMER MCOND $DEMO $LETSIMP $GRADEF $MAKEATOMIC $DEPENDENCIES $LDISPLAY $APPENDFILE $STORE $COMPFILE $OUTERMAP $PROPVARS $QPUT $APPLYB2 $MAIL $FASSAVE $REMARRAY $BATCON $EXAMPLE $GRAPH2 $OPTIONS $APPLYB1 $LOADFILE $HELP $REPLOT4 $MATRIXMAP $TIMER $NAMEPLOT $LOADPLOTS $SUBSTPART $ORDERLESS MDOIN $PRINTFILE $DESCRIBE $COMPILE $DELFILE $TELLSIMPAFTER $CATCH $DISPRULE $APPLY $ALARMCLOCK $SSTATUS $BATCH $PRINTPROPS $MACROEXPAND $LET $CONTOURPLOT2 $DEFTAYLOR $DEFMATCH MOR $DECLARE $STRING $INTERPOLATE $ALIAS $TOBREAK $EVAL_WHEN $MACROEXPAND1 $LABELS $UNTRACE $ASSUME $WRITEFILE MPROG $EV $UNTIMER $REMCON $SUBSTINPART $TELLSIMP MQUOTE $CF $REMOVE $CLOSEFILE $APROPOS $PARAMPLOT $ORDERGREAT MNOT $RENAMEFILE $MAKELIST $APPLY2 $IS $PARAMPLOT2 $NUMERVAL $HARDCOPY $MATCHDECLARE $MAP $LOCAL $TIME $NAMEFILE $APPLY1 $SUBVAR $DISPLAY $SEND $BUILDQ $DEFINE $FILELIST $ARRAYINFO $MODE_IDENTITY $FILELENGTH $MAPLIST $RESTORE $FUNDEF $ALLOC $ERRCATCH $SAVEPLOTS MGO $LETRULES $FORTRAN $LABEL MPROGN $REMFILE $SCANMAP MDO $TRANSLATE $ARRAY $LISTFILES $ROMBERG $FORGET $PLAYBACK $BUG $DEFRULE MSPEC-HOOK $TRACE MAND $REMLET $STRINGOUT $REMFUNCTION $SAVE $UNSTORE $MODEDECLARE $TIMER_INFO $STATUS $PROPERTIES MSETQ $PLOT3D $GRAPH $PLOT $QLISTFILES $SETUP_AUTOLOAD $SUPCONTEXT $KILL $PLOTMODE $GRIND $GRAPH3D $PLOT2 $SUM MLOCAL $REMVALUE $PRODUCT $DISPFUN MDEFINE $REPLOT $FULLMAP $KILLPLOTS $MULTIGRAPH MDEFMACRO)

276
src/maxdoc/dcl.multix Executable file
View File

@@ -0,0 +1,276 @@
(defprop dcl (date= (81. 4. 4.) daytime= (0. 14. 29.)) version)
(*expr cmod cplus ctimes cexpt crecip cfactor)
(*fexpr $fasmak)
(*expr solvequartic)
(*expr $getcharn)
(*expr $facout $distrib)
(*lexpr $scsimp)
(*expr $optimize)
(*expr $poisint $poissquare $poisexpt $poistimes $poisdiff $printpois $outofpois $poisctimes $intopois $poismap $poisplus $poissimp)
(*lexpr $poissubst)
(*expr $poisint $poissquare $poisexpt $poistimes $poisdiff $printpois $outofpois $poisctimes $intopois $poismap $poisplus $poissimp)
(*lexpr $poissubst)
(*fexpr $graph $plot)
(*lexpr $permanent $newdet)
(*fexpr $letsimp $letrules $remlet $let)
(*expr $niceindices $bashindices $intosum $sumcontract)
(*lexpr $fortmx)
(*fexpr $fortran)
(*expr $apply_nouns mtree-subst)
(*fexpr $defrule $tellsimpafter $tellsimp $defmatch $matchdeclare)
(*expr dimension-superscript)
(*lexpr $trigreduce)
(*expr $combine)
(*expr logarc $logarc)
(*expr $absconverge $converge $powerseries)
(*fexpr $apropos)
(*expr get-out get-flist)
(*expr $subsetp $elementof $elementp $cardinal $mapset $predset $elements $emptyp $universe $make_universe)
(*lexpr $setdiff $symdiff $intersection $union $ordinal ${)
(*expr simplify morp porm root ncpower power* power ncmuln ncmul2 div* div muln mul3 mul2* mul2 sub* sub neg addn add2* add2)
(*expr ask-integer)
(*lexpr $askinteger)
(*lexpr $nroots $realroots)
(*lexpr $nofix $matchfix $nary $infix $postfix $prefix)
(*expr simpmdefmacro (mmacroexpanded macro) mmacro-apply)
(*fexpr $macroexpand1 $macroexpand mdefmacro)
(*expr $polydecomp)
(*expr $clearscreen)
(*lexpr $pause)
(*expr $trigexpand)
(*expr $xthru)
(*expr $tr_warnings_get)
(*expr $pfet)
(*expr $sublist)
(*fexpr $makelist)
(*fexpr $renamefile $filelength $filelist $qlistfiles $listfiles $printfile)
(*expr $radcan freeof argsfreeof $bothcoef $ratsubst)
(*lexpr $freeof $ratcoef)
(*expr check-out-of-core-string allocate-message-index)
(*expr $tldefint)
(*lexpr $tlimit)
(*expr mapply-tr insure-array-props $arraysetapply $arrayapply interval-error)
(*lexpr display-for-tr marrayset marrayref mfuncall)
(*expr $bezout $discriminant $resultant)
(*expr $reset $listofvars $unknown)
(*fexpr $options)
(*fexpr $time $resetclock $printclock $unclock $clock)
(*expr $pade)
(*expr mbuildq-subst)
(*fexpr $buildq)
(*expr macsymacallp subrcall$p subrcallp)
(*lexpr fmapply)
(*expr define-symbol)
(*expr $debug)
(*lexpr $lispdebugmode $debugprintmode)
(*expr $factcomb $minfactorial $makegamma $makefact)
(*expr $bernpoly $bern $euler)
(*expr $fib $zeta)
(*expr $cfexpand $qunit $cfdisrep)
(*fexpr $cf)
(*fexpr $product)
(*expr $taytorat)
(*expr $polydecomp)
(*expr nformat-all nformat)
(*expr mdescribe)
(*fexpr $describe)
(*expr make-param)
(*expr $lhs $rhs $partition $demoivre)
(*expr $transpose $setelmx $row $minor $col $triangularize $rank onen $echelon $invertmx $diagmatrix $ident $determinant $charpoly $matrixp)
(*lexpr $submatrix)
(*expr $linsolve)
(*lexpr $solve)
(*expr $tminverse $tmlin)
(*lexpr $tmlinsolve $tmnewdet)
(*lexpr $sort)
(*expr $sublist)
(*fexpr $makelist)
(*expr apply2hack apply2 apply1hack apply1 part* part+ findbase findexpon findfun findbe $remrule)
(*fexpr $applyb2 $apply2 $applyb1 $apply1 $disprule)
(*expr outex-hook-exp $make_index_file)
(*expr $map_over_index_file $read_nth_object $number_of_objects_in_index_file $open_index_file)
(*expr $residue)
(*expr $ilt $laplace)
(*expr ratint)
(*expr outex-hook-exp $make_index_file)
(*expr $map_over_index_file $read_nth_object $index_file_dim $open_index_file)
(*expr mminusp*)
(*expr define-symbol rbp lbp)
(*expr rgrp $featurep like $sign asksign-p-or-n $asksign maximin minimum maximum $compare forget learn assume mevalp is $killcontext $newcontext)
(*lexpr $min $max $facts $deactivate $activate $context)
(*fexpr mor mand mnot $forget $assume $is $supcontext)
(*expr lowdeg)
(*expr pabs $nthroot $inrt $isqrt)
(*expr rassociative lassociative nary1 antisym commutative1 oddfun evenfun do%sum dosum simpsum simpgfact simpfact)
(*lexpr $genfact)
(*fexpr $sum $deftaylor)
(*expr $zeroequiv)
(*expr displaf)
(*lexpr *mformat)
(*expr fpentier *fpatan atanbigfloat ratbigfloat addbigfloat $bfloat fp2flo)
(*lexpr $ezgcd)
(*expr $taylorinfo)
(*lexpr $taylor)
(*expr $algsys)
(*expr $allroots)
(*expr $algnorm $splitfield $pfactoralg $algtrace)
(*lexpr $bdiscr $algfac)
(*expr simp-%sech simp-%csch simp-%coth simp-%tanh simp-%cosh simp-%sinh)
(*expr simp-%asec simp-%acsc simp-%acot simp-%acos simp-%asin)
(*expr simp-%asech simp-%acsch simp-%acoth simp-%atanh simp-%acosh simp-%asinh)
(*expr trigexpand $trigexpand)
(*expr $gcfactor $jacobi $totient $prime)
(*lexpr $divsum)
(*expr acsch asech acoth atanh asinh acosh sech csch coth tanh cosh sinh acsc asec acot atan1 acos asin csc sec cot tan mminusp* mminusp exponentialize $exponentialize rremainder rtimes rdifference rplus simp-%atan simp-%sec simp-%csc simp-%cot simp-%tan simp-%cos simp-%sin arcp trigp sq-sumsq sqrtx^2-1 sqrt1+x^2 sqrt1-x^2)
(*expr simpplog)
(*expr simpbinocoef)
(*expr simpgamma simpbeta)
(*expr erf simperf)
(*expr $ematrix $zeromatrix)
(*expr $augcoefmatrix $coefmatrix)
(*expr $entermatrix)
(*expr $xthru)
(*fexpr $multigraph $paramplot)
(*fexpr $graph $plot)
(*expr $gmark $gvprint $ghprint $gterpri $exitgraph $entergraph $clear $drawsymbol3 $line3 $vector3 $point3 $setpoint3 $size $screensize1 $screensize $definesymbol $drawsymbol $line $vector $popdash $pushdash $changedash $definedash $point $setpoint)
(*expr $batchload open-in-dsk open-out-dsk mstringp)
(*expr $tag_file_insert)
(*expr translate-macexpr-toplevel translate-and-eval-macsyma-expression)
(*expr ascii-numberp alphabetp cput a-atom log2 assqr firstn reconc amongl among xor andmapcar ormapc andmapc map2c)
(*lexpr concat *make-list)
(*expr trisplit cabs $carg $cabs $polarform $rectform $imagpart $realpart)
(*expr $timedate $who)
(*fexpr $alarmclock $send $mail $bug)
(*expr $reveal $pickapart $isolate)
(*fexpr $printprops $propvars $properties)
(*expr $changevar)
(*expr $gfactorsum $factorsum)
(*expr $combine)
(*lexpr $factorout)
(*expr $clearscreen)
(*lexpr $pause)
(*lexpr $translate_file)
(*expr $ldefint)
(*lexpr $limit)
(*expr testdivide cfactorw)
(*expr ptimes pquotient pmod pminus pminusp pderivative pdifference pplus pointergp)
(*expr ratquotient ratplus ratexpt rattimes ratreduce ratminus ratfact ratdif ratderivative)
(*expr pdegree $primep pgcd1 pquotientchk)
(*expr nthkdr *kar simpargs1 kdr kar matcherr bprog ratdenominator ratnumerator simpnrt alike alike1 great simpmqapply $ordergreatp $orderlessp simpmatrix simpexpt exptrl simpsignum signum1 simpderiv infsimp simpmdef simplambda simpexp simpbigfloat simpinteg simp-limit simptimes simpabs simpquot simpsqrt simpln simplus fpcofrat timesk addk simpargs ssimplifya eqtest simplifya freeargs freel free isinop constfun mxorlistp mequalp mbagp $nonscalarp $scalarp $constantp $numfactor subfunargs subfunsubs subfunname subfunmake subfunmakes subargcheck improper-arg-err wna-err twoargchk oneargchk twoargcheck oneargcheck $polysign specdisrep specrepp $ratp $ratnump $floatnump $evenp $oddp $integerp $numberp mratcheck simpcheck sratsimp ratdisrep mqapplyp mnegp mlogp mncexptp mnctimesp mexptp mtimesp mplusp ratnump even mnump $bfloatp zerop1 onep1 onep)
(*lexpr $integrate $expand $multthru)
(*fexpr retlist matcoef)
(*expr fstringc *errrjf read-only-assign $errormsg)
(*lexpr *merror)
(*fexpr $primer)
(*expr $sublis)
(*expr $plotreset $plotinit)
(*fexpr $killplots $loadplots $saveplots $nameplot $replot4 $replot $label $graph3d $graph2 $paramplot2 $contourplot2 $plot3d $plot2)
(*expr $binomial $gamma $acsch $asech $acoth $atanh $acosh $asinh $acsc $asec $acot $atan $acos $asin $csch $sech $coth $tanh $cosh $sinh $csc $sec $cot $tan $cos $sin $log $sqrt $exp dskrat mfilep autoldchk bigfloatm* add2lnc rat mreturn optionp mcons-op-args $funmake mapplyt mopp1 mopp arrstore mgetl mremprop mputprop mget remalias1 remrule remarrelem rempropchk remove1 $put $rem $get funcer $mapatom mmapev numerset msetchk mseterr $subvarp mquotep msetqp mevalatoms mset munbind mbind margs mop meval2 meval1 meval mevaln mapply)
(*lexpr $allbut $matrix outermap1 fmapl1 mcall)
(*fexpr dsksetq $subvar mgo mprog mdoin mdo mcond $dispfun $apply mdefine $define $array mdefprop $remvalue $remarray $remfunction $remove $declare $qput $outermap $fullmapl $matrixmap $fullmap $maplist $map mquote $ev msetq $local mprogn)
(*expr $untrace_it $trace_it)
(*expr killc contextmark kcntxt cntxt killframe remov unkind kill untrue doutern dintern dinternp remf addf datum par kind fact true* kindp factp isp falsep truep clear visiblep unmrk markp mark)
(*lexpr context deactivate activate)
(*fexpr deframe)
(*lexpr $suspend)
(*expr $lopow $hipow coeff $float $entier $fix $denom $num $symbolp $atom $length $reverse $args $last $first format1 atomchk $member $endcons $cons $listp listerchk getopr getop mpart part1 $dispterms $trunc remsimp delsimp nthelem union* substitutel notloreq atvarschk sdiff $del recur-apply subst0 substitute)
(*lexpr $coeff $delete $rest $append $inpart $part $dispform $disp $ldisp $diff $depends $substitute)
(*fexpr $substinpart $substpart $display $ldisplay $gradef $dependencies)
(*expr stotaldiff diffncexpt difflaplace diffsum diffint)
(*expr $at $atvalue)
(*expr $logcontract)
(*expr $nterms)
(*expr $fibtophi)
(*fexpr $numerval)
(*expr $derivdegree)
(*expr box)
(*lexpr $rembox $box $lpart $dpart)
(*fexpr $scanmap)
(*expr $copylist $copymatrix)
(*lexpr $genmatrix)
(*lexpr $addcol $addrow)
(*expr $arraymake)
(*fexpr $arrayinfo)
(*expr $unorder)
(*fexpr $orderless $ordergreat $makeatomic)
(*expr $getchar)
(*lexpr $concat)
(*expr $ratdisrep $ratexpand rationalize ratf $gfactor $sqfr $totaldisrep $showratvars $printvarlist $ratdenom $ratnumer)
(*lexpr $content $gcd $remainder $quotient $divide $mod factor $factor $ratsimp $rat $fullratsimp $ratvars $tellrat $untellrat)
(*fexpr $restore $remfile $fassave $store $save $unstore)
(*expr ass-eq-set assign-mode-check)
(*lexpr chekvalue ass-eq-ref)
(*expr $resultant $discriminant)
(*expr $bezout)
(*expr macherrfun iolfun ttyretfun ttyintfun ttyintfunsetup $dskgc $pagepause mfile-out fileprint filestrip $ddt $logout $quit $to_lisp computime timeorg $throw $uuo getlabcharn getlabels* getlabels $%th $poislim $fpprec casify-exploden strmeval makstring dollarify-name amperchk $verbify $nounify fullstrip1 fullstrip stripdollar remalias retrieve prinl erlist1 errexp nonvarchk nonsymchk fexprchk errbreak $debugmode ruleof remvalue remlabels kill1 batch1 carfile mtruename truefname loadfile filenamel mfboundp dollarify find0 load-function find-function reprint rubout* formfeed $bothcases tyi* addlabel mexploden printlabel makelabel meval*)
(*lexpr $filedefaults $break $error $random $readonly $read $print)
(*fexpr $alloc $sstatus $status $delfile $closefile $appendfile $writefile $time $catch $errcatch $labels $stringout $string $alias $playback $tobreak $kill $demo $batch $batcon $setup_autoload $loadfile)
(*expr memalike assolike assol)
(*expr cg-image-tyo-n cg-tyo-n cg-image-tyo cg-tyo dimension-superscript dimension-nofix dimension-postfix dimension-nary dimension-infix dimension-prefix makestring dimension-string dimension-atom displa)
(*expr sign)
(*expr mstring)
(*fexpr $grind)
(*expr $risch)
(*lexpr $compile_lisp_file)
(special $fortfloat $fortindent $fortspaces)
(fixnum $fortindent)
(special $user_mesfile dumping user-mesfile master-mesfile)
(special $universe $displayset)
(special $macroexpansion)
(special $tr_warn_bad_function_calls)
(special $assumescalar $dotident $scalarmatrixp $domxnctimes $doscmxops $domxmxops $doallmxops $dotassoc $dotexptsimp $dotdistrib $dotscrules $dot1simp $dot0nscsimp $dot0simp $dotconstrules)
(special $resultant)
(special $listconstvars)
(special $rombergit_used $rombergabs $rombergtol $rombergmin $rombergit)
(fixnum $rombergit_used $rombergmin $rombergit)
(flonum $rombergabs $rombergtol)
(special $negsumdispflag $sqrtdispflag $exptdispflag $%edispflag $pfeformat $powerdisp)
(special $linsolve_params $%rnum $backsubst $sparse $globalsolve)
(special $gammalim $sumsplitfact half%pi3 %pi2 half%pi fourth%pi %p%i)
(special $matrix_element_transpose $matrix_element_add $matrix_element_mult $ratmx)
(special $pointbound)
(special $solveradcan $solvetrigwarn $solvenullwarn $solvefactors $solveexplicit $solvedecomposes $savefactors $programmode $solve_inconsistent_error $linsolvewarn $multiplicities $breakup)
(special $trace_max_indent $trace_break_arg $trace)
(fixnum $trace_max_indent $trace_max_indent)
(special $maxapplyheight $maxapplydepth)
(special $parsewindow)
(fixnum $parsewindow)
(special limitp $askexp $signbfloat $prederror $activecontexts $contexts $context)
(special $homog_hack $savefactors $berlefact $intfaclim low* algfac* *irreds)
(special $prodhack $sumhack $simpsum $zerobern $genindex $gensumnum $cauchysum)
(special bigfloat%pi bigfloat%e bfmhalf bfhalf bigfloatone bigfloatzero $fpprec $fpprintprec $bftrunc $bftorat $float2bf)
(fixnum $fpprintprec)
(special $taylor_logexpand)
(special $algexact $realonly $%rnum_list)
(special -sqrt3//2 sqrt3//2 -sqrt2//2 sqrt2//2 %pi//2 %pi//4 -1//2 1//2 $halfangles $logarc $exponentialize $trigsign $trigexpandtimes $trigexpandplus $trigexpand $triginverses $%iargs $%piargs)
(special $tr_float_can_branch_complex)
(special *in-macsyma-indexer* *in-translate-file*)
(special $tr_optimize_max_loop *$any-modes* *tr-warn-break* *in-translate-file* *in-translate* *in-compfile* *in-compile* $tr_numer $tr_array_as_ref $tr_function_call_default *warned-mode-vars* *warned-fexprs* *warned-un-declared-vars* $tr_warn_undefined_variable $tr_warn_mode $tr_warn_fexpr $tr_warn_meval $tr_warn_undeclared tr-unique tr-abort *transl-traced* *transl-debug* *transl-backtrace* translate-time-evalables declares specials assigns need-prog? return-mode returns inside-mprog tr-progret fexprs lexprs arrays local tstack $special $transcompile $tr_semicompile $transbind)
(special $integration_constant_counter)
(special generate-atan2 implicit-real)
(special $tr_gen_tags $tr_true_name_of_file_being_translated $compgrind transl-file $tr_windy $tr_file_tty_messagesp $tr_output_file_default *transl-file-debug*)
(special preserve-direction limit-answers simplimplus-problems rd* infinitesimals real-infinities infinities)
(special $newfac $nalgfac smallprimes alpha mm* mplc* minpoly* *mx* *min* gauss)
(special errrjfflag hmodulus modulus)
(special $ratalgdenom $ratwtlvl)
(special *alpha bigprimes $gcd *gcdl*)
(special derivsimp errorsw dosimp $maxnegex $maxposex $expon $expop $mx0simp $domxtimes $domxplus $domxexpt $doscmxplus $simp $numer $negdistrib $float)
(fixnum $maxnegex $maxposex $expon $expop)
(special $error)
(special $sublis_apply_lambda)
(special munbindp)
(special $trace_max_indent $trace_break_arg $trace_safety $trace)
(fixnum $trace_max_indent $trace_max_indent $trace_max_indent)
(special $suspend)
(special $vect_cross)
(special $superlogcon $logconcoeffp)
(special $rootsconmode)
(special $ratdenomdivide $ratexpand $ratepsilon $ratprint fr-factor adn* inratsimp tellratlist $facexpand $ratvars $algebraic $ratfac $ratweights $norepeat $dontfactor $factorflag $keepfloat *ratweights *fnewvarsw varlist genpairs genvar)
(special $mode_check_errorp $mode_check_warnp $mode_checkp)
(special $resultant)
(special $showtime $file_string_print $change_filedefaults aliaslist $morewait $ttyintfun $ttyintnum casep $linenum $linechar $outchar $inchar)
(fixnum $linenum)
(special $display_format_internal $rmxchar $lmxchar $absboxchar $boxchar displayp stringdisp $fptrunc $noundisp $derivabbrev $linedisp $lispdisp $display2d $leftjust $stardisp $cursordisp line-graphics-tty character-graphics-tty)
(special $erfflag $liflag)
(special $to_call_lisp_compiler)

341
src/maxdoc/dcl.vars Normal file
View File

@@ -0,0 +1,341 @@
;; -*- Mode: Lisp; Package: Macsyma -*-
;; Declaration file for global variables known throughout Macsyma.
;; This file was generated by DEFINE version NIL.
;; Declarations for MAXSRC;MESRUN 9, compiled 10/23/80 3:47 by GJC.
(DECLARE (COMMENT MESRUN))
(DECLARE (SPECIAL $USER_MESFILE DUMPING USER-MESFILE MASTER-MESFILE))
;; Declarations for MAXSRC;SETS 10, compiled 10/28/80 23:37 by GJC.
(DECLARE (COMMENT SETS))
(DECLARE (SPECIAL $UNIVERSE $DISPLAYSET))
;; Declarations for MAXSRC;FCALL 36, compiled 11/15/80 19:08 by KMP.
(DECLARE (COMMENT FCALL))
(DECLARE (SPECIAL $TR_WARN_BAD_FUNCTION_CALLS))
;; Declarations for RAT;RESULT 20, compiled 12/9/80 21:40 by BMT.
(DECLARE (COMMENT RESULT))
(DECLARE (SPECIAL $RESULTANT))
;; Declarations for MAXSRC;NTRACE 24, compiled 1/22/81 1:13 by GJC.
(DECLARE (COMMENT NTRACE))
(DECLARE (SPECIAL $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE))
(DECLARE (FIXNUM $TRACE_MAX_INDENT $TRACE_MAX_INDENT))
;; Declarations for MAXSRC;TRANSF 9, compiled 2/17/81 19:27 by GJC.
(DECLARE (COMMENT TRANSF))
(DECLARE (SPECIAL $TR_FLOAT_CAN_BRANCH_COMPLEX))
;; Declarations for MAXSRC;SUSPEN 13, compiled 3/15/81 23:01 by GJC.
(DECLARE (COMMENT SUSPEN))
(DECLARE (SPECIAL $SUSPEND))
;; Declarations for MAXSRC;TRMODE 63, compiled 5/5/81 6:24 by JPG.
(DECLARE (COMMENT TRMODE))
(DECLARE (SPECIAL $MODE_CHECK_ERRORP $MODE_CHECK_WARNP $MODE_CHECKP))
;; Declarations for TRANSL;TRANSL 1145, compiled 6/26/81 18:44 by GJC.
(DECLARE (COMMENT TRANSL))
(DECLARE (SPECIAL $TR_BOUND_FUNCTION_APPLYP $TR_OPTIMIZE_MAX_LOOP *$ANY-MODES*
*TR-WARN-BREAK* $TR_PREDICATE_BRAIN_DAMAGE $TR_NUMER
$TR_ARRAY_AS_REF $TR_FUNCTION_CALL_DEFAULT
*WARNED-MODE-VARS* *WARNED-FEXPRS* *WARNED-UN-DECLARED-VARS*
$TR_WARN_UNDEFINED_VARIABLE $TR_WARN_MODE $TR_WARN_FEXPR
$TR_WARN_MEVAL $TR_WARN_UNDECLARED TR-UNIQUE TR-ABORT
*TRANSL-DEBUG* *TRANSL-BACKTRACE* TRANSLATE-TIME-EVALABLES
SPECIALS ASSIGNS NEED-PROG? RETURN-MODE RETURNS INSIDE-MPROG
TR-PROGRET FEXPRS EXPRS LEXPRS ARRAYS LOCAL TSTACK $SPECIAL
$TRANSCOMPILE $TR_SEMICOMPILE $TRANSBIND))
;; Declarations for TRANSL;TRPROP 1, compiled 7/15/81 1:48 by GJC.
(DECLARE (COMMENT TRPROP))
(DECLARE (SPECIAL META-PROP-L META-PROP-P))
;; Declarations for TRANSL;MCOMPI 145, compiled 9/21/81 10:48 by GJC.
(DECLARE (COMMENT MCOMPI))
(DECLARE (SPECIAL $TO_CALL_LISP_COMPILER))
;; Declarations for SHARE;FORMAT 13, compiled 12/3/81 2:30 by JPG.
(DECLARE (COMMENT FORMAT))
(DECLARE (SPECIAL $FLOATOPTIONS $FLOATWIDTH $FLOATPREC $FLOATFRAC $FLOATINT
$FLOATFORMAT))
;; Declarations for RP;DISPHK 764, compiled 12/12/81 9:57 by JPG.
(DECLARE (COMMENT DISPHK))
(DECLARE (SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR
$BOXCHAR DISPLAYP STRINGDISP $FPTRUNC $NOUNDISP $DERIVABBREV
$LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP
$CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY))
;; Declarations for TRANSL;TRANSS 79, compiled 1/22/82 6:51 by JPG.
(DECLARE (COMMENT TRANSS))
(DECLARE (SPECIAL $TR_GEN_TAGS $TR_STATE_VARS
$TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED $COMPGRIND
TRANSL-FILE $TR_WINDY $TR_FILE_TTY_MESSAGESP
$TR_OUTPUT_FILE_DEFAULT *TRANSL-FILE-DEBUG*))
;; Declarations for MAXSRC;ROMBRG 43, compiled 2/12/82 5:17 by JPG.
(DECLARE (COMMENT ROMBRG))
(DECLARE (SPECIAL $ROMBERGIT_USED $ROMBERGABS $ROMBERGTOL $ROMBERGMIN
$ROMBERGIT))
(DECLARE (FIXNUM $ROMBERGIT_USED $ROMBERGMIN $ROMBERGIT))
(DECLARE (FLONUM $ROMBERGABS $ROMBERGTOL))
;; Declarations for MAXSRC;NUMER 17, compiled 2/12/82 16:12 by JPG.
(DECLARE (COMMENT NUMER))
(DECLARE (SPECIAL TRAMP3$ TRAMP2$ TRAMP1$))
;; Declarations for JPG;BOPTIM 5, compiled 4/27/82 4:45 by JPG.
(DECLARE (COMMENT BOPTIM))
(DECLARE (SPECIAL $OPTIMPREFIX))
;; Declarations for JPG;AOPTIM 14, compiled 5/5/82 6:47 by JPG.
(DECLARE (COMMENT AOPTIM))
(DECLARE (SPECIAL $OPTIMWARN $OPTIMPREFIX))
;; Declarations for MAXSRC;MTRACE 42, compiled 10/28/82 7:02 by JPG.
(DECLARE (COMMENT MTRACE))
(DECLARE (SPECIAL $TIMER_DEVALUE $TIMER $TRACE_MAX_INDENT $TRACE_BREAK_ARG
$TRACE_SAFETY $TRACE))
(DECLARE (FIXNUM $TRACE_MAX_INDENT))
;; Declarations for JM;RISCH 436, compiled 11/16/82 6:35 by JPG.
(DECLARE (COMMENT RISCH))
(DECLARE (SPECIAL $ERFFLAG $LIFLAG))
;; Declarations for MRG;DISPLA 777, compiled 5/25/83 3:46 by JPG0.
(DECLARE (COMMENT DISPLA))
(DECLARE (SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR
$BOXCHAR DISPLAYP STRINGDISP $NOUNDISP $DERIVABBREV
$LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP
$CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY))
;; Declarations for MRG;GRAM 488, compiled 5/25/83 3:51 by JPG0.
(DECLARE (COMMENT GRAM))
(DECLARE (SPECIAL $PARSEWINDOW))
(DECLARE (FIXNUM $PARSEWINDOW))
;; Declarations for GZ;GROB 174, compiled 7/6/83 2:24 by JPG0.
(DECLARE (COMMENT GROB))
(DECLARE (SPECIAL $GROBNER_FUNCTIONS $GROBNER_GENVAR_INDEX
$GROBNER_GENVAR_PREFIX $GROBNER_TOT_ORDER
$GROBNER_COEF_DIVIDE $GROBNER_TOT_REDUCE $GROBNER_PRIMITIVE
$GROBNER_RAT $GROBNER_TRACE))
(DECLARE (FIXNUM $GROBNER_GENVAR_INDEX))
;; Declarations for LPH;QQ 2, compiled 8/31/83 20:41 by LPH.
(DECLARE (COMMENT QQ))
(DECLARE (SPECIAL $QUANC8_RELERR $QUANC8_ABSERR $QUANC8_ERREST $QUANC8_FLAG))
;; Declarations for LPH;FORTRN 70, compiled 4/12/84 18:08 by JPG.
(DECLARE (COMMENT FORTRN))
(DECLARE (SPECIAL $FORTINDENT $FORTSPACES $FORTNUM))
(DECLARE (FIXNUM $FORTINDENT))
;; Declarations for JPG;NDIFF 8, compiled 2/1/86 23:46 by JPG.
(DECLARE (COMMENT NDIFF))
(DECLARE (SPECIAL $NEWDIFF))
;; Declarations for MRG;NFORMA 15, compiled 1/28/18 8:47 by EJS.
(DECLARE (COMMENT NFORMA))
(DECLARE (SPECIAL $NEGSUMDISPFLAG $SQRTDISPFLAG $EXPTDISPFLAG $%EDISPFLAG
$PFEFORMAT $POWERDISP))
;; Declarations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS.
(DECLARE (COMMENT COMPAR))
(DECLARE (SPECIAL $ASSUME_POS_PRED $ASSUME_POS LIMITP $ASKEXP $SIGNBFLOAT
$PREDERROR SIGN-IMAG-ERRP $ACTIVECONTEXTS $CONTEXTS $CONTEXT))
;; Declarations for MRG;TRIGI 343, compiled 1/28/18 8:53 by EJS.
(DECLARE (COMMENT TRIGI))
(DECLARE (SPECIAL -SQRT3//2 SQRT3//2 -SQRT2//2 SQRT2//2 %PI//2 %PI//4 -1//2
1//2 $HALFANGLES $LOGARC $EXPONENTIALIZE $TRIGSIGN
$TRIGEXPANDTIMES $TRIGEXPANDPLUS $TRIGEXPAND $TRIGINVERSES
$%IARGS $%PIARGS))
;; Declarations for JPG;MLISP 613, compiled 1/28/18 9:52 by EJS.
(DECLARE (COMMENT MLISP))
(DECLARE (SPECIAL $SETCHECK MUNBINDP))
;; Declarations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS.
(DECLARE (COMMENT SUPRV))
(DECLARE (SPECIAL $SHOWTIME $FILE_STRING_PRINT $CHANGE_FILEDEFAULTS ALIASLIST
$MOREWAIT $TTYINTFUN $TTYINTNUM USER-TIMESOFAR CASEP $DIREC
$LINENUM $LINECHAR $OUTCHAR $INCHAR $%))
(DECLARE (FIXNUM $LINENUM))
;; Declarations for JPG;COMM 395, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT COMM))
(DECLARE (SPECIAL $VECT_CROSS))
;; Declarations for PAULW;CSIMP 299, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT CSIMP))
(DECLARE (SPECIAL $GAMMALIM $SUMSPLITFACT HALF%PI3 %PI2 HALF%PI FOURTH%PI %P%I))
;; Declarations for PAULW;MAT 286, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT MAT))
(DECLARE (SPECIAL $LINSOLVE_PARAMS $%RNUM $BACKSUBST $SPARSE $GLOBALSOLVE))
;; Declarations for RAT;FACTOR 472, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT FACTOR))
(DECLARE (SPECIAL $NEWFAC $NALGFAC SMALLPRIMES ALPHA MM* MPLC* MINPOLY* *MX*
*MIN* GAUSS))
;; Declarations for RAT;RAT3A 258, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3A))
(DECLARE (SPECIAL ERRRJFFLAG HMODULUS MODULUS))
;; Declarations for RAT;RAT3B 95, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3B))
(DECLARE (SPECIAL $RATALGDENOM $RATWTLVL))
;; Declarations for RAT;RAT3C 302, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3C))
(DECLARE (SPECIAL *ALPHA BIGPRIMES $GCD *GCDL*))
;; Declarations for RAT;RAT3D 264, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3D))
(DECLARE (SPECIAL $HOMOG_HACK $SAVEFACTORS $BERLEFACT $INTFACLIM LOW* ALGFAC*
*IRREDS))
;; Declarations for RAT;RAT3E 546, compiled 1/28/18 11:50 by EJS.
(DECLARE (COMMENT RAT3E))
(DECLARE (SPECIAL $RATDENOMDIVIDE $RATEXPAND $RATEPSILON $RATPRINT FR-FACTOR
ADN* INRATSIMP TELLRATLIST $FACEXPAND $RATVARS $ALGEBRAIC
$RATFAC $RATWEIGHTS $NOREPEAT $DONTFACTOR $FACTORFLAG
$KEEPFLOAT FACTORRESIMP *RATWEIGHTS *FNEWVARSW VARLIST
GENPAIRS GENVAR))
;; Declarations for JM;SIMP 834, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT SIMP))
(DECLARE (SPECIAL DERIVSIMP ERRORSW DOSIMP $MAXNEGEX $MAXPOSEX $EXPON $EXPOP
$MX0SIMP $DOMXTIMES $DOMXPLUS $DOMXEXPT $DOSCMXPLUS
$NUMER_PBRANCH $SUMEXPAND $SIMP $NUMER $NEGDISTRIB $FLOAT))
(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP))
;; Declarations for MAXSRC;INMIS 98, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT INMIS))
(DECLARE (SPECIAL $LISTCONSTVARS))
(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP))
;; Declarations for RZ;ASUM 271, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT ASUM))
(DECLARE (SPECIAL $PRODHACK $SUMHACK $SIMPSUM $ZEROBERN $GENINDEX $GENSUMNUM
$CAUCHYSUM))
(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP))
;; Declarations for RAT;SPGCD 110, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT SPGCD))
(DECLARE (SPECIAL $POINTBOUND))
(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP))
;; Declarations for MAXSRC;MERROR 47, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT MERROR))
(DECLARE (SPECIAL $ERROR_SYMS $ERROR_SIZE $ERRORMSG $ERROR))
(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP))
;; Declarations for MRG;FORTRA 64, compiled 1/28/18 11:53 by EJS.
(DECLARE (COMMENT FORTRA))
(DECLARE (SPECIAL $FORTFLOAT $FORTINDENT $FORTSPACES))
(DECLARE (FIXNUM $FORTINDENT))
;; Declarations for MRG;OPTIM 14, compiled 1/28/18 11:56 by EJS.
(DECLARE (COMMENT OPTIM))
(DECLARE (SPECIAL $OPTIMWARN $OPTIMPREFIX))
;; Declarations for JM;SIN 200, compiled 1/28/18 11:56 by EJS.
(DECLARE (COMMENT SIN))
(DECLARE (SPECIAL $INTEGRATION_CONSTANT_COUNTER))
;; Declarations for RAT;MATRUN 80, compiled 1/28/18 11:57 by EJS.
(DECLARE (COMMENT MATRUN))
(DECLARE (SPECIAL $MAXAPPLYHEIGHT $MAXAPPLYDEPTH))
;; Declarations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS.
(DECLARE (COMMENT FLOAT))
(DECLARE (SPECIAL BIGFLOAT%PI BIGFLOAT%E BFMHALF BFHALF BIGFLOATONE
BIGFLOATZERO $FPPREC $FPPRINTPREC $BFTRUNC $BFTORAT
$FLOAT2BF))
(DECLARE (FIXNUM $FPPRINTPREC))
;; Declarations for RAT;SOLVE 401, compiled 1/28/18 12:09 by EJS.
(DECLARE (COMMENT SOLVE))
(DECLARE (SPECIAL $SOLVERADCAN $SOLVETRIGWARN $SOLVENULLWARN $SOLVEFACTORS
$SOLVEEXPLICIT $SOLVEDECOMPOSES $PROGRAMMODE
$SOLVE_INCONSISTENT_ERROR $LINSOLVEWARN $MULTIPLICITIES
$BREAKUP))
;; Declarations for MAXSRC;MDOT 94, compiled 1/28/18 12:09 by EJS.
(DECLARE (COMMENT MDOT))
(DECLARE (SPECIAL $ASSUMESCALAR $DOTIDENT $SCALARMATRIXP $DOMXNCTIMES
$DOSCMXOPS $DOMXMXOPS $DOALLMXOPS $DOTASSOC $DOTEXPTSIMP
$DOTDISTRIB $DOTSCRULES $DOT1SIMP $DOT0NSCSIMP $DOT0SIMP
$DOTCONSTRULES))
;; Declarations for JIM;LIMIT 273, compiled 1/28/18 21:24 by EJS.
(DECLARE (COMMENT LIMIT))
(DECLARE (SPECIAL PRESERVE-DIRECTION LIMIT-ANSWERS SIMPLIMPLUS-PROBLEMS RD*
INFINITESIMALS REAL-INFINITIES INFINITIES))
;; Declarations for PAULW;DEFINT 658, compiled 1/28/18 21:24 by EJS.
(DECLARE (COMMENT DEFINT))
(DECLARE (SPECIAL DEFINTDEBUG))
;; Declarations for MACRAK;RPART 263, compiled 1/28/18 21:34 by EJS.
(DECLARE (COMMENT RPART))
(DECLARE (SPECIAL GENERATE-ATAN2 IMPLICIT-REAL))
;; Declarations for RZ;NUMTH 47, compiled 1/28/18 21:35 by EJS.
(DECLARE (COMMENT NUMTH))
(DECLARE (SPECIAL $MAXPRIME))
;; Declarations for RAT;HAYAT 386, compiled 1/28/18 21:37 by EJS.
(DECLARE (COMMENT HAYAT))
(DECLARE (SPECIAL $TAYLOR_LOGEXPAND $TAYLOR_TRUNCATE_POLYNOMIALS $MAXTAYORDER))
;; Declarations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT ALGSYS))
(DECLARE (SPECIAL ALGNOTEXACT $ALGEXACT REALONLYRATNUM $REALONLY $%RNUM_LIST))
;; Declarations for RAT;NISIMP 81, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT NISIMP))
(DECLARE (SPECIAL $LET_RULE_PACKAGES $CURRENT_LET_RULE_PACKAGE
$DEFAULT_LET_RULE_PACKAGE $LETRAT $LETVARSIMP))
;; Declarations for MAXSRC;SUBLIS 11, compiled 1/28/18 21:46 by EJS.
(DECLARE (COMMENT SUBLIS))
(DECLARE (SPECIAL $SUBLIS_APPLY_LAMBDA))
;; Declarations for REH;MMACRO 50, compiled 1/28/18 21:47 by EJS.
(DECLARE (COMMENT MMACRO))
(DECLARE (SPECIAL $MACROEXPANSION))
;; Declarations for JPG;LOGCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT LOGCON))
(DECLARE (SPECIAL $SUPERLOGCON $LOGCONCOEFFP))
;; Declarations for JPG;RTCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT RTCON))
(DECLARE (SPECIAL $ROOTSCONMODE))
;; Declarations for PAULW;GAMMA 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT GAMMA))
(DECLARE (SPECIAL $BETA_ARGS_SUM_TO_INTEGER))
;; Declarations for RAT;SCUBIC 19 (PSOLVE split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT SCUBIC))
(DECLARE (SPECIAL FLAG4))
;; Declarations for MAXSRC;ISOLAT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT ISOLAT))
(DECLARE (SPECIAL $ISOLATE_WRT_TIMES $EXPTISOLATE))
;; Declarations for RAT;MRESUL 30 (RESULT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT MRESUL))
(DECLARE (SPECIAL $RESULTANT))
;; Declarations for MAXSRC;MLOAD 121, compiled 1/30/18 22:44 by EJS.
(DECLARE (COMMENT MLOAD))
(DECLARE (SPECIAL $FILE_TYPES $FILE_SEARCH *IN-MACSYMA-INDEXER*
*IN-TRANSLATE-FILE* *IN-$BATCHLOAD*))

483
src/maxdoc/files.72 Executable file
View File

@@ -0,0 +1,483 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980, 1983 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Table of files comprising the Macsyma system.
;; This is the root in the tree of all macsyma documentation and system
;; organization. Therefore if any change is made to any of the
;; Macsyma source files, this table should be updated and mail sent
;; to Macsyma-Implementors. Macsyma implementors should familiarize
;; themselves with the various compilation, indexing, and documentation
;; features which depend on the information contained herein.
;; -GJC 2:52pm Monday, 3 November 1980
;; The MAXTUL directory contains the programs which manipulate these
;; data. In general they output data to the MAXDOC directory.
(EVAL-WHEN (COMPILE EVAL LOAD)
(OR (GET 'DEFMFILE 'VERSION)
;; which see for documentation of the structure.
(LOAD '((MAXTUL) DEFILE))))
(INIT-MACSYMA-SOURCE-FILES)
(HERALD MACSYMA-SOURCE-FILES)
;; Extensions to lisp.
;; Tools.
;; macro packages.
(DEFMFILE LIBMAX LMMAC
SYSTEMS-FOR '(PDP10 FRANZ)
GLOBAL-COMPILE T
MACRO-COMPILE T)
(DEFMFILE LIBMAX DEFINE
SYSTEMS-FOR '(PDP10)
GLOBAL-COMPILE T)
(DEFMFILE LIBMAX ERMSGC
;; out-of-core format strings.
GLOBAL-COMPILE T)
(DEFMFILE LIBMAX MAXMAC
GLOBAL-COMPILE T
MACRO-COMPILE T)
(DEFMFILE LIBMAX MFORMA
GLOBAL-COMPILE T
MACRO-COMPILE T)
(DEFMFILE LIBMAX MOPERS
GLOBAL-COMPILE T)
(DEFMFILE LIBMAX MRGMAC
SELECTIVE-COMPILE T)
(DEFMFILE LIBMAX STRMAC
SELECTIVE-COMPILE T)
(DEFMFILE LIBMAX META
GLOBAL-COMPILE T)
(DEFMFILE LIBMAX OPSHIN
MACRO-COMPILE T)
(DEFMFILE LIBMAX TRANSQ
SELECTIVE-COMPILE T)
(DEFMFILE LIBMAX TRANSM
SELECTIVE-COMPILE T)
(DEFMFILE LIBMAX MDEFUN
;; for translated code.
SELECTIVE-COMPILE T)
(DEFMFILE LIBMAX TPRELU
SELECTIVE-COMPILE T)
(DEFMFILE LIBMAX NUMERM
;; for numerical code man.
SELECTIVE-COMPILE T)
(DEFMFILE LIBMAX LMRUN
SYSTEMS-NOT-FOR '(FRANZ NIL LISPM)
SELECTIVE-COMPILE '?)
(DEFMFILE EMAXIM EDMAC
;; macsyma expression display editor.
SELECTIVE-COMPILE T)
;; runtime packages.
(DEFMFILE ELL HYP
UNFASL-DIR 'ELL
FASL-DIR 'ELL)
(DEFMFILE ELL HYPGEO
UNFASL-DIR 'ELL
FASL-DIR 'ELL)
(DEFMFILE SHARE APLOT2
FASL-DIR 'SHARE
UNFASL-DIR 'MUNFAS)
(DEFMFILE SHARE TEKPLT
FASL-DIR 'SHARE
UNFASL-DIR 'MUNFAS)
(DEFMFILE SHARE IFFUN
FASL-DIR 'SHARE
UNFASL-DIR 'MUNFAS)
(DEFMFILE SHARE PRINT
FASL-DIR 'SHARE
UNFASL-DIR 'MUNFAS)
(DEFMFILE SHARE PLOT3D
FASL-DIR 'SHARE
UNFASL-DIR 'MUNFAS)
(DEFMFILE CFFK CPOLY)
(DEFMFILE RZ MACROS
SELECTIVE-COMPILE T)
(DEFMFILE RZ ASUM
IN-CORE 270.)
(DEFMFILE RZ SERIES)
(DEFMFILE RZ NUMTH)
(DEFMFILE RZ SCHATC)
(DEFMFILE RZ TRGRED)
(DEFMFILE RZ COMBIN
SPLIT '(minfct eulbrn zeta cffun sum
prodct tayrat decomp))
(DEFMFILE JPG SUPRV
IN-CORE 60.)
(DEFMFILE JPG COMM
IN-CORE 50.)
(DEFMFILE JPG COMM2
SPLIT '(DIFF2 AT LOGCON RTCON NTERMS
ATAN2 ARITHF DERIVD BOX
MAPF GENMAT ADDROW ARRAYF
ALIAS CONCAT TTYINI))
(DEFMFILE JPG DSKFN
IN-CORE 310.)
(DEFMFILE JPG MLISP
IN-CORE 40.)
(DEFMFILE JPG MEDIT
SYSTEMS-NOT-FOR '(LISPM NIL)
IN-CORE 300.)
(DEFMFILE JPG ODE2
LANGUAGE 'MACSYMA)
(DEFMFILE JPG PLOT
SYSTEMS-FOR '(PDP10)
SPLIT '(GRAPH2 GRAPH))
(DEFMFILE MRG DB
IN-CORE 190.)
(DEFMFILE MRG DISPLA
IN-CORE 20.)
(DEFMFILE MRG FORTRA)
(DEFMFILE MRG GRAM
SYSTEMS-NOT-FOR '(LISPM NIL)
IN-CORE 10.)
(DEFMFILE MRG GRIND
IN-CORE 320.)
(DEFMFILE MRG COMPAR
IN-CORE 200.)
(DEFMFILE MRG NFORMA
IN-CORE 30.)
(DEFMFILE MRG OPTIM)
(DEFMFILE MRG SCS)
(DEFMFILE MRG TRIGI
IN-CORE 260.)
(DEFMFILE MRG TRIGO
SPLIT '( HYPER ATRIG AHYPER TRIGEX))
(DEFMFILE PAULW CSIMP
IN-CORE 240.)
(DEFMFILE PAULW MAT
IN-CORE 230.)
(DEFMFILE PAULW MATRIX
IN-CORE 220.)
(DEFMFILE RAT ALGSYS)
(DEFMFILE RAT FACTOR
IN-CORE 100.)
(DEFMFILE RAT MHAYAT
SELECTIVE-COMPILE T)
(DEFMFILE RAT RAT3A
IN-CORE 110.)
(DEFMFILE RAT RAT3B
IN-CORE 120.)
(DEFMFILE RAT RAT3C
IN-CORE 150.)
(DEFMFILE RAT RAT3D
IN-CORE 130.)
(DEFMFILE RAT RAT3E
IN-CORE 140.)
(DEFMFILE RAT RATLAP
SYSTEMS-FOR '(PDP10)
LANGUAGE 'MIDAS
IN-CORE 90.)
(DEFMFILE RAT RATMAC
SELECTIVE-COMPILE T)
(DEFMFILE RAT NRAT4
IN-CORE 210.)
(DEFMFILE RAT EZGCD)
(DEFMFILE RAT LESFAC
IN-CORE 160.)
(DEFMFILE RAT SPGCD
IN-CORE 290.)
(DEFMFILE RAT SOLVE)
(DEFMFILE RAT HOMOG)
(DEFMFILE RAT PADE)
(DEFMFILE RAT MATRUN)
(DEFMFILE RAT MATCOM)
(DEFMFILE RAT POIS2)
(DEFMFILE RAT POIS3)
(DEFMFILE RAT RATPOI)
(DEFMFILE RAT FLOAT)
(DEFMFILE RAT RESULT
SPLIT '(MRESUL SUBRES REDRES MODRES BEZOUT ))
(DEFMFILE RAT UFACT)
(DEFMFILE RAT HAYAT)
(DEFMFILE RAT POLYRZ)
(DEFMFILE RAT NALGFA)
(DEFMFILE RAT NEWDET)
(DEFMFILE RAT NISIMP)
(DEFMFILE RAT RATOUT
SPLIT '(MODGCD KRONEC FASTT RATWT HORNER PFRAC
RATDIF PFET ))
(DEFMFILE JM SIMP
IN-CORE 70.)
(DEFMFILE JM SININT)
(DEFMFILE JM SIN)
(DEFMFILE JM RISCH)
(DEFMFILE JM ZERO)
(DEFMFILE MAXSRC INMIS
IN-CORE 180.)
(DEFMFILE MAXSRC LAPLAC)
(DEFMFILE RAT PSOLVE
SPLIT '(SCUBIC SQUART))
(DEFMFILE MAXSRC OUTMIS
SPLIT '( STATUS ISOLAT PROPFN CHANGV FACSUM COMBF FACOUT SCREEN))
(DEFMFILE MAXSRC MTRACE
;; new trace package.
)
;; Terminal support
(DEFMFILE MAXSRC ARDS
SYSTEMS-NOT-FOR '(FRANZ))
(DEFMFILE MAXSRC VT100
SYSTEMS-NOT-FOR '(FRANZ))
(DEFMFILE MAXSRC H19
SYSTEMS-NOT-FOR '(FRANZ))
;; for suspending the macsyma session/environment
(DEFMFILE MAXSRC SUSPEN
SYSTEMS-FOR '(PDP10))
;; Other stuff.
(DEFMFILE MAXSRC OPERS
IN-CORE 80.)
(DEFMFILE MAXSRC OPS)
(DEFMFILE MAXSRC SUBLIS)
(DEFMFILE MAXSRC SETS
FASL-DIR 'SHARE
;; macsyma extended data types not fully supported.
UNFASL-DIR 'MAXOUT)
(DEFMFILE MAXSRC AR) ;; Array objects.
(DEFMFILE MAXSRC MTREE)
(DEFMFILE MAXSRC CHAR)
(DEFMFILE MAXSRC DOVER)
;; The transl package.
(DEFMFILE TRANSL TRDUMP
FASL-DIR 'MAXDMP
UNFASL-DIR 'MUNFAS)
(DEFMFILE TRANSL TRHOOK) ; used to implement translator modularity on the PDP-10.
(DEFMFILE TRANSL TRUTIL) ; Utilties.
(DEFMFILE TRANSL TRANSS) ; The system and user hacking part of transl.
(DEFMFILE TRANSL TRANSL) ; Toplevel expression translate and basic special forms.
(DEFMFILE TRANSL TRANS1) ; Translation properties by general grouping.
(DEFMFILE TRANSL TRANS2) ; ITS filenames don't allow more detail, see TRANSL >
(DEFMFILE TRANSL TRANS3)
(DEFMFILE TRANSL TRANS4)
(DEFMFILE TRANSL TRANS5)
(DEFMFILE TRANSL TRANSF)
(DEFMFILE TRANSL TROPER)
(DEFMFILE TRANSL TRPRED) ; predicates.
(DEFMFILE TRANSL TRPROP) ; META-PROPERTIES.
(DEFMFILE TRANSL TRMODE) ; User MODEDECLARE definitions.
(DEFMFILE TRANSL TRDATA) ; DATA on built-in functions.
(DEFMFILE TRANSL ACALL) ; RUNTIME support for translated code.
(DEFMFILE TRANSL FCALL) ; FSUBRs for the interpreter. (See TRANSQ).
(DEFMFILE TRANSL EVALW) ; User utility EVAL_WHEN.
(DEFMFILE TRANSL MCOMPI) ; User interface to lisp compiler.
(DEFMFILE TRANSL LJOB
;; Inferior JOB hacking, (so we can call lisp compiler).
SYSTEMS-FOR '(ITS))
(DEFMFILE TRANSL TRDEBG) ; For debugging translated code.
(DEFMFILE TRANSL MTAGS) ; generates macsyma-user TAGS while translating.
;; Numerical stuff.
(DEFMFILE MAXSRC ROMBRG)
(DEFMFILE MAXSRC INTPOL)
(DEFMFILE MAXSRC NUMER) ;; numerical support hacks.
(DEFMFILE MAXSRC NDIFFQ
FASL-DIR 'SHARE2)
;; Macsyma file handling stuff. Advanced user I/O
(DEFMFILE MAXSRC MLOAD IN-CORE 65.)
(DEFMFILE MAXSRC OUTEX
SPLIT '(outex OUTEY))
;; error handler.
(DEFMFILE MAXSRC MERROR IN-CORE 50.)
(DEFMFILE MAXSRC MFORMT IN-CORE 50.)
;; out of core strings.
(DEFMFILE MAXSRC ERMSGM IN-CORE 1. ; the first thing loaded!
SYSTEMS-FOR '(PDP10))
(DEFMFILE MAXSRC LDISP)
(DEFMFILE MAXSRC MDOT)
(DEFMFILE MAXSRC SUMCON)
(DEFMFILE MAXSRC SYNEX
SYSTEMS-NOT-FOR '(NIL LISPM))
(DEFMFILE MAXSRC RUNTIM
SYSTEMS-FOR '(PDP10)
IN-CORE 280.)
(DEFMFILE MAXSRC UTILS
IN-CORE 250.)
(DEFMFILE MAXSRC MUTILS
IN-CORE 5.)
(DEFMFILE ELLEN OPTION)
(DEFMFILE ELLEN PRIMER)
(DEFMFILE MAXSRC DESCRI
SPLIT '( DESCR EXAMPL)
SYSTEMS-NOT-FOR '(FRANZ LISPM NIL))
(DEFMFILE RLB FASDMP
SYSTEMS-NOT-FOR '(FRANZ LISPM MULTICS NIL))
(DEFMFILE MAXSRC IRINTE)
(DEFMFILE JIM ASKP)
(DEFMFILE JIM LIMIT)
(DEFMFILE JIM TLIMIT)
(DEFMFILE PAULW RESIDU)
(DEFMFILE PAULW DEFINT)
(DEFMFILE PAULW SPRDET)
(DEFMFILE PAULW NEWINV)
(DEFMFILE PAULW LINNEW)
(DEFMFILE PAULW EEZ)
(DEFMFILE PAULW NEWFAC)
(DEFMFILE PAULW ALGFAC)
(DEFMFILE PAULW CSIMP2
SPLIT '( PLOG BINOML GAMMA ERF EMATRIX COEFM ENTERM xthru XRTOUT
))
(DEFMFILE MACRAK LOGARC)
(DEFMFILE MACRAK RPART)
(DEFMFILE ZZ APROPO
SYSTEMS-NOT-FOR '(FRANZ LISPM NIL))
(DEFMFILE TENSOR ITENSR)
(DEFMFILE TENSOR CANTEN)
(DEFMFILE TENSOR GENER)
(DEFMFILE TENSOR SYMTRY)
(DEFMFILE SHARE FILEOP
SYSTEMS-FOR '(PDP10)
FASL-DIR 'SHARE)
(DEFMFILE ALJABR RESET
SYSTEMS-NOT-FOR '(FRANZ))
(DEFMFILE DAS MSTUFF
SPLIT '( MSORT MAKEL))
(DEFMFILE WGD SPECFN
SPLIT '( plylog plygam))
(DEFMFILE REH MMACRO)
(DEFMFILE REH BUILDQ)
;;; macsyma expression display editor.
(DEFMFILE EMAXIM EDCTL
FASL-DIR 'EMAXIM)
(DEFMFILE EMAXIM EDEXP
FASL-DIR 'EMAXIM)
(DEFMFILE EMAXIM EDBUF
FASL-DIR 'EMAXIM)
(DEFMFILE EMAXIM EDITS
SYSTEMS-FOR '(ITS)
FASL-DIR 'EMAXIM)
(DEFMFILE EMAXIM EDLM
SYSTEMS-FOR '(LISPM))

21
src/maxdoc/init.norese Normal file
View File

@@ -0,0 +1,21 @@
;; -*- Mode: Lisp; Package: Macsyma -*-
;; This is the initialization file for variables which cannot be reset.
;; This file was generated by DEFINE version NIL.
;; Initializations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS.
(DECLARE (COMMENT COMPAR))
(SETQ $CONTEXT (QUOTE $INITIAL) $CONTEXTS (QUOTE ((MLIST) $INITIAL $GLOBAL))
$ACTIVECONTEXTS (QUOTE ((MLIST))))
;; Initializations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS.
(DECLARE (COMMENT SUPRV))
(SETQ $% (QUOTE $%) $LINENUM 1. $DIREC (QUOTE JRMU) $MOREWAIT NIL)
;; Initializations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS.
(DECLARE (COMMENT FLOAT))
(SETQ BIGFLOATZERO (QUOTE ((BIGFLOAT SIMP 56.) 0. 0.))
BIGFLOATONE (QUOTE ((BIGFLOAT SIMP 56.) 36028797018963968. 1.)))
;; Initializations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT ALGSYS))
(SETQ REALONLYRATNUM NIL ALGNOTEXACT NIL)

175
src/maxdoc/init.reset Normal file
View File

@@ -0,0 +1,175 @@
;; -*- Mode: Lisp; Package: Macsyma -*-
;; This is the initialization file for variables which can be reset.
;; This file was generated by DEFINE version NIL.
;; Initializations for MRG;NFORMA 15, compiled 1/28/18 8:47 by EJS.
(DECLARE (COMMENT NFORMA))
(SETQ $POWERDISP NIL $PFEFORMAT NIL $%EDISPFLAG NIL $EXPTDISPFLAG T
$SQRTDISPFLAG T $NEGSUMDISPFLAG T)
;; Initializations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS.
(DECLARE (COMMENT COMPAR))
(SETQ $PREDERROR T $SIGNBFLOAT T $ASSUME_POS NIL $ASSUME_POS_PRED NIL)
;; Initializations for MRG;TRIGI 343, compiled 1/28/18 8:53 by EJS.
(DECLARE (COMMENT TRIGI))
(SETQ $%PIARGS T $%IARGS T $TRIGINVERSES (QUOTE $ALL) $TRIGEXPAND NIL
$TRIGEXPANDPLUS T $TRIGEXPANDTIMES T $TRIGSIGN T $EXPONENTIALIZE NIL
$LOGARC NIL $HALFANGLES NIL)
;; Initializations for JPG;MLISP 613, compiled 1/28/18 9:52 by EJS.
(DECLARE (COMMENT MLISP))
(SETQ $SETCHECK NIL)
;; Initializations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS.
(DECLARE (COMMENT SUPRV))
(SETQ $INCHAR (QUOTE $C) $OUTCHAR (QUOTE $D) $LINECHAR (QUOTE $E)
$TTYINTNUM 21. $TTYINTFUN NIL $CHANGE_FILEDEFAULTS T
$FILE_STRING_PRINT NIL $SHOWTIME NIL)
;; Initializations for JPG;COMM 395, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT COMM))
(SETQ $VECT_CROSS NIL)
;; Initializations for PAULW;CSIMP 299, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT CSIMP))
(SETQ $SUMSPLITFACT T $GAMMALIM 1000000.)
;; Initializations for PAULW;MAT 286, compiled 1/28/18 11:38 by EJS.
(DECLARE (COMMENT MAT))
(SETQ $GLOBALSOLVE NIL $SPARSE NIL $BACKSUBST T $%RNUM 0. $LINSOLVE_PARAMS T)
;; Initializations for RAT;FACTOR 472, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT FACTOR))
(SETQ $NALGFAC T $NEWFAC NIL)
;; Initializations for RAT;RAT3B 95, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3B))
(SETQ $RATWTLVL NIL $RATALGDENOM T)
;; Initializations for RAT;RAT3C 302, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3C))
(SETQ $GCD (CAR *GCDL*))
;; Initializations for RAT;RAT3D 264, compiled 1/28/18 11:49 by EJS.
(DECLARE (COMMENT RAT3D))
(SETQ $INTFACLIM 1000. $BERLEFACT T $SAVEFACTORS NIL $HOMOG_HACK NIL)
;; Initializations for RAT;RAT3E 546, compiled 1/28/18 11:50 by EJS.
(DECLARE (COMMENT RAT3E))
(SETQ $KEEPFLOAT NIL $FACTORFLAG NIL $DONTFACTOR (QUOTE ((MLIST))) $NOREPEAT T
$RATWEIGHTS (QUOTE ((MLIST SIMP))) $RATFAC NIL $ALGEBRAIC NIL
$RATVARS (QUOTE ((MLIST SIMP))) $FACEXPAND T $RATPRINT T
$RATEPSILON 2.0E-8 $RATEXPAND NIL $RATDENOMDIVIDE T)
;; Initializations for JM;SIMP 834, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT SIMP))
(SETQ $FLOAT NIL $NEGDISTRIB T $NUMER NIL $SIMP T $SUMEXPAND NIL
$NUMER_PBRANCH NIL $DOSCMXPLUS NIL $DOMXEXPT T $DOMXPLUS NIL
$DOMXTIMES NIL $MX0SIMP T $EXPOP 0. $EXPON 0. $MAXPOSEX 1000.
$MAXNEGEX 1000.)
;; Initializations for MAXSRC;INMIS 98, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT INMIS))
(SETQ $LISTCONSTVARS NIL)
;; Initializations for RZ;ASUM 271, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT ASUM))
(SETQ $CAUCHYSUM NIL $GENSUMNUM 0. $GENINDEX (QUOTE $I) $ZEROBERN T
$SIMPSUM NIL $SUMHACK NIL $PRODHACK NIL)
;; Initializations for RAT;SPGCD 110, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT SPGCD))
(SETQ $POINTBOUND *ALPHA)
;; Initializations for MAXSRC;MERROR 47, compiled 1/28/18 11:52 by EJS.
(DECLARE (COMMENT MERROR))
(SETQ $ERROR (QUOTE ((MLIST SIMP) |&No error.|)) $ERRORMSG (QUOTE T)
$ERROR_SIZE 10. $ERROR_SYMS (QUOTE ((MLIST) $ERREXP1 $ERREXP2 $ERREXP3)))
;; Initializations for MRG;FORTRA 64, compiled 1/28/18 11:53 by EJS.
(DECLARE (COMMENT FORTRA))
(SETQ $FORTSPACES NIL $FORTINDENT 0. $FORTFLOAT NIL)
;; Initializations for MRG;OPTIM 14, compiled 1/28/18 11:56 by EJS.
(DECLARE (COMMENT OPTIM))
(SETQ $OPTIMPREFIX (QUOTE $%) $OPTIMWARN T)
;; Initializations for JM;SIN 200, compiled 1/28/18 11:56 by EJS.
(DECLARE (COMMENT SIN))
(SETQ $INTEGRATION_CONSTANT_COUNTER 0.)
;; Initializations for RAT;MATRUN 80, compiled 1/28/18 11:57 by EJS.
(DECLARE (COMMENT MATRUN))
(SETQ $MAXAPPLYDEPTH 10000. $MAXAPPLYHEIGHT 10000.)
;; Initializations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS.
(DECLARE (COMMENT FLOAT))
(SETQ $FLOAT2BF NIL $BFTORAT NIL $BFTRUNC T $FPPRINTPREC 0. $FPPREC 16.)
;; Initializations for RAT;SOLVE 401, compiled 1/28/18 12:09 by EJS.
(DECLARE (COMMENT SOLVE))
(SETQ $BREAKUP T $MULTIPLICITIES (QUOTE $NOT_SET_YET) $LINSOLVEWARN T
$SOLVE_INCONSISTENT_ERROR T $PROGRAMMODE T $SOLVEDECOMPOSES T
$SOLVEEXPLICIT NIL $SOLVEFACTORS T $SOLVENULLWARN T $SOLVETRIGWARN T
$SOLVERADCAN NIL)
;; Initializations for MAXSRC;MDOT 94, compiled 1/28/18 12:09 by EJS.
(DECLARE (COMMENT MDOT))
(SETQ $DOTCONSTRULES T $DOT0SIMP T $DOT0NSCSIMP T $DOT1SIMP T $DOTSCRULES NIL
$DOTDISTRIB NIL $DOTEXPTSIMP T $DOTASSOC T $DOALLMXOPS T $DOMXMXOPS T
$DOSCMXOPS NIL $DOMXNCTIMES NIL $SCALARMATRIXP T $DOTIDENT 1.
$ASSUMESCALAR T)
;; Initializations for RZ;NUMTH 47, compiled 1/28/18 21:35 by EJS.
(DECLARE (COMMENT NUMTH))
(SETQ $MAXPRIME 489318.)
;; Initializations for RAT;HAYAT 386, compiled 1/28/18 21:37 by EJS.
(DECLARE (COMMENT HAYAT))
(SETQ $MAXTAYORDER T $TAYLOR_TRUNCATE_POLYNOMIALS T $TAYLOR_LOGEXPAND T)
;; Initializations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT ALGSYS))
(SETQ $%RNUM_LIST (QUOTE ((MLIST))) $REALONLY NIL $ALGEXACT NIL)
;; Initializations for RAT;NISIMP 81, compiled 1/28/18 21:41 by EJS.
(DECLARE (COMMENT NISIMP))
(SETQ $LETVARSIMP NIL $LETRAT NIL
$DEFAULT_LET_RULE_PACKAGE (QUOTE $DEFAULT_LET_RULE_PACKAGE)
$CURRENT_LET_RULE_PACKAGE (QUOTE $DEFAULT_LET_RULE_PACKAGE)
$LET_RULE_PACKAGES (QUOTE ((MLIST) $DEFAULT_LET_RULE_PACKAGE)))
;; Initializations for MAXSRC;SUBLIS 11, compiled 1/28/18 21:46 by EJS.
(DECLARE (COMMENT SUBLIS))
(SETQ $SUBLIS_APPLY_LAMBDA T)
;; Initializations for REH;MMACRO 50, compiled 1/28/18 21:47 by EJS.
(DECLARE (COMMENT MMACRO))
(SETQ $MACROEXPANSION NIL)
;; Initializations for JPG;LOGCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT LOGCON))
(SETQ $LOGCONCOEFFP NIL $SUPERLOGCON T)
;; Initializations for JPG;RTCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT RTCON))
(SETQ $ROOTSCONMODE T)
;; Initializations for PAULW;GAMMA 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS.
(DECLARE (COMMENT GAMMA))
(SETQ $BETA_ARGS_SUM_TO_INTEGER NIL)
;; Initializations for MAXSRC;ISOLAT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS.
(DECLARE (COMMENT ISOLAT))
(SETQ $EXPTISOLATE NIL $ISOLATE_WRT_TIMES NIL)
;; Initializations for RAT;MRESUL 30 (RESULT split), compiled 1/28/18 22:03 by EJS.
(DECLARE (COMMENT MRESUL))
(SETQ $RESULTANT (QUOTE $SUBRES))
;; Initializations for MAXSRC;MLOAD 121, compiled 1/30/18 22:44 by EJS.
(DECLARE (COMMENT MLOAD))
(SETQ
$FILE_SEARCH (LIST* (QUOTE (MLIST)) (MAPCAR (FUNCTION TO-MACSYMA-NAMESTRING) (QUOTE ("DSK:SHARE;" "DSK:SHARE1;" "DSK:SHARE2;" "DSK:SHAREM;"))))
$FILE_TYPES (LIST* (QUOTE (MLIST)) (MAPCAR (FUNCTION TO-MACSYMA-NAMESTRING) (QUOTE ("* FASL" "* TRLISP" "* LISP" "* >")))))

1212
src/maxdoc/mcldat.34 Executable file
View File

File diff suppressed because it is too large Load Diff

120
src/maxdoc/tdcl.10 Executable file
View File

@@ -0,0 +1,120 @@
;;;-*-lisp-*-
;;; loaded at compile time by translated macsyma code.
#-Multics
(herald tdcl)
#+Multics
(defprop tdcl t version)
;;; here are some important frobs which have not been taken care
;;; of by defmfun and defmvar. the macsyma switches are especially
;;; problematical, since various declare and setq's are spread throughout
;;; mlisp, suprv, and simp, and are not possible to fix via a tags query
;;; replace as i did with defun=>defmfun.
;;; -gjc 4:04pm saturday, 15 november 1980
(*lexpr mcall add* mul* $part map1 fmapl1 scanmap1
$error marrayref marrayset
mfuncall)
(*expr meval meval1 power simplify div munlocal mset mapply getopr
mbind munbind add2lnc addn muln add2* mul2* part1 mapply-tr
minimum maximum atan2 fmap1)
(flonum (atan2 flonum flonum)
;;($cosh flonum) no longer flonum due to mrg lossage (or some other asshole).
;;($sinh flonum) there are no flonum entries to these functions,
;; nice extra make-work for the transl maintainer.
)
;;; special variables for $ fsubr compatibility package in trans1 >
(special maplp fmaplvl mcatch bindlist loclist errcatch lisperrprint)
(*expr errlfun1 is)
;;; random fsubrs, for some reason defmfun is not working, so here
;;; is a list generated by a transl documentor program.
(*fexpr
$alias $alloc $appendfile $apply
$apropos $array $arrayinfo $assume
$batch $batchload $batcon $catch
$clock $closefile $compfile $contourplot2
$declare $define $define_variable $defmatch
$defrule $deftaylor $delfile $demo
$dependencies $describe $diskfree $diskuse
$dispfun $display $disprule $dumparrays
$errcatch $ev $fassave $filelength
$filelist $forget $fortran $fulldiskuse
$fullmap $fullmapl $gradef $graph
$graph2 $graph3d $grind $hardcopy
$is $kill $labels $ldisplay
$let $letsimp $listfiles $loadarrays
$loadfile $loadplots $local $macroexpand
$macroexpand1 $makeatomic $map
$maplist $matchdeclare $matrixmap $modedeclare
$mode_identity $multigraph $namefile $nameplot
$numerval $open_index_file $options $ordergreat
$orderless $outermap $paramplot $paramplot2
$playback $plot $plot2 $plot3d
$plotmode $primer $printclock $printdiskuse
$printfile $printprops $properties $propvars
$qlistfiles $qput $rearray $remarray
$remfile $remfunction $remove $remvalue
$renamefile $replot $replot4 $resetclock
$restore $save $saveplots $scanmap
$setup_autoload $sstatus $status $store
$string $stringout $substinpart $substpart
$subvar $sum $supcontext $tellsimp
$tellsimpafter $time $tobreak $translate
$tstring $unclock $unstore
$writefile mand matcoef
mcond mdefine mdefprop mdo
mdoin mgo mlocal mnot
mor mprog mprogn mquote
msetq )
;;; list of special variables, gotten by
;;; (let ((l nil))
;;; (mapatoms #'(lambda (x) (and (boundp x) (= (getcharn x 1) #/$) (push x l))))
;;; l)
(special $%edispflag $%emode $%enumer $%e_to_numlog $%iargs $%piargs $%rnum $abconvtest
$absboxchar $activecontexts $advise $algdelta $algebraic $algepsilon $algexact
$aliases $arrays $backsubst $backtrace $batchkill $batcount $berlefact $bftorat
$bftrunc $bothcases $boxchar $breakup $cauchysum $cflength $change_filedefaults
$combineflag $compgrind $context $contexts $cursor $cursordisp $debugmode $demoivre
$dependencies $derivabbrev $derivsubst $detout $device $dispflag $display2d
$disptime $domain $domxexpt $domxplus $domxtimes $dontfactor $doscmxplus $dskall
$dskgc $dskuse $dynamalloc $erfflag $error $errorfun $expon $exponentialize $expop
$exptdispflag $exptisolate $exptsubst $facexpand $factlim $factorflag $false
$features $filename $filenum $filesize $float $float2bf $fpprec $fpprintprec
$fptrunc $fullflag $functions $gammalim $gcd $genindex $gensumnum $globalsolve
$gradefs $grind $grindswitch $halfangles $inchar $infeval $inflag $infolists
$intanalysis $intfaclim $invertflag $keepfloat $labels $lasttime $leftjust
$lhospitallim $liflag $limitdomain $limsubst $linechar $linedisp $linenum
$linsolvewarn $lispdisp $listarith $listconstvars $lmxchar $loadprint $logabs
$logarc $logexpand $lognegint $lognumer $logsimp $m1pbranch $macroexpansion
$macros $maperror $mapprint $matrix_element_add $matrix_element_mult
$matrix_element_transpose $maxapplydepth $maxapplyheight $maxnegex $maxposex
$maxprime $maxtaydiff $maxtayorder $modresult $morewait $multiplicities $mx0simp
$myoptions $nalgfac $negdistrib $negsumdispflag $newfac $nointegrate $nolabels
$norepeat $noundisp $numer $off $on $opproperties $opsubst $optionset $outchar
$packagefile $pagepause $parsetime $parsewindow $partswitch $pfeformat $piece
$plotheight $plotundefined $pointbound $poislim $polyfactor $powerdisp $prederror
$prodhack $programmode $prompt $props $psexpand $radexpand $radsubstflag $ratalgdenom
$ratdenomdivide $ratepsilon $ratexpand $ratfac $ratmx $ratprint $ratsimpexpons
$ratvars $ratvarswitch $ratweights $ratwtlvl $realonly $refcheck $rmxchar
$rootsepsilon $rules $savedef $savefactors $setcheck $setcheckbreak $showtime
$signbfloat $simp $simpsum $singsolve $solvedecomposes $solveexplicit $solvefactors
$solvenullwarn $solveradcan $solvetrigwarn $solve_inconsistent_error $sparse
$special $sqrtdispflag $stardisp $storenum $strdisp $subnumsimp $subscrmap
$sumhack $sumsplitfact $taylordepth $tlimswitch $transbind $transcompile
$translate $transrun $trigexpand $trigexpandplus $trigexpandtimes $triginverses
$trigsign $true $tr_warn_fexpr $tr_warn_meval $ttyintfun $ttyintnum $uname $values
$verbose $version $weightlevels $wtlevel $zerobern $zeta%pi
)

165
src/maxsrc/ar.17 Normal file
View File

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

145
src/maxsrc/ards.11 Normal file
View File

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

33
src/maxsrc/char.2 Normal file
View File

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

226
src/maxsrc/descri.58 Normal file
View File

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

62
src/maxsrc/dover.3 Normal file
View File

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

61
src/maxsrc/ermsgm.12 Normal file
View File

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

47
src/maxsrc/h19.4 Normal file
View File

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

1155
src/maxsrc/ininte.54 Normal file
View File

File diff suppressed because it is too large Load Diff

90
src/maxsrc/inmis.98 Normal file
View File

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

107
src/maxsrc/intpol.13 Normal file
View File

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

1155
src/maxsrc/irinte.1 Normal file
View File

File diff suppressed because it is too large Load Diff

1155
src/maxsrc/irinte.54 Executable file
View File

File diff suppressed because it is too large Load Diff

935
src/maxsrc/laplac.202 Normal file
View File

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

918
src/maxsrc/laplac.205 Normal file
View File

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

100
src/maxsrc/ldisp.43 Normal file
View File

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

379
src/maxsrc/mdot.94 Normal file
View File

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

252
src/maxsrc/merror.47 Normal file
View File

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

145
src/maxsrc/mformt.27 Normal file
View File

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

479
src/maxsrc/mload.121 Normal file
View File

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

654
src/maxsrc/mtrace.41 Normal file
View File

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

86
src/maxsrc/mtree.1 Normal file
View File

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

57
src/maxsrc/mutils.11 Normal file
View File

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

199
src/maxsrc/ndiffq.5 Normal file
View File

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

276
src/maxsrc/numer.17 Normal file
View File

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

142
src/maxsrc/opers.75 Normal file
View File

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

47
src/maxsrc/ops.1 Normal file
View File

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

209
src/maxsrc/outex.37 Normal file
View File

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

1025
src/maxsrc/outmis.309 Normal file
View File

File diff suppressed because it is too large Load Diff

143
src/maxsrc/rombrg.43 Normal file
View File

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

104
src/maxsrc/runtim.19 Normal file
View File

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

439
src/maxsrc/sets.11 Normal file
View File

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

117
src/maxsrc/sublis.11 Normal file
View File

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

147
src/maxsrc/sumcon.18 Normal file
View File

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

99
src/maxsrc/suspen.13 Normal file
View File

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

187
src/maxsrc/synex.10 Normal file
View File

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

182
src/maxsrc/utils.26 Normal file
View File

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

33
src/maxsrc/vt100.5 Normal file
View File

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

20
src/maxtul/mcldmp.(init)
View File

@@ -58,10 +58,15 @@
(status jname)
(status subsys))
(load-em 'maxtul '(timepn))
;; ejs 2018-03-09: Commented out all the timing code since it appears to
;; cause arithmetic overflow errors under some circumstances. Will
;; restore this code when we find/fix the issue.
;; (load-em 'maxtul '(timepn))
(timeprogn
(time-origin)
;; ejs
;; (timeprogn
;; ejs
;; (time-origin)
;; workhorse section of code timed for the heck of it.
(or (status feature defstruct) ;; good ole ALAN has to be different.
@@ -73,7 +78,8 @@
'(module LMMAC MAXMAC MFORMA DEFINE MOPERS ERMSGC
TRANSM PROCS NUMERM))
(load-em 'maxdoc '(dcl mcldat))
(time-origin)
;; ejs
;; (time-origin)
(OR (MEMBER '(SETQ MESSAGES-INITIALIZED NIL) MCL-AFTER-PROC)
(PUSH '(SETQ MESSAGES-INITIALIZED NIL) MCL-AFTER-PROC))
(let ((^d t)) (gc))
@@ -85,7 +91,8 @@
(format msgfiles "~%~A ~A"
sym (get sym 'version))))))
;; end of workhorse section.
)
;; ejs
;; )
(progn ;; clean up message files.
(setq msgfiles (delete dskmsg msgfiles))
@@ -120,7 +127,8 @@
'(progn
(sstatus toplevel nil)
(sstatus gctime 0)
(time-origin 'set nil)
;; ejs
;; (time-origin 'set nil)
(announce-&-load-init-file
'mcompiler
nil

1320
src/mrg/compar.857 Normal file
View File

File diff suppressed because it is too large Load Diff

701
src/mrg/db.1145 Normal file
View File

@@ -0,0 +1,701 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module db)
(LOAD-MACSYMA-MACROS MRGMAC)
;; This file uses its own special syntax which is set up here. The function
;; which does it is defined in LIBMAX;MRGMAC. It sets up <, >, and : for
;; structure manipulation. A major bug with this package is that the code is
;; almost completely uncommented. Someone with nothing better to do should go
;; through it, figure out how it works, and write it down.
;; Note: After recompiling all of macsyma for the Lispm it was found
;; that some files were compiled with the syntax of ":" set up
;; incorectly. The (MODE-SYNTAX-OFF) function, which calls
;; undocumented system-internal routines evidently did not work anymore.
;; Therefore I removed the need for MODE-SYNTAX-ON from this file.
;; 7:57pm Thursday, 25 February 1982 -GJC
;; On systems which cons fixnums, a fixnum is used as a single label cell
;; and a pointer to the fixnum is passed around (i.e. the particular fixnum
;; is passed around. On systems which have immediate fixnums, a single cons
;; cell is created and the fixnum is stored in the car of the cell. Fixnums
;; are consed only in PDP-10 MacLisp and Franz Lisp.
#+(OR PDP10 Franz)
(EVAL-WHEN (EVAL COMPILE) (SSTATUS FEATURE FIXCONS))
#+NIL
(EVAL-WHEN (EVAL COMPILE) (SET-NOFEATURE 'FIXCONS))
(DECLARE (GENPREFIX DB)
;; LAB is not a special. This declares all occurrences of LAB
;; as a local or a parameter to be a fixnum. This should really
;; be done using a LOCAL-DECLARE around the entire file so as to
;; make sure any global compiler state gets undone.
#+FIXCONS (FIXNUM LAB)
(*LEXPR CONTEXT TYPE CON WN))
;; External specials
;; Please do not use DEFMVAR on these because some of them contain
;; circular list structure, and we want to be able to load in the
;; English version of the file at times. (DEFMVAR tries to print
;; out their values when the value in core is different from the
;; value in the file.) - JPG
;; Why don't you set PRINLEVEL and PRINLENGTH in your macsyma? -GJC
(DEFVAR CONTEXT 'GLOBAL)
(DEFVAR CONTEXTS NIL)
(DEFVAR CURRENT 'GLOBAL)
(DEFVAR +LABS NIL)
(DEFVAR -LABS NIL)
(DEFVAR DBTRACE NIL)
(DEFVAR DBCHECK NIL)
(DEFVAR DOBJECTS NIL)
(DEFVAR NOBJECTS NIL)
;; Internal specials
(DEFVAR MARKS 0) (DECLARE (FIXNUM MARKS))
(DEFVAR +L) (DECLARE (FIXNUM +L))
(DEFVAR -L) (DECLARE (FIXNUM -L))
(DEFVAR ULABS NIL)
(DEFVAR CONINDEX 0) (DECLARE (FIXNUM CONINDEX))
(DEFVAR CONNUMBER 50.) (DECLARE (FIXNUM CONNUMBER))
;; The most negative fixnum. On the PDP-10, this is 1_35.
(DEFVAR LAB-HIGH-BIT (ROT 1 -1))
;; One less than the number of bits in a fixnum. On the PDP-10, this is 35.
(DEFVAR LABNUMBER (1- (HAULONG LAB-HIGH-BIT)))
;; A cell with the high bit turned on.
(DEFVAR LAB-HIGH-LAB #+FIXCONS LAB-HIGH-BIT #-FIXCONS (LIST LAB-HIGH-BIT))
(DECLARE (SPECIAL +S +SM +SL -S -SM -SL LABS LPRS LABINDEX LPRINDEX WORLD *))
;; Macro for indirecting through the contents of a cell.
(DEFMACRO UNLAB (CELL)
#+FIXCONS CELL #-FIXCONS `(CAR ,CELL))
(DEFMACRO SETQ-UNLAB (CELL)
#+FIXCONS NIL
#-FIXCONS `(SETQ ,CELL (UNLAB ,CELL)))
(DEFMACRO SETQ-COPYN (CELL)
#+FIXCONS NIL
#-FIXCONS `(SETQ ,CELL (COPYN ,CELL)))
;; Conditionalize primitive functions used in this file. These are in
;; LAP for Lisp implementations which cons fixnums. This interface
;; is poorly designed since the meaning of COPYN is varies slightly
;; between systems. In one case it means "take a cell and produce a
;; new one with the same contents". In the other, it means "take an
;; immediate fixnum and return a cell containing it." As a result of
;; this, #+FIXCONS conditionalizations appear in the actual source code.
#-FIXCONS
(PROGN 'COMPILE
(DEFMACRO COPYN (N) `(LIST ,N))
(DEFMACRO IORM (CELL N)
`(RPLACA ,CELL (LOGIOR (CAR ,CELL) (CAR ,N))))
(DEFMACRO XORM (CELL N)
`(RPLACA ,CELL (LOGXOR (CAR ,CELL) (CAR ,N))))
)
;; The LAP for the PDP-10 version.
#+PDP10 (LAP-A-LIST '(
(LAP COPYN SUBR)
(MOVE TT 0 A)
(JSP T FWCONS)
(POPJ P)
NIL
(LAP IORM SUBR)
(MOVE B 0 B)
(IORM B 0 A)
(POPJ P)
NIL
(LAP XORM SUBR)
(MOVE B 0 B)
(XORM B 0 A)
(POPJ P)
NIL ))
#+Franz
(progn 'compile
(defmacro copyn (n) `(copyint* ,n))
(defmacro iorm (cell n) `(replace ,cell (logior ,cell ,n)))
(defmacro xorm (cell n) `(replace ,cell (logxor ,cell ,n))) )
(DEFPROP GLOBAL 1 CMARK)
(ARRAY CONUNMRK NIL (1+ CONNUMBER))
(ARRAY CONMARK T (1+ CONNUMBER))
(DEFMFUN MARK (X) (PUTPROP X T 'MARK))
(DEFMFUN MARKP (X) (AND (SYMBOLP X) (GET X 'MARK)))
(DEFMFUN UNMRK (X) (REMPROP X 'MARK))
(DEFUN MARKS (X) (COND ((NUMBERP X)) ((ATOM X) (MARK X)) (T (MAPC #'MARKS X))))
(DEFUN UNMRKS (X)
(COND ((NUMBERP X))
((OR (ATOM X) (NUMBERP (CAR X))) (UNMRK X))
(T (MAPC #'UNMRKS X))))
(DEFMODE TYPE ()
(ATOM (SELECTOR +LABS) (SELECTOR -LABS) (SELECTOR DATA))
SELECTOR)
(DEFMODE INDV ()
(ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR IN))
SELECTOR)
(DEFMODE UNIV ()
(ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR UN))
SELECTOR)
(DEFMODE DATUM ()
(ATOM (SELECTOR ULABS) (SELECTOR CON) (SELECTOR WN))
SELECTOR)
(DEFMODE CONTEXT ()
(ATOM (SELECTOR CMARK FIXNUM 0) (SELECTOR SUBC) (SELECTOR DATA)))
;; Is (COPYN 0) really needed in these next four macros instead of simply 0?
;; If the fixnum were to get clobbered, then it would seem that (LIST 0) would
;; be the correct thing to return in the #-FIXCONS case. -cwh
(DEFMACRO +LABZ (X)
`(COND ((+LABS ,X))
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
(DEFMACRO -LABZ (X)
`(COND ((-LABS ,X))
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
(DEFMACRO =LABZ (X)
`(COND ((=LABS ,X))
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
(DEFMACRO NLABZ (X)
`(COND ((NLABS ,X))
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
(DEFMACRO ULABZ (X)
`(COND ((ULABS ,X))
(T #+FIXCONS 0 #-FIXCONS '(0))))
(DEFMACRO SUBP X
#-FIXCONS (SETQ X (MAPCAR #'(LAMBDA (FORM) `(UNLAB ,FORM)) X))
`(= ,(CAR X) (LOGAND . ,X)))
(DEFUN DBNODE (X) (IF (SYMBOLP X) X (LIST X)))
(DEFUN NODEP (X) (OR (ATOM X) (MNUMP (CAR X))))
(DEFUN DBVARP (X) (GETL X '(UN EX)))
;; Is this supposed to return a fixnum or a cell?
(DEFUN LAB (N) (LSH 1 (1- N)))
(DEFUN LPR (M N)
(COND ((DO L LPRS (CDR L) (NULL L)
(IF (AND (LABEQ M (CAAAR L)) (LABEQ N (CDAAR L)))
(RETURN (CDAR L)))))
((= (SETQ LPRINDEX (1- LPRINDEX)) LABINDEX) (BREAK LPR T))
(T (SETQ LPRS (CONS (CONS (CONS M N) (LSH 1 LPRINDEX)) LPRS))
(CDAR LPRS))))
(DEFUN LABEQ (X Y) (EQUAL (LOGIOR X LAB-HIGH-BIT) (LOGIOR Y LAB-HIGH-BIT)))
(DEFUN MARKND (ND)
(COND ((+LABS ND))
((= LPRINDEX (SETQ LABINDEX (1+ LABINDEX))) (BREAK MARKND T))
(T (SETQ LABS (CONS (CONS ND (LAB LABINDEX)) LABS))
(BEG ND (LAB LABINDEX))
(CDAR LABS))))
(DEFUN DBV (X R)
(DECLARE (FIXNUM X R Y))
(DO ((L LPRS (CDR L)) (Y 0)) ((NULL L) Y)
(IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND X (CAAAR L)))))
(SETQ Y (LOGIOR (CDAAR L) Y)))))
(DEFUN DBA (R Y)
(DECLARE (FIXNUM X R Y))
(DO ((L LPRS (CDR L)) (X 0)) ((NULL L) X)
(IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND (CDAAR L) Y))))
(SETQ X (LOGIOR X (CAAAR L))))))
(DEFUN PRLAB (X)
(SETQ-UNLAB X)
(SETQ X (LET ((BASE 2)) (EXPLODEN (BOOLE 2 LAB-HIGH-BIT X))))
(DO I (\ (LENGTH X) 3) 3 (NULL X)
(DO J I (1- J) (= 0 J) (TYO (CAR X)) (SETQ X (CDR X)))
(TYO #\SP)))
(DEFUN ONP (CL LAB) (SUBP LAB (+LABZ CL)))
(DEFUN OFFP (CL LAB) (SUBP LAB (-LABZ CL)))
(DEFUN ONPU (LAB FACT) (SUBP LAB (ULABZ FACT)))
(DEFMFUN VISIBLEP (DAT) (AND (NOT (ULABS DAT)) (CNTP DAT)))
(DEFUN CANCEL (LAB DAT)
(IF (SETQ * (ULABS DAT)) (IORM * LAB)
(SETQ ULABS (CONS DAT ULABS))
(SETQ-UNLAB LAB)
(PUTPROP DAT (COPYN LAB) 'ULABS)))
(DEFUN BEG (ND LAB)
(SETQ-COPYN LAB)
(IF (QUEUE+P ND LAB)
(IF (NULL +S) (SETQ +S (NCONS ND) +SM +S +SL +S)
(SETQ +S (CONS ND +S)))))
(DEFUN BEG- (ND LAB)
(SETQ-COPYN LAB)
(IF (QUEUE-P ND LAB)
(IF (NULL -S) (SETQ -S (NCONS ND) -SM -S -SL -S)
(SETQ -S (CONS ND -S)))))
(DEFUN MID (ND LAB)
(IF (QUEUE+P ND LAB)
(IF (NULL +SM) (SETQ +S (NCONS ND) +SM +S +SL +S)
(RPLACD +SM (CONS ND (CDR +SM)))
(IF (EQ +SM +SL) (SETQ +SL (CDR +SL)))
(SETQ +SM (CDR +SM)))))
(DEFUN MID- (ND LAB)
(IF (QUEUE-P ND LAB)
(IF (NULL -SM) (SETQ -S (NCONS ND) -SM -S -SL -S)
(RPLACD -SM (CONS ND (CDR -SM)))
(IF (EQ -SM -SL) (SETQ -SL (CDR -SL)))
(SETQ -SM (CDR -SM)))))
(DEFUN END (ND LAB)
(IF (QUEUE+P ND LAB)
(IF (NULL +SL) (SETQ +S (NCONS ND) +SM +S +SL +S)
(RPLACD +SL (NCONS ND))
(SETQ +SL (CDR +SL)))))
(DEFUN END- (ND LAB)
(IF (QUEUE-P ND LAB)
(IF (NULL -SL) (SETQ -S (NCONS ND) -SM -S -SL -S)
(RPLACD -SL (NCONS ND))
(SETQ -SL (CDR -SL)))))
(DEFUN QUEUE+P (ND LAB)
(COND ((NULL (SETQ * (+LABS ND)))
(SETQ +LABS (CONS ND +LABS))
(SETQ-UNLAB LAB)
(PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '+LABS))
((SUBP LAB *) NIL)
((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL)
(T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB))))))
(DEFUN QUEUE-P (ND LAB)
(COND ((NULL (SETQ * (-LABS ND)))
(SETQ -LABS (CONS ND -LABS))
(SETQ-UNLAB LAB)
(PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '-LABS))
((SUBP LAB *) NIL)
((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL)
(T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB))))))
(DEFUN DQ+ ()
(IF +S (PROG2 (XORM (+LABS (CAR +S)) LAB-HIGH-LAB)
(CAR +S)
(COND ((NOT (EQ +S +SM)) (SETQ +S (CDR +S)))
((NOT (EQ +S +SL)) (SETQ +S (CDR +S) +SM +S))
(T (SETQ +S NIL +SM NIL +SL NIL))))))
(DEFUN DQ- ()
(IF -S (PROG2 (XORM (-LABS (CAR -S)) LAB-HIGH-LAB)
(CAR -S)
(COND ((NOT (EQ -S -SM)) (SETQ -S (CDR -S)))
((NOT (EQ -S -SL)) (SETQ -S (CDR -S) -SM -S))
(T (SETQ -S NIL -SM NIL -SL NIL))))))
(DEFMFUN CLEAR ()
(IF DBTRACE (MTELL "~%Clearing ~A" MARKS))
(MAPC #'(LAMBDA (L) (_ (SEL L +LABS) NIL)) +LABS)
(MAPC #'(LAMBDA (L) (_ (SEL L -LABS) NIL)) -LABS)
(MAPC #'(LAMBDA (L) (REM L 'ULABS)) ULABS)
(SETQ +S NIL +SM NIL +SL NIL -S NIL -SM NIL -SL NIL
LABS NIL LPRS NIL LABINDEX 0 LPRINDEX LABNUMBER
MARKS 0 +LABS NIL -LABS NIL ULABS NIL)
(CONTEXTMARK))
(DEFMFUN TRUEP (PAT)
(CLEAR)
(COND ((ATOM PAT) PAT)
((PROG2 (SETQ PAT (MAPCAR #'SEMANT PAT)) NIL))
((EQ (CAR PAT) 'KIND) (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 1) (PROPG))
(T (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 2) (BEG (CAR PAT) (LPR 1 2)) (PROPG))))
(DEFMFUN FALSEP (PAT)
(CLEAR)
(COND ((EQ (CAR PAT) 'KIND)
(BEG (CADR PAT) 1) (BEG (CADDR PAT) 1) (PROPG))))
(DEFMFUN ISP (PAT) (COND ((TRUEP PAT)) ((FALSEP PAT) NIL) (T 'UNKNOWN)))
(DEFMFUN KINDP (X Y)
(IF (NOT (SYMBOLP X)) (MERROR "KINDP called on a non-symbolic atom."))
(CLEAR) (BEG X 1)
(DO P (DQ+) (DQ+) (NULL P)
(IF (EQ Y P) (RETURN T) (MARK+ P (+LABS P)))))
(DEFMFUN TRUE* (PAT)
(LET ((DUM (SEMANT PAT))) (IF DUM (CNTXT (IND (NCONS DUM)) CONTEXT))))
(DEFMFUN FACT (FUN ARG VAL) (CNTXT (IND (DATUM (LIST FUN ARG VAL))) CONTEXT))
(DEFMFUN KIND (X Y)
(SETQ Y (DATUM (LIST 'KIND X Y))) (CNTXT Y CONTEXT) (ADDF Y X))
(DEFMFUN PAR (S Y)
(SETQ Y (DATUM (LIST 'PAR S Y))) (CNTXT Y CONTEXT)
(MAPC #'(LAMBDA (L) (ADDF Y L)) S))
(DEFMFUN DATUM (PAT) (NCONS PAT))
(DEFUN IND (DAT)
(MAPC #'(LAMBDA (L) (IND1 DAT L)) (CDAR DAT))
(MAPC #'IND2 (CDAR DAT))
DAT)
(DEFUN IND1 (DAT PAT)
(COND ((NOT (NODEP PAT)) (MAPC #'(LAMBDA (L) (IND1 DAT L)) PAT))
((OR (MARKP PAT) (EQ 'UNKNOWN PAT)))
(T (ADDF DAT PAT) (MARK PAT))))
(DEFUN IND2 (ND) (IF (NODEP ND) (UNMRK ND) (MAPC #'IND2 ND)))
(DEFMFUN ADDF (DAT ND) (_ (SEL ND DATA) (CONS DAT (SEL ND DATA))))
(DEFMFUN REMF (DAT ND) (_ (SEL ND DATA) (FDEL DAT (SEL ND DATA))))
(DEFUN FDEL (FACT DATA)
(IF (AND (EQ (CAR FACT) (CAAAR DATA))
(EQ (CADR FACT) (CADAAR DATA))
(EQ (CADDR FACT) (CADDAAR DATA)))
(CDR DATA)
(DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS)))
(SETQ D (CAADR DS))
(COND ((AND (EQ (CAR FACT) (CAR D))
(EQ (CADR FACT) (CADR D))
(EQ (CADDR FACT) (CADDR D)))
(_ (SEL D CON DATA) (DELQ D (SEL D CON DATA)))
(RPLACD DS (CDDR DS)) (RETURN T))))
DATA))
(DEFUN SEMANTICS (PAT) (IF (ATOM PAT) PAT (LIST (SEMANT PAT))))
(DEFUN DB-MNUMP (X)
(OR (NUMBERP X)
(AND (NOT (ATOM X))
(NOT (ATOM (CAR X)))
(MEMQ (CAAR X) '(RAT BIGFLOAT)))))
(DEFUN SEMANT (PAT)
(COND ((SYMBOLP PAT) (OR (GET PAT 'VAR) PAT))
((DB-MNUMP PAT) (DINTNUM PAT))
(T (MAPCAR #'SEMANT PAT))))
(DEFMFUN DINTERNP (X)
(COND ((MNUMP X) (DINTNUM X))
((ATOM X) X)
((ASSOL X DOBJECTS))))
(DEFMFUN DINTERN (X)
(COND ((MNUMP X) (DINTNUM X))
((ATOM X) X)
((ASSOL X DOBJECTS))
(T (SETQ DOBJECTS (CONS (DBNODE X) DOBJECTS))
(CAR DOBJECTS))))
(DEFUN DINTNUM (X)
(COND ((ASSOL X NOBJECTS))
((PROGN (SETQ X (DBNODE X)) NIL))
((NULL NOBJECTS) (SETQ NOBJECTS (LIST X)) X)
((EQ '$POS (RGRP (CAR X) (CAAR NOBJECTS)))
(LET ((CONTEXT 'GLOBAL))
(FACT 'MGRP X (CAR NOBJECTS)))
(SETQ NOBJECTS (CONS X NOBJECTS)) X)
(T (DO ((L NOBJECTS (CDR L)) (CONTEXT '$GLOBAL))
((NULL (CDR L))
(LET ((CONTEXT 'GLOBAL))
(FACT 'MGRP (CAR L) X)) (RPLACD L (LIST X)) X)
(COND ((EQ '$POS (RGRP (CAR X) (CAADR L)))
(LET ((CONTEXT 'GLOBAL))
(FACT 'MGRP (CAR L) X) (FACT 'MGRP X (CADR L)))
(RPLACD L (CONS X (CDR L)))
(RETURN X)))))))
(DEFMFUN DOUTERN (X) (IF (ATOM X) X (CAR X)))
(DEFMFUN UNTRUE (PAT)
(KILL (CAR PAT) (SEMANT (CADR PAT)) (SEMANT (CADDR PAT))))
(DEFMFUN KILL (FUN ARG VAL) (KILL2 FUN ARG VAL ARG) (KILL2 FUN ARG VAL VAL))
(DEFUN KILL2 (FUN ARG VAL CL)
(COND ((NOT (ATOM CL)) (MAPC #'(LAMBDA (L) (KILL2 FUN ARG VAL L)) CL))
((NUMBERP CL))
(T (_ (SEL CL DATA) (KILL3 FUN ARG VAL (SEL CL DATA))))))
(DEFUN KILL3 (FUN ARG VAL DATA)
(IF (AND (EQ FUN (CAAAR DATA))
(EQ ARG (CADAAR DATA)) (EQ VAL (CADDAAR DATA)))
(CDR DATA)
(DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS)))
(SETQ D (CAADR DS))
(IF (NOT (AND (EQ FUN (CAR D))
(EQ ARG (CADR D))
(EQ VAL (CADDR D))))
T
(_ (SEL D CON DATA) (DELQ D (SEL D CON DATA)))
(RPLACD DS (CDDR DS)) (RETURN T)))
DATA))
(DEFMFUN UNKIND (X Y)
(setq y (car (datum (LIST 'kind x y))))
(kcntxt y context)
(remf y x))
(defmfun remov (fact)
(remov4 fact (cadar fact))
(remov4 fact (caddar fact)))
(defun remov4 (fact cl)
(cond ((or (symbolp cl) (numberp (car cl))) ;if CL is a symbol or
;an interned number, then we want to REMOV4 FACT
;from its property list.
(_ (sel cl data) (delq fact (sel cl data))))
((or (atom cl) (atom (car cl)))) ;if CL is an atom (not a symbol)
;or its CAR is an atom then we don't want to do
;anything to it.
(t (mapc #'(lambda (l) (remov4 fact l))
(cond ((atom (caar cl)) (cdr cl)) ;if CL's CAAR is
;an atom, then CL is an expression, and
;we want to REMOV4 FACT from the parts
;of the expression.
((atom (caaar cl)) (cdar cl)))))))
;if CL's CAAAR is an atom, then CL is a
;fact, and we want to REMOV4 FACT from
;the parts of the fact.
(DEFMFUN KILLFRAME (CL)
(MAPC #'REMOV (SEL CL DATA))
(REMPROP CL '+LABS) (REMPROP CL '-LABS)
(REMPROP CL 'OBJ) (REMPROP CL 'VAR)
(REMPROP CL 'FACT)
(REMPROP CL 'WN))
(DEFMFUN ACTIVATE N
(DO I 1 (1+ I) (> I N)
(IF (MEMQ (ARG I) CONTEXTS) NIL
(SETQ CONTEXTS (CONS (ARG I) CONTEXTS))
(CMARK (ARG I)))))
(DEFMFUN DEACTIVATE N
(DO I 1 (1+ I) (> I N)
(IF (NOT (MEMQ (ARG I) CONTEXTS)) NIL
(CUNMRK (ARG I))
(SETQ CONTEXTS (DELQ (ARG I) CONTEXTS)))))
(DEFMFUN CONTEXT N (NEWCON (LISTIFY N)))
(DEFUN NEWCON (C)
(IF (> CONINDEX CONNUMBER) (GCCON))
(SETQ C (IF (NULL C) (LIST '*GC NIL) (LIST '*GC NIL 'SUBC C)))
(STORE (CONUNMRK CONINDEX) C) (STORE (CONMARK CONINDEX) (CDR C))
(SETQ CONINDEX (1+ CONINDEX)) C)
;; To be used with the WITH-NEW-CONTEXT macro.
(DEFUN CONTEXT-UNWINDER ()
(KILLC (CONMARK CONINDEX))
(SETQ CONINDEX (1- CONINDEX))
(STORE (CONUNMRK CONINDEX) ()))
(DEFUN GCCON ()
(GCCON1)
(WHEN (> CONINDEX CONNUMBER)
#+GC (GC)
(GCCON1)
(WHEN (> CONINDEX CONNUMBER)
(MERROR "~%Too many contexts."))))
(DEFUN GCCON1 ()
(SETQ CONINDEX 0)
(DO I 0 (1+ I) (> I CONNUMBER)
(IF (NOT (EQ (CONMARK I) (CDR (CONUNMRK I)))) (KILLC (CONMARK I))
(STORE (CONUNMRK CONINDEX) (CONUNMRK I))
(STORE (CONMARK CONINDEX) (CONMARK I))
(SETQ CONINDEX (1+ CONINDEX)))))
(DEFMFUN CNTXT (DAT CON)
(IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
(PUT CON (CONS DAT (GET CON 'DATA)) 'DATA)
(IF (NOT (EQ 'GLOBAL CON)) (PUT DAT CON 'CON))
DAT)
(defmfun kcntxt (fact con)
(if (not (atom con)) (setq con (cdr con)))
(put con (fdel fact (get con 'data)) 'data)
(if (not (eq 'global con)) (rem fact 'con))
fact)
(DEFUN CNTP (F)
(COND ((NOT (SETQ F (SEL F CON))))
((SETQ F (GET F 'CMARK)) (> F 0))))
(DEFMFUN CONTEXTMARK ()
(LET ((CON CONTEXT))
(UNLESS (EQ CURRENT CON)
(CUNMRK CURRENT) (SETQ CURRENT CON) (CMARK CON))))
(DEFUN CMARK (CON)
(IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
(LET ((CM (GET CON 'CMARK)))
(PUTPROP CON (IF CM (1+ CM) 1) 'CMARK)
(MAPC #'CMARK (GET CON 'SUBC))))
(DEFUN CUNMRK (CON)
(IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
(LET ((CM (GET CON 'CMARK)))
(COND (CM (PUTPROP CON (1- CM) 'CMARK)))
(MAPC #'CUNMRK (GET CON 'SUBC))))
(DEFMFUN KILLC (CON)
(CONTEXTMARK)
(COND ((NOT (NULL CON))
(MAPC #'REMOV (GET CON 'DATA))
(REMPROP CON 'DATA)
(REMPROP CON 'CMARK)
(REMPROP CON 'SUBC)))
T)
(DEFUN PROPG ()
(DO ((X) (LAB)) (NIL)
(COND ((SETQ X (DQ+))
(SETQ LAB (+LABS X))
(IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (-LABZ X))))
(MARK+ X LAB) (RETURN T)))
((SETQ X (DQ-))
(SETQ LAB (-LABS X))
(IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (+LABZ X))))
(MARK- X LAB) (RETURN T)))
(T (RETURN NIL)))))
(DEFUN MARK+ (CL LAB)
(COND (DBTRACE (SETQ MARKS (1+ MARKS))
(MTELL "~%Marking ~A +" CL) (PRLAB LAB)))
(MAPC #'(LAMBDA (L) (MARK+0 CL LAB L)) (SEL CL DATA)))
(DEFUN MARK+0 (CL LAB FACT)
(COND (DBCHECK (MTELL "~%Checking ~A from ~A+" (CAR FACT) CL) (PRLAB LAB)))
(COND ((ONPU LAB FACT))
((NOT (CNTP FACT)))
((NULL (WN FACT)) (MARK+1 CL LAB FACT))
((ONP (WN FACT) WORLD) (MARK+1 CL LAB FACT))
((OFFP (WN FACT) WORLD) NIL)
(T (MARK+3 CL LAB FACT))))
(DEFUN MARK+1 (CL LAB DAT)
(COND ((EQ (CAAR DAT) 'KIND)
(IF (EQ (CADAR DAT) CL) (MID (CADDAR DAT) LAB))) ; E1
((EQ (CAAR DAT) 'PAR)
(IF (NOT (EQ (CADDAR DAT) CL))
(PROGN (CANCEL LAB DAT) ; PR1
(MID (CADDAR DAT) LAB)
(DO L (CADAR DAT) (CDR L) (NULL L)
(IF (NOT (EQ (CAR L) CL)) (MID- (CAR L) LAB))))))
((EQ (CADAR DAT) CL)
(IF (+LABS (CAAR DAT)) ; V1
(END (CADDAR DAT) (DBV LAB (+LABS (CAAR DAT)))))
(IF (-LABS (CADDAR DAT)) ; F4
(END- (CAAR DAT) (LPR LAB (-LABS (CADDAR DAT))))))))
(DEFUN MARK+3 (CL LAB DAT) CL LAB ;Ignored
(IFN (= 0 (LOGAND (UNLAB (+LABZ (CADDAR DAT)))
(UNLAB (DBV (+LABZ (CADAR DAT)) (-LABZ (CAAR DAT))))))
(BEG- (WN DAT) WORLD)))
(DEFUN MARK- (CL LAB)
(WHEN DBTRACE
(SETQ MARKS (1+ MARKS)) (MTELL "Marking ~A -" CL) (PRLAB LAB))
(MAPC #'(LAMBDA (L) (MARK-0 CL LAB L)) (SEL CL DATA)))
(DEFUN MARK-0 (CL LAB FACT)
(WHEN DBCHECK (MTELL "~%Checking ~A from ~A-" (CAR FACT) CL) (PRLAB LAB))
(COND ((ONPU LAB FACT))
((NOT (CNTP FACT)))
((NULL (WN FACT)) (MARK-1 CL LAB FACT))
((ONP (WN FACT) WORLD) (MARK-1 CL LAB FACT))
((OFFP (WN FACT) WORLD) NIL)))
(DEFUN MARK-1 (CL LAB DAT)
(COND ((EQ (CAAR DAT) 'KIND)
(IF (NOT (EQ (CADAR DAT) CL)) (MID- (CADAR DAT) LAB))) ; E4
((EQ (CAAR DAT) 'PAR)
(IF (EQ (CADDAR DAT) CL)
(PROG2 (CANCEL LAB DAT) ; S4
(DO L (CADAR DAT) (CDR L) (NULL L) (MID- (CAR L) LAB)))
(PROGN (SETQ-UNLAB LAB) ; ALL4
(DO L (CADAR DAT) (CDR L) (NULL L)
(SETQ LAB (LOGAND (UNLAB (-LABZ (CAR L))) LAB)))
(SETQ-COPYN LAB)
(CANCEL LAB DAT)
(MID- (CADDAR DAT) LAB))))
((EQ (CADDAR DAT) CL)
(IF (+LABS (CAAR DAT)) ; A2
(END- (CADAR DAT) (DBA (+LABS (CAAR DAT)) LAB)))
(IF (+LABS (CADAR DAT)) ; F6
(END- (CAAR DAT) (LPR (+LABS (CADAR DAT)) LAB))))))
; in out in out ins in out
; ----------- ------------- ----------------
; E1 | + INV1 | + AB1 |(+) + +
; E2 | - INV2 | - AB2 |(+) - +
; E3 | + INV3 | + AB3 |(+) + -
; E4 | - INV4 | - AB4 |(+) - -
; AB5 |(-) + +
; in out in out AB6 |(-) - +
; ----------- ------------- AB7 |(-) + -
; S1 | (+) ALL1 |(+) + AB8 |(-) - -
; S2 | (-) ALL2 |(+) -
; S3 |(+) ALL3 |(-) +
; S4 |(-) ALL4 |(-) -
; in rel out in rel out in rel out
; --------------- --------------- ---------------
; V1 | (+) + A1 | + (+) F1 | + (+)
; V2 | (+) - A2 | - (+) F2 | + (-)
; V3 | (-) + A3 | + (-) F3 | - (+)
; V4 | (-) - A4 | - (-) F4 | - (-)
; F5 |(+) +
; F6 |(+) -
; F7 |(-) +
; F8 |(-) -
(DEFUN UNI (P1 P2 AL)
(COND ((DBVARP P1) (DBUNIVAR P1 P2 AL))
((NODEP P1)
(COND ((DBVARP P2) (DBUNIVAR P2 P1 AL))
((NODEP P2) (IF (EQ P1 P2) AL))))
((DBVARP P2) (DBUNIVAR P2 P1 AL))
((NODEP P2) NIL)
((SETQ AL (UNI (CAR P1) (CAR P2) AL)) (UNI (CDR P1) (CDR P2) AL))))
(DEFUN DBUNIVAR (P V AL)
(LET ((DUM (ASSQ P AL)))
(COND ((NULL DUM) (CONS (CONS P V) AL))
(T (UNI (CDR DUM) V AL)))))
; Undeclarations for the file:
(DECLARE (NOTYPE LAB))

1558
src/mrg/displa.769 Normal file
View File

File diff suppressed because it is too large Load Diff

158
src/mrg/fortra.64 Normal file
View File

@@ -0,0 +1,158 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module fortra)
(DECLARE (SPECIAL LB RB ;Used for communication with MSTRING.
$LOADPRINT ;If NIL, no load message gets printed.
1//2 -1//2)
(*LEXPR FORTRAN-PRINT $FORTMX))
(DEFMVAR $FORTSPACES NIL
"If T, Fortran card images are filled out to 80 columns using spaces."
BOOLEAN
MODIFIED-COMMANDS '$FORTRAN)
(DEFMVAR $FORTINDENT 0
"The number of spaces (beyond 6) to indent Fortran statements as they
are printed."
FIXNUM
MODIFIED-COMMANDS '$FORTRAN)
(DEFMVAR $FORTFLOAT NIL "Something JPG is working on.")
;; This function is called from Macsyma toplevel. If the argument is a
;; symbol, and the symbol is bound to a matrix, then the matrix is printed
;; using an array assignment notation.
(DEFMSPEC $FORTRAN (L)
(SETQ L (FEXPRCHECK L))
(LET ((VALUE (STRMEVAL L)))
(COND ((MSETQP L) (SETQ VALUE `((MEQUAL) ,(CADR L) ,(MEVAL L)))))
(COND ((AND (SYMBOLP L) ($MATRIXP VALUE))
($FORTMX L VALUE))
((AND (NOT (ATOM VALUE)) (EQ (CAAR VALUE) 'MEQUAL)
(SYMBOLP (CADR VALUE)) ($MATRIXP (CADDR VALUE)))
($FORTMX (CADR VALUE) (CADDR VALUE)))
(T (FORTRAN-PRINT VALUE)))))
;; This function is called from Lisp programs. It takes an expression and
;; a stream argument. Default stream is NIL in MacLisp and STANDARD-OUTPUT
;; in LMLisp. This should be canonicalized in Macsyma at some point.
;; TERPRI is a PDP10 MacLisp flag which, if set to T, will keep symbols and
;; bignums from being broken across page boundaries when printed. $LOADPRINT
;; is NIL to keep a message from being printed when the file containing MSTRING
;; is loaded. (MRG;GRIND)
(DEFPROP MEXPT (#/* #/*) DISSYM)
(DEFUN FORTRAN-PRINT (X &OPTIONAL (STREAM #-LISPM NIL #+LISPM STANDARD-OUTPUT)
&AUX #+PDP10 (TERPRI T) #+PDP10 ($LOADPRINT NIL)
;; This is a poor way of saying that array references
;; are to be printed with parens instead of brackets.
(LB #/( ) (RB #/) ))
;; Restructure the expression for displaying.
(SETQ X (FORTSCAN X))
;; Linearize the expression using MSTRING. Some global state must be
;; modified for MSTRING to generate using Fortran syntax. This must be
;; undone so as not to modifiy the toplevel behavior of MSTRING.
(UNWIND-PROTECT
(PROGN
(DEFPROP MEXPT MSIZE-INFIX GRIND)
(DEFPROP MMINUS 100. LBP)
(DEFPROP MSETQ (#/=) STRSYM)
(SETQ X (MSTRING X)))
;; Make sure this gets done before exiting this frame.
(DEFPROP MEXPT MSZ-MEXPT GRIND)
(REMPROP 'MMINUS 'LBP)
(DEFPROP MSETQ (#/:) STRSYM))
;; MSTRING returns a list of characters. Now print them.
(DO ((C #/0 (+ 1 (\ (- c #/0) 16) #/0))
(COLUMN (+ 6 $FORTINDENT) (+ 9 $FORTINDENT)))
((NULL X))
;; Print five spaces, a continuation character if needed, and then
;; more spaces. COLUMN points to the last column printed in. When
;; it equals 80, we should quit.
(COND ((= C #/0)
(PRINT-SPACES COLUMN STREAM))
(T (PRINT-SPACES 5 STREAM)
(TYO C STREAM)
(PRINT-SPACES (- COLUMN 6) STREAM)))
;; Print the expression. Remember, Fortran ignores blanks and line
;; terminators, so we don't care where the expression is broken.
(DO ()
((= COLUMN 72.))
(IF (NULL X)
(IF $FORTSPACES (TYO #\SP STREAM) (RETURN NIL))
(progn (and (equal (car x) #/\) (setq x (cdr x)))
(TYO (POP X) STREAM)))
(INCREMENT COLUMN))
;; Columns 73 to 80 contain spaces
(IF $FORTSPACES (PRINT-SPACES 8 STREAM))
(TERPRI STREAM))
'$DONE)
(DEFUN PRINT-SPACES (N STREAM)
(DOTIMES (I N) (TYO #\SP STREAM)))
;; This function is similar to NFORMAT. Prepare an expression
;; for printing by converting x^(1/2) to sqrt(x), etc. A better
;; way of doing this would be to have a programmable printer and
;; not cons any new expressions at all. Some of this formatting, such
;; as E^X --> EXP(X) is specific to Fortran, but why isn't the standard
;; function used for the rest?
(DEFUN FORTSCAN (E)
(COND ((ATOM E) (cond ((eq e '$%i) '((mprogn) 0.0 1.0))
(t E))) ;%I is (0,1)
((AND (EQ (CAAR E) 'MEXPT) (EQ (CADR E) '$%E))
(LIST '($EXP SIMP) (FORTSCAN (CADDR E))))
((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADDR E) 1//2))
(LIST '(%SQRT SIMP) (FORTSCAN (CADR E))))
((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADDR E) -1//2))
(LIST '(MQUOTIENT SIMP) 1 (LIST '(%SQRT SIMP) (FORTSCAN (CADR E)))))
((AND (EQ (CAAR E) 'MTIMES) (RATNUMP (CADR E))
(MEMBER (CADADR E) '(1 -1)))
(COND ((EQUAL (CADADR E) 1) (FORTSCAN-MTIMES E))
(T (LIST '(MMINUS SIMP) (FORTSCAN-MTIMES E)))))
((EQ (CAAR E) 'RAT)
(LIST '(MQUOTIENT SIMP) (FLOAT (CADR E)) (FLOAT (CADDR E))))
((EQ (CAAR E) 'MRAT) (FORTSCAN (RATDISREP E)))
;; complex numbers to f77 syntax a+b%i ==> (a,b)
((and (memq (caar e) '(mtimes mplus))
((lambda (a)
(and (numberp (cadr a))
(numberp (caddr a))
(not (zerop1 (cadr a)))
(list '(mprogn) (caddr a) (cadr a))))
(simplify ($bothcoef e '$%i)))))
(T (CONS (CAR E) (MAPCAR 'FORTSCAN (CDR E))))))
(DEFUN FORTSCAN-MTIMES (E)
(LIST '(MQUOTIENT SIMP)
(COND ((NULL (CDDDR E)) (FORTSCAN (CADDR E)))
(T (CONS (CAR E) (MAPCAR 'FORTSCAN (CDDR E)))))
(FLOAT (CADDR (CADR E)))))
;; Takes a name and a matrix and prints a sequence of Fortran assignment
;; statements of the form
;; NAME(I,J) = <corresponding matrix element>
(DEFMFUN $FORTMX (NAME MAT &OPTIONAL (STREAM #-LISPM NIL #+LISPM STANDARD-OUTPUT)
&AUX ($LOADPRINT NIL))
(DECLARE (FIXNUM I J))
(COND ((NOT (EQ (TYPEP NAME) 'SYMBOL))
(MERROR "~%First argument to FORTMX must be a symbol."))
((NOT ($MATRIXP MAT))
(MERROR "Second argument to FORTMX not a matrix: ~M" MAT)))
(DO ((MAT (CDR MAT) (CDR MAT)) (I 1 (1+ I))) ((NULL MAT))
(DO ((M (CDAR MAT) (CDR M)) (J 1 (1+ J))) ((NULL M))
(FORTRAN-PRINT `((MEQUAL) ((,NAME) ,I ,J) ,(CAR M)) STREAM)))
'$DONE)
;; Local Modes:
;; Comment Column:26
;; End:

599
src/mrg/gram.5 Normal file
View File

@@ -0,0 +1,599 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module gram)
;(includef (cond ((status feature ITS) "libmax;prelud >")
; ((status feature TOPS-20) "<libmax>prelude.lisp")
; ((status feature Multics) "prelude")
; ((status feature Unix) "libmax//prelud.l")
; (t (error "Unknown system -- see MC:LIBMAX;INCLUD >"))))
(DECLARE (GENPREFIX GRM)
(SPECIAL ST1 STRING MOPL $PROPS ALIASLIST)
(*EXPR MEVAL MEVAL1 GETOP ADD2LNC REMCHK
FULLSTRIP1 STRING* WNA-ERR GETOPR REMPROPCHK $LISTP))
;; "First character" and "Pop character"
(DEFMACRO FIRST-C () `(FIRST STRING))
(DEFMACRO POP-C () `(POP STRING))
(DEFMACRO MATCH (X) `(GET ,X 'MATCH))
(DEFMVAR $PARSEWINDOW 10.
"The maximum number of 'lexical tokens' that are printed out on
each side of the error-point when a syntax (parsing) error occurs. This
option is especially useful on slow terminals. Setting it to -1 causes the
entire input string to be printed out when an error occurs."
FIXNUM)
;; This function isn't called directly from anyplace in Macsyma, but some of
;; MRG's macros expand into calls to it. The function makes a symbol's
;; property list look like a structure. If the value to be stored is NIL, then
;; flush the property. Otherwise, store the value under the appropriate
;; property.
(DEFMFUN A-ATOM (BAS SEL VAL)
(COND ((NULL VAL) (REMPROP BAS SEL) NIL)
(T (PUTPROP BAS VAL SEL))))
;; This does the identical thing with args reversed. Flush one of these
;; at some point.
(DEFMFUN CPUT (BAS VAL SEL)
(COND ((NULL VAL) (REMPROP BAS SEL) NIL)
(T (PUTPROP BAS VAL SEL))))
;; Like ASSOC, but uses ALIKE1 as the comparison predicate rather than
;; EQUAL. (ASSOL ITEM ALIST) = (ASS #'ALIKE1 ITEM ALIST)
(DEFMFUN ASSOL (ITEM ALIST)
(DOLIST (PAIR ALIST)
(IF (ALIKE1 ITEM (CAR PAIR)) (RETURN PAIR))))
;; KMP: Note that my SUPRV no longer binds LINELABLE -- this should be fixed
(DEFUN GRAM (ST1) (DECLARE (SPECIAL ST1)) (PARSE '$ANY 0))
(DEFUN PARSE (MODE RBP)
(DO ((LEFT (IF (OPERATORP (FIRST-C)) (NUD (POP-C)) (CONS '$ANY (POP-C)))
(LED (POP-C) LEFT)))
((>= RBP (LBP (FIRST-C))) (CONVERT LEFT MODE))))
(DEFUN PARSE-PREFIX (OP)
(LIST (POS OP) (LIST OP) (PARSE (RPOS OP) (RBP OP))))
(DEFUN PARSE-POSTFIX (OP L)
(LIST (POS OP) (LIST OP) (CONVERT L (LPOS OP))))
(DEFUN PARSE-INFIX (OP L)
(LIST (POS OP) (LIST OP) (CONVERT L (LPOS OP)) (PARSE (RPOS OP) (RBP OP))))
(DEFUN PARSE-NARY (OP L)
(CONS (POS OP) (CONS (LIST OP) (CONS (CONVERT L (LPOS OP)) (PRSNARY OP (LPOS OP) (LBP OP))))))
(DEFUN PARSE-MATCHFIX (OP)
(CONS (POS OP) (CONS (LIST OP) (PRSMATCH (MATCH OP) (LPOS OP)))))
(DEFUN PARSE-NOFIX (OP) (LIST (POS OP) (LIST OP)))
(DEFUN PRSNARY (OP MODE RBP)
(DO ((NL (LIST (PARSE MODE RBP)) (CONS (PARSE MODE RBP) NL)))
((NOT (EQ OP (FIRST-C))) (NREVERSE NL))
(POP-C)))
(DEFUN PRSMATCH (MATCH MODE)
(COND ((EQ MATCH (FIRST-C)) (POP-C) NIL)
(T (DO ((NL (LIST (PARSE MODE 10.)) (CONS (PARSE MODE 10.) NL)))
((EQ MATCH (FIRST-C)) (POP-C) (NREVERSE NL))
(IF (EQ '$/, (FIRST-C)) (POP-C) (MRP-ERR MATCH))))))
(DEFUN CONVERT (ITEM MODE)
(IF (OR (EQ MODE (CAR ITEM)) (EQ '$ANY MODE) (EQ '$ANY (CAR ITEM)))
(CDR ITEM)
(PARSE-ERR)))
(DEFUN OPERATORP (LEX) (OR (GET LEX 'LED) (GET LEX 'NUD)))
(DEFUN OPERATORP1 (LEX) (OR (GET LEX 'LED) (GET LEX 'NUD)
(GET LEX 'LBP) (GET LEX 'RBP)))
(DEFUN NUD (OP) (IF (GET OP 'NUD) (FUNCALL (GET OP 'NUD) OP) (UDN-ERR OP)))
(DEFUN LED (OP L) (IF (GET OP 'LED) (FUNCALL (GET OP 'LED) OP L) (UDL-ERR OP)))
(DEFMFUN LBP (LEX) (COND ((GET LEX 'LBP)) (T 200.)))
(DEFMFUN RBP (LEX) (COND ((GET LEX 'RBP)) (T 200.)))
(DEFUN LPOS (OP) (COND ((GET OP 'LPOS)) (T '$ANY)))
(DEFUN RPOS (OP) (COND ((GET OP 'RPOS)) (T '$ANY)))
(DEFUN POS (OP) (COND ((GET OP 'POS)) (T '$ANY)))
;; This is all going to have to be made to signal if it is to work thorough
;; ZWEI or a display front end. We can't pass format strings in MacLisp, and
;; we can't pass symbols either (address space). So I guess we use a
;; PARSE-ERROR macro which becomes PRINC on ITS. This doesn't solve the
;; problem for the ITS display front end, unless separate fasl files are used.
(DEFUN PARSE-ERR ()
(MTELL "~%Syntax err")
(PRSYNERR))
(DEFUN MO-ERR (OP) OP ;Ignored
(MTELL "~%Missing operand")
(PRSYNERR))
(DEFUN MRP-ERR (MATCH)
(TERPRI)
(PRINC '|Missing "|) (PRINC (FULLSTRIP1 MATCH)) (PRINC '|"|)
(PRSYNERR))
(DEFUN ERP-ERR (OP L) OP L ;Ignored
(MTELL "~%Too many )")
(PRSYNERR))
(DEFUN ERB-ERR (OP L) OP L ;Ignored
(MTELL "~%Too many ]")
(PRSYNERR))
(DEFUN UDN-ERR (OP)
(TERPRI)
(PRINC '/") (PRINC (FULLSTRIP1 OP)) (PRINC '|" is not a prefix operator|)
(PRSYNERR))
(DEFUN UDL-ERR (OP)
(TERPRI)
(PRINC '/") (PRINC (FULLSTRIP1 OP)) (PRINC '|" is not an infix operator|)
(PRSYNERR))
(DEFUN DELIM-ERR (OP) OP ;Ignored
(MTELL "~%Illegal use of delimiter")
(PRSYNERR))
(DEFUN PRSYNERR ()
(IF (NULL STRING) (RPLACA (LAST ST1) '**$**)
(RPLACD STRING (CONS (CAR STRING) (CDR STRING)))
(RPLACA STRING '**$**)
(RPLACA (LAST ST1) '/ ))
(TERPRI)
(COND ((NOT (= $PARSEWINDOW 0))
(COND ((NOT (= $PARSEWINDOW -1))
(COND ((NOT (NULL STRING))
(DO ((STR (LIST NIL) (CONS (CAR S) STR))
(S (CDR STRING) (CDR S)))
((OR (NULL S) (> (LENGTH STR) $PARSEWINDOW))
(RPLACD STRING (CDR (NREVERSE STR)))))))
(DO ((STR ST1 (CDR STR)))
((NOT (> (- (LENGTH STR) (LENGTH (MEMBER '**$** STR)))
$PARSEWINDOW))
(SETQ ST1 STR)))))
(MAPC '(LAMBDA (L) (PRINC (FULLSTRIP1 L)) (PRINC '/ )) ST1)
(TERPRI)))
(PRINC "Please rephrase or edit")
(COND ((NOT (= $PARSEWINDOW 0)) (TERPRI)))
(ERR))
(DEFMFUN DEFINE-SYMBOL (SYM)
(PROG (DUMMY LEN X Y)
(SETQ DUMMY (CDR (EXPLODEC SYM)) SYM (IMPLODE (CONS '$ DUMMY))
LEN (LENGTH DUMMY))
(COND ((= 2 LEN)
(COND ((NOT (AND (SETQ X (GET (CAR DUMMY) 'OP2C))
(ASSOC (GETCHARN (CADR DUMMY) 1) X)))
(PUTPROP (CAR DUMMY)
(CONS (CONS (GETCHARN (CADR DUMMY) 1) SYM)
(GET (CAR DUMMY) 'OP2C))
'OP2C))))
((= 3 LEN)
(COND ((NOT (AND (SETQ X (GET (CAR DUMMY) 'OP3C))
(ASSOC (SETQ Y (MAPCAR #'(LAMBDA (X) (GETCHARN X 1))
(CDR DUMMY)))
X)))
(PUTPROP (CAR DUMMY)
(CONS (CONS Y SYM) (GET (CAR DUMMY) 'OP3C))
'OP3C)))))
(RETURN SYM)))
(DEFUN KILL-OPERATOR (OP)
(REMPROP OP 'NUD) (REMPROP OP 'LED)
(REMPROP OP 'LBP) (REMPROP OP 'RBP)
(REMPROP OP 'LPOS) (REMPROP OP 'RPOS) (REMPROP OP 'POS)
(REMPROP OP 'GRIND)
(REMPROP OP 'DIMENSION) (REMPROP OP 'DISSYM)
(LET ((OPR (GET OP 'OP))) (REMPROP OP 'OP) (REMPROP OPR 'OPR) (REMPROPCHK OPR))
(SETQ OP ($NOUNIFY OP))
(REMPROP OP 'DIMENSION) (REMPROP OP 'DISSYM)
(REMPROP OP 'LBP) (REMPROP OP 'RBP))
(DEFPROP $[ NUD-$[ NUD)
(DEFPROP $[ LED-$[ LED)
(DEFPROP $[ 200. LBP)
(DEFPROP $] DELIM-ERR NUD)
(DEFPROP $] ERB-ERR LED)
(DEFPROP $] 5. LBP)
(DEFUN NUD-$[ (OP) OP ;Ignored
(CONS '$ANY (CONS '(MLIST) (PRSMATCH '$] '$ANY))))
(DEFUN LED-$[ (OP LEFT) OP ;Ignored
(PROG (RIGHT)
(IF (NUMBERP (CDR LEFT)) (PARSE-ERR))
(SETQ RIGHT (PRSMATCH '$] '$ANY))
(COND ((NULL RIGHT) (NSUB-ERR))
((ATOM (CDR LEFT))
(SETQ RIGHT (CONS (LIST (CONVERT LEFT '$ANY) 'ARRAY) RIGHT))
(RETURN (CONS '$ANY (COND ((CDR (ASSOL RIGHT ALIASLIST)))
(T RIGHT)))))
(T (RETURN (CONS '$ANY (CONS '(MQAPPLY ARRAY) (CONS (CONVERT LEFT '$ANY) RIGHT))))))))
(DEFUN NSUB-ERR ()
(MTELL "~%No subscripts given")
(PRSYNERR))
(DEFPROP $/( NUD-$/( NUD)
(DEFPROP $/( LED-$/( LED)
(DEFPROP $/( 200. LBP)
(DEFPROP $/) DELIM-ERR NUD)
(DEFPROP $/) ERP-ERR LED)
(DEFPROP $/) 5. LBP)
(DEFUN NUD-$/( (OP) OP ;Ignored
(LET ((RIGHT))
(COND ((EQ '$/) (FIRST-C)) (PARSE-ERR))
((OR (NULL (SETQ RIGHT (PRSMATCH '$/) '$ANY))) (CDR RIGHT))
(CONS '$ANY (CONS '(MPROGN) RIGHT)))
(T (CONS '$ANY (CAR RIGHT))))))
(DEFUN LED-$/( (OP LEFT) OP ;Ignored
(LET ((R))
(IF (NUMBERP (CDR LEFT)) (PARSE-ERR))
(SETQ R (PRSMATCH '$/) '$ANY) LEFT (CDR LEFT))
(CONS '$ANY
(COND ((NOT (ATOM LEFT)) (CONS '(MQAPPLY) (CONS LEFT R)))
((AND (EQ '$DIFF LEFT) (CDR R) (NULL (CDDR R)))
(CONS '($DIFF) R))
((EQ '& (GETCHAR LEFT 1))
(CONS (LIST (COND ((GET LEFT 'OPR))
(T ((LAMBDA (DUMMY)
(PUTPROP DUMMY LEFT 'OP)
(PUTPROP LEFT DUMMY 'OPR)
(ADD2LNC LEFT $PROPS)
DUMMY)
(IMPLODE (CONS '$ (CDR (EXPLODEN LEFT))))))))
R))
(T (CONS (LIST LEFT) R))))))
(DEFPROP $/' NUD-$/' NUD)
(DEFUN NUD-$/' (OP) OP ;Ignored
(PROG (RIGHT)
(RETURN (COND ((EQ '$/( (FIRST-C))
(LIST '$ANY '(MQUOTE) (PARSE '$ANY 190.)))
((OR (ATOM (SETQ RIGHT (PARSE '$ANY 190.)))
(MEMQ (CAAR RIGHT) '(MQUOTE MLIST MPROG MPROGN LAMBDA)))
(LIST '$ANY '(MQUOTE) RIGHT))
((EQ 'MQAPPLY (CAAR RIGHT))
(COND ((EQ (CAAADR RIGHT) 'LAMBDA)
(LIST '$ANY '(MQUOTE) RIGHT))
(T (RPLACA (CDR RIGHT)
(CONS (CONS ($NOUNIFY (CAAADR RIGHT)) (CDAADR RIGHT))
(CDADR RIGHT)))
(CONS '$ANY RIGHT))))
(T (CONS '$ANY (CONS (CONS ($NOUNIFY (CAAR RIGHT)) (CDAR RIGHT))
(CDR RIGHT))))))))
(DEFPROP $/'/' NUD-$/'/' NUD)
(DEFUN NUD-$/'/' (OP) OP ;Ignored
(PROG (RIGHT)
(RETURN
(CONS '$ANY (COND ((EQ '$/( (FIRST-C)) (MEVAL (PARSE '$ANY 190.)))
((ATOM (SETQ RIGHT (PARSE '$ANY 190.))) (MEVAL1 RIGHT))
((EQ 'MQAPPLY (CAAR RIGHT))
(RPLACA (CDR RIGHT) (CONS (CONS ($VERBIFY (CAAADR RIGHT)) (CDAADR RIGHT)) (CDADR RIGHT)))
RIGHT)
(T (CONS (CONS ($VERBIFY (CAAR RIGHT)) (CDAR RIGHT)) (CDR RIGHT))))))))
(DEFPROP $/: LED-$/: LED)
(DEFPROP $/: 180. LBP)
(DEFUN LED-$/: (OP LEFT) OP ;Ignored
(LIST '$ANY '(MSETQ) (CONVERT LEFT '$ANY) (PARSE '$ANY 20.)))
(DEFPROP $/:/: LED-$/:/: LED)
(DEFPROP $/:/: 180. LBP)
(DEFUN LED-$/:/: (OP LEFT) OP ;Ignored
(LIST '$ANY '(MSET) (CONVERT LEFT '$ANY) (PARSE '$ANY 20.)))
(DEFPROP $/:= LED-$/:= LED)
(DEFPROP $/:= 180. LBP)
(DEFUN LED-$/:= (OP LEFT) OP ;Ignored
(COND ((ATOM (CDR LEFT)) (ATM-ERR))
(T (LIST '$ANY '(MDEFINE) (CONVERT LEFT '$ANY) (PARSE '$ANY 20.)))))
(DEFPROP $/:/:= LED-$/:/:= LED)
(DEFPROP $/:/:= 180. LBP)
(DEFUN LED-$/:/:= (OP LEFT) OP ;Ignored
(LIST '$ANY '(MDEFMACRO) (CONVERT LEFT '$ANY) (PARSE '$ANY 20.)))
(DEFUN ATM-ERR ()
(TERPRI)
(PRINC '|Atom passed to ":=" or "::="; try ":"|)
(PRSYNERR))
(DEFPROP $/! LED-$/! LED)
(DEFPROP $/! 160. LBP)
(DEFUN LED-$/! (OP LEFT) OP ;Ignored
(LIST '$EXPR '(MFACTORIAL) (CONVERT LEFT '$EXPR)))
(DEFPROP $/!/! LED-$/!/! LED)
(DEFPROP $/!/! 160. LBP)
(DEFUN LED-$/!/! (OP LEFT) OP ;Ignored
(LIST '$EXPR '($GENFACT) (CONVERT LEFT '$EXPR)
(LIST '(MQUOTIENT) (CONVERT LEFT '$EXPR) 2) 2))
(DEFPROP $^ LED-$^ LED)
(DEFPROP $^ 140. LBP)
(DEFPROP $** LED-$^ LED)
(DEFPROP $** 140. LBP)
(DEFUN LED-$^ (OP LEFT) OP ;Ignored
(SETQ LEFT (LIST '(MEXPT) (CONVERT LEFT '$EXPR)
(COND ((EQ '$- (FIRST-C)) (POP-C) (LIST '(MMINUS) (PARSE '$EXPR 139.)))
(T (PARSE '$EXPR 139.)))))
(CONS '$EXPR (COND ((CDR (ASSOL LEFT ALIASLIST))) (T LEFT))))
(DEFPROP $^^ LED-$^^ LED)
(DEFPROP $^^ 135. LBP)
(DEFUN LED-$^^ (OP LEFT) OP ;Ignored
(SETQ LEFT (LIST '(MNCEXPT) (CONVERT LEFT '$EXPR)
(IFN (EQ '$- (FIRST-C)) (PARSE '$EXPR 134.)
(POP-C) (LIST '(MMINUS) (PARSE '$EXPR 134.)))))
(CONS '$EXPR (COND ((CDR (ASSOL LEFT ALIASLIST))) (T LEFT))))
(DEFPROP $/. LED-$/. LED)
(DEFPROP $/. 130. LBP)
(DEFUN LED-$/. (OP LEFT) OP ;Ignored
(LIST '$EXPR '(MNCTIMES) (CONVERT LEFT '$EXPR) (PARSE '$EXPR 129.)))
(DEFPROP $* LED-$* LED)
(DEFPROP $* 120. LBP)
(DEFUN LED-$* (OP LEFT) OP ;Ignored
(LIST* '$EXPR '(MTIMES) (CONVERT LEFT '$EXPR) (PRSNARY '$* '$EXPR 120.)))
(DEFPROP $// LED-$// LED)
(DEFPROP $// 120. LBP)
(DEFUN LED-$// (OP LEFT) OP ;Ignored
(LIST '$EXPR '(MQUOTIENT) (CONVERT LEFT '$EXPR) (PARSE '$EXPR 120.)))
(DEFPROP $+ NUD-$+ NUD)
(DEFPROP $+ LED-$+ LED)
(DEFPROP $+ 100. LBP)
(DEFUN NUD-$+ (OP) OP ;Ignored
(COND ((MEMQ (FIRST-C) '($+ $-)) (PARSE-ERR))
(T (LIST '$EXPR '(MPLUS) (PARSE '$EXPR 100.)))))
(DEFUN LED-$+ (OP LEFT) OP ;Ignored
(DO ((NL (LIST (PARSE '$EXPR 100.) (CONVERT LEFT '$EXPR))))
(NIL)
(COND ((EQ '$+ (FIRST-C)) (POP-C) (SETQ NL (CONS (PARSE '$EXPR 100.) NL)))
((EQ '$- (FIRST-C)) (POP-C)
(SETQ NL (CONS (LIST '(MMINUS) (PARSE '$EXPR 100.)) NL)))
(T (RETURN (CONS '$EXPR (CONS '(MPLUS) (NREVERSE NL))))))))
(DEFPROP $- NUD-$- NUD)
(DEFPROP $- LED-$- LED)
(DEFPROP $- 100. LBP)
(DEFUN NUD-$- (OP) OP ;Ignored
(IF (EQ '$+ (FIRST-C)) (PARSE-ERR)
(LIST '$EXPR '(MMINUS) (PARSE '$EXPR 100.))))
(DEFUN LED-$- (OP LEFT) OP ;Ignored
(DO ((NL (LIST (LIST '(MMINUS) (PARSE '$EXPR 100.)) (CONVERT LEFT '$EXPR)))) (NIL)
(COND ((EQ '$+ (FIRST-C)) (POP-C)
(SETQ NL (CONS (PARSE '$EXPR 100.) NL)))
((EQ '$- (FIRST-C)) (POP-C)
(SETQ NL (CONS (LIST '(MMINUS) (PARSE '$EXPR 100.)) NL)))
(T (RETURN (CONS '$EXPR (CONS '(MPLUS) (NREVERSE NL))))))))
(DEFPROP $= LED-$= LED)
(DEFPROP $= 80. LBP)
(DEFUN LED-$= (OP LEFT) OP ;Ignored
`($CLAUSE (MEQUAL) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
(DEFPROP $/# LED-$/# LED)
(DEFPROP $/# 80. LBP)
(DEFUN LED-$/# (OP LEFT) OP ;Ignored
`($CLAUSE (MNOTEQUAL) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
(DEFPROP $/> NUD-$/> NUD)
(DEFUN NUD-$/> (OP) OP ;Ignored
'($ANY . $/>))
(DEFPROP $/> LED-$/> LED)
(DEFPROP $/> 80. LBP)
(DEFUN LED-$/> (OP LEFT) OP ;Ignored
`($CLAUSE (MGREATERP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
(DEFPROP $/>= LED-$/>= LED)
(DEFPROP $/>= 80. LBP)
(DEFUN LED-$/>= (OP LEFT) OP ;Ignored
`($CLAUSE (MGEQP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
(DEFPROP $/< LED-$/< LED)
(DEFPROP $/< 80. LBP)
(DEFUN LED-$/< (OP LEFT) OP ;Ignored
`($CLAUSE (MLESSP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
(DEFPROP $/<= LED-$/<= LED)
(DEFPROP $/<= 80. LBP)
(DEFUN LED-$/<= (OP LEFT) OP ;Ignored
`($CLAUSE (MLEQP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
(DEFPROP $NOT NUD-$NOT NUD)
(DEFUN NUD-$NOT (OP) OP ;Ignored
`($CLAUSE (MNOT) ,(PARSE '$CLAUSE 70.)))
(DEFPROP $AND LED-$AND LED)
(DEFPROP $AND 60. LBP)
(DEFUN LED-$AND (OP LEFT) OP ;Ignored
`($CLAUSE (MAND) ,(CONVERT LEFT '$CLAUSE) . ,(PRSNARY '$AND '$CLAUSE 60.)))
(DEFPROP $OR LED-$OR LED)
(DEFPROP $OR 50. LBP)
(DEFUN LED-$OR (OP LEFT) OP ;Ignored
`($CLAUSE (MOR) ,(CONVERT LEFT '$CLAUSE) . ,(PRSNARY '$OR '$CLAUSE 50.)))
(DEFPROP $/, LED-$/, LED)
(DEFPROP $/, 10. LBP)
(DEFUN LED-$/, (OP LEFT) OP ;Ignored
`($ANY ($EV) ,(CONVERT LEFT '$ANY) . ,(PRSNARY '$/, '$ANY 10.)))
(DEFPROP $IF NUD-$IF NUD)
(DEFPROP $THEN DELIM-ERR NUD)
(DEFPROP $THEN 5. LBP)
(DEFPROP $ELSE DELIM-ERR NUD)
(DEFPROP $ELSE 5. LBP)
(DEFUN NUD-$IF (OP) OP ;Ignored
(LIST '$ANY '(MCOND)
(PARSE '$CLAUSE 45.)
(COND ((EQ '$THEN (FIRST-C)) (POP-C) (PARSE '$ANY 25.)) (T (MTHEN-ERR)))
T
(COND ((EQ '$ELSE (FIRST-C)) (POP-C) (PARSE '$ANY 25.)) (T '$FALSE))))
(DEFUN MTHEN-ERR ()
(TERPRI)
(PRINC '|Missing "THEN"|)
(PRSYNERR))
(DEFPROP $FOR NUD-$DO NUD)
(DEFPROP $FOR 30. LBP)
(DEFPROP $FROM NUD-$DO NUD)
(DEFPROP $FROM 30. LBP)
(DEFPROP $STEP NUD-$DO NUD)
(DEFPROP $STEP 30. LBP)
(DEFPROP $NEXT NUD-$DO NUD)
(DEFPROP $NEXT 30. LBP)
(DEFPROP $THRU NUD-$DO NUD)
(DEFPROP $THRU 30. LBP)
(DEFPROP $UNLESS NUD-$DO NUD)
(DEFPROP $UNLESS 30. LBP)
(DEFPROP $WHILE NUD-$DO NUD)
(DEFPROP $WHILE 30. LBP)
(DEFPROP $DO NUD-$DO NUD)
(DEFPROP $DO 30. LBP)
;; A hand-made DEFSTRUCT for dealing with the Macsyma MDO structure.
;; The new opers package will provide these macros.
(DEFMACRO MAKE-MDO () '(LIST '$ANY (LIST 'MDO) NIL NIL NIL NIL NIL NIL NIL))
(DEFMACRO MDO-OP (X) `(CAR (CADR ,X)))
(DEFMACRO MDO-FOR (X) `(CAR (CDDR ,X)))
(DEFMACRO MDO-FROM (X) `(CAR (CDDDR ,X)))
(DEFMACRO MDO-STEP (X) `(CAR (CDDDDR ,X)))
(DEFMACRO MDO-NEXT (X) `(CAR (CDR (CDDDDR ,X))))
(DEFMACRO MDO-THRU (X) `(CAR (CDDR (CDDDDR ,X))))
(DEFMACRO MDO-UNLESS (X) `(CAR (CDDDR (CDDDDR ,X))))
(DEFMACRO MDO-BODY (X) `(CAR (CDDDDR (CDDDDR ,X))))
(DEFUN NUD-$DO (LEX)
(DO ((OP LEX (POP-C)) (LEFT (MAKE-MDO)))
((EQ '$DO OP) (SETF (MDO-BODY LEFT) (PARSE '$ANY 25.)) LEFT)
(COND ((AND (EQ '$FOR OP) (NULL (MDO-FOR LEFT)))
(SETF (MDO-FOR LEFT) (PARSE '$ANY 200.)))
((AND (OR (EQ '$FROM OP) (EQ '$/: OP))
(NULL (MDO-FROM LEFT))
(EQ 'MDO (MDO-OP LEFT)))
(SETF (MDO-FROM LEFT) (PARSE '$ANY 95.)))
((AND (EQ '$IN OP) (NULL (MDO-STEP LEFT)) (NULL (MDO-NEXT LEFT)))
(SETF (MDO-OP LEFT) 'MDOIN)
(SETF (MDO-FROM LEFT) (PARSE '$ANY 95.)))
((AND (EQ '$STEP OP) (NULL (MDO-STEP LEFT)) (NULL (MDO-NEXT LEFT))
(EQ 'MDO (MDO-OP LEFT)))
(SETF (MDO-STEP LEFT) (PARSE '$EXPR 95.)))
((AND (EQ '$NEXT OP) (NULL (MDO-NEXT LEFT)) (NULL (MDO-STEP LEFT))
(EQ 'MDO (MDO-OP LEFT)))
(SETF (MDO-NEXT LEFT) (PARSE '$ANY 45.)))
((AND (EQ '$THRU OP) (NULL (MDO-THRU LEFT)))
(SETF (MDO-THRU LEFT) (PARSE '$EXPR 95.)))
((EQ '$WHILE OP)
(SETF (MDO-UNLESS LEFT)
(COND ((NULL (MDO-UNLESS LEFT)) (LIST '(MNOT) (PARSE '$CLAUSE 45.)))
(T (LIST '(MOR) (LIST '(MNOT) (PARSE '$CLAUSE 45.))
(MDO-UNLESS LEFT))))))
((EQ '$UNLESS OP)
(SETF (MDO-UNLESS LEFT)
(COND ((NULL (MDO-UNLESS LEFT)) (PARSE '$CLAUSE 45.))
(T (LIST '(MOR) (PARSE '$CLAUSE 45.) (MDO-UNLESS LEFT))))))
(T (PARSE-ERR)))))
(DEFPROP $/; NUD-$/; NUD)
(DEFPROP $/; LED-$/; LED)
(DEFPROP $/; -1 LBP)
(DEFUN NUD-$/; (OP) OP ;Ignored
(MTELL "Premature termination of input.")
(PRSYNERR))
(DEFUN LED-$/; (OP LEFT) OP ;Ignored
(CONVERT LEFT '$ANY))
;; Local Modes:
;; Mode: LISP
;; Comment Col: 40
;; END:

Some files were not shown because too many files have changed in this diff Show More