;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.283
;;; Reason:
;;;  ZWEI was getting the section name of a DEFSTRUCT incorrectly
;;; Written 16-May-88 12:03:05 by pld at site Gigamos Cambridge
;;; while running on Fish food from band 1
;;; with Experimental System 123.267, Experimental Local-File 73.5, Experimental FILE-Server 22.5, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.2, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1756, SDU Boot Tape 3.14, SDU ROM 103, patch/experimental.



; From file DJ: L.ZWEI; SECTIO.LISP#294 at 16-May-88 12:03:10
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "

(DEFUN (:PROPERTY :LISP GET-SECTION-NAME) (LINE BP &AUX STR SYM ERROR-P
					   IDX END-IDX (EOF "") NON-FONT-LINE)
  (IF (NOT (AND (> (LENGTH LINE) 1) (CHAR-EQUAL (CHAR LINE 0) #/()))
      (VALUES NIL NIL T)
    (SETQ ERROR-P T)
    (WHEN (AND (%STRING-EQUAL LINE 0 "(DEF" 0 4)
	       (NOT (%STRING-EQUAL LINE 0 "(DEFPROP " 0 9))
	       (SETQ IDX (STRING-SEARCH-SET *WHITESPACE-CHARS* LINE))
 	       (SETQ IDX (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* LINE IDX)))
     (SETQ NON-FONT-LINE (STRING-REMOVE-FONTS LINE))
     (dotimes (i 2)
       ;;Kludge -- (defstruct (abc :opt1 xx :opt2 xxx)  parses fine
       ;;          (defstruct (abc :opt1 xx
       ;;                          :opt2 xxx)           doesn't
       ;;If we run out of line on first try and start idx is "(", try again skipping the "("
       (SETQ ERROR-P NIL)
       (CONDITION-CASE ()
	  (MULTIPLE-VALUE-SETQ (SYM END-IDX)
	    (CL:READ-FROM-STRING NON-FONT-LINE NIL EOF :START IDX))
	(:NO-ERROR
	 (cond ((EQ SYM EOF)
		(SETQ ERROR-P T)
		(if (eq (char non-font-line idx) #/()
		    (incf idx)
		  (return)))
	       (t
		(SETQ STR (SUBSTRING NON-FONT-LINE IDX (MIN (LENGTH LINE) END-IDX))))))
	(SYS:PARSE-ERROR
	 (SETQ STR (GET-DEFUN-NAME (MOVE-BP BP LINE 0)))))
       (UNLESS ERROR-P
	 (MULTIPLE-VALUE-SETQ (SYM NIL ERROR-P)
	   (SYMBOL-FROM-STRING STR NON-FONT-LINE NIL SYM))
	 ;;No error, all is cool
	 (return))))
    (WHEN ERROR-P
      (SETQ SYM (CONCATENATE 'STRING
			     (LET ((BUFFER (NODE-TOP-LEVEL-NODE (LINE-NODE LINE))))
			       (IF (safe-get-zwei-buffer-instance-variable BUFFER 'PATHNAME)
				   (LET ((NAME
					   (PATHNAME-NAME (BUFFER-PATHNAME BUFFER))))
				     (IF (CONSP NAME)
					 (APPLY #'STRING-APPEND
						(MAPCAR (LAMBDA (NAME-ELT)
							  (IF (CONSP NAME-ELT)
							      (CAR NAME-ELT) NAME-ELT))
							NAME))
				       (STRING NAME)))
				 (or (safe-get-zwei-buffer-instance-variable BUFFER 'name)
				     "SECTION")))
			     "-"
			     (LET ((START-INDEX (STRING-SEARCH-NOT-CHAR #/( LINE)))
			       (SUBSTRING LINE START-INDEX
					  (AND START-INDEX
					       (STRING-SEARCH-SET *WHITESPACE-CHARS*
								  LINE START-INDEX))))
			     "-"
			     (PRIN1-TO-STRING (INCF *SECTION-COUNT*)))
	    STR SYM))
    (VALUES SYM STR NIL)))

))