;-*- Mode:LISP; Package:READERMACROSPACKAGE; Base:10; Readtable:INTERLISP -*-
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This program contains confidential information of Inference Corporation.  Use or copying   ;
; without express written authorization of Inference Corporation is strictly prohibited.     ;
; Copyright ownership rights hereby asserted by Inference Corporation.  Copyright 1984.      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;;; Macro to ignore font change characters
(DEFUN FlushCharacter (ListSoFar Stream)
  (FUNCALL Stream ':TYI)
  (VALUES ListSoFar 'LIST T))
;(SET-SYNTAX-MACRO-CHAR #/ 'FlushCharacter) ;  is too valuable as a symbol for this!

;;; Create a read macro that acts as a break character in symbols
(DEFUN MakeHardReadMacro (Character Function &OPTIONAL (Table READTABLE))
  (SET-SYNTAX-FROM-CHAR Character #/' table table)
  (set-syntax-macro-char character function table))


;;; Reader macro to print information about the arguments of the function referenced by
;;; the form that is currently being typed.
;(DEFUN ArglistReaderMacro (ListSoFar Stream)
;  (MULTIPLE-VALUE-BIND  (X Y) (FUNCALL Stream ':READ-CURSORPOS)
;    (COND ((NOT (AND (LISTP ListSoFar)
;		     (SYMBOLP (CAR ListSoFar))
;		     (FBOUNDP (CAR ListSoFar))))
;	   (SI:BEEP))
;	  (T (TERPRI Stream) (TERPRI Stream)
;	     (bind (Formals _ (OR (GET (CAR ListSoFar) 'ArgumentDeclaration)
;				  (ARGLIST (CAR ListSoFar))))
;		   (Actuals _ (CDR ListSoFar))
;		   ThisFormal
;		   first (AND (EQ Formals 'MACRO)
;			      (FORMAT Stream "; MACRO with no argument declaration~%"))
;		   while (AND Formals Actuals) do
;		   (COND ((NLISTP Formals)
;			  (FORMAT Stream "; ~S = ~S~%" Formals Actuals)
;			  (RETURN))
;			 (T (AND (LISTP (SETQ ThisFormal (POP Formals)))
;				 (SETQ ThisFormal (CAR ThisFormal)))
;			    (SELECTQ ThisFormal
;			      (&QUOTE (FORMAT Stream "; Following arguments QUOTED:~%"))
;			      (&EVAL (FORMAT Stream "; Following arguments EVALUATED:~%"))
;			      (&OPTIONAL (FORMAT Stream "; Following arguments OPTIONAL~%"))
;			      (&REST (FORMAT Stream "; The REST of the arguments are in:~%~
;						     ; ~S = ~S~%" (CAR Formals) Actuals)
;				     (RETURN))
;			      (&AUX (SETQ Formals NIL) (RETURN))
;			      ((&SPECIAL &LOCAL))
;			      (OTHERWISE
;			       (FORMAT Stream "; ~S = ~S~%" ThisFormal (POP Actuals))))))
;		   finally
;		   (COND (Actuals
;			  (FORMAT Stream "; plus EXTRANEOUS arguments:~%; ~S~%" Actuals))
;			 (Formals
;			  (FORMAT Stream "; Remaining arguments:~%; [")
;			  (FORMAT:PRINT-LIST Stream "~S" Formals "; " "; ")
;			  (FORMAT Stream "]~%"))))))
;    (FUNCALL Stream ':SET-CURSORPOS X Y)
;    (FUNCALL Stream ':FORCE-KBD-INPUT #\RUBOUT)
;    (FUNCALL Stream ':FORCE-KBD-INPUT #\RUBOUT)
;    (VALUES ListSoFar 'LIST T)))
;(SET-SYNTAX-/#-MACRO-CHAR #/? 'ArglistReaderMacro)


;;; *****
;;; Reader macros for structure accessing and modification
;;; *****

;;; Unique internal representations of the operators
(DEFVAR AccessorOperator (NCONS NIL))
(DEFVAR AssignmentOperator (NCONS NIL))
(DEFVAR SegmentOperator (NCONS NIL))
(DEFVAR SegmentTerminator (NCONS NIL))

(DEFUN AccessorReaderMacro (ListSoFar Stream)
  (ReadAccessorForm ListSoFar Stream AccessorOperator))
(MakeHardReadMacro #/
 'AccessorReaderMacro)

(DEFUN AssignmentReaderMacro (ListSoFar Stream)
  (ReadAccessorForm ListSoFar Stream AssignmentOperator))
(MakeHardReadMacro #/ 'AssignmentReaderMacro)

(DEFUN SegmentReaderMacro (ListSoFar Stream)
  (ReadAccessorForm ListSoFar Stream SegmentOperator))
(MakeHardReadMacro #/{ 'SegmentReaderMacro)

(DEFUN SegmentTerminatorReaderMacro (ListSoFar Stream) ListSoFar Stream
  (VALUES SegmentTerminator 'LIST NIL))
(MakeHardReadMacro #/} 'SegmentTerminatorReaderMacro)

;;; #\CLOSE does not work!
(DEFCONST CloseParen #/))

;;; Finish reading ListSoFar and process it as a structure access/modify statement
(DEFUN ReadAccessorForm (ListSoFar Stream Operator)
  (COND
    ((EQ ListSoFar ':TOPLEVEL) (VALUES Operator 'LIST NIL))
    ((NULL ListSoFar) (si:BEEP) NIL)
    (T (VALUES
	 (BuildAccessorForm
	   (NCONC ListSoFar
		  (NCONS Operator)
		  (until (EQ CloseParen (si:XR-xrTYIPEEK T Stream)) collect (READ Stream))))
	 'LIST T))))

;;; Translate the access/modify Form by interpreting its operators
(DEFUN BuildAccessorForm (Form &AUX (Expression (NCONS (CAR Form))))
  ()
  (bind item for tail on (CDR Form) do
       (SELECT (CAR tail)
	 (AccessorOperator
	  (pop tail)
	  (COND ((EQ AccessorOperator (CAR tail))
		 (pop tail)
		 (RPLACA Expression (BuildTailAccess (CAR Expression) (CAR tail))))
		((FIXP (CAR tail))
		 (RPLACA Expression (BuildElementAccess (CAR Expression) (CAR tail))))
		(T (RPLACA Expression
			   `(fetch ,(ParseFieldSymbol (CAR tail)) of ,(CAR Expression))))))
	 (AssignmentOperator
	  (pop tail)
	  (MULTIPLE-VALUE-BIND (RightSide Type) (BuildAccessorForm tail)
	    (SELECTQ Type
	      (List (RETURN `(,.(NREVERSE (CDR Expression))
			      (SETF ,(CAR Expression) ,(CAR RightSide))
			      ,.(CDR RightSide))
			    'List))
	      (OTHERWISE (COND ((CDR Expression)
				(RETURN `(,.(NREVERSE (CDR Expression))
					  (SETF ,(CAR Expression) ,RightSide))
					'List))
			       (T (RETURN `(SETF ,(CAR Expression) ,RightSide)
					  'Element)))))))
	 (SegmentOperator
	  (pop tail)
	  (RPLACA Expression `(RecordSegment ,(CAR Expression) ,(pop tail)))
	  (OR (EQ (CAR tail) SegmentTerminator) (FERROR NIL "{ then ~S but no } ??" Item)))
	 (OTHERWISE (global:push (CAR tail) Expression)))
       finally (COND ((CDR Expression) (RETURN (NREVERSE Expression) 'List))
		     (T (RETURN (CAR Expression) 'Element)))))

;;; Special cases for list element access (general case uses NTH)
(DEFCONST AccessorFunctions '((0 . CAR) (1 . SECOND) (2 . THIRD) (3 . FOURTH)
			      (4 . FIFTH) (5 . SIXTH) (6 . SEVENTH)))

;;; Apply the list element Accessor to the value of Form
(DEFUN BuildElementAccess (Form Accessor)
  (LET ((Function (CDR (ASSQ Accessor AccessorFunctions))))
    (COND (Function `(,Function ,Form))
	  ((PLUSP Accessor) `(NTH ,Accessor ,Form))
	  ((= Accessor -1) `(CAR (LAST ,Form)))
	  ((MINUSP Accessor) `(CAR (NLEFT ,(- Accessor) ,Form NIL)))
	  (T (FERROR NIL "Bad accesssor ~S of form ~S." Accessor Form)))))

;;; Special cases for list tail access (general case uses NTHCDR)
(DEFCONST TailFunctions '((1 . REST1) (2 . REST2) (3 . REST3) (4 . REST4)))

;;; These are needed to assign to negative tail accesses.
(DEFPROP LAST ((LAST List) . (CDR (RPLACD (NLEFT 2 List) si:VAL))) SETF)
(DEFPROP NLEFT ((NLEFT n List Tail) . (CDR (RPLACD (NLEFT (1+ n) List Tail) si:VAL))) SETF)

;;; Apply the list tail Accessor to the value of Form
(DEFUN BuildTailAccess (Form Accessor)
  (LET ((Function (CDR (ASSQ Accessor TailFunctions))))
    (COND (Function `(,Function ,Form))
	  ((PLUSP Accessor) `(NTHCDR ,Accessor ,Form))
	  ((= Accessor -1) `(LAST ,Form))
	  ((MINUSP Accessor) `(NLEFT ,(- Accessor) ,Form NIL))
	  ((= Accessor 0) Form)
	  (T (FERROR NIL "Bad tail accessor ~S of form ~S." Accessor Form)))))

;;; Return the list of qualifications in the record field Symbol
(DEFUN ParseFieldSymbol (Symbol)
  (COND ((SYMBOLP Symbol)
	 (LET (Position (String (GET-PNAME Symbol)))
	   (COND ((SETQ Position (STRING-SEARCH-CHAR #/. String))
		  (bind Result do (global:push (INTERN (SUBSTRING String 0 Position)) Result)
				  (SETQ String (SUBSTRING String (ADD1 Position)))
				  (SETQ Position (STRING-SEARCH-CHAR #/. String))
		     repeatwhile Position
		     finally (RETURN (NREVERSE (global:push (INTERN String) Result)))))
		 (T (LIST Symbol)))))
	(T Symbol)))



(COMMENT   ; Temporarily commented out....
;;; *****
;;; Syntax updates so ZWEI will handle the structure accessing macros reasonably.
;;; *****

zwei:
(ADVISE INITIALIZE-SYNTAX-TABLES AFTER InterlispStructureMacroAdvice NIL
	(ASET WORD-DELIMITER *WORD-SYNTAX-TABLE* #/
)
	(ASET WORD-DELIMITER *ATOM-WORD-SYNTAX-TABLE* #/
)
	(ASET WORD-DELIMITER *WORD-SYNTAX-TABLE* #/)
	(ASET WORD-DELIMITER *ATOM-WORD-SYNTAX-TABLE* #/)
	(ASET WORD-DELIMITER *WORD-SYNTAX-TABLE* #/.)
	(ASET WORD-DELIMITER *ATOM-WORD-SYNTAX-TABLE* #/.))	

zwei:
(COND (*ZMACS-COMMAND-LOOP*
       (FUNCALL *ZMACS-COMMAND-LOOP* ':FUNCALL-INSIDE-YOURSELF 'INITIALIZE-SYNTAX-TABLES)
       (FUNCALL *ZMACS-COMMAND-LOOP* ':EVAL-INSIDE-YOURSELF
		'(SETQ *MODE-WORD-SYNTAX-TABLE*
		       (MAKE-SPARSE-SYNTAX-TABLE *WORD-SYNTAX-TABLE*)))))

)