(FILECREATED "13-Jan-84 19:24:43" {PHYLUM}<LISP>LIBRARY>CMLSPECIALFORMS.;6
 16586  

      changes to:  (VARS CMLSPECIALFORMSCOMS)
		   (FNS DEFUN \LetPPMacro)

      previous date: " 9-NOV-83 23:22:03" {PHYLUM}<LISP>LIBRARY>CMLSPECIALFORMS.;5)


(* Copyright (c) 1983, 1984 by Xerox Corporation)

(PRETTYCOMPRINT CMLSPECIALFORMSCOMS)

(RPAQQ CMLSPECIALFORMSCOMS
 [(COMS (* CommonLisp style DEFUN, LET and LET@ macros and other primitives)
				  (MACROS LET LET*)
				  [COMS (* Patchup until \DECL.COMNT.PROCESS goes into system)
					(FNS \DECL.COMNT.PROCESS.cmlspecs)
					(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE 
								     \DECL.COMNT.PROCESS.cmlspecs)
										 (QUOTE 
									      \DECL.COMNT.PROCESS))
									  (PUTD (QUOTE 
								     \DECL.COMNT.PROCESS.cmlspecs]
				  (FNS \LETtran \LetPPMacro)
				  (ALISTS (PRETTYPRINTMACROS LET LET*))
				  (FNS DEFUN LIST*)
				  (MACROS LIST* PSETQ PROGV))
			    [COMS (* CommonLisp style CATCH and THROW)
				  (FNS CATCH \CATCH.AUX \CATCH.FINDFRAME \CATCH.TAG.INTERN THROW 
				       \THROW.AUX)
				  (MACROS CATCH *CATCH \CATCHRUNFUN THROW *THROW \CATCHRELSTKP 
					  UNWINDPROTECT)
				  (VARS (\CATCH.1SHOT.OPOS (STKNTH 0 T))
					(\THROW.1SHOT.OPOS (STKNTH 0 T)))
				  (DECLARE: EVAL@COMPILE (PROP SPECVAR \CATCH.1SHOT.OPOS 
							       \THROW.1SHOT.OPOS)
					    (DECLARE: DONTCOPY (MACROS DATATYPE.TEST)))
				  (DECLARE: COPYWHEN (EQ COMPILEMODE (QUOTE D))
					    (* Crufty low-level stuff to help make \CATCH.TAG.INTERN 
					       more efficient)
					    [VARS (\THROW.STRBUFFER (PROG ((X (ALLOCSTRING 256)))
									  (RPLSTRING X 1
										     (QUOTE 
										      \CATCH.TAG.))
									  (RETURN X]
					    (PROP DMACRO \MYALINK)
					    (DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE D))
						      (PROP GLOBALVAR \THROW.STRBUFFER)
						      (DECLARE: DONTCOPY (MACROS UNINTERRUPTABLY)
								(RECORDS LITATOM DSTRINGP)
								(I.S.OPRS inatom]
			    (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
				      (ADDVARS (NLAMA DEFUN)
					       (NLAML CATCH)
					       (LAMA LIST*])



(* CommonLisp style DEFUN, LET and LET@ macros and other primitives)


(DECLARE: EVAL@COMPILE 

(PUTPROPS LET MACRO 
(X (\LETtran X)))

(PUTPROPS LET* MACRO 
(X (\LETtran X T)))
)



(* Patchup until \DECL.COMNT.PROCESS goes into system)


(DEFINEQ

(\DECL.COMNT.PROCESS.cmlspecs

  (LAMBDA (FORMS)                                            (* JonL "17-OCT-83 22:01")


          (* Returns a list whose first element is the list of all declarations preceeding significand, whose second element

	  is the list of all comments preceeding significand, and whose remaining elements are the "body" of FORMS)



    (for
 L DECLS COMNTS Y on
 FORMS while
 (AND (LISTP (SETQ Y (CAR L)))
					      (OR (EQ COMMENTFLG (SETQ Y (CAR Y)))
						  (EQ Y (QUOTE DECLARE))))
       do
 (if
 (EQ COMMENTFLG Y)
	      then
 (push
 COMNTS (CAR L))
	    elseif
 (EQ Y (QUOTE DECLARE))
	      then
 (push
 DECLS (CAR L)))
       finally
 (RETURN (CONS DECLS (CONS COMNTS L))))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(MOVD? (QUOTE \DECL.COMNT.PROCESS.cmlspecs)
       (QUOTE \DECL.COMNT.PROCESS))
(PUTD (QUOTE \DECL.COMNT.PROCESS.cmlspecs))
)
(DEFINEQ

(\LETtran

  (LAMBDA (X SEQUENTIALP)                                    (* JonL " 9-NOV-83 23:00")

    (PROG ((VARS (MAPCAR (CAR X)
			 (FUNCTION (LAMBDA (X)
			     (if
 (LISTP X)
				 then
 (SETQ X (CAR X)))
			     (if
 (OR (NULL X)
				     (EQ X T)
				     (NOT (LITATOM X)))
				 then
 (ERRORX (LIST (if
 (LITATOM X)
							then
 35
						      else
 14)
						    X)))
			     X))))
	   (VALS (MAPCAR (CAR X)
			 (FUNCTION (LAMBDA (X)
			     (if
 (LISTP X)
				 then
 (CADR X)
			       else
 NIL)))))
	   (BODY (CDR X))
	   (DECLS NIL)
	   (COMNTS NIL))
          (RETURN (if
 (NOT SEQUENTIALP)
		      then
 (LIST*
 (LIST*
 (QUOTE LAMBDA)
					 VARS BODY)
				  VALS)
		    else
 (PROGN                              (* foo, in the sequential case, all declarations must be

							     "pulled up" to the top)

				(SETQ BODY (\DECL.COMNT.PROCESS BODY))
				(SETQ DECLS (pop
 BODY))
				(SETQ COMNTS (pop
 BODY)))
			 (for
 VAR in
 (DREVERSE (CDR VARS)) as
 VAL in
 (DREVERSE (CDR VALS))
			    do
 (SETQ BODY (LIST (LIST (LIST*
 (QUOTE LAMBDA)
							     (LIST VAR)
							     BODY)
						      VAL))))
			 (LIST (LIST*
 (QUOTE LAMBDA)
				      (LIST (CAR VARS))
				      (NCONC (DREVERSE COMNTS)
					     (DREVERSE DECLS)
					     BODY))
			       (CAR VALS)))))))

(\LetPPMacro

  [LAMBDA (FORM)                                             (* JonL "13-Jan-84 19:24")

    (if
 [OR (NLISTP (CDR FORM))
	    (NLISTP (CDDR FORM))
	    (if
 (NLISTP (CADR FORM))
		then
 (NOT (NULL (CADR FORM]
	then
 FORM
      else
 (PROG ((POS (POSITION))
		  VPOS LASTWASATOM)
	         (printout
 NIL "(" .FONT CLISPFONT (pop
 FORM)
			   .FONT DEFAULTFONT " (")
	         (SETQ VPOS (POSITION))
	         [MAPC (pop
 FORM)
		       (FUNCTION (LAMBDA (X)
			   (if
 (LISTP X)
			       then
 (TAB VPOS 0)
				    (printout
 NIL "(" .P2 (CAR X)
					      -1 .PPF (CADR X)
					      ")")
				    (SETQ LASTWASATOM)
			     else
 (if
 (AND LASTWASATOM (FITP (QUOTE % )))
				      then
 (PRIN1 (QUOTE % ))
					   (if
 (NOT (FITP X))
					       then
 (TAB VPOS 0))
				    else
 (TAB VPOS 0))
				  (PRIN2 X)
				  (SETQ LASTWASATOM T]
	         (PRIN1 ")")
	         (TERPRI)
	         (TAB (IDIFFERENCE VPOS 4)
		      0)
	         (printout
 NIL .PPFTL FORM)
	         (PRIN1 ")"])
)

(ADDTOVAR PRETTYPRINTMACROS
 (LET . \LetPPMacro)
			    (LET* . \LetPPMacro))
(DEFINEQ

(DEFUN

  [NLAMBDA X                                                 (* JonL "13-Jan-84 19:20")

    (PROG (NAME LL BODY (TYPE (QUOTE EXPR)))
          (OR (AND [SETQ NAME (CAR (OR (LISTP X)
				       (GO BAD]
		   (LITATOM NAME)
		   (NEQ NAME T))
	      (ERRORX (LIST 14 NAME)))
          [SETQ LL (CAR (OR (LISTP (CDR X))
			    (GO BAD]
          (SETQ BODY (CDDR X))
          (SELECTQ LL
		   [(EXPR FEXPR)
		     (SETQ TYPE LL)
		     (SETQ LL (CAR BODY))
		     (SETQ BODY (CDR (OR (LISTP BODY)
					 (GO BAD]
		   (MACRO (HELP "MACRO defun'itions not supported"))
		   NIL)
          (OR (AND (LITATOM LL)
		   (NEQ LL T))
	      [AND (LISTP LL)
		   (EVERY LL (QUOTE (LAMBDA (X)
					    (AND X (LITATOM X)
						 (NEQ X T]
	      (ERROR LL (QUOTE Bad% LAMBDA% list% for% DEFUN)))
          (SELECTQ TYPE
		   ((FEXPR)
		     (OR (AND (LISTP LL)
			      (NULL (CDR LL)))
			 (ERROR LL (QUOTE Bad% LAMBDA% list% for% DEFUN)))
		     (SETQ LL (CAR LL)))
		   NIL)
          (for
 Y on
 BODY until
 [OR (NLISTP (CDR Y))
				   (AND (LISTP (CAR Y))
					(NEQ COMMENTFLG (CAAR Y))
					(NEQ (QUOTE DECLARE)
					     (CAAR Y]
	     when
 (STRINGP (CAR Y)) do
 ([LAMBDA (Z)
					   [SETQ Z (NLSETQ (PROG1 (READ Z)
								  (PUTHASH Z NIL \STRINGOFDS]
					   (if
 [LISTP (SETQ Z (CAR (LISTP Z]
					       then
          (* Aha! a MacLisp style string comment that can be 

							     converted)

						    (RPLACA Y (CONS COMMENTFLG Z]
					 (CONCAT "(" (CAR Y)
						 ")")))
          [DEFINE (LIST (LIST NAME (LIST*
 (SELECTQ TYPE
						   (EXPR (QUOTE LAMBDA))
						   (FEXPR (QUOTE NLAMBDA))
						   (SHOULDNT))
					  LL BODY]
          (RETURN NAME)
      BAD (ERROR X "Bad format for DEFUN"])

(LIST*

  (LAMBDA NARGS                                              (* JonL "21-SEP-83 17:02")

    (if
 (ZEROP NARGS)
	then
 NIL
      elseif
 (IEQP 1 NARGS)
	then
 (ARG NARGS 1)
      else
 (bind
 (VAL ←(ARG NARGS NARGS)) for
 I from
 (SUB1 NARGS) by
 -1 until
 (ILEQ I 0)
	      do
 (push
 VAL (ARG NARGS I)) finally
 (RETURN VAL)))))
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS LIST* MACRO 
(X
  [COND
    ((NULL X)
      NIL)
    ((NULL (CDR X))
      (CAR X))
    ((NULL (CDDR X))
      (CONS (QUOTE CONS)
	    X))
    (T (LIST (QUOTE CONS)
	     (CAR X)
	     (CONS (QUOTE LIST*)
		   (CDR X]))

(PUTPROPS PSETQ MACRO 
(X
  [COND
    ((NLISTP X)
      NIL)
    ((NLISTP (CDR X))
      (HELP "Odd number args for PSETQ"))
    (T (LIST (QUOTE SETQ)
	     (CAR X)
	     (COND
	       [(CDDR X)
		 (LIST (QUOTE PROG1)
		       (CADR X)
		       (LIST (QUOTE PSETQ)
			     (CDDR X]
	       (T (CADR X]))

(PUTPROPS PROGV MACRO 
((SYMS VALS . BODY)
  (EVALA (LIST (FUNCTION [LAMBDA NIL . BODY]))
	 ([LAMBDA (\Vars \Vals)
	     (DECLARE
 (LOCALVARS \Vars \Vals))
	     (while
 \Vars collect
 (CONS (pop
 \Vars)
					(OR (pop
 \Vals)
					    (QUOTE NOBIND]
	   SYMS VALS))))
)



(* CommonLisp style CATCH and THROW)


(DEFINEQ

(CATCH

  (NLAMBDA (TAG FORM)                                        (* JonL "25-SEP-83 23:50")

    (\CATCH.AUX
 (EVAL TAG (QUOTE INTERNAL))
		FORM T)))

(\CATCH.AUX

  (LAMBDA (TAG FUN FORMP)                                    (* JonL "25-SEP-83 23:08")

    (DECLARE
 (USEDFREE \CATCH.1SHOT.OPOS))                   (* WARNING! This function cannot be run interpretively, 

							     due to the expectations for the STKNTH call below)

    (PROG ((STKPOSVARNAME (\CATCH.TAG.INTERN
 TAG))
	   (STKPOS (\CATCH.FINDFRAME
))
	   (\CATCH.1SHOT.OPOS NIL))
          (DECLARE
 (LOCALVARS STKPOSVARNAME STKPOS)
		   (SPECVARS \CATCH.1SHOT.OPOS \CATCHBODY))
                                                             (* Now do you see why Interlisp needs a PROGV like 

							     MacLisp has?)

          (RETURN (EVALA (if
 FORMP
			     then
 FUN
			   else
 (if
 (LITATOM FUN)
				    then
 (OR (AND FUN (NEQ FUN T))
					     (SHOULDNT "unacceptable function")))
				(LIST FUN))
			 (LIST (CONS STKPOSVARNAME STKPOS)))))))

(\CATCH.FINDFRAME

  (LAMBDA (POS)                                              (* JonL "25-SEP-83 23:18")

    (STKNTH -1 (OR (STACKP (SETQ POS (STKPOS (QUOTE \CATCH.AUX)
					     NIL NIL POS)))
		   (SHOULDNT))
	    POS)))

(\CATCH.TAG.INTERN

  (LAMBDA (TAG)                                              (* JonL "21-SEP-83 15:00")

    (OR (AND (SETQ TAG (DATATYPE.TEST TAG (QUOTE LITATOM)))
	     (NEQ TAG T))
	(ERROR TAG "NIL and T not usable as CATCH tags"))
    (OR (SELECTQ (SYSTEMTYPE)
		 (D (UNINTERRUPTABLY
                        (bind
 (BASE ←(fetch
 (DSTRINGP BASE) of
 \THROW.STRBUFFER)) for
 CHAR
			   inatom
 TAG as
 I from
 (IPLUS 11 (fetch
 (DSTRINGP OFFST) of
 \THROW.STRBUFFER)
						       )
			   do
                                (* 11 is Compensation for initial characters 

							     \CATCH.TAG.)

			      (if
 (IGEQ I 256)
				  then
 (RETURN))
			      (\PUTBASEBYTE BASE I CHAR)
			   finally
 (PROGN (replace
 (DSTRINGP LENGTH) of
 \THROW.STRBUFFER
					     with
 I)
					  (RETURN (MKATOM \THROW.STRBUFFER))))))
		 (if
 (ILESSP (NCHARS TAG)
			     (CONSTANT (IDIFFERENCE 128 11)))
		     then
 (MKATOM (CONCAT (QUOTE \CATCH.TAG.)
					  TAG))))
	(ERROR TAG "name too long to be CATCH tag"))))

(THROW

  (LAMBDA (TAG VAL)                                          (* JonL "21-SEP-83 15:21")

    (\THROW.AUX
 (EVALV (\CATCH.TAG.INTERN
 TAG))
		TAG VAL)))

(\THROW.AUX

  (LAMBDA (POS TAG VAL)                                      (* JonL "25-SEP-83 23:57")

    (DECLARE
 (LOCALVARS POS TAG VAL FORMP)
	     (USEDFREE \THROW.1SHOT.OPOS))

          (* Note that both TAG and VAL have been "evaluated" before the call to this SUBR, and hence before any of the 

	  validity checking below.)



    (PROG NIL
      A   (SELECTQ (SYSTEMTYPE)
		   (D (if
 (SMALLP POS)
			  then
 (UNINTERRUPTABLY
                                   (RETTO (\MAKESTACKP \THROW.1SHOT.OPOS POS)
					  VAL T))))
		   NIL)
          (if
 (STACKP POS)
	      then
 (if
 (\CATCHRELSTKP POS)
		       then
 (SHOULDNT "THROW to a released frame"))
		   (RETTO POS VAL T))
          (SETQ TAG (ERROR TAG (QUOTE Tag% to% THROW,% but% no% corresponding% tag% in% a% CATCH)))
          (SETQ POS (EVALV (\CATCH.TAG.INTERN
 TAG)))
          (GO A))))
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS CATCH MACRO 
(X
  ([LAMBDA (TAGFORM FN)
      (COND
	[(SETQ TAGFORM (CONSTANTEXPRESSIONP TAGFORM))
	  (SETQ TAGFORM (\CATCH.TAG.INTERN (CAR TAGFORM)))
	  (SUBPAIR (QUOTE (X FORM))
		   (LIST TAGFORM (CADR X))
		   (SELECTQ COMPILEMODE
			    [D (QUOTE (\CATCHRUNFUN (FUNCTION (LAMBDA NIL
							([LAMBDA (X)
							    (DECLARE
 (SPECVARS X))
							    FORM]
							  (\MYALINK]
			    (QUOTE (\CATCHRUNFUN (FUNCTION (LAMBDA NIL
						     ([LAMBDA (X \CATCH.1SHOT.OPOS)
							 (DECLARE
 (SPECVARS X \CATCH.1SHOT.OPOS))
							 FORM]
						       (STKNTH -2 NIL \CATCH.1SHOT.OPOS]
	(T (LIST (QUOTE \CATCH.AUX)
		 (CAR X)
		 (LIST (QUOTE FUNCTION)
		       (LIST (QUOTE LAMBDA)
			     NIL
			     (CADR X]
    (CAR X))))

(PUTPROPS *CATCH MACRO 
(= . CATCH))

(PUTPROPS \CATCHRUNFUN DMACRO 
(= . SPREADAPPLY*))

(PUTPROPS \CATCHRUNFUN MACRO 
((FUN . REST)
  ([LAMBDA (\CatchBody)
      (DECLARE
 (LOCALVARS \CatchBody))
      (APPLY* \CatchBody . REST]
    FUN)))

(PUTPROPS THROW MACRO 
(X
  ([LAMBDA (TAGFORM)
      (COND
	(TAGFORM (LIST (QUOTE \THROW.AUX)
		       (\CATCH.TAG.INTERN (CAR TAGFORM))
		       (KWOTE (CAR TAGFORM))
		       (CADR X)))
	(T (QUOTE IGNOREMACRO]
    (CONSTANTEXPRESSIONP (CAR X)))))

(PUTPROPS *THROW MACRO 
(= . THROW))

(PUTPROPS \CATCHRELSTKP DMACRO 
((X)
  (ZEROP (\GETBASE X 1))))

(PUTPROPS \CATCHRELSTKP MACRO 
(= . RELSTKP))

(PUTPROPS UNWINDPROTECT MACRO 
((FORM . CLEANUPS)
  (RESETLST [RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL . CLEANUPS]
	    FORM)))
)

(RPAQ \CATCH.1SHOT.OPOS
 (STKNTH 0 T))

(RPAQ \THROW.1SHOT.OPOS
 (STKNTH 0 T))
(DECLARE: EVAL@COMPILE 

(PUTPROPS \CATCH.1SHOT.OPOS SPECVAR 
T)

(PUTPROPS \THROW.1SHOT.OPOS SPECVAR 
T)

(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS DATATYPE.TEST MACRO 
(OPENLAMBDA (X TYPE)
  (COND
    [(NOT (TYPENAMEP X TYPE))
      (ERROR X (CONCAT (QUOTE Not% of% type% TYPE]
    (T X))))

(PUTPROPS DATATYPE.TEST DMACRO 
(= . \DTEST))
)
)
)
(DECLARE: COPYWHEN (EQ COMPILEMODE (QUOTE D)) 



(* Crufty low-level stuff to help make \CATCH.TAG.INTERN more efficient)




(RPAQ \THROW.STRBUFFER
 (PROG ((X (ALLOCSTRING 256)))
			     (RPLSTRING X 1 (QUOTE \CATCH.TAG.))
			     (RETURN X)))


(PUTPROPS \MYALINK DMACRO 
(NIL
  ((OPCODES MYALINK))))

(DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE D)) 

(PUTPROPS \THROW.STRBUFFER GLOBALVAR 
T)

(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS UNINTERRUPTABLY DMACRO 
((X . Y)
  ([LAMBDA (\INTERRUPTABLE)
      (PROGN X . Y]
    NIL)))
)

[DECLARE: EVAL@COMPILE 

(ACCESSFNS LITATOM
 ((PNPCELL (\ADDBASE \PNPSPACE (LLSH (\ATOMPROPINDEX DATUM)
						       1)))
		    (DEFINITIONCELL (\ADDBASE \DEFSPACE (LLSH (\ATOMDEFINDEX DATUM)
							      1)))
		    (PROPCELL (\ADDBASE \PLISTSPACE (LLSH (\ATOMPROPINDEX DATUM)
							  1)))
		    (VALINDEX (\ATOMVALINDEX DATUM)))
		   (TYPE?
 (LITATOM DATUM))
		   [BLOCKRECORD PNPCELL ((PNAMEBASE FULLXPOINTER))
				(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE]
		   (BLOCKRECORD PROPCELL ((PROPLIST POINTER))))

(BLOCKRECORD DSTRINGP
 ((ORIG BITS 1)
		       (NIL BITS 1)
		       (READONLY FLAG)
		       (NIL BITS 1)
		       (TYP BITS 4)                          (* TYP must always be \ST.BYTE)

		       (BASE POINTER)
		       (LENGTH WORD)
		       (OFFST WORD)))
]

(DECLARE: EVAL@COMPILE 
(I.S.OPR (QUOTE inatom)
	 NIL
	 [QUOTE (SUBPAIR (QUOTE ($$OFF $$BASE $$END $$BODY))
			 (LIST (GETDUMMYVAR)
			       (GETDUMMYVAR)
			       (GETDUMMYVAR)
			       (GETDUMMYVAR))
			 (QUOTE (BIND $$OFF ← 1 $$BODY ← BODY $$BASE $$END FIRST $$BASE ←
				      (fetch (LITATOM PNAMEBASE)
					     of BODY)
				      $$END ← (fetch (LITATOM PNAMELENGTH)
						     of BODY)
				      EACHTIME
				      (COND ((IGREATERP $$OFF $$END)
					     (GO $$OUT)))
				      (SETQ I.V. (GETBASEBYTE $$BASE (PROG1 $$OFF (SETQ $$OFF
											(ADD1 $$OFF]
	 T)
)
)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 DEFUN)

(ADDTOVAR NLAML
 CATCH)

(ADDTOVAR LAMA
 LIST*)
)
(PUTPROPS CMLSPECIALFORMS COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2379 3148 (\DECL.COMNT.PROCESS.cmlspecs 2389 . 3146)) (3307 5751 (\LETtran 3317 . 4685)
 (\LetPPMacro 4687 . 5749)) (5834 7977 (DEFUN 5844 . 7590) (LIST* 7592 . 7975)) (8884 12353 (CATCH 
8894 . 9056) (\CATCH.AUX 9058 . 9974) (\CATCH.FINDFRAME 9976 . 10207) (\CATCH.TAG.INTERN 10209 . 11280
) (THROW 11282 . 11453) (\THROW.AUX 11455 . 12351)))))
STOP