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