(FILECREATED "19-Feb-87 09:42:40" {QV}<LFG>PARSER>SIMPLIFY.;1
 4714   

      previous date: " 6-NOV-79 17:25:50" <LISPUSERS>SIMPLIFY.;3)


(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT SIMPLIFYCOMS)

(RPAQQ SIMPLIFYCOMS
 ((* Tools for symbolic simplification of LISP forms)
		       (FNS SIMPLIFY)
		       (FNS APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL)
		       (BLOCKS (APPLYFORM APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL))))



(* Tools for symbolic simplification of LISP forms)


(DEFINEQ

(SIMPLIFY

  [LAMBDA (FORM)                                             (* bas: " 6-NOV-79 16:51")

                                                             (* Eventually this will be a general symbolic 

							     simplification package, but for now its just a dummy 

							     entry)

    FORM])
)
(DEFINEQ

(APPLYFORM

  [LAMBDA (FN ARG1)                                          (* bas: " 6-NOV-79 17:24")

    (
PROG
 (FNARG FNFORM)
	    (
RETURN
 (if
 (
AND
 (
EQ
 (
CAR
 (
LISTP
 FN))
					 (
QUOTE
 LAMBDA))
				   [
LISTP
 (
CAR
 (
LISTP
 (
CDR
 FN]
				   (
NULL
 (
CDADR
 FN))
				   (
LITATOM
 (
SETQ
 FNARG (
CAADR
 FN)))
				   FNARG
				   (
OR
 (
PROGN
 (
SETQ
 FNFORM (if
 (
CDDDR
 FN)
								     then
 (
CONS
 (
QUOTE
 PROGN)
										    (
CDDR
 FN))
								   else
 (
CADDR
 FN)))
						  (SIMPLEP
 ARG1))
					 (ONCE
 FNARG FNFORM)))
			  then
 

          (* We know that FN is a LAMBDA with one non-NIL litatom argument, and that either FNARG can be safely evaluated 

	  multiple times or the function body only references it once.)



				 (if
 (
EQ
 FNARG ARG1)
				     then
                  (* Arg and arg name are same so body will do)

					    FNFORM
				   else
 (SUBSTVAL
 ARG1 FNARG FNFORM))
			else
 (
LIST
 FN ARG1])

(ONCE

  [LAMBDA (
ATOM
 FORM FLG)                                  (* bas: "19-AUG-78 17:34")

    (DECLARE
 (
SPECVARS
 FLG))
    (ONCE1
 ATOM FORM)
    (
NEQ
 FLG (
QUOTE
 FAILED])

(ONCE1

  [LAMBDA (A L)                                              (* bas: "18-SEP-79 17:03")

    (for
 I in
 L do
 [if
 (
LISTP
 I)
			     then
 (
OR
 (OPAQUE
 I A)
					  (ONCE1
 A I))
			   elseif
 (
EQ
 A I)
			     then
 (
SETQ
 FLG (if
 FLG
						    then
 (
QUOTE
 FAILED)
						  else
 (
QUOTE
 ONCE]
       until
 (
EQ
 FLG (
QUOTE
 FAILED])

(OPAQUE

  [LAMBDA (FORM VAR)                                         (* rmk: " 5-AUG-79 22:11")

                                                             (* Determines if VAR substitution can take place in 

							     FORM)

    (
SELECTQ
 (
CAR
 FORM)
	       (
QUOTE
 T)
	       ([LAMBDA NLAMBDA]
		 (
FMEMB
 VAR (
CADR
 FORM)))
	       [
PROG
 (for
 I in
 (
CADR
 FORM) thereis
 (
EQ
 VAR (if
 (
LISTP
 I)
									   then
 (
CAR
 I)
									 else
 I]
	       NIL])

(SIMPLEP

  [LAMBDA (FORM)                                             (* rmk: " 5-AUG-79 22:06")

                                                             (* Decides if a form is simple enough so that it can 

							     be evaluated repeatedly rather than taking a LAMBDA 

							     binding)

    (
OR
 (
ATOM
 FORM)
	  (
SELECTQ
 (
CAR
 (
LISTP
 FORM))
		     ((
QUOTE
 CAR CDR CADR CDDR)
		       (
LITATOM
 (
CADR
 FORM)))
		     NIL)
	  (
STRINGP
 FORM])

(SUBSTVAL

  [LAMBDA (NEW OLD FORM)                                     (* bas: " 8-MAR-79 20:39")

                                                             (* Substitutes NEW for OLD in FORM.

							     Just like SUBST except is sensitive to opacity)

    (if
 (
LISTP
 FORM)
	then
 [if
 (OPAQUE
 FORM OLD)
		   then
 FORM
		 else
 (
PROG
 (NSCR OSCR)
			        (
RETURN
 (if
 [
SETQ
 OSCR (for
 I in
 FORM
								thereis
 (
NEQ
 I
										 (
SETQ
 NSCR
										   (SUBSTVAL
 NEW 
											      OLD I]
					      then
 (for
 I in
 FORM
							collect
 (if
 (
NULL
 OSCR)
								      then
 (SUBSTVAL
 NEW OLD I)
								    elseif
 (
EQ
 OSCR I)
								      then
 (
SETQ
 OSCR NIL)
									     NSCR
								    else
 I))
					    else
 FORM]
      elseif
 (
EQ
 FORM OLD)
	then
 NEW
      else
 FORM])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: APPLYFORM APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL)
]
(PUTPROPS SIMPLIFY COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (541 874 (SIMPLIFY 551 . 872)) (875 4521 (APPLYFORM 885 . 1935) (ONCE 1937 . 2140) (
ONCE1 2142 . 2557) (OPAQUE 2559 . 3085) (SIMPLEP 3087 . 3588) (SUBSTVAL 3590 . 4519)))))
STOP