;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.74
;;; Reason:
;;;  First: (setq x '(a b c))
;;;  Then, `(a ,@x b) --> (a a b c b)
;;;  but   `#(a ,@x b) -- error
;;; Written 18-Jun-88 15:39:40 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 1
;;; with Experimental System 124.65, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1760, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.IO; READ.LISP#463 at 18-Jun-88 15:39:54
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; READ  "

(DEFUN BACKQUOTIFY (CODE)
  (PROG (AFLAG A DFLAG D)
	(COND ((SIMPLE-VECTOR-P CODE)
	       (RETURN (VALUES 'VECTOR
			       (do* ((index 0 (1+ index))
				     (end (length code))
				     (result nil))
				    ((= index end)
				     (nreverse result))
				 (multiple-value-bind (flag code)
				     (backquotify (aref code index))
				   (cond ((or (eq flag **backquote-/,/@-flag**)
					      (eq flag **backquote-/,/.-flag**))
					  (let ((value (if (symbolp code)
							   (symbol-value code)
							 (eval code))))
					    (if (listp value)
						(dolist (x value)
						  (push (list-in-area read-area 'quote x) result :area read-area))
					      (push (list-in-area read-area 'quote value) result :area read-area)))
					  )
					 (t
					  (push (backquotify-1 flag code) result :area read-area))))))))
;			       (MAPCAR (LAMBDA (ELT)
;					 (MULTIPLE-VALUE-BIND (FLAG CODE)
;					     (BACKQUOTIFY ELT)
;					   (BACKQUOTIFY-1 FLAG CODE)))
;				       (LISTARRAY CODE)))))
	      ((ATOM CODE)
	       (COND ((NULL CODE)
		      (RETURN (VALUES NIL NIL)))
		     ((OR (NUMBERP CODE)
			  (EQ CODE T))
		      (RETURN (VALUES T CODE)))
		     (T
		      (RETURN (VALUES 'QUOTE CODE)))))
	      ((EQ (CAR CODE) **BACKQUOTE-/,-FLAG**)
	       (SETQ CODE (CDR CODE))
	       (GO COMMA))
	      ((EQ (CAR CODE) **BACKQUOTE-/,/@-FLAG**)
	       (RETURN (VALUES **BACKQUOTE-/,/@-FLAG** (CDR CODE))))
	      ((EQ (CAR CODE) **BACKQUOTE-/,/.-FLAG**)
	       (RETURN (VALUES **BACKQUOTE-/,/.-FLAG** (CDR CODE)))))
	(MULTIPLE-VALUE-SETQ (AFLAG A) (BACKQUOTIFY (CAR CODE)))
	(MULTIPLE-VALUE-SETQ (DFLAG D) (BACKQUOTIFY (CDR CODE)))
	(AND (EQ DFLAG **BACKQUOTE-/,/@-FLAG**)
	     (READ-ERROR " /",@/" after a /"./": .,@~S in ~S." D CODE))
	(AND (EQ DFLAG **BACKQUOTE-/,/.-FLAG**)
	     (READ-ERROR " /",./" after a /"./": .,.~S in ~S." D CODE))
	(COND ((EQ AFLAG **BACKQUOTE-/,/@-FLAG**)
	       (COND ((NULL DFLAG)
		      (SETQ CODE A)
		      (GO COMMA)))
	       (RETURN (VALUES 'APPEND
			       (IF (EQ DFLAG 'APPEND)
				   (CONS-IN-AREA A D READ-AREA)
				   (LIST-IN-AREA READ-AREA A (BACKQUOTIFY-1 DFLAG D))))))
	      ((EQ AFLAG **BACKQUOTE-/,/.-FLAG**)
	       (WHEN (NULL DFLAG)
		 (SETQ CODE A)
		 (GO COMMA))
	       (RETURN (VALUES 'NCONC
			       (IF (EQ DFLAG 'NCONC)
				   (CONS-IN-AREA A D READ-AREA)
				   (LIST-IN-AREA READ-AREA A (BACKQUOTIFY-1 DFLAG D))))))
	      ((NULL DFLAG)
	       (IF (MEMQ AFLAG '(QUOTE T NIL))
		   (RETURN (VALUES 'QUOTE (LIST A)))
		   (RETURN (VALUES 'LIST (LIST-IN-AREA READ-AREA (BACKQUOTIFY-1 AFLAG A))))))
	      ((MEMQ DFLAG '(QUOTE T))
	       (IF (MEMQ AFLAG '(QUOTE T NIL))
		   (RETURN (VALUES 'QUOTE
				   (CONS-IN-AREA A D READ-AREA)))
		   (RETURN (VALUES 'LIST*
				   (LIST-IN-AREA READ-AREA
						 (BACKQUOTIFY-1 AFLAG A)
						 (BACKQUOTIFY-1 DFLAG D)))))))
	(SETQ A (BACKQUOTIFY-1 AFLAG A))
	(IF (MEMQ DFLAG '(LIST LIST*))
	    (RETURN (VALUES DFLAG (CONS-IN-AREA A D READ-AREA))))
	(RETURN (VALUES 'LIST* (LIST-IN-AREA READ-AREA A (BACKQUOTIFY-1 DFLAG D))))
     COMMA
	(COND ((ATOM CODE)
	       (COND ((NULL CODE)
		      (RETURN (VALUES NIL NIL)))
		     ((OR (NUMBERP CODE)
			  (EQ CODE 'T))
		      (RETURN (VALUES T CODE)))
		     (T
		      (RETURN (VALUES **BACKQUOTE-/,-FLAG** CODE)))))
	      ((EQ (CAR CODE) 'QUOTE)
	       (RETURN (VALUES 'QUOTE (CADR CODE))))
	      ((MEMQ (CAR CODE) '(APPEND LIST LIST* NCONC))
	       (RETURN (VALUES (CAR CODE) (CDR CODE))))
	      ((EQ (CAR CODE) 'CONS)
	       (RETURN (VALUES 'LIST* (CDR CODE))))
	      (T
		(RETURN (VALUES **BACKQUOTE-/,-FLAG** CODE))))))

))