mirror of
https://github.com/PDP-10/its.git
synced 2026-03-23 09:19:24 +00:00
bf8f96b837
Also updates a bunch of Macsyma sources to latest versions, which was needed to get declare working with consistent sources. Resolves #960.
119 lines
4.4 KiB
Common Lisp
119 lines
4.4 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- 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))))))
|