;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.107
;;; Reason:
;;;  Moderately hairy patch to DEFSTRUCT: Sort subslot fields in order that
;;;  provides better handling by constructor form.
;;;  
;;;  Fixes the most pathological of problems with constructors for structures with
;;;  byte fields (ZetaLISP style).  You may not get the fields initialized in the
;;;  "obvious" order, but at least the constructor doesn't blow up.  The order of
;;;  initialization is fairly predictable, but still differs from the manual; but
;;;  I don't believe I've broken any cases that even sort of worked before.
;;; Written 14-Oct-88 17:39:32 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 126.104, Experimental ZWEI 126.18, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Experimental IMicro 20.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103.

; From file DJ: L.SYS2; STRUCT.LISP#340 at 14-Oct-88 17:41:11
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  "

(DEFUN DEFSTRUCT-PARSE-ITEMS (ITEMS DESCRIPTION)
  (LET ((NAME (DEFSTRUCT-DESCRIPTION-NAME))
	(OFFSET (DEFSTRUCT-DESCRIPTION-INITIAL-OFFSET))
	(INCLUDE (DEFSTRUCT-DESCRIPTION-INCLUDE))
	(O-SLOT-ALIST NIL)
	(CONC-NAME (DEFSTRUCT-DESCRIPTION-CONC-NAME))
	#+MACLISP-10 (CHARS (EXPLODEN CONC-NAME)))
    ;;;Handle INCLUDEd structures:
    (OR (NULL INCLUDE)
	(LET ((D (GET-DEFSTRUCT-DESCRIPTION (CAR INCLUDE))))
	  (SETQ OFFSET (+ OFFSET (DEFSTRUCT-DESCRIPTION-SIZE D))) 
	  (SETQ O-SLOT-ALIST
		(COPYTREE (DEFSTRUCT-DESCRIPTION-SLOT-ALIST D)))
	  (DOLIST (L O-SLOT-ALIST)
	    (SETF (DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME (CDR L))
		  (IF CONC-NAME #+MACLISP-10 (IMPLODE (APPEND CHARS (EXPLODEN (CAR L))))
				#-MACLISP-10 (DEFSTRUCT-APPEND-SYMBOLS CONC-NAME (CAR L))
		      (CAR L))))
	  (DOLIST (L (CDR INCLUDE))
	    (LET* ((IT (IF (CONSP L) (CAR L) L))
		   (name-of-it (if (consp it) (car it) it))
		   (REST (IF (CONSP L) (CDR L) NIL))
		   (SLOT-DESCRIPTION (CDR (ASSQ name-of-IT O-SLOT-ALIST))))
	      (IF (NULL SLOT-DESCRIPTION)
		(DEFSTRUCT-ERROR
		  "Unknown slot in :INCLUDEd defstruct"
		  IT 'IN INCLUDE 'INCLUDED 'BY NAME))
	      (cond ((not (consp it))
		     (DEFSTRUCT-PARSE-ONE-FIELD
		       name-of-IT NIL NIL REST CONC-NAME #+MACLISP-10 (EXPLODEN CONC-NAME)
		       SLOT-DESCRIPTION))
		    (t
    ;Following code allows multiple names for an included slot.  The slot in question
    ; is specified by the first name.  The new names are in "format 3" and may have byte-specs.
		     (DEFSTRUCT-PARSE-ONE-FIELD ;use the original slot-description for the first guy.
		       name-of-IT NIL NIL (cddr it) CONC-NAME #+MACLISP-10 (EXPLODEN CONC-NAME)
		       SLOT-DESCRIPTION)		     
		     (dolist (e (cdr l))
		       (let ((name-of-it (if (consp e) (car e) e))
			     (rest (if (consp e) (cddr e) nil))
		     ;for the rest, use the original as a default, but mung as necessary.
			     (slot-description (copy-list slot-description)))
			 (defstruct-parse-one-field
			   name-of-it nil (if (consp e) (cadr e) nil)
			   rest conc-name  #+MACLISP-10 (EXPLODEN CONC-NAME)
			   slot-description)
			 (push (cons name-of-it slot-description) o-slot-alist)))))
	      ))))
    ;;;Handle slots:
    (DO ((I OFFSET (1+ I))
	 (L ITEMS (CDR L))
	 (SLOT-ALIST NIL)
	 )
	((NULL L)
	 (SETQ SLOT-ALIST (NREVERSE SLOT-ALIST))
	 (SETF (DEFSTRUCT-DESCRIPTION-SIZE) I)
	 (SETF (DEFSTRUCT-DESCRIPTION-SLOT-ALIST)
	       (NCONC O-SLOT-ALIST SLOT-ALIST)))	;Now returns ALL slots, not just new
      ;;;
      (COND ((ATOM (CAR L))				;Just slot name, no initial value
	     (PUSH (DEFSTRUCT-PARSE-ONE-FIELD
		     (CAR L) I NIL NIL CONC-NAME #+MACLISP-10 CHARS)
		   SLOT-ALIST))
	    ((ATOM (CAAR L))				;Slot definition list 
	     (PUSH (DEFSTRUCT-PARSE-ONE-FIELD
		     (CAAR L) I NIL (CDAR L) CONC-NAME #+MACLISP-10 CHARS)
		   SLOT-ALIST))
	    (T						;Slot with subslots
	     ;;;Currently,
	     ;;;BYTE FIELDS are the only kind of supported subslot definition!
	     ;;;
	     ;;;Possible extension: SUB-STRING FIELDS...
	     ;;;
	     (let ((subslots (car l))
		   subfield-inits subfield-no-inits
		   whole-word-inits whole-word-no-inits)
	       ;;;Order subslots so that constructor works properly:
	       ;;; 1) Whole-word slots with inits
	       ;;; 2) Subfields with inits
	       ;;; 3) Whole-word slots without inits
	       ;;; 4) Subfields without inits
	       (do* ((slots subslots (cdr slots))
		     (slot (first slots) (first slots)))
		    ((null slots))
		 (if (second slot)		;Presumably, a subfield
		     (if (third slot)
			 (push slot subfield-inits)
		       (push slot subfield-no-inits))
		   (if (third slot)
		       (push slot whole-word-inits)
		     (push slot whole-word-no-inits))))
	       (setq subslots (append whole-word-inits subfield-inits
				      whole-word-no-inits subfield-no-inits))
	       ;;;Parse (reordered) subslots
	       (do ((slots subslots (cdr slots)))
		   ((null slots))
		 (let* ((slot (car slots))
			(name (car slot))
			(spec (cadr slot))
			(options (cddr slot)))
		   (PUSH (DEFSTRUCT-PARSE-ONE-FIELD
			   name I spec
			   options
			   CONC-NAME #+MACLISP-10 CHARS)
			 SLOT-ALIST)))))))))

))