;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 121.58
;;; Reason:
;;;  Fix funcalling of special form in DEFTYPE.
;;; Written 23-Apr-87 17:18:55 by jrm (Joe Marshall) at site LMI Cambridge
;;; while running on Lambda Four A from band 1
;;; with Experimental System 121.57, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, microcode 1742, SDU Boot Tape 3.14, SDU ROM 102, 121.46.



; From modified file DJ: L.SYS; TYPES.LISP#102 at 23-Apr-87 17:19:00
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; TYPES  "

(defmacro deftype (name arglist &body body)
  "Defines NAME as a data type name for use in TYPEP, etc.
A list starting with NAME, used as a type specifier,
expands by binding the args in ARGLIST and then evaluating the BODY.
The value of BODY should be another type specifier.
Any optional arguments in ARGLIST which do not have default values specified
will be bound to * by default, rather than NIL."
  (check-type name symbol)
  (cond ((memq name *standard-system-type-specifiers*)
	 (ferror "~~S is the name of a standard type specifier used by the system.
Redefining it would probably break the world.~" name))
	((or (getdecl name 'defstruct-description)
	     (let ((tem (assq 'si::flavors file-local-declarations)))
	       (and tem (get tem name)))
	     (get name 'si::flavor))
	 (cerror "Yes, please. I want to lose. ~S ~S anyway"
		 "~*~S is already the name of a ~:[flavor~;structure~]
  ~\(~S ~S ...) will cause (~S foo '~S) not to recognize existing
~:[instances of that flavor~;structures of that type~] in new code, ~
but not affect (~S foo '~S)~%in existing compiled code. You may lose!~"
		 'deftype name (getdecl name 'defstruct-description) 'deftype name 'typep name
		 (getdecl name 'defstruct-description) 'typep name)))
  (let ((argcopy (copy-list arglist))
	optionalf doc)
    (if (stringp (car body)) (setq doc (car body)))
    (do ((tail argcopy (cdr tail))) ((null tail))
      (cond ((eq (car tail) '&optional)
	     (setq optionalf t))
	    ((memq (car tail) '(&key &rest &aux))
	     (return))
	    ((and optionalf
		  (atom (car tail))
		  (not (memq (car tail) lambda-list-keywords)))
	     (setf (car tail)
		   `(,(car tail) '*)))))
    `(progn
       (eval-when (load eval)
	 (si:record-source-file-name ',name 'deftype)
	 (clear-cached-subtype-info ',name)
	 (defun (:property ,name type-expander) ,argcopy
	   . ,body)
	 (remprop ',name 'type-alias-for)
	 (setf (documentation ',name 'type) ',doc))
       (eval-when (compile)
	 (putdecl ',name (function (lambda ,argcopy . ,body)) 'type-expander))
       ',name)))

))