(FILECREATED "11-Feb-86 23:35:25" {QV}<IDL>SOURCES>ULAMTRAN.;10 23280
changes to: (VARS ULAMTRANCOMS)
previous date: "26-Nov-84 00:38:31" {QV}<IDL>SOURCES>ULAMTRAN.;9)
(* Copyright (c) 1983, 1984, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ULAMTRANCOMS)
(RPAQQ ULAMTRANCOMS [(* Contains definition, printing, and translation functions for ULAMBDA's.)
(FNS COERCETRAN DU PPULAM ULAMTRAN ULAMTYPE ULAMTYPEATOM ULAMTYPEEXPR ULAMVAR)
(FNS OCCURRENCES OCCURRENCES1)
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
DECL)
(PROP INFO ULAMBDA)
(PROP CLISPWORD coerce COERCE)
(ADDVARS (LAMBDASPLST ULAMBDA)
(DECLATOMS ULAMBDA))
(INITVARS (COERCIONFNS NIL))
(PROP VARTYPE COERCIONFNS)
(ALISTS (PRETTYPRINTMACROS ULAMBDA)
(LAMBDATRANFNS ULAMBDA))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DU)
(NLAML)
(LAMA])
(* Contains definition, printing, and translation functions for ULAMBDA's.)
(DEFINEQ
(COERCETRAN
[LAMBDA (FORM) (* bas: "15-FEB-83 10:02")
(* Constructs the translation for COERCE forms)
(SETQ CLISPCHANGE T)
(PROG (VARSNAMES TRAN)
(DECLARE (SPECVARS VARSNAMES))
[SETQ TRAN (if (CDDR FORM)
then (RESETVARS ((NOSPELLFLG T)
(DWIMESSGAG T))
(DWIMIFY0? (CDR FORM)
FORM
(CDR FORM)
NIL NIL FAULTFN))
(* The dwimify explodes atoms so the LISTP check works)
[CADR (if (LISTP (CADR FORM))
then (ULAMVAR (CDDR FORM)
(LIST (CADR FORM)))
else (ULAMVAR (CDR FORM]
else (* If no type given, translate to PROGN)
(LIST (QUOTE PROGN)
(CADR FORM]
(DWIMIFY0? TRAN TRAN NIL NIL NIL FAULTFN)
(if LCASEFLG
then (/RPLACA FORM (QUOTE coerce)))
(RETURN (CLISPTRAN FORM TRAN])
(DU
[NLAMBDA X
[CLISP:(RECORD ARGRECORD (NAME . DEF)
(RECORD DEF (ARGS . BODY] (* rmk: "24-JUL-78 08:21" posted: " 2-SEP-77 11:13")
(* For Defining ULambda functions.
NAME is the function name and DEF the rest of its
definition.)
(DEFINE <<X:NAME <'ULAMBDA ! X:DEF>>> T])
(PPULAM
[LAMBDA (FORM) (* rmk: "31-AUG-77 16:19" posted: "31-AUG-77 16:21")
(* Special prettyprinter for ULAMBDA's.
Called from PRETTYPRINTMACROS)
(if (OR (NLISTP (CDR FORM))
(AND PRETTYTRANFLG (GETHASH FORM CLISPARRAY)))
then FORM
else (PROG [(VLIST (CADR FORM))
(FORMPOS (IPLUS 2 (POSITION]
(PRIN1 "[ULAMBDA ")
(if (LISTP VLIST)
then (PRIN1 "(")
(for V (VARPOS ←(POSITION))
(LASTLIST ← T) in VLIST do (if (LISTP V)
then (printout NIL .TAB0 VARPOS "(" .P2
(CAR V))
(for X in (CDR V)
do (SPACES 1)
(PRINTDEF X (POSITION)
T NIL FNSLST))
(if (ILESSP (POSITION)
VARPOS)
then (TAB VARPOS)
(PRIN1 ")")
else (PRIN3 ")"))
(SETQ LASTLIST T)
else (if LASTLIST
then (TAB VARPOS 0)
else (SPACES 1))
(SETQ LASTLIST NIL)
(PRIN2 V)))
(PRIN3 ")")
else (PRIN2 VLIST))
(if (AND (LISTP (SETQ FORM (CDDR FORM)))
(NEQ (CAR FORM)
COMMENTFLG))
then (printout NIL .TAB0 FORMPOS))
(PRINTDEF FORM FORMPOS T T FNSLST)
(PRIN1 "]"))
NIL])
(ULAMTRAN
[LAMBDA (FORM) (* DECLARATIONS: FAST (RECORD FORM
(ATOM DCLS . FORMS)))
(* rmk: "26-Nov-84 00:38")
(* Translator for user-entry declarations)
(SETQ CLISPCHANGE T)
(PROG (TEMP CLISPCOLON DECLARE DECL TOP DPROGDCL VARSNAMES UE RETURNS ENTRYNAME
(FORMS (fetch FORMS of FORM))
(VARS VARS))
(DECLARE (SPECVARS VARSNAMES VARS))
(SETQ DPROGDCL (for V in old TEMP first (SETQ TEMP (fetch DCLS of FORM))
unless [AND (EQ (CAR (LISTP V))
(QUOTE RETURNS))
(COND
(RETURNS (LISPXTERPRI T)
(LISPXPRIN1 (CONCAT "{in " FAULTFN "} ")
T)
(LISPXPRIN1 "multiple RETURNS declaration" T)
(LISPXPRINT V T)
(ERROR!))
(T (SETQ RETURNS V]
collect (ULAMVAR V)))
(if (OR (EQ [CAR (SETQ TEMP (LISTP (CAR FORMS]
(QUOTE CLISP:))
(match TEMP with (== COMMENTFLG 'DECLARATIONS: --)))
then (SETQ CLISPCOLON TEMP)
(SETQ FORMS (CDR FORMS)))
(for B in old FORMS do (if (NLISTP B)
then (RETURN)
elseif (EQ (CAR B)
COMMENTFLG)
elseif (EQ (CAR B)
(QUOTE DECLARE))
then (* APPEND picks up multiple declares)
(SETQ DECLARE (APPEND DECLARE (CDR B)))
elseif (EQ (CAR B)
(QUOTE DECL))
then (SETQ DECL (APPEND DECL (CDR B)))
elseif (EQ (CAR B)
(QUOTE ENTRYNAME))
then [SETQ ENTRYNAME (CAR (LISTP (CDR B]
else (RETURN)))
(SETQ VARSNAMES (DREVERSE VARSNAMES)) (* Used to be a DPROG. Changed to a DLAMBDA to properly
position CLISP: info within the UENTRY)
[SETQ FORMS (LIST (LIST (QUOTE DECLARE)
(CONS (QUOTE SPECVARS)
VARSNAMES))
(SETQ UE
(LIST (QUOTE UENTRY)
(CONS (CONS (QUOTE DLAMBDA)
(CONS (NCONC (for I in DPROGDCL
collect (CONS (CAR I)
(CDDR I)))
(AND RETURNS (CONS RETURNS)))
(NCONC (if CLISPCOLON
then (LIST CLISPCOLON))
(if DECL
then (LIST (CONS (QUOTE DECL)
DECL)))
(if DECLARE
then (LIST (CONS (QUOTE DECLARE)
DECLARE)))
FORMS)))
(for I in DPROGDCL collect (CADR I]
(* Save UE to insert function name later, after
dwimify)
[push FORMS (CONS COMMENTFLG (QUOTE (ASSERT: (CLISP ULAMBDA]
(SETQ TOP (CONS (QUOTE LAMBDA)
(CONS VARSNAMES FORMS)))
(SETQ VARS (APPEND VARSNAMES VARS)) (* For some reason, the dwimify doesn't notice the vars
in the lambda expression)
(DWIMIFY0? (CDR UE)
TOP NIL NIL NIL FAULTFN)
(push (CDR UE)
(if ENTRYNAME
elseif (LITATOM FAULTFN)
then FAULTFN))
(* A non-atomic FAULTFN means that the ULAMBDA was invoked out of its lexical scope, presumably as a functional
argument. The entry name will be NIL.)
(RETURN TOP])
(ULAMTYPE
[LAMBDA (DECL NAME) (* DECLARATIONS: (RECORD CDATA
(RESTR COERC . TYPETEST)))
(* bas: "25-JAN-83 15:58")
(* Returns NIL if DECL is not a valid type declaration, otherwise the corresponding type-checking form.
This will always be a list, except for ANY/POINTER, wherein it is T, and may be omitted from higher-level
consideration (e.g. assertions) DECL must either be a simple type expression, or a ONEOF construction)
(DECLARE (USEDFREE UERRORFORM))
(PROG NIL
(RETURN
(SELECTQ
(CAR (LISTP DECL))
[ONEOF (* Propagate the NIL error indicator)
(create
CDATA
COERC ←(AND
(PROG1 (CDR DECL) (* Permit the NULL list)
)
(OR [for D TYPES TEMP in (CDR DECL)
join (OR (SETQ TEMP (ULAMTYPEEXPR D NAME T))
(RETURN NIL))
(push TYPES (fetch TYPETEST of TEMP))
[if (fetch COERC of TEMP)
then (LIST (LIST (QUOTE UERRORGUARD)
(if (LISTP (fetch RESTR of TEMP))
then
(* No restriction to check)
[LIST (QUOTE PROGN)
(fetch COERC of TEMP)
(LIST (QUOTE OR)
(fetch RESTR of TEMP)
(QUOTE (UERROR]
else (fetch COERC of TEMP]
finally (SETQ $$VAL (if $$VAL
then (CONS (QUOTE AND)
(NCONC1 $$VAL UERRORFORM))
else UERRORFORM))
(RETURN (if (AND (NULL TYPES)
(EQ $$VAL UERRORFORM))
then (QUOTE (PROGN))
else (CONS (QUOTE OR)
(NCONC1 (DREVERSE TYPES)
$$VAL]
(RETURN]
(ULAMTYPEEXPR DECL NAME])
(ULAMTYPEATOM
[LAMBDA (ATM NAME) (* DECLARATIONS: (RECORD CDATA
(RESTR COERC . TYPETEST)))
(* bas: "25-JAN-83 15:55")
(* Returns NIL if ATM is not a valid type atom,
otherwise a structure containing the restriction,
coercion, and type-testing forms associated with ATM.)
(DECLARE (USEDFREE UERRORFORM))
(if (EQ (CAR (LISTP ATM))
(QUOTE MEMQ))
then [if (NULL (CDR (LAST ATM)))
then (create CDATA
TYPETEST ←(LIST (QUOTE type?)
ATM NAME)
COERC ←(if (EVERY (CDR ATM)
(FUNCTION LITATOM))
then
(LIST
(QUOTE SETQ)
NAME
(if (FMEMB NIL (CDR ATM))
then (LIST (QUOTE AND)
(QUOTE UARG)
(LIST (QUOTE OR)
[LIST (QUOTE MISSPELLED?)
(QUOTE UARG)
80
(KWOTE (REMOVE NIL
(CDR ATM]
UERRORFORM))
else (LIST (QUOTE OR)
(LIST (QUOTE MISSPELLED?)
(QUOTE UARG)
80
(KWOTE (CDR ATM)))
UERRORFORM]
elseif (OR (EQ ATM T)
(NOT (LITATOM ATM)))
then NIL
else (PROG [C (TEMP (GETDECLTYPEPROP ATM (QUOTE COERCION]
[if (SETQ C (CAR TEMP))
then (SETQ C (LIST (QUOTE SETQ)
NAME
(if (OR (LITATOM C)
(EQ (CAR (LISTP C))
(QUOTE LAMBDA)))
then (LIST C (QUOTE UARG))
else C]
(RETURN (create CDATA
COERC ← C
RESTR ←(if (AND C (SETQ TEMP (CADR TEMP)))
then
(* There might be additional restrictions in the COERCION, e.g. type NIL converts to a scalar that must be NULL.
We only care about restrictions if there is a coercion. If no coercion, the typetest must be sufficient)
(if (OR (LITATOM TEMP)
(EQ (CAR (LISTP TEMP))
(QUOTE LAMBDA)))
then (LIST TEMP NAME)
else (SUBST NAME (QUOTE UARG)
TEMP)))
TYPETEST ←(LIST (QUOTE type?)
ATM NAME])
(ULAMTYPEEXPR
[LAMBDA (D NAME ONEOFFLAG) (* DECLARATIONS: FAST (RECORD CDATA
(RESTR COERC . TYPETEST)))
(* rmk: "25-MAY-78 20:32")
(* Returns NIL if D is not a valid simple type expression (i.e., ONEOF is excluded.) Otherwise, returns the
coercion and type-checking information. In effect, DECL can be a typeatom, or a list consisting of a typeatom and
a satisfies predicate. -
ONEOFFLAG is T if result is going to be part of a ONEOF. In that case, the local satisfies must be included as
part of the typetest. It must also be combined with the restriction, which exists only if there is a coercion.
as well as RESTR.)
(PROG (TEMP ELTEXPR EVERYFN C R S TYPE)
(RETURN (if (ULAMTYPEATOM D NAME)
elseif (AND (LISTP D)
(SETQ TEMP (ULAMTYPEATOM (CAR D)
NAME)))
then (if (NOT (CDR D))
then TEMP
else (SETQ C (fetch COERC of TEMP))
(* Unpack type and coercion)
(SETQ TYPE (fetch TYPETEST of TEMP))
(SETQ R (fetch RESTR of TEMP))
(if (EQ (CADR D)
(QUOTE OF))
then (HELP "AGGREGATE COERCIONS NOT IMPLEMENTED!"))
(if (EQ (CAADR D)
(QUOTE SATISFIES))
then (SETQ S (CDADR D))
(create CDATA
COERC ← C
RESTR ←(AND C (if (LISTP R)
then (CONS (QUOTE AND)
(CONS R S))
elseif (CDR S)
then (CONS (QUOTE AND)
S)
else (CAR S)))
TYPETEST ←(if ONEOFFLAG
then (if (LISTP TYPE)
then (CONS (QUOTE AND)
(CONS TYPE S))
elseif (CDR S)
then (CONS (QUOTE AND)
S)
else (CAR S))
else (LISTP TYPE])
(ULAMVAR
[LAMBDA (VARD UARGVAL) (* DECLARATIONS: FAST (RECORD CDATA
(RESTR COERC . TYPETEST)))
(* edited: "20-Nov-84 09:16")
(* Produces the coercion form for the variable declaration VARD, which is either a litatom, or a list whose first
element is the variable name and whose remaining elements are a standard declaration list ala decltran, except that
a single string or a MSG list can also occur, which determines a UERROR message. -
If UARGVAL is given, then it is a list whose car is a form to be coerced. VARD is then assumed to be the declaration
tail, and the variable name is VALUE.)
(DECLARE (USEDFREE VARSNAMES FAULTFN))
(PROG [S TYPE TEMP ONEOFFLAG ASSERTION NAME REM COERCION RESTR ERRMSG DPROGTYPE INITFORM UERRMSG
(UERRORFORM (LIST (QUOTE UERROR]
(DECLARE (SPECVARS UERRORFORM))
(if UARGVAL
then (SETQQ NAME VALUE)
(SETQ REM VARD)
elseif (LISTP VARD)
then (SETQ NAME (CAR VARD))
(SETQ REM (CDR VARD))
else (SETQ NAME VARD))
(push VARSNAMES NAME)
(SETQ DPROGTYPE (for V in REM unless (if (OR (STRINGP V)
(EQ (CAR (LISTP V))
(QUOTE MSG)))
then (* Take out ULAM specific information)
(if UERRMSG
then (SETQ ERRMSG
"CAN'T HAVE MULTIPLE ERROR MESSAGES")
(GO ERROR))
[FRPLACD UERRORFORM (SETQ UERRMSG
(if (STRINGP V)
then (LIST V)
else (CDR V]
else (EQ (CAR (LISTP V))
COMMENTFLG))
collect (if (EQ (CAR (LISTP V))
(QUOTE SATISFIES))
then (SETQ S (CDR V))
elseif [AND (NOT UARGVAL)
(OR (FMEMB V (QUOTE (LOCAL SPECIAL)))
(EQ (CAR (LISTP V))
(QUOTE USEDIN]
elseif (SETQ TEMP (ULAMTYPE V NAME))
then (if (OR TYPE COERCION)
then (SETQ ERRMSG (CONCAT
"MORE THAN ONE TYPE DECLARATION: "
V))
(GO ERROR))
(SETQ RESTR (fetch RESTR of TEMP))
(if (NULL (SETQ COERCION (fetch COERC of TEMP)))
then (SETQ TYPE (fetch TYPETEST of TEMP)))
(if (EQ (CAR V)
(QUOTE ONEOF))
then (SETQ ONEOFFLAG T))
else (SETQ ERRMSG (CONCAT "INVALID DECLARATION: " V))
(GO ERROR))
V))
[if (NULL UERRMSG)
then (FRPLACD UERRORFORM (LIST (CONCAT "Invalid " NAME ": ")
(QUOTE .P2)
(QUOTE UARG] (* The restriction always combines with the top-level
SATISFIES. They combine with the typetest only if there
is no coercion.)
(if (AND UARGVAL TYPE (NULL COERCION))
then (SETQQ COERCION (SETQ VALUE UARG))
(SETQ RESTR TYPE)) (* Must guarantee a binding for VALUE if there is no
coercion)
(if (SETQ ASSERTION (if (AND S (LISTP RESTR))
then (* The LISTP check catches the T from ANY)
(CONS (QUOTE AND)
(CONS RESTR S))
elseif (LISTP RESTR)
elseif (CDR S)
then (CONS (QUOTE AND)
S)
else (CAR S)))
then (SETQ ASSERTION (LIST (QUOTE OR)
ASSERTION UERRORFORM)))
(RETURN
(CONS
NAME
(CONS
(if COERCION
then
(SETQ COERCION (if (if (EQ (CAR (FLAST COERCION))
UERRORFORM)
then S
else UERRMSG)
then
(* Promote the error-message if either this was a ONEOF, indicated by the errorform appearing as the final clause,
and there was a top-level satisfies, or if this was not a ONEOF and there was a user-specified message.)
[LIST (CONS (QUOTE UERRORGUARD)
(CONS (if ASSERTION
then (LIST (QUOTE PROGN)
COERCION ASSERTION)
else COERCION)
(PROG1 (CDR UERRORFORM)
(FRPLACD UERRORFORM NIL]
elseif ASSERTION
then (LIST COERCION ASSERTION)
else (LIST COERCION)))
[if (AND (EQ (CAR COERCION)
(QUOTE SETQ))
(EQ (CADR COERCION)
NAME)
(ZEROP (OCCURRENCES NAME (CADDR COERCION)))
(ZEROP (OCCURRENCES (QUOTE UARG)
UERRORFORM))
(OR (NULL UARGVAL)
(ILEQ (OCCURRENCES (QUOTE UARG)
(CADDR (CAR COERCION)))
1)))
then
(* Don't need extra bindings for the very simply case where there is a simple SETQ to NAME, with no other references
to NAME or UARG)
(SUBST (if UARGVAL
then (CAR UARGVAL)
else NAME)
(QUOTE UARG)
(CADDR (CAR COERCION)))
else (CONS (QUOTE PROG)
(CONS (if UARGVAL
then (LIST NAME (CONS (QUOTE UARG)
UARGVAL))
else (LIST (LIST NAME NAME)
(LIST (QUOTE UARG)
NAME)))
(CONS (QUOTE (DECLARE (LOCALVARS . T)))
(NCONC [if (AND UARGVAL ONEOFFLAG)
then
(* Must setup VALUE if there is a form to be evaled and
a ONEOF declaration)
(LIST (CONS (QUOTE SETQ)
(CONS NAME (QUOTE (UARG]
COERCION
(LIST (LIST (QUOTE RETURN)
NAME]
else [if (IGREATERP (OCCURRENCES (QUOTE UARG)
(CDR UERRORFORM))
0)
then (FRPLACD UERRORFORM (SUBST NAME (QUOTE UARG)
(CDR UERRORFORM]
(* Since UARG is being bound for a possible MSG.)
(if TYPE
then (LIST (QUOTE PROGN)
(LIST (QUOTE OR)
(if ASSERTION
then (LIST (QUOTE AND)
TYPE
(CADR ASSERTION))
else TYPE)
UERRORFORM)
NAME)
elseif ASSERTION
then (LIST (QUOTE PROGN)
ASSERTION NAME)
else NAME))
DPROGTYPE)))
ERROR
(LISPXTERPRI T)
(LISPXPRIN1 (CONCAT "{in " FAULTFN "} ")
T)
(LISPXPRIN1 ERRMSG T)
(LISPXTERPRI T)
(LISPXPRIN1 " inside " T)
(LISPXPRINT VARD T)
(ERROR!])
)
(DEFINEQ
(OCCURRENCES
[LAMBDA (ITEM STRUCTURE) (* rmk: "30-SEP-77 08:46")
(* Counts the number of times that ITEM is EQ to some
element of STRUCTURE)
(DECLARE (SPECVARS ITEM))
(PROG ((COUNT 0))
(DECLARE (SPECVARS COUNT))
(OCCURRENCES1 STRUCTURE)
(RETURN COUNT])
(OCCURRENCES1
[LAMBDA (STRUCTURE) (* rmk: "30-SEP-77 08:52")
(DECLARE (USEDFREE ITEM COUNT))
(if (EQ ITEM STRUCTURE)
then (SETQ COUNT (ADD1 COUNT))
elseif (NLISTP STRUCTURE)
else (OCCURRENCES1 (CAR STRUCTURE))
(OCCURRENCES1 (CDR STRUCTURE])
)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
DECL)
(PUTPROPS ULAMBDA INFO BINDS)
(PUTPROPS coerce CLISPWORD (COERCETRAN . coerce))
(PUTPROPS COERCE CLISPWORD (COERCETRAN . COERCE))
(ADDTOVAR LAMBDASPLST ULAMBDA)
(ADDTOVAR DECLATOMS ULAMBDA)
(RPAQ? COERCIONFNS NIL)
(PUTPROPS COERCIONFNS VARTYPE ALIST)
(ADDTOVAR PRETTYPRINTMACROS (ULAMBDA . PPULAM))
(ADDTOVAR LAMBDATRANFNS [ULAMBDA EXULAMTRAN
EXPR DLAMARGLIST])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DU)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS ULAMTRAN COPYRIGHT ("Xerox Corporation" 1983 1984 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1104 21768 (COERCETRAN 1114 . 2316) (DU 2318 . 2726) (PPULAM 2728 . 4208) (ULAMTRAN
4210 . 8067) (ULAMTYPE 8069 . 10052) (ULAMTYPEATOM 10054 . 12347) (ULAMTYPEEXPR 12349 . 14398) (
ULAMVAR 14400 . 21766)) (21769 22557 (OCCURRENCES 21779 . 22211) (OCCURRENCES1 22213 . 22555)))))
STOP