;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.87
;;; Reason:
;;;  For people who like to modify their readtables...
;;;  SET-MACRO-CHARACTER now signals a legible error when passed 
;;;  certain kinds of invalid CHAR arguments.  For example, don't
;;;  let the caller set syntax for a character with special bits
;;;  (font, control, meta, etc.).
;;; Written 22-Jun-88 14:22:50 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 1
;;; with Experimental System 124.86, 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, Tiger 28.0, microcode 1761, SDU Boot Tape 3.14, SDU ROM 103, Beta 3 for in-house.



; From modified file DJ: L.IO; READ.LISP#465 at 22-Jun-88 14:22:51
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; READ  "

(DEFUN SET-MACRO-CHARACTER (CHAR FUNCTION &OPTIONAL NON-TERMINATING-P
						    (A-READTABLE *READTABLE*))
  "Set the syntax of CHAR in A-READTABLE to be a macro character that invokes FUNCTION.
NON-TERMINATING-P non-NIL means the macro char is recognized only
 at the start of a token; it can appear unquoted in the middle of a symbol.
FUNCTION is passed the input stream and the character that invoked it.
It should return zero or more values, each of which is an object produced
by the macro.  Zero and one are the most common numbers of values.
More than one may not be accepted in certain contexts.

The function can examine the list of input so far at the current level
 through the special variable XR-LIST-SO-FAR.  It can also be
 :TOPLEVEL if not within list, or :AFTER-DOT if after a dot.

A function can also hairily mung the list so far.
To do this, modify XR-LIST-SO-FAR and return the modified list as
 the only value, after setting the special variable XR-SPLICE-P to T."
  ;;;Check character code, bucky bits, etc.
  (IF (CHARACTERP CHAR) (SETQ CHAR (CHAR-INT CHAR)))
  (cond ((not (fixnump char))
	 (ferror "Can't set syntax for ~s (which cannot be coerced into a character)" char))
	((not (zerop (char-bits char)))
	 (ferror "Can't set syntax for a character (~@c) with modifier bits" (int-char char)))
	((not (zerop (char-font char)))
	 (ferror "Can't set syntax for a character (~@c) with font bits" (int-char char))))
  ;;;Now we have a good character code.
  (LET ((SYNTAX (GETF (RDTBL-PLIST A-READTABLE)
		      (IF NON-TERMINATING-P 'NON-TERMINATING-MACRO 'MACRO))))
    (UNLESS (AND (CONSP SYNTAX)
		 (FIXNUMP (CAR SYNTAX))
		 (FIXNUMP (CDR SYNTAX)))
      (FERROR "No saved syntax found for defining macro characters."))
    (SETF (RDTBL-BITS A-READTABLE CHAR) (CAR SYNTAX))
    (SETF (RDTBL-CODE A-READTABLE CHAR) (CDR SYNTAX))
    (LET ((X (ASSQ CHAR (RDTBL-MACRO-ALIST A-READTABLE))))
      (IF (NULL X)
	  (SETF (RDTBL-MACRO-ALIST A-READTABLE)
		(CONS (LIST CHAR FUNCTION NON-TERMINATING-P) (RDTBL-MACRO-ALIST A-READTABLE)))
	(SETF (CDR X) (LIST FUNCTION NON-TERMINATING-P)))))
  T)

))