mirror of
https://github.com/PDP-10/its.git
synced 2026-02-15 12:26:27 +00:00
This fixes the declare command in macsyma.
Also updates a bunch of Macsyma sources to latest versions, which was needed to get declare working with consistent sources. Resolves #960.
This commit is contained in:
Eric Swenson
1320
src/mrg/compar.864
Normal file
1320
src/mrg/compar.864
Normal file
File diff suppressed because it is too large
Load Diff
710
src/mrg/db.1149
Normal file
710
src/mrg/db.1149
Normal file
@@ -0,0 +1,710 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1982 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
|
||||
;; incorrectly. 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))
|
||||
|
||||
;; 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) ;if CL is a symbol or
|
||||
(and (listp cl) ;an interned number, then we want to REMOV4 FACT
|
||||
(numberp (car cl)))) ;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)))
|
||||
#-LISPM (STORE (CONUNMRK CONINDEX) C)
|
||||
#-LISPM (STORE (CONMARK CONINDEX) (CDR C))
|
||||
#+LISPM (SETF (AREF #'CONUNMRK CONINDEX) C)
|
||||
#+LISPM (SETF (AREF #'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))
|
||||
#-LISPM (STORE (CONUNMRK CONINDEX) ())
|
||||
#+LISPM (SETF (AREF #'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))
|
||||
#-LISPM (STORE (CONUNMRK CONINDEX) (CONUNMRK I))
|
||||
#+LISPM (SETF (AREF #'CONUNMRK CONINDEX) (CONUNMRK I))
|
||||
#-LISPM (STORE (CONMARK CONINDEX) (CONMARK I))
|
||||
#+LISPM (SETF (AREF #'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 (SEL FACT WN)) (MARK+1 CL LAB FACT))
|
||||
((ONP (SEL FACT WN) WORLD) (MARK+1 CL LAB FACT))
|
||||
((OFFP (SEL FACT WN) 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- (SEL DAT WN) 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 (SEL FACT WN)) (MARK-1 CL LAB FACT))
|
||||
((ONP (SEL FACT WN) WORLD) (MARK-1 CL LAB FACT))
|
||||
((OFFP (SEL FACT WN) 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))
|
||||
|
||||
1589
src/mrg/displa.780
Normal file
1589
src/mrg/displa.780
Normal file
File diff suppressed because it is too large
Load Diff
158
src/mrg/fortra.66
Normal file
158
src/mrg/fortra.66
Normal file
@@ -0,0 +1,158 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1976, 1983 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)
|
||||
|
||||
;;; Output the EXP to the editor buffer Macsyma-Generated-Fortran.
|
||||
#+LispM
|
||||
(DEFMSPEC $FORTRAN_TO_EDITOR (EXP)
|
||||
(ZWEI:WITH-EDITOR-STREAM (STANDARD-OUTPUT ':BUFFER-NAME "Macsyma-Generated-Fortran")
|
||||
(FUNCALL (GET '$FORTRAN 'MFEXPR*) EXP)))
|
||||
|
||||
;; 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 modify 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.
|
||||
|
||||
(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)
|
||||
|
||||
|
||||
565
src/mrg/gram.487
Normal file
565
src/mrg/gram.487
Normal file
@@ -0,0 +1,565 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module gram)
|
||||
|
||||
;;; Notes:
|
||||
;;;
|
||||
;;; KMP 12/14/80 -- Modified $DO and friends (things with NUD prop of NUD-$DO)
|
||||
;;; to have an LBP of 5. instead 30. New operators introduced
|
||||
;;; after this time should have an LBP of 5 if they have an
|
||||
;;; NUD but no LED property unless there is a *very* good
|
||||
;;; reason for that not to be so.
|
||||
;;;
|
||||
;;; Note also that the binding powers for - are incorrectly
|
||||
;;; set also. New operators with LBP's in the range 120.-130.
|
||||
;;; should beware of this. My new parser scheme has the
|
||||
;;; correction for this. It's too much pain right now to
|
||||
;;; integrate the correct thing into this parser. Due to some
|
||||
;;; inelegant and inefficient patches to special-case "-" here
|
||||
;;; and there throughout this code, the user doesn't see the
|
||||
;;; difference, so we can live with current lossage for now.
|
||||
|
||||
|
||||
|
||||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||||
|
||||
(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 CONVERT-$ANY (X) `(CDR ,X))
|
||||
|
||||
(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)
|
||||
|
||||
|
||||
(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 through
|
||||
;; 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.
|
||||
|
||||
;; N.B. Format strings can now be passed in Maclisp on ITS due to the
|
||||
;; out-of-core error-string system. So whoever wrote the above comment
|
||||
;; might want to do something about it. -gjc
|
||||
|
||||
(DEFUN PARSE-ERR ()
|
||||
(MTELL-OPEN "~%Syntax error") (PRSYNERR))
|
||||
|
||||
(DEFUN MRP-ERR (MATCH)
|
||||
(MTELL-OPEN "~%Missing /"~A/"" (STRIPDOLLAR MATCH))
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN ERP-ERR (OP L) OP L ;Ignored
|
||||
(MTELL-OPEN "~%Too many /)")
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN ERB-ERR (OP L) OP L ;Ignored
|
||||
(MTELL-OPEN "~%Too many ]")
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN UDN-ERR (OP)
|
||||
(MTELL-OPEN "~%/"~A/" is not a prefix operator." (FULLSTRIP1 OP))
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN UDL-ERR (OP)
|
||||
(MTELL-OPEN "~%/"~A/" is not an infix operator." (FULLSTRIP1 OP))
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN DELIM-ERR (OP) OP ;Ignored
|
||||
(MTELL-OPEN "~%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)) (TYO #\SPACE)) ST1)
|
||||
(TERPRI)))
|
||||
(PRINC "Please rephrase or edit.")
|
||||
(IF (NOT (= $PARSEWINDOW 0)) (TERPRI))
|
||||
(MERROR ""))
|
||||
|
||||
(DEFMFUN DEFINE-SYMBOL (SYM)
|
||||
(PROG (DUMMY LEN X Y)
|
||||
(SETQ DUMMY (MAPCAR 'ASCII (CASIFY-EXPLODEN SYM))
|
||||
SYM (IMPLODE (CONS '$ DUMMY))
|
||||
LEN (LENGTH DUMMY))
|
||||
(COND ((= LEN 2)
|
||||
(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))))
|
||||
((= LEN 3)
|
||||
(SETQ Y (MAPCAR #'(LAMBDA (X) (GETCHARN X 1)) (CDR DUMMY)))
|
||||
(COND ((NOT (AND (SETQ X (GET (CAR DUMMY) 'OP3C))
|
||||
(ASSOC Y X)))
|
||||
(PUTPROP (CAR DUMMY)
|
||||
(CONS (CONS Y SYM) (GET (CAR DUMMY) 'OP3C))
|
||||
'OP3C))))
|
||||
; ((> LEN 3) ; This error check needs more work. - JPG
|
||||
; (PRINC (FULLSTRIP1 SYM))
|
||||
; (MERROR "~%User defined operators can have at most 3 characters."))
|
||||
)
|
||||
(RETURN SYM)))
|
||||
|
||||
(DEFUN KILL-OPERATOR (OP)
|
||||
(REM OP 'NUD) (REM OP 'LED)
|
||||
(REM OP 'LBP) (REM OP 'RBP)
|
||||
(REM OP 'LPOS) (REM OP 'RPOS) (REM OP 'POS)
|
||||
(REM OP 'GRIND)
|
||||
(REM OP 'DIMENSION) (REM OP 'DISSYM)
|
||||
(LET ((OPR (GET OP 'OP))) (REM OP 'OP) (REM OPR 'OPR) (REMPROPCHK OPR))
|
||||
(SETQ OP ($NOUNIFY OP))
|
||||
(REM OP 'DIMENSION) (REM OP 'DISSYM)
|
||||
(REM OP 'LBP) (REM 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
|
||||
(LET ((RIGHT))
|
||||
(SETQ LEFT (CONVERT-$ANY LEFT))
|
||||
(IF (NUMBERP LEFT) (PARSE-ERR))
|
||||
(SETQ RIGHT (PRSMATCH '$/] '$ANY))
|
||||
(IF (NULL RIGHT) (NSUB-ERR))
|
||||
(CONS '$ANY
|
||||
(COND ((ATOM LEFT)
|
||||
(SETQ RIGHT (CONS (LIST (AMPERCHK LEFT) 'ARRAY) RIGHT))
|
||||
(OR (CDR (ASSOL RIGHT ALIASLIST)) RIGHT))
|
||||
(T (LIST* '(MQAPPLY ARRAY) LEFT RIGHT))))))
|
||||
|
||||
(DEFUN NSUB-ERR ()
|
||||
(MTELL-OPEN "~%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))
|
||||
(IF (EQ (FIRST-C) '$/)) (PARSE-ERR))
|
||||
(CONS '$ANY
|
||||
(COND ((OR (NULL (SETQ RIGHT (PRSMATCH '$/) '$ANY))) (CDR RIGHT))
|
||||
(CONS '(MPROGN) RIGHT))
|
||||
(T (CAR RIGHT))))))
|
||||
|
||||
(DEFUN LED-$/( (OP LEFT) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(SETQ LEFT (CONVERT-$ANY LEFT))
|
||||
(IF (NUMBERP LEFT) (PARSE-ERR))
|
||||
(SETQ RIGHT (PRSMATCH '$/) '$ANY))
|
||||
(CONS '$ANY
|
||||
(COND ((ATOM LEFT) (CONS (NCONS (AMPERCHK LEFT)) RIGHT))
|
||||
(T (LIST* '(MQAPPLY) LEFT RIGHT))))))
|
||||
|
||||
(DEFPROP $/' NUD-$/' NUD)
|
||||
|
||||
(DEFUN NUD-$/' (OP) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(CONS '$ANY
|
||||
(COND ((EQ (FIRST-C) '$/()
|
||||
(LIST '(MQUOTE) (PARSE '$ANY 190.)))
|
||||
((OR (ATOM (SETQ RIGHT (PARSE '$ANY 190.)))
|
||||
(MEMQ (CAAR RIGHT)
|
||||
'(MQUOTE MLIST MPROG MPROGN LAMBDA MDO MDOIN)))
|
||||
(LIST '(MQUOTE) RIGHT))
|
||||
((EQ (CAAR RIGHT) 'MQAPPLY)
|
||||
(COND ((EQ (CAAADR RIGHT) 'LAMBDA)
|
||||
(LIST '(MQUOTE) RIGHT))
|
||||
(T (RPLACA (CDR RIGHT)
|
||||
(CONS (CONS ($NOUNIFY (CAAADR RIGHT))
|
||||
(CDAADR RIGHT))
|
||||
(CDADR RIGHT)))
|
||||
RIGHT)))
|
||||
(T (CONS (CONS ($NOUNIFY (CAAR RIGHT)) (CDAR RIGHT))
|
||||
(CDR RIGHT)))))))
|
||||
|
||||
|
||||
(DEFPROP |$''| |NUD-$''| NUD)
|
||||
|
||||
(DEFUN |NUD-$''| (OP) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(CONS '$ANY
|
||||
(COND ((EQ (FIRST-C) '$/() (MEVAL (PARSE '$ANY 190.)))
|
||||
((ATOM (SETQ RIGHT (PARSE '$ANY 190.))) (MEVAL1 RIGHT))
|
||||
((EQ (CAAR RIGHT) 'MQAPPLY)
|
||||
(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) (CDR LEFT) (PARSE '$ANY 20.)))
|
||||
|
||||
|
||||
(DEFPROP |$::| |LED-$::| LED)
|
||||
(DEFPROP |$::| 180. LBP)
|
||||
|
||||
(DEFUN |LED-$::| (OP LEFT) OP ;Ignored
|
||||
(LIST '$ANY '(MSET) (CDR LEFT) (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) (CDR LEFT) (PARSE '$ANY 20.)))))
|
||||
|
||||
(DEFPROP |$::=| |LED-$::=| LED)
|
||||
(DEFPROP |$::=| 180. LBP)
|
||||
|
||||
(DEFUN |LED-$::=| (OP LEFT) OP ;Ignored
|
||||
(LIST '$ANY '(MDEFMACRO) (CDR LEFT) (PARSE '$ANY 20.)))
|
||||
|
||||
(DEFUN ATM-ERR ()
|
||||
(MTELL-OPEN "~%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 $/. 110. LBP)
|
||||
|
||||
(DEFUN LED-$/. (OP LEFT) OP ;Ignored
|
||||
(LIST '$EXPR '(MNCTIMES) (CONVERT LEFT '$EXPR) (PARSE '$EXPR 109.)))
|
||||
|
||||
(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) ,(CDR LEFT) . ,(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 (TERPRI) (PRINC '|Missing "THEN"|) (PRSYNERR)))
|
||||
T
|
||||
(COND ((EQ '$ELSE (FIRST-C)) (POP-C) (PARSE '$ANY 25.)) (T '$FALSE))))
|
||||
|
||||
(DEFPROP $FOR NUD-$DO NUD)
|
||||
(DEFPROP $FOR 5. LBP)
|
||||
|
||||
(DEFPROP $FROM NUD-$DO NUD)
|
||||
(DEFPROP $FROM 5. LBP)
|
||||
|
||||
(DEFPROP $STEP NUD-$DO NUD)
|
||||
(DEFPROP $STEP 5. LBP)
|
||||
|
||||
(DEFPROP $NEXT NUD-$DO NUD)
|
||||
(DEFPROP $NEXT 5. LBP)
|
||||
|
||||
(DEFPROP $THRU NUD-$DO NUD)
|
||||
(DEFPROP $THRU 5. LBP)
|
||||
|
||||
(DEFPROP $UNLESS NUD-$DO NUD)
|
||||
(DEFPROP $UNLESS 5. LBP)
|
||||
|
||||
(DEFPROP $WHILE NUD-$DO NUD)
|
||||
(DEFPROP $WHILE 5. LBP)
|
||||
|
||||
(DEFPROP $DO NUD-$DO NUD)
|
||||
(DEFPROP $DO 5. LBP)
|
||||
|
||||
(DEFUN NUD-$DO (LEX)
|
||||
(DO ((OP LEX (POP-C)) (LEFT (MAKE-MDO)))
|
||||
((EQ '$DO OP) (SETF (MDO-BODY LEFT) (PARSE '$ANY 25.))
|
||||
(CONS '$ANY 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) (MDO-UNLESS LEFT)
|
||||
(LIST '(MNOT) (PARSE '$CLAUSE 45.)))))))
|
||||
((EQ '$UNLESS OP)
|
||||
(SETF (MDO-UNLESS LEFT)
|
||||
(COND ((NULL (MDO-UNLESS LEFT)) (PARSE '$CLAUSE 45.))
|
||||
(T (LIST '(MOR) (MDO-UNLESS LEFT) (PARSE '$CLAUSE 45.))))))
|
||||
(T (PARSE-ERR)))))
|
||||
|
||||
|
||||
(DEFPROP |$;| |NUD-$;| NUD)
|
||||
(DEFPROP |$;| |LED-$;| LED)
|
||||
(DEFPROP |$;| -1 LBP)
|
||||
|
||||
(DEFUN |NUD-$;| (OP) OP ;Ignored
|
||||
(MTELL-OPEN "Premature termination of input.")
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN |LED-$;| (OP LEFT) OP ;Ignored
|
||||
(CDR LEFT))
|
||||
|
||||
|
||||
;; Local Modes:
|
||||
;; Mode: LISP
|
||||
;; Comment Col: 40
|
||||
;; END:
|
||||
|
||||
427
src/mrg/grind.153
Normal file
427
src/mrg/grind.153
Normal file
@@ -0,0 +1,427 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module grind)
|
||||
|
||||
(DECLARE (GENPREFIX GRI)
|
||||
(SPECIAL LOP ROP STRING CHRPS $ALIASES ALIASLIST LINEL)
|
||||
(FIXNUM (CHRCT*))
|
||||
(*EXPR LBP RBP))
|
||||
|
||||
(DEFUN CHRCT* () (- LINEL CHRPS))
|
||||
|
||||
(DEFVAR ALPHABET '(#/% #/_))
|
||||
(DEFVAR FORTRANP NIL)
|
||||
|
||||
(DEFMSPEC $GRIND (X) (SETQ X (CDR X))
|
||||
(LET (Y)
|
||||
(IF (NOT (ZEROP (CHARPOS T))) (MTERPRI))
|
||||
(COND ((OR (NULL X) (CDR X)) (WNA-ERR '$GRIND))
|
||||
((SYMBOLP (SETQ X (STRMEVAL (CAR X))))
|
||||
(SETQ X ($VERBIFY X))
|
||||
(COND ((SETQ Y (MGET X 'MEXPR))
|
||||
(MGRIND (LIST '(MDEFINE) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
|
||||
((SETQ Y (MGET X 'MMACRO))
|
||||
(MGRIND (LIST '(MDEFMACRO) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
|
||||
((SETQ Y (MGET X 'AEXPR))
|
||||
(MGRIND (LIST '(MDEFINE) (CONS (LIST X 'ARRAY) (CDADR Y)) (CADDR Y)) NIL))
|
||||
(T (MGRIND X NIL)))
|
||||
(TYO #/$ NIL))
|
||||
(T (MGRIND X NIL) (TYO #/$ NIL)))
|
||||
'$DONE))
|
||||
|
||||
(DEFUN MGRIND (X OUT)
|
||||
(SETQ CHRPS 0)
|
||||
(MPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN) OUT))
|
||||
|
||||
(DEFUN MPRINT (X OUT)
|
||||
(COND ((FIXP X) (SETQ CHRPS (1+ CHRPS)) (TYO X OUT))
|
||||
((< (CAR X) (CHRCT*)) (MAPC #'(LAMBDA (L) (MPRINT L OUT)) (CDR X)))
|
||||
(T (PROG (I) (SETQ I CHRPS)
|
||||
(MPRINT (CADR X) OUT)
|
||||
(COND ((NULL (CDDR X)) (RETURN NIL))
|
||||
((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
|
||||
(OR (> (CHRCT*) (// LINEL 2))
|
||||
(ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
|
||||
(SETQ I CHRPS)
|
||||
(MPRINT (CADDR X) OUT))
|
||||
(T (SETQ I (1+ I)) (SETQ CHRPS 0) (TERPRI OUT)
|
||||
(MTYOTBSP I OUT) (MPRINT (CADDR X) OUT)))
|
||||
(DO L (CDDDR X) (CDR L) (NULL L)
|
||||
(IF (OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL
|
||||
(SETQ CHRPS 0) (TERPRI OUT) (MTYOTBSP I OUT))
|
||||
(MPRINT (CAR L) OUT))))))
|
||||
|
||||
(DEFUN MTYOTBSP (N OUT) (DECLARE (FIXNUM N))
|
||||
(SETQ CHRPS (+ N CHRPS))
|
||||
(DO () ((< N 8)) (TYO #\TAB OUT) (SETQ N (- N 8)))
|
||||
(DO () ((< N 1)) (TYO #\SP OUT) (SETQ N (1- N))))
|
||||
|
||||
(DEFUN STRGRIND (X)
|
||||
(LET (STRING (CHRPS 0))
|
||||
(STRPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN))
|
||||
(NREVERSE STRING)))
|
||||
|
||||
(DEFUN STRPRINT (X)
|
||||
(COND ((ATOM X) (STYO X))
|
||||
((< (CAR X) (CHRCT*)) (MAPC #'STRPRINT (CDR X)))
|
||||
(T (PROG (I)
|
||||
(SETQ I CHRPS)
|
||||
(STRPRINT (CADR X))
|
||||
(COND ((NULL (CDDR X)) (RETURN NIL))
|
||||
((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
|
||||
(OR (> (CHRCT*) (// LINEL 2))
|
||||
(ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
|
||||
(SETQ I CHRPS)
|
||||
(STRPRINT (CADDR X)))
|
||||
(T (SETQ I (1+ I)) (SETQ CHRPS 0) (STERPRI)
|
||||
(STYOTBSP I) (STRPRINT (CADDR X))))
|
||||
(DO L (CDDDR X) (CDR L) (NULL L)
|
||||
(IF (OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL
|
||||
(SETQ CHRPS 0) (STERPRI) (STYOTBSP I))
|
||||
(STRPRINT (CAR L)))))))
|
||||
|
||||
(DEFUN STYO (X) (SETQ STRING (CONS X STRING) CHRPS (1+ CHRPS)))
|
||||
|
||||
(DEFUN STERPRI () (SETQ STRING (CONS #\NEWLINE STRING) CHRPS 0))
|
||||
|
||||
(DEFUN STYOTBSP (N) (DECLARE (FIXNUM N)) (SETQ CHRPS N)
|
||||
(DO () ((< N 8)) (SETQ STRING (CONS #\TAB STRING) N (- N 8)))
|
||||
(DO () ((< N 1)) (SETQ STRING (CONS #\SP STRING) N (1- N))))
|
||||
|
||||
(DEFMFUN MSTRING (X)
|
||||
(NREVERSE (STRING1 (MSIZE X NIL NIL 'MPAREN 'MPAREN) NIL)))
|
||||
|
||||
(DEFUN STRING1 (X L)
|
||||
(IF (ATOM X) (CONS X L)
|
||||
(SETQ X (CDR X))
|
||||
(DO () ((NULL X) L) (SETQ L (STRING1 (CAR X) L) X (CDR X)))))
|
||||
|
||||
(DEFUN MSIZE (X L R LOP ROP)
|
||||
(SETQ X (NFORMAT X))
|
||||
(COND ((ATOM X) (IF FORTRANP (MSZ (MAKESTRING X) L R) (MSIZE-ATOM X L R)))
|
||||
((OR (<= (LBP (CAAR X)) (RBP LOP)) (> (LBP ROP) (RBP (CAAR X))))
|
||||
(MSIZE-PAREN X L R))
|
||||
((MEMQ 'ARRAY (CDAR X)) (MSIZE-ARRAY X L R))
|
||||
((GET (CAAR X) 'GRIND) (FUNCALL (GET (CAAR X) 'GRIND) X L R))
|
||||
(T (MSIZE-FUNCTION X L R NIL))))
|
||||
|
||||
(DEFUN MSIZE-ATOM (X L R)
|
||||
(PROG (Y)
|
||||
(COND ((NUMBERP X) (SETQ Y (EXPLODEN X)))
|
||||
((AND (SETQ Y (GET X 'REVERSEALIAS))
|
||||
(NOT (AND (MEMQ X $ALIASES) (GET X 'NOUN))))
|
||||
(SETQ Y (EXPLODEN Y)))
|
||||
((SETQ Y (ASSQR X ALIASLIST)) (RETURN (MSIZE (CAR Y) L R LOP ROP)))
|
||||
((NULL (SETQ Y (IF (EQ '%DERIVATIVE X)
|
||||
(COPY-TOP-LEVEL '(#/% #/D #/I #/F #/F))
|
||||
(EXPLODEN X)))))
|
||||
((= #/$ (CAR Y)) (SETQ Y (SLASH (CDR Y))))
|
||||
((= #/% (CAR Y)) (SETQ Y (SLASH (CDR Y))))
|
||||
((= #/& (CAR Y))
|
||||
(DO L (CDR Y) (CDR L) (NULL L)
|
||||
(COND ((OR (MEMBER (CAR L) '(#/" #/\ #/; #/$))
|
||||
(AND (< (CAR L) 32.) (NOT (= (CAR L) 13.))))
|
||||
(RPLACD L (CONS (CAR L) (CDR L)))
|
||||
(RPLACA L #/\) (SETQ L (CDR L)))))
|
||||
(SETQ Y (CONS #/" (NCONC (CDR Y) (LIST #/")))))
|
||||
(T (SETQ Y (CONS #/? (SLASH Y)))))
|
||||
(RETURN (MSZ Y L R))))
|
||||
|
||||
(DEFUN MSZ (X L R) (SETQ X (NRECONC L (NCONC X R))) (CONS (LENGTH X) X))
|
||||
|
||||
(DEFUN SLASH (X)
|
||||
(DO L (CDR X) (CDR L) (NULL L)
|
||||
(IF (ALPHANUMP (CAR L)) NIL
|
||||
(RPLACD L (CONS (CAR L) (CDR L)))
|
||||
(RPLACA L #/\) (SETQ L (CDR L))))
|
||||
(IF (ALPHABETP (CAR X)) X (CONS #/\ X)))
|
||||
|
||||
(DEFUN ALPHANUMP (N) (DECLARE (FIXNUM N))
|
||||
(OR (ASCII-NUMBERP N) (ALPHABETP N)))
|
||||
|
||||
(DEFUN MSIZE-PAREN (X L R) (MSIZE X (CONS #/( L) (CONS #/) R) 'MPAREN 'MPAREN))
|
||||
|
||||
;; The variables LB and RB are not uses here syntactically, but for
|
||||
;; communication. The FORTRAN program rebinds them to #/( and #/) since
|
||||
;; Fortran array references are printed with parens instead of brackets.
|
||||
|
||||
(DEFVAR LB #/[)
|
||||
(DEFVAR RB #/])
|
||||
|
||||
(DEFUN MSIZE-ARRAY (X L R &AUX F)
|
||||
(IF (EQ 'MQAPPLY (CAAR X)) (SETQ F (CADR X) X (CDR X)) (SETQ F (CAAR X)))
|
||||
(COND ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
|
||||
(SETQ L (RECONC '(#/' #/') L)))
|
||||
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
|
||||
(NOT (GET (CAAR X) 'REVERSEALIAS)))
|
||||
(SETQ L (CONS #/' L))))
|
||||
(SETQ L (MSIZE F L (LIST LB) LOP 'MFUNCTION)
|
||||
R (MSIZE-LIST (CDR X) NIL (CONS RB R)))
|
||||
(CONS (+ (CAR L) (CAR R)) (CONS L (CDR R))))
|
||||
|
||||
(DEFUN MSIZE-FUNCTION (X L R OP)
|
||||
(COND ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
|
||||
(SETQ L (RECONC '(#/' #/') L)))
|
||||
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
|
||||
(NOT (GET (CAAR X) 'REVERSEALIAS)))
|
||||
(SETQ L (CONS #/' L))))
|
||||
(SETQ L (MSIZE (IF OP (GETOP (CAAR X)) (CAAR X)) L (NCONS #/( ) 'MPAREN 'MPAREN)
|
||||
R (MSIZE-LIST (CDR X) NIL (CONS #/) R)))
|
||||
(CONS (+ (CAR L) (CAR R)) (CONS L (CDR R))))
|
||||
|
||||
(DEFUN MSIZE-LIST (X L R)
|
||||
(DECLARE (FIXNUM W))
|
||||
(IF (NULL X) (MSZ NIL L R)
|
||||
(DO ((NL) (W 0))
|
||||
((NULL (CDR X))
|
||||
(SETQ NL (CONS (MSIZE (CAR X) L R 'MPAREN 'MPAREN) NL))
|
||||
(CONS (+ W (CAAR NL)) (NREVERSE NL)))
|
||||
(SETQ NL (CONS (MSIZE (CAR X) L (LIST #/,) 'MPAREN 'MPAREN) NL)
|
||||
W (+ W (CAAR NL)) X (CDR X) L NIL))))
|
||||
|
||||
(DEFUN MSIZE-PREFIX (X L R)
|
||||
(MSIZE (CADR X) (RECONC (STRSYM (CAAR X)) L) R (CAAR X) ROP))
|
||||
|
||||
(DEFUN MSIZE-INFIX (X L R)
|
||||
(IF (OR (NULL (CDDR X)) (CDDDR X)) (WNA-ERR (CAAR X)))
|
||||
(SETQ L (MSIZE (CADR X) L NIL LOP (CAAR X))
|
||||
R (MSIZE (CADDR X) (REVERSE (STRSYM (CAAR X))) R (CAAR X) ROP))
|
||||
(LIST (+ (CAR L) (CAR R)) L R))
|
||||
|
||||
(DEFUN MSIZE-POSTFIX (X L R)
|
||||
(MSIZE (CADR X) L (APPEND (STRSYM (CAAR X)) R) LOP (CAAR X)))
|
||||
|
||||
(DEFUN MSIZE-NARY (X L R) (MSZNARY X L R (STRSYM (CAAR X))))
|
||||
|
||||
(DEFUN MSIZE-NOFIX (X L R) (MSIZE (CAAR X) L R (CAAR X) ROP))
|
||||
|
||||
(DEFUN MSIZE-MATCHFIX (X L R)
|
||||
(SETQ L (NRECONC L (CAR (STRSYM (CAAR X))))
|
||||
L (CONS (LENGTH L) L)
|
||||
R (APPEND (CDR (STRSYM (CAAR X))) R)
|
||||
X (MSIZE-LIST (CDR X) NIL R))
|
||||
(CONS (+ (CAR L) (CAR X)) (CONS L (CDR X))))
|
||||
|
||||
(DEFUN MSZNARY (X L R DISSYM)
|
||||
(DECLARE (FIXNUM W))
|
||||
(COND ((NULL (CDDR X)) (MSIZE-FUNCTION X L R T))
|
||||
(T (SETQ L (MSIZE (CADR X) L NIL LOP (CAAR X)))
|
||||
(DO ((OL (CDDR X) (CDR OL)) (NL (LIST L)) (W (CAR L)))
|
||||
((NULL (CDR OL))
|
||||
(SETQ R (MSIZE (CAR OL) (REVERSE DISSYM) R (CAAR X) ROP))
|
||||
(CONS (+ (CAR R) W) (NREVERSE (CONS R NL))))
|
||||
(SETQ NL (CONS (MSIZE (CAR OL) (REVERSE DISSYM) NIL (CAAR X) (CAAR X))
|
||||
NL)
|
||||
W (+ (CAAR NL) W))))))
|
||||
|
||||
(DEFUN STRSYM (X) (OR (GET X 'STRSYM) (GET X 'DISSYM)))
|
||||
|
||||
(DEFPROP BIGFLOAT MSZ-BIGFLOAT GRIND)
|
||||
|
||||
(DEFUN MSZ-BIGFLOAT (X L R)
|
||||
(MSZ (MAPCAR '(LAMBDA (L) (GETCHARN L 1)) (FPFORMAT X)) L R))
|
||||
|
||||
(DEFPROP MPROGN MSIZE-MATCHFIX GRIND)
|
||||
(DEFPROP MLIST MSIZE-MATCHFIX GRIND)
|
||||
|
||||
(DEFPROP MQAPPLY MSZ-MQAPPLY GRIND)
|
||||
|
||||
(DEFUN MSZ-MQAPPLY (X L R)
|
||||
(SETQ L (MSIZE (CADR X) L (LIST #/( ) LOP 'MFUNCTION)
|
||||
R (MSIZE-LIST (CDDR X) NIL (CONS #/) R)))
|
||||
(CONS (+ (CAR L) (CAR R)) (CONS L (CDR R))))
|
||||
|
||||
|
||||
(DEFPROP MQUOTE MSIZE-PREFIX GRIND)
|
||||
(DEFPROP MQUOTE 201. RBP)
|
||||
|
||||
(DEFPROP MSETQ MSIZE-INFIX GRIND)
|
||||
(DEFPROP MSETQ (#/:) STRSYM)
|
||||
(DEFPROP MSETQ 180. RBP)
|
||||
(DEFPROP MSETQ 20. RBP)
|
||||
|
||||
(DEFPROP MSET MSIZE-INFIX GRIND)
|
||||
(DEFPROP MSET (#/: #/:) STRSYM)
|
||||
(DEFPROP MSET 180. LBP)
|
||||
(DEFPROP MSET 20. RBP)
|
||||
|
||||
(DEFPROP MDEFINE MSZ-MDEF GRIND)
|
||||
(DEFPROP MDEFINE (#/: #/=) STRSYM)
|
||||
(DEFPROP MDEFINE 180. LBP)
|
||||
(DEFPROP MDEFINE 20. RBP)
|
||||
|
||||
(DEFPROP MDEFMACRO MSZ-MDEF GRIND)
|
||||
(DEFPROP MDEFMACRO (#/: #/: #/=) STRSYM)
|
||||
(DEFPROP MDEFMACRO 180. LBP)
|
||||
(DEFPROP MDEFMACRO 20. RBP)
|
||||
|
||||
(DEFUN MSZ-MDEF (X L R)
|
||||
(SETQ L (MSIZE (CADR X) L (COPY-TOP-LEVEL (STRSYM (CAAR X))) LOP (CAAR X))
|
||||
R (MSIZE (CADDR X) NIL R (CAAR X) ROP))
|
||||
(SETQ X (CONS (- (CAR L) (CAADR L)) (CDDR L)))
|
||||
(IF (AND (NOT (ATOM (CADR R))) (NOT (ATOM (CADDR R)))
|
||||
(< (+ (CAR L) (CAADR R) (CAADDR R)) LINEL))
|
||||
(SETQ X (NCONC X (LIST (CADR R) (CADDR R)))
|
||||
R (CONS (CAR R) (CDDDR R))))
|
||||
(CONS (+ (CAR L) (CAR R)) (CONS (CADR L) (CONS X (CDR R)))))
|
||||
|
||||
|
||||
(DEFPROP MFACTORIAL MSIZE-POSTFIX GRIND)
|
||||
(DEFPROP MFACTORIAL 160. LBP)
|
||||
|
||||
(DEFPROP MEXPT MSZ-MEXPT GRIND)
|
||||
(DEFPROP MEXPT 140. LBP)
|
||||
(DEFPROP MEXPT 139. RBP)
|
||||
|
||||
(DEFUN MSZ-MEXPT (X L R)
|
||||
(SETQ L (MSIZE (CADR X) L NIL LOP 'MEXPT)
|
||||
R (IF (MMMINUSP (SETQ X (NFORMAT (CADDR X))))
|
||||
(MSIZE (CADR X) (REVERSE '(#/^ #/-)) R 'MEXPT ROP)
|
||||
(MSIZE X (LIST #/^) R 'MEXPT ROP)))
|
||||
(LIST (+ (CAR L) (CAR R)) L R))
|
||||
|
||||
|
||||
(DEFPROP MNCEXPT MSIZE-INFIX GRIND)
|
||||
(DEFPROP MNCEXPT 135. LBP)
|
||||
(DEFPROP MNCEXPT 134. RBP)
|
||||
|
||||
(DEFPROP MNCTIMES MSIZE-NARY GRIND)
|
||||
(DEFPROP MNCTIMES 110. LBP)
|
||||
(DEFPROP MNCTIMES 109. RBP)
|
||||
|
||||
(DEFPROP MTIMES MSZ-MTIMES GRIND)
|
||||
(DEFPROP MTIMES 120. LBP)
|
||||
(DEFPROP MTIMES 120. RBP)
|
||||
|
||||
(DEFUN MSZ-MTIMES (X L R) (MSZNARY X L R '(#/*)))
|
||||
|
||||
|
||||
(DEFPROP MQUOTIENT MSIZE-INFIX GRIND)
|
||||
(DEFPROP MQUOTIENT 120. LBP)
|
||||
(DEFPROP MQUOTIENT 121. RBP)
|
||||
(DEFPROP RAT MSIZE-INFIX GRIND)
|
||||
(DEFPROP RAT 120. LBP)
|
||||
(DEFPROP RAT 121. RBP)
|
||||
|
||||
(DEFPROP MPLUS MSZ-MPLUS GRIND)
|
||||
(DEFPROP MPLUS 100. LBP)
|
||||
(DEFPROP MPLUS 100. RBP)
|
||||
|
||||
(DEFUN MSZ-MPLUS (X L R)
|
||||
(DECLARE (FIXNUM W))
|
||||
(COND ((NULL (CDDR X))
|
||||
(IF (NULL (CDR X))
|
||||
(MSIZE-FUNCTION X L R T)
|
||||
(MSIZE (CADR X) (APPEND (NCONS #/+) L) R 'MPLUS ROP)))
|
||||
(T (SETQ L (MSIZE (CADR X) L NIL LOP 'MPLUS) X (CDDR X))
|
||||
(DO ((NL (LIST L)) (W (CAR L)) (DISSYM))
|
||||
((NULL (CDR X))
|
||||
(IF (MMMINUSP (CAR X)) (SETQ L (CADAR X) DISSYM (LIST #/-))
|
||||
(SETQ L (CAR X) DISSYM (LIST #/+)))
|
||||
(SETQ R (MSIZE L DISSYM R 'MPLUS ROP))
|
||||
(CONS (+ (CAR R) W) (NREVERSE (CONS R NL))))
|
||||
(IF (MMMINUSP (CAR X)) (SETQ L (CADAR X) DISSYM (LIST #/-))
|
||||
(SETQ L (CAR X) DISSYM (LIST #/+)))
|
||||
(SETQ NL (CONS (MSIZE L DISSYM NIL 'MPLUS 'MPLUS) NL)
|
||||
W (+ (CAAR NL) W)
|
||||
X (CDR X))))))
|
||||
|
||||
(DEFPROP MMINUS MSIZE-PREFIX GRIND)
|
||||
(DEFPROP MMINUS (#/-) STRSYM)
|
||||
(DEFPROP MMINUS 100. RBP)
|
||||
(DEFPROP MMINUS 100. LBP)
|
||||
|
||||
(DEFPROP MEQUAL MSIZE-INFIX GRIND)
|
||||
(DEFPROP MEQUAL 80. LBP)
|
||||
(DEFPROP MEQUAL 80. RBP)
|
||||
|
||||
(DEFPROP MNOTEQUAL MSIZE-INFIX GRIND)
|
||||
(DEFPROP MNOTEQUAL 80. LBP)
|
||||
(DEFPROP MNOTEQUAL 80. RBP)
|
||||
|
||||
(DEFPROP MGREATERP MSIZE-INFIX GRIND)
|
||||
(DEFPROP MGREATERP 80. LBP)
|
||||
(DEFPROP MGREATERP 80. RBP)
|
||||
|
||||
(DEFPROP MGEQP MSIZE-INFIX GRIND)
|
||||
(DEFPROP MGEQP 80. LBP)
|
||||
(DEFPROP MGEQP 80. RBP)
|
||||
|
||||
(DEFPROP MLESSP MSIZE-INFIX GRIND)
|
||||
(DEFPROP MLESSP 80. LBP)
|
||||
(DEFPROP MLESSP 80. RBP)
|
||||
|
||||
(DEFPROP MLEQP MSIZE-INFIX GRIND)
|
||||
(DEFPROP MLEQP 80. LBP)
|
||||
(DEFPROP MLEQP 80. RBP)
|
||||
|
||||
(DEFPROP MNOT MSIZE-PREFIX GRIND)
|
||||
(DEFPROP MNOT 70. RBP)
|
||||
|
||||
(DEFPROP MAND MSIZE-NARY GRIND)
|
||||
(DEFPROP MAND 60. LBP)
|
||||
(DEFPROP MAND 60. RBP)
|
||||
|
||||
(DEFPROP MOR MSIZE-NARY GRIND)
|
||||
(DEFPROP MOR 50. LBP)
|
||||
(DEFPROP MOR 50. RBP)
|
||||
|
||||
(DEFPROP MCOND MSZ-MCOND GRIND)
|
||||
(DEFPROP MCOND 25. LBP)
|
||||
(DEFPROP MCOND 25. RBP)
|
||||
|
||||
(DEFUN MSZ-MCOND (X L R &AUX IF)
|
||||
(SETQ IF (NRECONC L '(#/I #/F #\SP)) IF (CONS (LENGTH IF) IF)
|
||||
L (MSIZE (CADR X) NIL NIL 'MCOND 'MPAREN))
|
||||
(COND ((EQ '$FALSE (FIFTH X))
|
||||
(SETQ X (MSIZE (CADDR X)
|
||||
(REVERSE '(#\SP #/T #/H #/E #/N #\SP))
|
||||
R 'MCOND ROP))
|
||||
(LIST (+ (CAR IF) (CAR L) (CAR X)) IF L X))
|
||||
(T (SETQ R (MSIZE (FIFTH X)
|
||||
(REVERSE '(#\SP #/E #/L #/S #/E #\SP))
|
||||
R 'MCOND ROP)
|
||||
X (MSIZE (CADDR X)
|
||||
(REVERSE '(#\SP #/T #/H #/E #/N #\SP))
|
||||
NIL 'MCOND 'MPAREN))
|
||||
(LIST (+ (CAR IF) (CAR L) (CAR X) (CAR R)) IF L X R))))
|
||||
|
||||
|
||||
(DEFPROP MDO MSZ-MDO GRIND)
|
||||
(DEFPROP MDO 30. LBP)
|
||||
(DEFPROP MDO 30. RBP)
|
||||
(DEFPROP MDOIN MSZ-MDOIN GRIND)
|
||||
(DEFPROP MDOIN 30. RBP)
|
||||
|
||||
(DEFUN MSZ-MDO (X L R)
|
||||
(MSZNARY (CONS '(MDO) (STRMDO X)) L R '(#\SP)))
|
||||
|
||||
(DEFUN MSZ-MDOIN (X L R)
|
||||
(MSZNARY (CONS '(MDO) (STRMDOIN X)) L R '(#\SP)))
|
||||
|
||||
(DEFUN STRMDO (X)
|
||||
(NCONC (COND ((SECOND X) `($FOR ,(SECOND X))))
|
||||
(COND ((EQUAL 1 (THIRD X)) NIL)
|
||||
((THIRD X) `($FROM ,(THIRD X))))
|
||||
(COND ((EQUAL 1 (FOURTH X)) NIL)
|
||||
((FOURTH X) `($STEP ,(FOURTH X)))
|
||||
((FIFTH X) `($NEXT ,(FIFTH X))))
|
||||
(COND ((SIXTH X) `($THRU ,(SIXTH X))))
|
||||
(COND ((NULL (SEVENTH X)) NIL)
|
||||
((EQ 'MNOT (CAAR (SEVENTH X)))
|
||||
`($WHILE ,(CADR (SEVENTH X))))
|
||||
(T `($UNLESS ,(SEVENTH X))))
|
||||
`($DO ,(EIGHTH X))))
|
||||
|
||||
(DEFUN STRMDOIN (X)
|
||||
(NCONC `($FOR ,(SECOND X) $IN ,(THIRD X))
|
||||
(COND ((SIXTH X) `($THRU ,(SIXTH X))))
|
||||
(COND ((NULL (SEVENTH X)) NIL)
|
||||
((EQ 'MNOT (CAAR (SEVENTH X)))
|
||||
`($WHILE ,(CADR (SEVENTH X))))
|
||||
(T `($UNLESS ,(SEVENTH X))))
|
||||
`($DO ,(EIGHTH X))))
|
||||
|
||||
|
||||
118
src/mrg/nforma.18
Normal file
118
src/mrg/nforma.18
Normal file
@@ -0,0 +1,118 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module nforma)
|
||||
|
||||
(DECLARE (SPECIAL 1//2 -1//2 DISPLAYP ALIASLIST IN-P))
|
||||
|
||||
(DEFMVAR $POWERDISP NIL)
|
||||
(DEFMVAR $PFEFORMAT NIL)
|
||||
(DEFMVAR $%EDISPFLAG NIL)
|
||||
(DEFMVAR $EXPTDISPFLAG T)
|
||||
(DEFMVAR $SQRTDISPFLAG T)
|
||||
(DEFMVAR $NEGSUMDISPFLAG T)
|
||||
(SETQ IN-P NIL)
|
||||
|
||||
(DEFMFUN NFORMAT (FORM)
|
||||
(COND ((ATOM FORM)
|
||||
(COND ((AND (NUMBERP FORM) (MINUSP FORM)) (LIST '(MMINUS) (MINUS FORM)))
|
||||
((EQ T FORM) (IF IN-P T '$TRUE))
|
||||
((EQ NIL FORM) (IF IN-P NIL '$FALSE))
|
||||
((AND DISPLAYP (CAR (ASSQR FORM ALIASLIST))))
|
||||
(T FORM)))
|
||||
((ATOM (CAR FORM)) FORM)
|
||||
((EQ 'RAT (CAAR FORM))
|
||||
(COND ((MINUSP (CADR FORM))
|
||||
(LIST '(MMINUS) (LIST '(RAT) (MINUS (CADR FORM)) (CADDR FORM))))
|
||||
(T (CONS '(RAT) (CDR FORM)))))
|
||||
((EQ 'MMACROEXPANDED (CAAR FORM)) (NFORMAT (CADDR FORM)))
|
||||
((NULL (CDAR FORM)) FORM)
|
||||
((EQ 'MPLUS (CAAR FORM)) (FORM-MPLUS FORM))
|
||||
((EQ 'MTIMES (CAAR FORM)) (FORM-MTIMES FORM))
|
||||
((EQ 'MEXPT (CAAR FORM)) (FORM-MEXPT FORM))
|
||||
((EQ 'MRAT (CAAR FORM)) (FORM-MRAT FORM))
|
||||
((EQ 'MPOIS (CAAR FORM)) (NFORMAT ($OUTOFPOIS FORM)))
|
||||
((EQ 'BIGFLOAT (CAAR FORM))
|
||||
(IF (MINUSP (CADR FORM))
|
||||
(LIST '(MMINUS) (LIST (CAR FORM) (MINUS (CADR FORM)) (CADDR FORM)))
|
||||
(CONS (CAR FORM) (CDR FORM))))
|
||||
(T FORM)))
|
||||
|
||||
(DEFUN FORM-MPLUS (FORM &AUX ARGS TRUNC)
|
||||
(SETQ ARGS (MAPCAR #'NFORMAT (CDR FORM)))
|
||||
(SETQ TRUNC (MEMQ 'TRUNC (CDAR FORM)))
|
||||
(CONS (IF TRUNC '(MPLUS TRUNC) '(MPLUS))
|
||||
(COND ((AND (MEMQ 'RATSIMP (CDAR FORM)) (NOT (MEMQ 'SIMP (CDAR FORM))))
|
||||
(IF $POWERDISP (NREVERSE ARGS) ARGS))
|
||||
((AND TRUNC (NOT (MEMQ 'SIMP (CDAR FORM)))) (NREVERSE ARGS))
|
||||
((OR $POWERDISP TRUNC (MEMQ 'CF (CDAR FORM))) ARGS)
|
||||
((AND $NEGSUMDISPFLAG (NULL (CDDDR FORM)))
|
||||
(IF (AND (NOT (MMMINUSP (CAR ARGS)))
|
||||
(MMMINUSP (CADR ARGS)))
|
||||
ARGS
|
||||
(NREVERSE ARGS)))
|
||||
(T (NREVERSE ARGS)))))
|
||||
|
||||
(DEFUN FORM-MTIMES (FORM)
|
||||
(COND ((NULL (CDR FORM)) '((MTIMES)))
|
||||
((EQUAL -1 (CADR FORM)) (LIST '(MMINUS) (FORM-MTIMES (CDR FORM))))
|
||||
(T (PROG (NUM DEN MINUS FLAG)
|
||||
(DO ((L (CDR FORM) (CDR L)) (DUMMY)) ((NULL L))
|
||||
(SETQ DUMMY (NFORMAT (CAR L)))
|
||||
(COND ((ATOM DUMMY) (SETQ NUM (CONS DUMMY NUM)))
|
||||
((EQ 'MMINUS (CAAR DUMMY))
|
||||
(SETQ MINUS (NOT MINUS) L (APPEND DUMMY (CDR L))))
|
||||
((OR (EQ 'MQUOTIENT (CAAR DUMMY))
|
||||
(AND (NOT $PFEFORMAT) (EQ 'RAT (CAAR DUMMY))))
|
||||
(COND ((NOT (EQUAL 1 (CADR DUMMY)))
|
||||
(SETQ NUM (CONS (CADR DUMMY) NUM))))
|
||||
(SETQ DEN (CONS (CADDR DUMMY) DEN)))
|
||||
(T (SETQ NUM (CONS DUMMY NUM)))))
|
||||
(SETQ NUM (COND ((NULL NUM) 1)
|
||||
((NULL (CDR NUM)) (CAR NUM))
|
||||
(T (CONS '(MTIMES) (NREVERSE NUM))))
|
||||
DEN (COND ((NULL DEN) (SETQ FLAG T) NIL)
|
||||
((NULL (CDR DEN)) (CAR DEN))
|
||||
(T (CONS '(MTIMES) (NREVERSE DEN)))))
|
||||
(IF (NOT FLAG) (SETQ NUM (LIST '(MQUOTIENT) NUM DEN)))
|
||||
(RETURN (IF MINUS (LIST '(MMINUS) NUM) NUM))))))
|
||||
|
||||
(DEFUN FORM-MEXPT (FORM &AUX EXP)
|
||||
(COND ((AND $SQRTDISPFLAG (ALIKE1 1//2 (CADDR FORM))) (LIST '(%SQRT) (CADR FORM)))
|
||||
((AND $SQRTDISPFLAG (ALIKE1 -1//2 (CADDR FORM)))
|
||||
(LIST '(MQUOTIENT) 1 (LIST '(%SQRT) (CADR FORM))))
|
||||
((AND (OR (AND $%EDISPFLAG (EQ '$%E (CADR FORM)))
|
||||
(AND $EXPTDISPFLAG (NOT (EQ '$%E (CADR FORM)))))
|
||||
(NOT (ATOM (SETQ EXP (NFORMAT (CADDR FORM)))))
|
||||
(EQ 'MMINUS (CAAR EXP)))
|
||||
(LIST '(MQUOTIENT) 1 (IF (EQUAL 1 (CADR EXP)) (CADR FORM)
|
||||
(LIST '(MEXPT) (CADR FORM) (CADR EXP)))))
|
||||
(T (CONS '(MEXPT) (CDR FORM)))))
|
||||
|
||||
(DEFUN FORM-MRAT (FORM)
|
||||
(LET ((TRUNC (MEMQ 'TRUNC (CDAR FORM))) EXACT)
|
||||
(IF (AND TRUNC (EQ (CADR FORM) 'PS))
|
||||
(SETQ EXACT (NULL (CAR (CADDDR FORM)))))
|
||||
(SETQ FORM (RATDISREPD FORM))
|
||||
(RDIS1 FORM)
|
||||
(IF (AND TRUNC (OR (ATOM FORM)
|
||||
;; A constant, e.g. ((mplus) $a 1)
|
||||
(not (member (car form)
|
||||
'((mplus exact) (mplus trunc))))))
|
||||
(CONS (IF EXACT '(MPLUS EXACT) '(MPLUS TRUNC)) (NCONS FORM))
|
||||
(NFORMAT FORM))))
|
||||
|
||||
(DEFUN RDIS1 (FORM)
|
||||
(COND ((OR (ATOM FORM) (SPECREPP FORM)))
|
||||
((NULL (CDAR FORM)) (RPLACA FORM (LIST (CAAR FORM) 'RATSIMP)))
|
||||
(T (MAPC #'RDIS1 (CDR FORM)))))
|
||||
|
||||
(DEFMFUN NFORMAT-ALL (FORM)
|
||||
(SETQ FORM (NFORMAT FORM))
|
||||
(IF (OR (ATOM FORM) (EQ (CAAR FORM) 'BIGFLOAT))
|
||||
FORM
|
||||
(CONS (DELSIMP (CAR FORM))
|
||||
(IF (MEMQ (CAAR FORM) '(MDO MDOIN))
|
||||
(MAPCAR #'(LAMBDA (U) (IF U (NFORMAT-ALL U))) (CDR FORM))
|
||||
(MAPCAR #'NFORMAT-ALL (CDR FORM))))))
|
||||
146
src/mrg/optim.16
Normal file
146
src/mrg/optim.16
Normal file
@@ -0,0 +1,146 @@
|
||||
;;; -*- Mode:LISP; Package:MACSYMA -*-
|
||||
|
||||
; ** (c) Copyright 1982 Massachusetts Institute of Technology **
|
||||
|
||||
(macsyma-module optim)
|
||||
|
||||
(DECLARE (SPECIAL VARS SETQS OPTIMCOUNT XVARS)
|
||||
(FIXNUM N (OPT-HASH))
|
||||
(ARRAY* (NOTYPE (SUBEXP 1)))
|
||||
(UNSPECIAL ARGS))
|
||||
|
||||
(ARRAY SUBEXP T 64.)
|
||||
|
||||
(DEFMVAR $OPTIMPREFIX '$%)
|
||||
|
||||
(DEFMVAR $OPTIMWARN T "warns if OPTIMIZE encounters a special form.")
|
||||
|
||||
;; $OPTIMIZE takes a Macsyma expression and returns a BLOCK form which is
|
||||
;; equivalent, but which uses local variables to store the results of computing
|
||||
;; common subexpressions. These subexpressions are found by hashing them.
|
||||
|
||||
(DEFMFUN $OPTIMIZE (X0)
|
||||
(LET (($OPTIMWARN $OPTIMWARN))
|
||||
(PROG (VARS SETQS OPTIMCOUNT XVARS X)
|
||||
(SETQ OPTIMCOUNT 0 XVARS (CDR ($LISTOFVARS X0)))
|
||||
(FILLARRAY 'SUBEXP '(NIL))
|
||||
(SETQ X (COLLAPSE (OPFORMAT (COLLAPSE X0))))
|
||||
(IF (ATOM X) (RETURN X))
|
||||
(COMEXP X)
|
||||
(SETQ X (OPTIM X))
|
||||
(RETURN (PROG1 (COND ((NULL VARS) X0)
|
||||
(T (IF (OR (NOT (EQ (CAAR X) 'MPROG))
|
||||
(AND ($LISTP (CADR X)) (CDADR X)))
|
||||
(SETQ X (NREVERSE (CONS X SETQS)))
|
||||
(SETQ X (NCONC (NREVERSE SETQS) (CDDR X))))
|
||||
`((MPROG SIMP) ((MLIST) . ,(NREVERSE VARS)) . ,X)))
|
||||
(FILLARRAY 'SUBEXP '(NIL)))))))
|
||||
|
||||
(DEFUN OPFORMAT (X)
|
||||
(COND ((ATOM X) X)
|
||||
((SPECREPP X) (OPFORMAT (SPECDISREP X)))
|
||||
((AND $OPTIMWARN
|
||||
(MSPECFUNP (CAAR X))
|
||||
(PROG2 (MTELL "OPTIMIZE has met up with a special form - ~
|
||||
answer may be wrong.")
|
||||
(SETQ $OPTIMWARN NIL))))
|
||||
((EQ (CAAR X) 'MEXPT) (OPMEXPT X))
|
||||
(T (LET ((NEWARGS (MAPCAR #'OPFORMAT (CDR X))))
|
||||
(IF (ALIKE NEWARGS (CDR X)) X (CONS (CAR X) NEWARGS))))))
|
||||
|
||||
(DEFUN OPMEXPT (X)
|
||||
(LET ((*BASE (OPFORMAT (CADR X))) (EXP (OPFORMAT (CADDR X))) XNEW NEGEXP)
|
||||
(SETQ NEGEXP
|
||||
(COND ((AND (NUMBERP EXP) (MINUSP EXP)) (MINUS EXP))
|
||||
((AND (RATNUMP EXP) (MINUSP (CADR EXP)))
|
||||
(LIST (CAR EXP) (MINUS (CADR EXP)) (CADDR EXP)))
|
||||
((AND (MTIMESP EXP) (NUMBERP (CADR EXP)) (MINUSP (CADR EXP)))
|
||||
(IF (EQUAL (CADR EXP) -1)
|
||||
(IF (NULL (CDDDR EXP)) (CADDR EXP)
|
||||
(CONS (CAR EXP) (CDDR EXP)))
|
||||
(LIST* (CAR EXP) (MINUS (CADR EXP)) (CDDR EXP))))
|
||||
((AND (MTIMESP EXP) (RATNUMP (CADR EXP)) (MINUSP (CADADR EXP)))
|
||||
(LIST* (CAR EXP)
|
||||
(LIST (CAADR EXP) (MINUS (CADADR EXP)) (CADDR (CADR EXP)))
|
||||
(CDDR EXP)))))
|
||||
(SETQ XNEW
|
||||
(COND (NEGEXP
|
||||
`((MQUOTIENT)
|
||||
1
|
||||
,(COND ((EQUAL NEGEXP 1) *BASE)
|
||||
(T (SETQ XNEW (LIST (CAR X) *BASE NEGEXP))
|
||||
(IF (AND (RATNUMP NEGEXP) (EQUAL (CADDR NEGEXP) 2))
|
||||
(OPMEXPT XNEW)
|
||||
XNEW)))))
|
||||
((AND (RATNUMP EXP) (EQUAL (CADDR EXP) 2))
|
||||
(SETQ EXP (CADR EXP))
|
||||
(IF (EQUAL EXP 1) `((%SQRT) ,*BASE)
|
||||
`((MEXPT) ((%SQRT) ,*BASE) ,EXP)))
|
||||
(T (LIST (CAR X) *BASE EXP))))
|
||||
(IF (ALIKE1 X XNEW) X XNEW)))
|
||||
|
||||
(DEFMFUN $COLLAPSE (X)
|
||||
(FILLARRAY 'SUBEXP '(NIL))
|
||||
(PROG1 (COLLAPSE X) (FILLARRAY 'SUBEXP '(NIL))))
|
||||
|
||||
(DEFUN COLLAPSE (X)
|
||||
(COND ((ATOM X) X)
|
||||
((SPECREPP X) (COLLAPSE (SPECDISREP X)))
|
||||
(T (LET ((N (OPT-HASH (CAAR X))))
|
||||
(DO ((L (CDR X) (CDR L)))
|
||||
((NULL L))
|
||||
(IF (NOT (EQ (COLLAPSE (CAR L)) (CAR L)))
|
||||
(RPLACA L (COLLAPSE (CAR L))))
|
||||
(SETQ N (\ (+ (OPT-HASH (CAR L)) N) 12553.)))
|
||||
(SETQ N (LOGAND 63. N))
|
||||
(DO ((L (SUBEXP N) (CDR L)))
|
||||
((NULL L) (STORE (SUBEXP N) (CONS (LIST X) (SUBEXP N))) X)
|
||||
(IF (ALIKE1 X (CAAR L)) (RETURN (CAAR L))))))))
|
||||
|
||||
(DEFUN COMEXP (X)
|
||||
(IF (NOT (OR (ATOM X) (EQ (CAAR X) 'RAT)))
|
||||
(LET ((N (OPT-HASH (CAAR X))))
|
||||
(DOLIST (U (CDR X)) (SETQ N (\ (+ (OPT-HASH U) N) 12553.)))
|
||||
(SETQ X (ASSOL X (SUBEXP (LOGAND 63. N))))
|
||||
(COND ((NULL (CDR X)) (RPLACD X 'SEEN) (MAPC #'COMEXP (CDAR X)))
|
||||
(T (RPLACD X 'COMEXP))))))
|
||||
|
||||
(DEFUN OPTIM (X)
|
||||
(COND ((ATOM X) X)
|
||||
((AND (MEMQ 'ARRAY (CDAR X))
|
||||
(NOT (EQ (CAAR X) 'MQAPPLY))
|
||||
(NOT (MGET (CAAR X) 'ARRAYFUN-MODE)))
|
||||
X)
|
||||
((EQ (CAAR X) 'RAT) X)
|
||||
(T (LET ((N (OPT-HASH (CAAR X))) (NX (LIST (CAR X))))
|
||||
(DOLIST (U (CDR X))
|
||||
(SETQ N (\ (+ (OPT-HASH U) N) 12553.)
|
||||
NX (CONS (OPTIM U) NX)))
|
||||
(SETQ X (ASSOL X (SUBEXP (LOGAND 63. N))) NX (NREVERSE NX))
|
||||
(COND ((EQ (CDR X) 'SEEN) NX)
|
||||
((EQ (CDR X) 'COMEXP)
|
||||
(RPLACD X (GETOPTIMVAR))
|
||||
(SETQ SETQS (CONS `((MSETQ) ,(CDR X) ,NX) SETQS))
|
||||
(CDR X))
|
||||
(T (CDR X)))))))
|
||||
|
||||
(DEFUN OPT-HASH (EXP) ; EXP is in general representation.
|
||||
(\ (IF (ATOM EXP)
|
||||
(SXHASH EXP)
|
||||
(DO ((N (OPT-HASH (CAAR EXP)))
|
||||
(ARGS (CDR EXP) (CDR ARGS)))
|
||||
((NULL ARGS) N)
|
||||
(SETQ N (\ (+ (OPT-HASH (CAR ARGS)) N) 12553.))))
|
||||
12553.)) ; a prime number < 2^14 ; = PRIME(1500)
|
||||
|
||||
(DEFUN GETOPTIMVAR ()
|
||||
(PROG (VAR)
|
||||
LOOP (INCREMENT OPTIMCOUNT)
|
||||
(SETQ VAR (INTERN #-Lispm (MAKNAM (NCONC (EXPLODEN $OPTIMPREFIX)
|
||||
(MEXPLODEN OPTIMCOUNT)))
|
||||
#+Lispm (MAKE-SYMBOL
|
||||
(FORMAT NIL "~A~D" $OPTIMPREFIX OPTIMCOUNT))))
|
||||
(IF (MEMQ VAR XVARS) (GO LOOP))
|
||||
(SETQ VARS (CONS VAR VARS))
|
||||
(RETURN VAR)))
|
||||
|
||||
55
src/mrg/scs.61
Normal file
55
src/mrg/scs.61
Normal file
@@ -0,0 +1,55 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module scs)
|
||||
|
||||
(DECLARE (*EXPR $RATSUBST CONSSIZE))
|
||||
|
||||
(DEFMFUN $SCSIMP N
|
||||
(DO ((I N (1- I)) (ZRS)) ((= 1 I) (SCS (ARG 1) ZRS))
|
||||
(SETQ ZRS (CONS (IFN (EQ 'MEQUAL (CAAR (ARG I))) (ARG I)
|
||||
(SUB (CADR (ARG I)) (CADDR (ARG I)))) ZRS))))
|
||||
|
||||
(DEFUN SCS (X ZRS)
|
||||
(DO ((FLAG T) (SZ (CONSSIZE X)) (NX) (NSZ)) ((NOT FLAG) X)
|
||||
(DO ((L ZRS (CDR L))) ((NULL L) (SETQ FLAG NIL))
|
||||
(SETQ NX (SUBSCS 0 (CAR L) X) NSZ (CONSSIZE NX))
|
||||
(IF (< NSZ SZ) (RETURN (SETQ X NX SZ NSZ))))))
|
||||
|
||||
(DEFUN SUBSCS (A B C)
|
||||
(COND ((ATOM B) (SUBSC A B C))
|
||||
((EQ 'MPLUS (CAAR B))
|
||||
(DO ((L (CDR B) (CDR L)) (SZ (CONSSIZE C)) (NL) (NC) (NSZ)) ((NULL L) C)
|
||||
(SETQ NC (SUBSCS (SUB A (ADDN (RECONC NL (CDR L)) T)) (CAR L) C)
|
||||
NSZ (CONSSIZE NC) NL (CONS (CAR L) NL))
|
||||
(IF (< NSZ SZ) (SETQ C NC SZ NSZ))))
|
||||
(T (SUBSC A B C))))
|
||||
|
||||
(DEFUN SUBSC (A B C) ($EXPAND ($RATSUBST A B C)))
|
||||
|
||||
(DEFMFUN $DISTRIB (EXP)
|
||||
(COND ((OR (MNUMP EXP) (SYMBOLP EXP)) EXP)
|
||||
((EQ 'MTIMES (CAAR EXP))
|
||||
(SETQ EXP (MAPCAR '$DISTRIB (CDR EXP)))
|
||||
(DO ((L (CDR EXP) (CDR L))
|
||||
(NL (IF (MPLUSP (CAR EXP)) (CDAR EXP) (LIST (CAR EXP)))))
|
||||
((NULL L) (ADDN NL T))
|
||||
(IF (MPLUSP (CAR L))
|
||||
(DO ((M (CDAR L) (CDR M)) (ML)) ((NULL M) (SETQ NL ML))
|
||||
(SETQ ML (DSTRB (CAR M) NL ML)))
|
||||
(SETQ NL (DSTRB (CAR L) NL NIL)))))
|
||||
((EQ 'MEQUAL (CAAR EXP))
|
||||
(LIST '(MEQUAL) ($DISTRIB (CADR EXP)) ($DISTRIB (CADDR EXP))))
|
||||
((EQ 'MRAT (CAAR EXP)) ($DISTRIB (RATDISREP EXP)))
|
||||
(T EXP)))
|
||||
|
||||
(DEFUN DSTRB (X L NL)
|
||||
(DO () ((NULL L) NL)
|
||||
(SETQ NL (CONS (MUL X (CAR L)) NL) L (CDR L))))
|
||||
|
||||
(DEFMFUN $FACOUT (X Y)
|
||||
(IFN (AND (NOT (ATOM Y))
|
||||
(EQ 'MPLUS (CAAR Y))) Y
|
||||
(MUL X (ADDN (MAPCAR #'(LAMBDA (L) (DIV L X)) (CDR Y)) T))))
|
||||
|
||||
636
src/mrg/trigi.358
Normal file
636
src/mrg/trigi.358
Normal file
@@ -0,0 +1,636 @@
|
||||
;; -*- Mode: Lisp; Package: Macsyma; -*-
|
||||
|
||||
;; (c) Copyright 1976, 1984 Massachusetts Institute of Technology
|
||||
;; All Rights Reserved.
|
||||
|
||||
;; Enhancements (c) Copyright 1984 Symbolics Inc.
|
||||
;; All Rights Reserved.
|
||||
|
||||
;; The data and information in the Enhancements are proprietary to, and
|
||||
;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation.
|
||||
;; They are given in confidence by SYMBOLICS, pursuant to the license
|
||||
;; agreement between Symbolics and their recipient, and may not be used,
|
||||
;; reproduced, or copied, or distributed to any other party, in whole or
|
||||
;; in part, without the prior written consent of SYMBOLICS except as
|
||||
;; permitted by the license agreement.
|
||||
|
||||
(macsyma-module trigi)
|
||||
|
||||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||||
|
||||
(DECLARE (GENPREFIX TRI)
|
||||
(SPECIAL VARLIST ERRORSW $DEMOIVRE)
|
||||
(FLONUM (TAN) (COT) (SEC) (CSC)
|
||||
(ATAN2) (ATAN1) (ACOT)
|
||||
(SINH) (COSH) (TANH) (COTH) (CSCH) (SECH)
|
||||
(ASINH) (ACSCH)
|
||||
(T//$ FLONUM FLONUM NOTYPE))
|
||||
(*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR EXPAND1
|
||||
TIMESK ADDK INTEGERP EVOD LOGARC
|
||||
MEVENP EQTEST HALFANGLE COEFF))
|
||||
|
||||
(DEFMVAR $%PIARGS T)
|
||||
(DEFMVAR $%IARGS T)
|
||||
(DEFMVAR $TRIGINVERSES '$ALL)
|
||||
(DEFMVAR $TRIGEXPAND NIL)
|
||||
(DEFMVAR $TRIGEXPANDPLUS T)
|
||||
(DEFMVAR $TRIGEXPANDTIMES T)
|
||||
(DEFMVAR $TRIGSIGN T)
|
||||
(DEFMVAR $EXPONENTIALIZE NIL)
|
||||
(DEFMVAR $LOGARC NIL)
|
||||
(DEFMVAR $HALFANGLES NIL)
|
||||
|
||||
(DEFMVAR 1//2 '((RAT SIMP) 1 2))
|
||||
(DEFMVAR -1//2 '((RAT SIMP) -1 2))
|
||||
(DEFMVAR %PI//4 '((MTIMES SIMP) ((RAT SIMP) 1 4.) $%PI))
|
||||
(DEFMVAR %PI//2 '((MTIMES SIMP) ((RAT SIMP) 1 2) $%PI))
|
||||
(DEFMVAR SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
|
||||
((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
|
||||
(DEFMVAR -SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
|
||||
((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
|
||||
(DEFMVAR SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
|
||||
((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
|
||||
(DEFMVAR -SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
|
||||
((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
|
||||
|
||||
;;; Arithmetic utilities.
|
||||
|
||||
(DEFMFUN SQRT1-X^2 (X) (POWER (SUB 1 (POWER X 2)) 1//2))
|
||||
|
||||
(DEFMFUN SQRT1+X^2 (X) (POWER (ADD 1 (POWER X 2)) 1//2))
|
||||
|
||||
(DEFMFUN SQRTX^2-1 (X) (POWER (ADD (POWER X 2) -1) 1//2))
|
||||
|
||||
(DEFMFUN SQ-SUMSQ (X Y) (POWER (ADD (POWER X 2) (POWER Y 2)) 1//2))
|
||||
|
||||
(DEFMFUN TRIGP (FUNC) (MEMQ FUNC '(%SIN %COS %TAN %CSC %SEC %COT
|
||||
%SINH %COSH %TANH %CSCH %SECH %COTH)))
|
||||
|
||||
(DEFMFUN ARCP (FUNC) (MEMQ FUNC '(%ASIN %ACOS %ATAN %ACSC %ASEC %ACOT
|
||||
%ASINH %ACOSH %ATANH %ACSCH %ASECH %ACOTH)))
|
||||
|
||||
(DEFPROP %SIN SIMP-%SIN OPERATORS)
|
||||
(DEFPROP %COS SIMP-%COS OPERATORS)
|
||||
(DEFPROP %TAN SIMP-%TAN OPERATORS)
|
||||
(DEFPROP %COT SIMP-%COT OPERATORS)
|
||||
(DEFPROP %CSC SIMP-%CSC OPERATORS)
|
||||
(DEFPROP %SEC SIMP-%SEC OPERATORS)
|
||||
(DEFPROP %SINH SIMP-%SINH OPERATORS)
|
||||
(DEFPROP %COSH SIMP-%COSH OPERATORS)
|
||||
(DEFPROP %TANH SIMP-%TANH OPERATORS)
|
||||
(DEFPROP %COTH SIMP-%COTH OPERATORS)
|
||||
(DEFPROP %CSCH SIMP-%CSCH OPERATORS)
|
||||
(DEFPROP %SECH SIMP-%SECH OPERATORS)
|
||||
(DEFPROP %ASIN SIMP-%ASIN OPERATORS)
|
||||
(DEFPROP %ACOS SIMP-%ACOS OPERATORS)
|
||||
(DEFPROP %ATAN SIMP-%ATAN OPERATORS)
|
||||
(DEFPROP %ACOT SIMP-%ACOT OPERATORS)
|
||||
(DEFPROP %ACSC SIMP-%ACSC OPERATORS)
|
||||
(DEFPROP %ASEC SIMP-%ASEC OPERATORS)
|
||||
(DEFPROP %ASINH SIMP-%ASINH OPERATORS)
|
||||
(DEFPROP %ACOSH SIMP-%ACOSH OPERATORS)
|
||||
(DEFPROP %ATANH SIMP-%ATANH OPERATORS)
|
||||
(DEFPROP %ACOTH SIMP-%ACOTH OPERATORS)
|
||||
(DEFPROP %ACSCH SIMP-%ACSCH OPERATORS)
|
||||
(DEFPROP %ASECH SIMP-%ASECH OPERATORS)
|
||||
|
||||
(DEFMFUN SIMP-%SIN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SIN Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS Y)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SINH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ASIN (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ACOS Z) (SQRT1-X^2 (CADR Y)))
|
||||
((EQ '%ATAN Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ACOT Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ASEC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV 1 (CADR Y)))
|
||||
((EQ '$ATAN2 Z) (DIV (CADR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SIN Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SIN Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SIN Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SIN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%SIN) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COS (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COS Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS (ADD %PI//2 Y))))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COSH (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ACOS (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (SQRT1-X^2 (CADR Y)))
|
||||
((EQ '%ATAN Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ACOT Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ASEC Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
|
||||
((EQ '$ATAN2 Z) (DIV (CADDR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COS Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COS Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COS Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COS (NEG Y)))
|
||||
(T (EQTEST (LIST '(%COS) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS-SIN\COS (X)
|
||||
(LET ($FLOAT COEFF RATCOEFF REM)
|
||||
(SETQ RATCOEFF (COEFFICIENT X '$%PI 1)
|
||||
COEFF (LINEARIZE RATCOEFF) REM (COEFFICIENT X '$%PI 0))
|
||||
(COND ((ZEROP1 REM) (%PIARGS COEFF RATCOEFF))
|
||||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||||
((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%SIN REM))
|
||||
((EQUAL 1 X) (NEG (CONS-EXP '%SIN REM)))
|
||||
((ALIKE1 1//2 X) (CONS-EXP '%COS REM))
|
||||
((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%COS REM))))))
|
||||
|
||||
(DEFMFUN SIMP-%TAN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TAN Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-TAN\COT Y)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TANH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ATAN (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ACOS Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACOT Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ASEC Z) (SQRTX^2-1 (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '$ATAN2 Z) (DIV (CADR Y) (CADDR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%TAN Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%TAN Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%TAN Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TAN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%TAN) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COT (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COT Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'COT))
|
||||
((AND (LINEARP Y '$%PI) (SETQ Z (%PIARGS-TAN\COT (ADD %PI//2 Y)))) (NEG Z)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ACOT (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACOS Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ATAN Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ASEC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '%ACSC Z) (SQRTX^2-1 (CADR Y)))
|
||||
((EQ '$ATAN2 Z) (DIV (CADDR Y) (CADR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COT Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COT Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COT Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COT (NEG Y))))
|
||||
(T (EQTEST (LIST '(%COT) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS-TAN\COT (X)
|
||||
(PROG ($FLOAT COEFF REM)
|
||||
(SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0))
|
||||
(RETURN (COND ((AND (ZEROP1 REM)
|
||||
(SETQ REM (%PIARGS COEFF NIL))
|
||||
(SETQ COEFF (%PIARGS (CONS (CAR COEFF) (RPLUS 1//2 (CDR COEFF)))
|
||||
NIL)))
|
||||
(DIV REM COEFF))
|
||||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||||
((FIXP (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%TAN REM))
|
||||
((OR (ALIKE1 1//2 X) (ALIKE1 '((RAT) 3 2) X)) (NEG (CONS-EXP '%COT REM)))))))
|
||||
|
||||
(DEFMFUN SIMP-%CSC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSC))
|
||||
((LINEARP Y '$%PI) (%PIARGS-CSC\SEC Y)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSCH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ACSC (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ACOS Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ATAN Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACOT Z) (SQRT1+X^2 (CADR Y)))
|
||||
((EQ '%ASEC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%CSC Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%CSC Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%CSC Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSC (NEG Y))))
|
||||
|
||||
(T (EQTEST (LIST '(%CSC) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%SEC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SEC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-CSC\SEC (ADD %PI//2 Y))))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SECH (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ASEC (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ACOS Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ATAN Z) (SQRT1+X^2 (CADR Y)))
|
||||
((EQ '%ACOT Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADDR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SEC Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SEC Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SEC Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SEC (NEG Y)))
|
||||
|
||||
(T (EQTEST (LIST '(%SEC) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS-CSC\SEC (X)
|
||||
(PROG ($FLOAT COEFF REM)
|
||||
(SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0))
|
||||
(RETURN (COND ((AND (ZEROP1 REM) (SETQ REM (%PIARGS COEFF NIL))) (DIV 1 REM))
|
||||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||||
((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%CSC REM))
|
||||
((EQUAL 1 X) (NEG (CONS-EXP '%CSC REM)))
|
||||
((ALIKE1 1//2 X) (CONS-EXP '%SEC REM))
|
||||
((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%SEC REM)))))))
|
||||
|
||||
(DEFMFUN SIMP-%ATAN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ATAN1 Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) 0)
|
||||
((EQUAL Y 1) (SIMPLIFY FOURTH%PI))
|
||||
((EQUAL Y -1) (NEG (SIMPLIFY FOURTH%PI))))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I))
|
||||
(MUL '$%I (CONS-EXP '%ATANH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(COND ((EQ (CAAR Y) '%TAN) (CADR Y))
|
||||
((EQ (CAAR Y) '%COT) (SUB (SIMPLIFY HALF%PI) (CADR Y))))))
|
||||
($LOGARC (LOGARC '%ATAN Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATAN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ATAN) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS (X RATCOEFF)
|
||||
(COND ((AND (FIXP (CAR X)) (FIXP (CDR X))) 0)
|
||||
((NOT (MEVENP (CAR X)))
|
||||
(COND ((NULL RATCOEFF) NIL)
|
||||
((ALIKE1 (CDR X) '((RAT) 1 2))
|
||||
(POWER -1 (ADD RATCOEFF -1//2)))))
|
||||
((OR (ALIKE1 '((RAT) 1 6) (SETQ X (MMOD (CDR X) 2))) (ALIKE1 '((RAT) 5 6) X))
|
||||
1//2)
|
||||
((OR (ALIKE1 '((RAT) 1 4) X) (ALIKE1 '((RAT) 3 4) X))
|
||||
(DIV (POWER 2 1//2) 2))
|
||||
((OR (ALIKE1 '((RAT) 1 3) X) (ALIKE1 '((RAT) 2 3) X))
|
||||
(DIV (POWER 3 1//2) 2))
|
||||
((ALIKE1 1//2 X) 1)
|
||||
((OR (ALIKE1 '((RAT) 7 6) X) (ALIKE1 '((RAT) 11 6) X)) -1//2)
|
||||
((OR (ALIKE1 '((RAT) 4 3) X) (ALIKE1 '((RAT) 5 3) X))
|
||||
(DIV (POWER 3 1//2) -2))
|
||||
((OR (ALIKE1 '((RAT) 5 4) X) (ALIKE1 '((RAT) 7 4) X))
|
||||
(MUL -1//2 (POWER 2 1//2)))
|
||||
((ALIKE1 '((RAT) 3 2) X) -1)))
|
||||
|
||||
(DEFUN LINEARIZE (FORM)
|
||||
(COND ((FIXP FORM) (CONS 0 FORM))
|
||||
((NUMBERP FORM) NIL)
|
||||
((ATOM FORM)
|
||||
(LET (DUM)
|
||||
(COND ((SETQ DUM (EVOD FORM))
|
||||
(IF (EQ '$EVEN DUM) '(2 . 0) '(2 . 1)))
|
||||
((INTEGERP FORM) '(1 . 0)))))
|
||||
((EQ 'RAT (CAAR FORM)) (CONS 0 FORM))
|
||||
((EQ 'MPLUS (CAAR FORM)) (LIN-MPLUS FORM))
|
||||
((EQ 'MTIMES (CAAR FORM)) (LIN-MTIMES FORM))
|
||||
((EQ 'MEXPT (CAAR FORM)) (LIN-MEXPT FORM))))
|
||||
|
||||
(DEFUN LIN-MPLUS (FORM)
|
||||
(DO ((TL (CDR FORM) (CDR TL)) (DUMMY) (COEFF 0) (REM 0))
|
||||
((NULL TL) (IF (FIXNUMP COEFF) (CONS COEFF (MMOD REM COEFF))))
|
||||
(SETQ DUMMY (LINEARIZE (CAR TL)))
|
||||
(IF (NULL DUMMY)
|
||||
(RETURN NIL)
|
||||
(SETQ COEFF (RGCD (CAR DUMMY) COEFF) REM (RPLUS (CDR DUMMY) REM)))))
|
||||
|
||||
(DEFUN LIN-MTIMES (FORM)
|
||||
(DO ((FL (CDR FORM) (CDR FL)) (DUMMY) (COEFF 0) (REM 1))
|
||||
((NULL FL) (IF (FIXNUMP COEFF) (CONS COEFF (MMOD REM COEFF))))
|
||||
(SETQ DUMMY (LINEARIZE (CAR FL)))
|
||||
(IF (NULL DUMMY)
|
||||
(RETURN NIL)
|
||||
(SETQ COEFF (RGCD (RTIMES COEFF (CAR DUMMY))
|
||||
(RGCD (RTIMES COEFF (CDR DUMMY))
|
||||
(RTIMES REM (CAR DUMMY))))
|
||||
REM (RTIMES (CDR DUMMY) REM)))))
|
||||
|
||||
(DEFUN LIN-MEXPT (FORM)
|
||||
(LET (DUMMY)
|
||||
(IF (AND (FIXNUMP (CADDR FORM))
|
||||
(NOT (MINUSP (CADDR FORM)))
|
||||
(NOT (NULL (SETQ DUMMY (LINEARIZE (CADR FORM))))))
|
||||
(CONS (CAR DUMMY) (MMOD (CDR DUMMY) (CADDR FORM))))))
|
||||
|
||||
|
||||
(DEFUN LCM (X Y) (QUOTIENT (TIMES X Y) (GCD X Y)))
|
||||
|
||||
(DEFUN RGCD (X Y)
|
||||
(COND ((FIXP X)
|
||||
(COND ((FIXP Y) (GCD X Y))
|
||||
(T (LIST '(RAT) (GCD X (CADR Y)) (CADDR Y)))))
|
||||
((FIXP Y) (LIST '(RAT) (GCD (CADR X) Y) (CADDR X)))
|
||||
(T (LIST '(RAT) (GCD (CADR X) (CADR Y)) (LCM (CADDR X) (CADDR Y))))))
|
||||
|
||||
(DEFUN REDUCE (X Y)
|
||||
(PROG (GCD)
|
||||
(SETQ GCD (GCD X Y) X (QUOTIENT X GCD) Y (QUOTIENT Y GCD))
|
||||
(IF (MINUSP Y) (SETQ X (MINUS X) Y (MINUS Y)))
|
||||
(RETURN (IF (EQUAL Y 1) X (LIST '(RAT SIMP) X Y)))))
|
||||
|
||||
;; The following four functions are generated in code by TRANSL. - JPG 2/1/81
|
||||
|
||||
(DEFMFUN RPLUS (X Y) (ADDK X Y))
|
||||
|
||||
(DEFMFUN RDIFFERENCE (X Y) (ADDK X (TIMESK -1 Y)))
|
||||
|
||||
(DEFMFUN RTIMES (X Y) (TIMESK X Y))
|
||||
|
||||
(DEFMFUN RREMAINDER (X Y)
|
||||
(COND ((EQUAL 0 Y) (DBZ-ERR))
|
||||
((FIXP X)
|
||||
(COND ((FIXP Y) (REDUCE X Y))
|
||||
(T (REDUCE (TIMES X (CADDR Y)) (CADR Y)))))
|
||||
((FIXP Y) (REDUCE (CADR X) (TIMES (CADDR X) Y)))
|
||||
(T (REDUCE (TIMES (CADR X) (CADDR Y)) (TIMES (CADDR X) (CADR Y))))))
|
||||
|
||||
(DEFMFUN $EXPONENTIALIZE (EXP)
|
||||
(LET ($DEMOIVRE)
|
||||
(COND ((ATOM EXP) EXP)
|
||||
((TRIGP (CAAR EXP))
|
||||
(EXPONENTIALIZE (CAAR EXP) ($EXPONENTIALIZE (CADR EXP))))
|
||||
(T (RECUR-APPLY #'$EXPONENTIALIZE EXP)))))
|
||||
|
||||
(DEFMFUN EXPONENTIALIZE (OP ARG)
|
||||
(COND ((EQ '%SIN OP)
|
||||
(DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
|
||||
(MUL 2 '$%I)))
|
||||
((EQ '%COS OP)
|
||||
(DIV (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))) 2))
|
||||
((EQ '%TAN OP)
|
||||
(DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
|
||||
(MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
|
||||
(POWER '$%E (MUL -1 '$%I ARG))))))
|
||||
((EQ '%COT OP)
|
||||
(DIV (MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
|
||||
(POWER '$%E (MUL -1 '$%I ARG))))
|
||||
(SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||||
((EQ '%CSC OP)
|
||||
(DIV (MUL 2 '$%I)
|
||||
(SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||||
((EQ '%SEC OP)
|
||||
(DIV 2 (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||||
((EQ '%SINH OP)
|
||||
(DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))) 2))
|
||||
((EQ '%COSH OP)
|
||||
(DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))) 2))
|
||||
((EQ '%TANH OP)
|
||||
(DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))
|
||||
(ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))
|
||||
((EQ '%COTH OP)
|
||||
(DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))
|
||||
(SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
|
||||
((EQ '%CSCH OP)
|
||||
(DIV 2 (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
|
||||
((EQ '%SECH OP)
|
||||
(DIV 2 (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))))
|
||||
|
||||
(DEFUN COEFFICIENT (EXP VAR POW)
|
||||
(LET ($NUMER $FLOAT) (COEFF (EXPAND1 EXP 1 0) VAR POW)))
|
||||
|
||||
(DEFUN LINEARP (EXP VAR)
|
||||
(LET ($NUMER $FLOAT)
|
||||
(AND (SETQ EXP (ISLINEAR (EXPAND1 EXP 1 0) VAR))
|
||||
(NOT (EQUAL (CAR EXP) 0)))))
|
||||
|
||||
(DEFUN MMOD (X MOD)
|
||||
(COND ((FIXNUMP X)
|
||||
(IF (MINUSP (SETQ X (- X (* MOD (// X MOD))))) (+ X MOD) X))
|
||||
((RATNUMP X)
|
||||
(LIST '(RAT) (MMOD (CADR X) (* MOD (CADDR X))) (CADDR X)))))
|
||||
|
||||
(DEFUN MULTIPLEP (EXP VAR)
|
||||
(AND (NOT (ZEROP1 EXP)) (ZEROP1 (SUB EXP (MUL VAR (COEFF EXP VAR 1))))))
|
||||
|
||||
(DEFMFUN MMINUSP (X) (= -1 (SIGNUM1 X)))
|
||||
|
||||
(DEFMFUN MMINUSP* (X) (MMINUSP X)) ;; This could be done by a macro in
|
||||
;; LIBMAX;MAXMAC . - JPG
|
||||
|
||||
;; The following definition for MMINUSP* was used experimentally to test
|
||||
;; for e.g. SIN(-X) -> -SIN(X) using the Macsyma database. However, this
|
||||
;; approach was found to be very slow in many cases. Instead the syntactic
|
||||
;; check offered by MMINUSP should be quite sufficient. - JPG
|
||||
|
||||
;;(DEFMFUN MMINUSP* (X)
|
||||
;; (LET (SIGN)
|
||||
;; (SETQ SIGN (CSIGN X))
|
||||
;; (OR (MEMQ SIGN '($NEG $NZ))
|
||||
;; (AND (MMINUSP X) (NOT (MEMQ SIGN '($POS $PZ)))))))
|
||||
|
||||
(DEFUN DBZ-ERR ()
|
||||
(IF (NOT ERRORSW) (MERROR "Division by zero") (*THROW 'ERRORSW T)))
|
||||
|
||||
(DEFUN DBZ-ERR1 (FUNC)
|
||||
(IF (NOT ERRORSW) (MERROR "Division by zero in ~A function" FUNC)
|
||||
(*THROW 'ERRORSW T)))
|
||||
|
||||
;; Only used by LAP code right now.
|
||||
|
||||
#+PDP10
|
||||
(DEFUN NUMERIC-ERR (X MSG) (MERROR "~A in ~A function" MSG X))
|
||||
|
||||
;; Trig, hyperbolic functions, and inverses, which take real floating args
|
||||
;; and return real args. Checks made for overflow and out of range args.
|
||||
;; The following are read-time constants.
|
||||
;; This seems bogus. Probably want (FSC (LSH 1 26.) 0) for the PDP10. -cwh
|
||||
|
||||
#.(SETQ EPS #+PDP10 (FSC 1.0 -26.)
|
||||
#+LispM (ASH 1.0 #+3600 -24. #-3600 -31.)
|
||||
#-(or PDP10 LispM) 1.4E-8)
|
||||
|
||||
#.(SETQ PI (ATAN 0.0 -1.0) PIBY2 (//$ PI 2.0))
|
||||
|
||||
;; This function is in LAP for PDP10 systems. On the Lisp Machine and
|
||||
;; in NIL, this should CONDITION-BIND the appropriate arithmetic overflow
|
||||
;; signals and do whatever NUMERIC-ERR or DBZ-ERR does. Fix later.
|
||||
|
||||
#-(OR PDP10 LISPM) (DEFMACRO T//$ (X Y FUNCTION) FUNCTION ;Ignored
|
||||
`(//$ ,X ,Y))
|
||||
#+LISPM
|
||||
(DEFMACRO T//$ (X Y FUNCTION)
|
||||
(IF (EQUAL Y 0.0)
|
||||
;; DEFEAT INCOMPETENTLY DONE COMPILER:OPTIMIZATION.
|
||||
`(T//$-FOO ,X ,Y ,FUNCTION)
|
||||
`(//$ ,X ,Y)))
|
||||
#+LISPM
|
||||
(DEFUN T//$-FOO (X Y FUNCTION) FUNCTION
|
||||
(//$ X Y))
|
||||
|
||||
#+PDP10 (LAP-A-LIST '(
|
||||
|
||||
(LAP T//$ SUBR)
|
||||
(ARGS T//$ (NIL . 3))
|
||||
(PUSH P (% 0 0 FLOAT1))
|
||||
(JRST 2 @ (% 0 0 NEXTA))
|
||||
NEXTA (MOVE TT 0 A)
|
||||
(FDVR TT 0 B) ;DIVIDE TT BY SECOND ARG
|
||||
(JFCL 10 UFLOW)
|
||||
ANS (POPJ P)
|
||||
UFLOW (MOVE A C)
|
||||
(SKIPN 0 0 B)
|
||||
(JCALL 1 'DBZ-ERR1)
|
||||
(MOVEI B 'OVERFLOW)
|
||||
(JSP T NEXTB)
|
||||
NEXTB (TLNN T 64.)
|
||||
(JCALL 2 'NUMERIC-ERR)
|
||||
(MOVEI B 'UNDERFLOW)
|
||||
(SKIPN 0 (SPECIAL ZUNDERFLOW))
|
||||
(JCALL 2 'NUMERIC-ERR)
|
||||
(MOVEI TT 0)
|
||||
(JRST 0 ANS)
|
||||
NIL ))
|
||||
|
||||
;; Numeric functions (SIN, COS, LOG, EXP are built in to Lisp).
|
||||
|
||||
(DEFMFUN TAN (X) (T//$ (SIN X) (COS X) 'TAN))
|
||||
|
||||
(DEFMFUN COT (X) (T//$ (COS X) (SIN X) 'COT))
|
||||
|
||||
(DEFMFUN SEC (X) (T//$ 1.0 (COS X) 'SEC))
|
||||
|
||||
(DEFMFUN CSC (X) (T//$ 1.0 (SIN X) 'CSC))
|
||||
|
||||
;; #.<form> means to evaluate <form> at read-time.
|
||||
|
||||
(DECLARE (FLONUM YY YFLO))
|
||||
|
||||
;; We don't use the built-in Franz definitions of ASIN and ACOS because
|
||||
;; they obviously don't know about LOGARC. - JPG
|
||||
|
||||
(DEFMFUN ASIN (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((> (ABS YFLO) 1.0) (LOGARC '%ASIN YFLO))
|
||||
((< (ABS YFLO) #.(SQRT EPS)) YFLO)
|
||||
(T (*$ (ATAN (ABS YFLO) (SQRT (-$ 1.0 (*$ YFLO YFLO))))
|
||||
(IF (< YFLO 0.0) -1.0 1.0))))))
|
||||
|
||||
(DEFMFUN ACOS (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((> (ABS YFLO) 1.0) (LOGARC '%ACOS YFLO))
|
||||
((< (ABS YFLO) #.(SQRT EPS)) (-$ #.PIBY2 YFLO))
|
||||
(T (ATAN (SQRT (-$ 1.0 (*$ YFLO YFLO))) YFLO)))))
|
||||
#-LispM
|
||||
(DEFMFUN ATAN2 (Y X)
|
||||
(LET ((YFLO (ATAN (ABS Y) X))) (IF (MINUSP Y) (-$ YFLO) YFLO)))
|
||||
|
||||
(DEFMFUN ATAN1 (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(*$ (ATAN (ABS YFLO) 1.0) (IF (MINUSP YFLO) -1.0 1.0))))
|
||||
|
||||
(DEFMFUN ACOT (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(*$ (ATAN 1.0 (ABS YFLO)) (IF (MINUSP YFLO) -1.0 1.0))))
|
||||
|
||||
(DEFMFUN ASEC (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(IF (< (ABS YFLO) 1.0) (LOGARC '%ASEC YFLO)) (ACOS (//$ YFLO))))
|
||||
|
||||
(DEFMFUN ACSC (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(IF (< (ABS YFLO) 1.0) (LOGARC '%ACSC YFLO)) (ASIN (//$ YFLO))))
|
||||
|
||||
(DEFMFUN SINH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||||
(T (SETQ YFLO (EXP (ABS YY)) YFLO (//$ (-$ YFLO (//$ YFLO)) 2.0))
|
||||
(IF (< YY 0.0) (-$ YFLO) YFLO)))))
|
||||
|
||||
(DEFMFUN COSH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(SETQ YFLO (EXP (ABS YFLO))) (//$ (+$ YFLO (//$ YFLO)) 2.0)))
|
||||
|
||||
#-Lispm
|
||||
(DEFMFUN TANH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY)))
|
||||
YFLO (//$ (1-$ YFLO) (1+$ YFLO)))
|
||||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||||
|
||||
#+Lispm
|
||||
(DEFMFUN TANH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||||
(T (LET ((ANSWER 0.0))
|
||||
(SETQ ANSWER
|
||||
(COND ((> (ABS YY) #.(//$ (-$ (LOG EPS)) 2.0)) -1.0)
|
||||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY)))
|
||||
ANSWER (//$ (1-$ YFLO) (1+$ YFLO))))))
|
||||
(IF (PLUSP YY) (-$ ANSWER) ANSWER))))))
|
||||
|
||||
(DEFMFUN COTH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) (T//$ 1.0 YY 'COTH))
|
||||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY)))
|
||||
YFLO (T//$ (1+$ YFLO) (1-$ YFLO) 'COTH))
|
||||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||||
|
||||
(DEFMFUN CSCH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) (//$ YY))
|
||||
(T (SETQ YFLO (EXP (-$ (ABS YY)))
|
||||
YFLO (T//$ (*$ 2.0 YFLO)
|
||||
(1-$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))) 'CSCH))
|
||||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||||
|
||||
(DEFMFUN SECH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM))) (SETQ YFLO (EXP (-$ (ABS YFLO))))
|
||||
(//$ YFLO 0.5 (1+$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))))))
|
||||
|
||||
(DEFMFUN ACOSH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((< YFLO 1.0) (LOGARC '%ACOSH YFLO))
|
||||
((> YFLO #.(SQRT (//$ EPS))) (LOG (*$ 2.0 YFLO)))
|
||||
(T (LOG (+$ (SQRT (1-$ (*$ YFLO YFLO))) YFLO))))))
|
||||
|
||||
(DEFMFUN ASINH (NUM)
|
||||
(LET* ((YY (FLOAT NUM))
|
||||
(YFLO (ABS YY)))
|
||||
(COND ((< YFLO #.(SQRT EPS)) YFLO)
|
||||
(T (SETQ YFLO (LOG (COND ((> YFLO #.(SQRT (//$ EPS))) (*$ 2.0 YFLO))
|
||||
(T (+$ (SQRT (1+$ (*$ YFLO YFLO))) YFLO)))))
|
||||
(COND ((MINUSP YY) (-$ YFLO)) (T YFLO))))))
|
||||
|
||||
(DEFMFUN ATANH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((< (ABS YFLO) #.(SQRT EPS)) YFLO)
|
||||
((< (ABS YFLO) 1.0) (//$ (LOG (T//$ (1+$ YFLO) (-$ 1.0 YFLO) 'ATANH)) 2.0))
|
||||
((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ATANH))
|
||||
(T (LOGARC '%ATANH YFLO)))))
|
||||
|
||||
(DEFMFUN ACOTH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((> (ABS YFLO) 1.0) (//$ (LOG (//$ (-$ 1.0 YFLO) (1+$ YFLO))) 2.0))
|
||||
((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ACOTH))
|
||||
(T (LOGARC '%ACOTH YFLO)))))
|
||||
|
||||
(DEFMFUN ASECH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((OR (MINUSP YFLO) (> YFLO 1.0)) (LOGARC '%ASECH YFLO)))
|
||||
(ACOSH (T//$ 1.0 YFLO 'ASECH))))
|
||||
|
||||
(DEFMFUN ACSCH (NUM) (ASINH (T//$ 1.0 (FLOAT NUM) 'ACSCH)))
|
||||
|
||||
378
src/mrg/trigo.333
Normal file
378
src/mrg/trigo.333
Normal file
@@ -0,0 +1,378 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module trigo)
|
||||
|
||||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||||
|
||||
(DECLARE (GENPREFIX TRI)
|
||||
(SPECIAL VARLIST ERRORSW)
|
||||
(FLONUM (TAN) (COT) (SEC) (CSC)
|
||||
(ATAN2) (ATAN1) (ACOT)
|
||||
(SINH) (COSH) (TANH) (COTH) (CSCH) (SECH)
|
||||
(ASINH) (ACSCH)
|
||||
(T//$ FLONUM FLONUM NOTYPE))
|
||||
(*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR
|
||||
TIMESK ADDK INTEGERP EVOD LOGARC MEVENP HALFANGLE COEFF))
|
||||
|
||||
(DECLARE (SPLITFILE HYPER))
|
||||
|
||||
(DEFMFUN SIMP-%SINH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SINH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) 0)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SIN (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASINH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SINH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SINH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SINH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SINH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%SINH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COSH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COSH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) 1)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COS (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOSH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COSH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COSH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COSH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COSH (NEG Y)))
|
||||
(T (EQTEST (LIST '(%COSH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%TANH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TANH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) 0)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TAN (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ATANH (SETQ Z (CAAR Y))) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%TANH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%TANH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%TANH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TANH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%TANH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COTH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COTH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'COTH))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOTH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COTH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COTH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COTH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COTH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%COTH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%CSCH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSCH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSCH)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSC (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACSCH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%CSCH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%CSCH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%CSCH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSCH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%CSCH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%SECH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SECH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (ZEROP1 Y)) 1)
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SEC (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASECH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SECH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SECH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SECH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SECH (NEG Y)))
|
||||
(T (EQTEST (LIST '(%SECH) Y) FORM))))
|
||||
|
||||
(DECLARE (SPLITFILE ATRIG))
|
||||
|
||||
(DEFMFUN SIMP-%ASIN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASIN Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) 0) ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2))
|
||||
((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 6) '$%PI)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASINH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) (IF (EQ '%SIN (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASIN Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASIN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ASIN) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOS (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOS Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI)
|
||||
((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 3) '$%PI)))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COS (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOS Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ACOS (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACOS) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOT (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOT Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) %PI//4) ((EQUAL -1 Y) (NEG %PI//4)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOTH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COT (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOT Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOT (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACOT) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACSC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSCH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%CSC (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACSC Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSC (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACSC) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ASEC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASEC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%SEC (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASEC Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ASEC (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ASEC) Y) FORM))))
|
||||
|
||||
(DECLARE (SPLITFILE AHYPER))
|
||||
|
||||
(DEFMFUN SIMP-%ASINH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASINH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) Y)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASIN (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%SINH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASINH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASINH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ASINH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOSH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOSH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (EQUAL Y 1) 0)))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COSH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOSH Y))
|
||||
(T (EQTEST (LIST '(%ACOSH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ATANH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ATANH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 0)
|
||||
((OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ATANH)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ATAN (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%TANH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ATANH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATANH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ATANH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOTH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOTH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ACOTH))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOT (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COTH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOTH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOTH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACOTH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACSCH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSCH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'ACSCH))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSC (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%CSCH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACSCH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSCH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACSCH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ASECH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASECH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((EQUAL Y 1) 0)
|
||||
((ZEROP1 Y) (DBZ-ERR1 'ASECH)))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%SECH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASECH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%ASECH (NEG Y)))
|
||||
(T (EQTEST (LIST '(%ASECH) Y) FORM))))
|
||||
|
||||
(DECLARE (SPLITFILE TRIGEX) (SPECIAL $TRIGEXPANDPLUS $TRIGEXPANDTIMES))
|
||||
|
||||
(DEFMFUN $TRIGEXPAND (E)
|
||||
(COND ((ATOM E) E)
|
||||
((SPECREPP E) ($TRIGEXPAND (SPECDISREP E)))
|
||||
((TRIGEXPAND (CAAR E) (CADR E)))
|
||||
(T (RECUR-APPLY #'$TRIGEXPAND E))))
|
||||
|
||||
(DEFMFUN TRIGEXPAND (OP ARG)
|
||||
(COND ((ATOM ARG) NIL)
|
||||
((AND $TRIGEXPANDPLUS (EQ 'MPLUS (CAAR ARG)))
|
||||
(COND ((EQ '%SIN OP) (SIN\COS-PLUS (CDR ARG) 1 '%SIN '%COS -1))
|
||||
((EQ '%COS OP) (SIN\COS-PLUS (CDR ARG) 0 '%SIN '%COS -1))
|
||||
((EQ '%TAN OP) (TAN-PLUS (CDR ARG) '%TAN -1))
|
||||
((EQ '%COT OP) (COT-PLUS (CDR ARG) '%COT -1))
|
||||
((EQ '%CSC OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSC '%SEC -1))
|
||||
((EQ '%SEC OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSC '%SEC -1))
|
||||
((EQ '%SINH OP) (SIN\COS-PLUS (CDR ARG) 1 '%SINH '%COSH 1))
|
||||
((EQ '%COSH OP) (SIN\COS-PLUS (CDR ARG) 0 '%SINH '%COSH 1))
|
||||
((EQ '%TANH OP) (TAN-PLUS (CDR ARG) '%TANH 1))
|
||||
((EQ '%COTH OP) (COT-PLUS (CDR ARG) '%COTH 1))
|
||||
((EQ '%CSCH OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSCH '%SECH 1))
|
||||
((EQ '%SECH OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSCH '%SECH 1))))
|
||||
((AND $TRIGEXPANDTIMES (EQ 'MTIMES (CAAR ARG)) (EQ (TYPEP (CADR ARG)) 'FIXNUM))
|
||||
(COND ((EQ '%SIN OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SIN '%COS -1))
|
||||
((EQ '%COS OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SIN '%COS -1))
|
||||
((EQ '%TAN OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TAN -1))
|
||||
((EQ '%COT OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COT -1))
|
||||
((EQ '%CSC OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSC '%SEC -1))
|
||||
((EQ '%SEC OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSC '%SEC -1))
|
||||
((EQ '%SINH OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SINH '%COSH 1))
|
||||
((EQ '%COSH OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SINH '%COSH 1))
|
||||
((EQ '%TANH OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TANH 1))
|
||||
((EQ '%COTH OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COTH 1))
|
||||
((EQ '%CSCH OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSCH '%SECH 1))
|
||||
((EQ '%SECH OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSCH '%SECH 1))))))
|
||||
|
||||
|
||||
(DEFUN SIN\COS-PLUS (L N F1 F2 FLAG)
|
||||
(DO ((I N (+ 2 I)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (RESULT))
|
||||
((> I LEN) (SIMPLIFY (CONS '(MPLUS) RESULT)))
|
||||
(SETQ RESULT (MPC (COND ((MINUSP SIGN) '(-1 (MTIMES))) (T '((MTIMES)))) L RESULT F1 F2 LEN I))))
|
||||
|
||||
(DEFUN TAN-PLUS (L F FLAG)
|
||||
(DO ((I 1 (+ 2 I)) (SIGN 1 (* FLAG SIGN)) (LEN (LENGTH L)) (NUM) (DEN (LIST 1)))
|
||||
((> I LEN) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
|
||||
DEN (COND ((= LEN I) DEN)
|
||||
(T (MPC1 (LIST (* FLAG SIGN) '(MTIMES)) L DEN F LEN (1+ I)))))))
|
||||
|
||||
(DEFUN COT-PLUS (L F FLAG)
|
||||
(DO ((I (LENGTH L) (- I 2)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (NUM) (DEN))
|
||||
((< I 0) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
|
||||
DEN (COND ((= 0 I) DEN)
|
||||
(T (MPC1 (LIST SIGN '(MTIMES)) L DEN F LEN (1- I)))))))
|
||||
|
||||
(DEFUN CSC\SEC-PLUS (L N F1 F2 FLAG)
|
||||
(DIV* (DO ((L L (CDR L)) (RESULT)) ((NULL L) (CONS '(MTIMES) RESULT))
|
||||
(SETQ RESULT (CONS (CONS-EXP F1 (CAR L)) (CONS (CONS-EXP F2 (CAR L)) RESULT))))
|
||||
(SIN\COS-PLUS L N F1 F2 FLAG)))
|
||||
|
||||
(DEFUN SIN\COS-TIMES (L M N F1 F2 FLAG)
|
||||
;; Assume m,n < 2^17, but Binom may become big
|
||||
;; Flag is 1 or -1
|
||||
(SETQ F1 (CONS-EXP F1 (CONS '(MTIMES) L)) F2 (CONS-EXP F2 (CONS '(MTIMES) L)))
|
||||
(DO ((I M (+ 2 I)) (END (ABS N)) (RESULT)
|
||||
(BINOM (COND ((= 0 M) 1) (T (ABS N))) (quotient (times (* FLAG (- END I 1) (- END I)) BINOM) (* (+ 2 I) (1+ I)))))
|
||||
((> I END) (SETQ RESULT (SIMPLIFY (CONS '(MPLUS) RESULT)))
|
||||
(COND ((AND (= 1 M) (MINUSP N)) (NEG RESULT)) (T RESULT)))
|
||||
(SETQ RESULT (CONS (MUL BINOM (POWER F1 I) (POWER F2 (- END I))) RESULT))))
|
||||
|
||||
(DEFUN TAN-TIMES (L N F FLAG)
|
||||
(SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
|
||||
(DO ((I 1 (+ 2 I)) (END (ABS N)) (NUM) (DEN (LIST 1))
|
||||
(BINOM (ABS N) (quotient (times (- END I 1) BINOM) (+ 2 I))))
|
||||
((> I END) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(COND ((MINUSP N) (NEG NUM)) (T NUM)))
|
||||
(SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM)
|
||||
DEN (COND ((= END I) DEN)
|
||||
(T (CONS (MUL (SETQ BINOM (quotient (times (* FLAG (- END I)) BINOM) (1+ I)))
|
||||
(POWER F (1+ I)))
|
||||
DEN))))))
|
||||
|
||||
(DEFUN COT-TIMES (L N F FLAG)
|
||||
(SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
|
||||
(DO ((I (ABS N) (- I 2)) (END (ABS N)) (NUM) (DEN)
|
||||
(BINOM 1 (quotient (times (* FLAG (1- I)) BINOM) (- END I -2))))
|
||||
((< I 0) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(IF (MINUSP N) (NEG NUM) NUM))
|
||||
(SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM)
|
||||
DEN (IF (= 0 I) DEN
|
||||
(CONS (MUL (SETQ BINOM (quotient (times I BINOM) (- END I -1))) (POWER F (1- I))) DEN)))))
|
||||
|
||||
(DEFUN CSC\SEC-TIMES (L M N F1 F2 FLAG)
|
||||
(DIV* (MUL (POWER (CONS-EXP F1 (CONS '(MTIMES) L)) (ABS N))
|
||||
(POWER (CONS-EXP F2 (CONS '(MTIMES) L)) (ABS N)))
|
||||
(SIN\COS-TIMES L M N F1 F2 FLAG)))
|
||||
|
||||
(DEFUN MPC (DL UL RESULT F1 F2 DI UI)
|
||||
(COND ((= 0 UI)
|
||||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F2 L)) UL))
|
||||
RESULT))
|
||||
((= DI UI)
|
||||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F1 L)) UL))
|
||||
RESULT))
|
||||
(T (MPC (CONS (CONS-EXP F1 (CAR UL)) DL) (CDR UL)
|
||||
(MPC (CONS (CONS-EXP F2 (CAR UL)) DL)
|
||||
(CDR UL) RESULT F1 F2 (1- DI) UI) F1 F2
|
||||
(1- DI) (1- UI)))))
|
||||
|
||||
(DEFUN MPC1 (DL UL RESULT F DI UI)
|
||||
(COND ((= 0 UI) (CONS (REVERSE DL) RESULT))
|
||||
((= DI UI)
|
||||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F L)) UL)) RESULT))
|
||||
(T (MPC1 (CONS (CONS-EXP F (CAR UL)) DL) (CDR UL)
|
||||
(MPC1 DL (CDR UL) RESULT F (1- DI) UI) F
|
||||
(1- DI) (1- UI)))))
|
||||
|
||||
;; Local Modes:
|
||||
;; Mode: LISP
|
||||
;; Comment Col: 40
|
||||
;; End:
|
||||
|
||||
Reference in New Issue
Block a user