;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.82
;;; Reason:
;;;  Yet another implementation of `#(...)
;;; Written 21-Jun-88 12:15:43 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 1
;;; with Experimental System 124.79, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, 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#464 at 21-Jun-88 12:26:29
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; READ  "

(defmacro XR-BQ-VECTOR* (ELEMENT)
  `(if (consp ,element)
       (apply #'vector ,element)
     (vector ,element)))

))

; From modified file DJ: L.IO; READ.LISP#464 at 21-Jun-88 12:26:36
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; READ  "

(DEFUN XR-BACKQUOTE-MACRO (STREAM IGNORE)
  (LET* ((**BACKQUOTE-REPEAT-VARIABLE-LISTS** (CONS T **BACKQUOTE-REPEAT-VARIABLE-LISTS**))
	 (object (INTERNAL-READ STREAM T NIL T))
	 (vector-p (simple-vector-p object)))
    (MULTIPLE-VALUE-BIND (FLAG THING)
	(BACKQUOTIFY (if vector-p (listarray object) object))
      (COND ((EQ FLAG **BACKQUOTE-/,/@-FLAG**)
	     (READ-ERROR "/",@/" right after a /"`/": `,@~S." THING))
	    ((EQ FLAG **BACKQUOTE-/,/.-FLAG**)
	     (READ-ERROR "/",./" right after a /"`/": `,.~S." THING))
	    (vector-p
	     `(xr-bq-vector* ,(backquotify-1 flag thing)))
	    (T
	     (BACKQUOTIFY-1 FLAG THING))))))

))

; From modified file DJ: L.IO; READ.LISP#464 at 21-Jun-88 12:28:06
#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 ((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))))))

))