(FILECREATED " 5-Sep-85 02:57:36" {ERIS}<LISPCORE>LIBRARY>CMLSTRUCT.;7
 5620   

      changes to:  (FNS DEFSTRUCT.TRANSLATE)

      previous date: "15-Aug-85 17:44:32" {ERIS}<LISPCORE>LIBRARY>CMLSTRUCT.;6)


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

(PRETTYCOMPRINT CMLSTRUCTCOMS)

(RPAQQ CMLSTRUCTCOMS
 ((FNS DEFSTRUCT.TRANSLATE DEFAULT-STRUCTURE-PRINTER)
		      (PROP (USERRECORDTYPE MACRO)
			    DEFSTRUCT)
		      (P (MOVD (QUOTE RECORD)
			       (QUOTE DEFSTRUCT))
			 (ADDTOVAR CLISPRECORDTYPES DEFSTRUCT))))
(DEFINEQ

(DEFSTRUCT.TRANSLATE

  [LAMBDA (TAIL)                                             (* lmm " 5-Sep-85 02:48")

    (LET* ((name&options (
CAR
 TAIL))
	   (slotdescrs (
CDR
 TAIL))
	   options
	   (doc (
AND
 (
STRINGP
 (
CAR
 slotdescrs))
		     (pop
 slotdescrs)))
	   class
	   (name (
COND

		   ((
LISTP
 name&options)
		     (
CAR
 name&options))
		   (T name&options)))
	   includes initialization slotnames (conc-name (
CONCAT
 name "-"))
	   (constructors)
	   (predicate (
PACK*
 name "-P"))
	   (print-function (
FUNCTION
 DEFAULT-STRUCTURE-PRINTER))
	   (copier (
PACK*
 "COPY-" name))
	   named NAMED)
          [if
 (
LISTP
 name&options)
	      then
 (for
 option in
 (
SETQ
 options (
CDR
 name&options))
		      do
 (
COND

			   [(
LISTP
 option)
			     (
SELECTQ
 (
CAR
 option)
				      (:CLASS (
SETQ
 class (
CADR
 option))
					      NIL)
				      (:CONSTRUCTOR (push
 constructors (
CDR
 option)))
				      (:CONC-NAME (
SETQ
 conc-name (
CADR
 option)))
				      (:INCLUDE (push
 includes (
CADR
 option)))
				      (:COPIER (
SETQ
 copier (
CADR
 option)))
				      (:PRINT-FUNCTION (
SETQ
 print-function (
CADR
 option)))
				      (:PREDICATE (
SETQ
 predicate (
CADR
 option)))
				      (:TYPE (
SETQ
 class (
PACK*
 (
CADR
 option)
								"-CLASS"]
			   (T (
SELECTQ
 option
				       (:NAMED (
SETQ
 NAMED T))
				       (
HELP
]
          (if
 includes
	      then
 (
HELP
 "Can't fake includes yet"))
          (
BQUOTE
 ((, (
SELECTQ
 class
			       ((NIL STRUCTURE)
				 (
QUOTE
 DATATYPE))
			       (LIST-CLASS (if
 NAMED
					       then
 (
QUOTE
 TYPERECORD)
					     else
 (
QUOTE
 RECORD)))
			       (
HELP
))
		      , name , [
SETQ
 slotnames (for
 x in
 slotdescrs
						  collect
 (if
 (
NLISTP
 x)
							      then
 x
							    else
 (if
 (
CDDR
 x)
								     then
 (
HELP
))
								 (
CAR
 x]
		      ,@ initialization)
		   ,@
		   [
AND
 predicate (
BQUOTE
 ((DEFUN , predicate (obj)
						  (type?
 , name obj]
		   ,@
		   [
AND
 copier (
BQUOTE
 ((DEFUN , copier (obj)
					       (create
 (\, name) using
 obj]
		   ,@
		   [
AND
 print-function (
BQUOTE
 ((
DEFPRINT
 (
QUOTE
 (\, name))
							  (
FUNCTION
 (LAMBDA (x stream)
							      (
COND

								(stream
								  (
APPLY*
 (
FUNCTION
 (\, 
										   print-function))
									  x stream 0)
								  (
QUOTE
 (""]
		   ,@
		   [for
 constructor in
 [
OR
 constructors (
LIST
 (
LIST
 (
PACK*
 "MAKE-" name]
		      collect
 (IF
 (
CDR
 constructor)
				  THEN
 [
BQUOTE
 (DEFUN , (
CAR
 constructor)
						      ,
						      (
CADR
 constructor)
						      (create
 , name ,@ (for
 x in
 slotnames
									   join
 (
LIST
 x (
QUOTE
 ←)
										      x]
				ELSE
 (
BQUOTE
 (DEFUN , (
CAR
 constructor)
						    [&KEY ,@ (for
 x in
 slotdescrs
								collect
 (if
 (
NLISTP
 x)
									    then
 x
									  else
 (
LIST
 (
CAR
 x)
										     (
CADR
 x]
						    (create
 , name ,@ (for
 x in
 slotnames
									 join
 (
LIST
 x (
QUOTE
 ←)
										    x]
		   ,@
		   (for
 slot in
 slotnames bind
 conc setfconc
		      join
 (
BQUOTE
 ((DEFUN (\, (
SETQ
 conc (
PACK*
 conc-name slot)))
					   (object)
					   (fetch
 ((\, name)
						   (\, slot))
						  object))
				    (DECLARE:
 EVAL@COMPILE [
PUTPROP
 (
QUOTE
 (\, conc))
								    (
QUOTE
 DMACRO)
								    (
QUOTE
 ((obj)
									     (fetch
 ((\, name)
										     (\, slot))
										    obj]
					      [
PUTPROP
 [
QUOTE
 (\, (
SETQ
 setfconc (
PACK*
 "SETF-" conc]
						       (
QUOTE
 DMACRO)
						       (
QUOTE
 ((obj value)
								(replace
 ((\, name)
									  (\, slot))
									 obj value]
					      (DEFSETF (\, conc)
						       (\, setfconc])

(DEFAULT-STRUCTURE-PRINTER

  (CL:LAMBDA (STRUC STREAM LEVEL)                            (* raf "15-Aug-85 17:23")

    (LET ((TYPE (
TYPENAME
 STRUC)))
         (
PRIN1
 \CML.READPREFIX)
         (
PRIN1
 (
QUOTE
 S))
         (
PRIN1
 "(")
         (
PRIN1
 TYPE)
         (for
 FIELD in
 (
RECORDFIELDNAMES
 TYPE) as
 DESCRIPTOR in
 (
GETDESCRIPTORS
 TYPE)
	    do
 (
PRIN1
 " ")
	       (
PRIN1
 FIELD)
	       (
PRIN1
 " ")
	       (
PRIN1
 (
FETCHFIELD
 DESCRIPTOR STRUC)))
         (
PRIN1
 ")"))))
)

(PUTPROPS DEFSTRUCT USERRECORDTYPE
 [LAMBDA (L)
					   (LET [(DE (DEFSTRUCT.TRANSLATE (CDR L]
						(RESETVARS ((FILEPKGFLG))
							   (MAPC (CDR DE)
								 (QUOTE EVAL)))
						(CAR DE])

(PUTPROPS DEFSTRUCT MACRO
 (
DEFMACRO
 (&REST tail)
				    (
DEFSTRUCT.TRANSLATE
 tail)))
(MOVD (QUOTE RECORD)
      (QUOTE DEFSTRUCT))
(ADDTOVAR CLISPRECORDTYPES DEFSTRUCT)
(PUTPROPS CMLSTRUCT COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (552 5161 (DEFSTRUCT.TRANSLATE 562 . 4603) (DEFAULT-STRUCTURE-PRINTER 4605 . 5159)))))
STOP