(FILECREATED "26-Nov-84 02:25:12" {PHYLUM}<IDL>SOURCES>EXULAMTRAN.;5
 3767   

      changes to:  (FNS EXULAMTRAN)

      previous date: "25-JAN-83 14:50:41" {PHYLUM}<IDL>SOURCES>EXULAMTRAN.;2)


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

(PRETTYCOMPRINT EXULAMTRANCOMS)

(RPAQQ EXULAMTRANCOMS
 ((* Contains processor for ULAMBDA EXPECTS declarations)
		       (FNS EXULAMTRAN)
		       (ALISTS (LAMBDATRANFNS ULAMBDA))))



(* Contains processor for ULAMBDA EXPECTS declarations)


(DEFINEQ

(EXULAMTRAN

  [LAMBDA (FORM)                                             (* rmk: "26-Nov-84 02:24" posted: "29-SEP-77 15:41")

                                                             (* Intercepts ULAMBDA's and removes EXPECTS information

							     before calling ULAMTRAN. Rebinds COERCIONFNS to 

							     separate the internal coercions from the external 

							     ones.)

    (
PROG
 (EXPECTS EFLAG VNAMES NEDECLS EXTCOERCIONS NOEXPECTSFORM ENTRYNAME (COERCIONFNS COERCIONFNS)
		   )
          (DECLARE
 (
SPECVARS
 COERCIONFNS))
          [
SETQ
 NEDECLS (for
 V TEMP in
 (
CADR
 FORM)
			   collect
 (if
 (
NLISTP
 V)
				       then
 (push
 VNAMES V)
					    (push
 EXPECTS NIL)
					    V
				     elseif
 (
EQ
 (
CAR
 V)
						(
QUOTE
 RETURNS))
				       then
 V
				     else
 (push
 VNAMES (
CAR
 V))
					  (if
 (
SETQ
 TEMP (
ASSOC
 (
QUOTE
 EXPECTS)
								(
CDR
 V)))
					      then
 (
SETQ
 EFLAG T) 
                                                             (* We need the EAPPLY*)

						   (push
 EXPECTS
							 (if
 (
FMEMB
 (
CADR
 TEMP)
								    (
QUOTE
 (ARITH INTEGER FLOATING)))
							     then
 (
QUOTE
 SCALAR)
							   else
 (
CADR
 TEMP)))
						   (
SUBST
 (if
 (
CDDR
 TEMP)
							      then
 (
CADDR
 TEMP)
							    else
 (
CADR
 TEMP))
							  TEMP V)
					    else
 (push
 EXPECTS NIL)
						 V]
          (if
 EFLAG
	      then
 (
SETQ
 VNAMES (
DREVERSE
 VNAMES))
		   (
SETQ
 EXPECTS (
DREVERSE
 EXPECTS))
		   (
PROG
 ((GLITCH (
EXPCHK
 EXPECTS)))
		         (if
 GLITCH
			     then
 (
LISPXPRIN1
 "{in " T)
				  (
LISPXPRIN2
 FAULTFN T)
				  (
LISPXPRIN1
 "} illegal EXPECTS declaration " T)
				  (
LISPXPRINT
 (
CAR
 GLITCH)
					      T)
				  (
ERROR!
)))
		   [
SETQ
 NOEXPECTSFORM (
CONS
 (
QUOTE
 ULAMBDA)
					     (
CONS
 NEDECLS (
CDDR
 FORM]
		   (
SETQ
 EXTCOERCIONS VNAMES)
		   (
RETURN
 (
PROG1
 [
LIST
 (
QUOTE
 LAMBDA)
					VNAMES
					(
LIST
 (
QUOTE
 DECLARE)
					      (
CONS
 (
QUOTE
 SPECVARS)
						    VNAMES))
					(
LIST
 (
QUOTE
 UENTRY)
					      (for
 F in
 (
CDDR
 FORM)
						 while
 [
AND
 (
LISTP
 F)
							    (
OR
 (
EQ
 COMMENTFLG (
CAR
 F))
								(
MEMB
 (
CAR
 F)
								      (
QUOTE
 (ENTRYNAME DECLARE DECL]
						 when
 (
EQ
 (
CAR
 F)
							  (
QUOTE
 ENTRYNAME))
						 do
 (
RETURN
 (
OR
 (
CAR
 (
LISTP
 (
CDR
 F)))
								FAULTFN))
						 finally
 (
RETURN
 FAULTFN))
					      (
CONS
 (
QUOTE
 EAPPLY*)
						    (
CONS
 (
LIST
 (
QUOTE
 FUNCTION)
								(
ULAMTRAN
 NOEXPECTSFORM))
							  (
CONS
 (
KWOTE
 EXPECTS)
								EXTCOERCIONS]
                                                             (* No need to keep NOEXPECTSFORM in the CLISPARRAY)

				  (
PUTHASH
 NOEXPECTSFORM NIL CLISPARRAY)))
	    else
 (
RETURN
 (
ULAMTRAN
 FORM])
)

(ADDTOVAR LAMBDATRANFNS
 [ULAMBDA EXULAMTRAN
                          EXPR DLAMARGLIST])
(PUTPROPS EXULAMTRAN COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (518 3592 (EXULAMTRAN 528 . 3590)))))
STOP