;;; -*- Mode:LISP; Package:(FSI :USE LISP) ; Base:10; Readtable:CL -*-

;;;; Useful subroutines which should live outside this file.

(DEFUN MAKE-SYMBOL-FROM-CONCATENATED-NAMES (&OPTIONAL (PKG *PACKAGE*) &REST FROBS)
  (INTERN (APPLY #'CONCATENATE 'STRING
		 (MAP 'LIST #'STRING-UPCASE FROBS))
	  PKG))

;;;; Immediate instances.

(DEFMACRO DEFINSTANCE-IMMEDIATE (NAME &BODY INSTANCE-VARIABLES)
  (LET ((INSTANCE-VARIABLE-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-INSTANCE-VARIABLES"))
	(METHOD-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-WHICH-OPERATIONS")))
    (SET METHOD-LIST-NAME NIL)
    (SET INSTANCE-VARIABLE-LIST-NAME INSTANCE-VARIABLES)
    `(PROGN 'COMPILE
	    (SETQ ,INSTANCE-VARIABLE-LIST-NAME ',INSTANCE-VARIABLES)
	    (SETQ ,METHOD-LIST-NAME NIL)
	    (SETF (GET ',NAME 'SI:FLAVOR) T)	;This makes M-. work
	    (DEFVAR ,NAME))))

(DEFMACRO DECLARE-INSTANCE-IMMEDIATE-INSTANCE-VARIABLES ((NAME) &BODY BODY)
  (LET ((INSTANCE-VARIABLE-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-INSTANCE-VARIABLES")))
    `(LOCAL-DECLARE ((SPECIAL . ,(SYMBOL-VALUE INSTANCE-VARIABLE-LIST-NAME)))
		    . ,BODY)))

(EVAL-WHEN (COMPILE LOAD)
  (SETF (GET 'DECLARE-INSTANCE-IMMEDIATE-INSTANCE-VARIABLES 'SI:MAY-SURROUND-DEFUN) T))


(DEFMACRO DEFMETHOD-IMMEDIATE ((NAME MESSAGE) ARGLIST &BODY BODY)
  (LET ((METHOD-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-WHICH-OPERATIONS"))
	(METHOD-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME #\- MESSAGE "-METHOD")))
    (WHEN (MEMBER MESSAGE (SYMBOL-VALUE METHOD-LIST-NAME))
      (PUSH MESSAGE (SYMBOL-VALUE METHOD-LIST-NAME)))
    `(DECLARE-INSTANCE-IMMEDIATE-INSTANCE-VARIABLES (,NAME)
       (DEFUN ,METHOD-NAME (IGNORE . ,ARGLIST)
	 . ,BODY))))

(DEFMACRO MAKE-INSTANCE-IMMEDIATE (NAME INIT-PLIST-GENERATOR)
  (LET ((INSTANCE-VARIABLE-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-INSTANCE-VARIABLES"))
	(METHOD-LIST-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-WHICH-OPERATIONS"))
	(SEND-IF-HANDLES-METHOD-NAME
	  (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-SEND-IF-HANDLES"))
	(OPERATION-HANDLED-P-METHOD-NAME
	  (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-OPERATION-HANDLED-P"))
	(GET-HANDLER-FOR-METHOD-NAME
	  (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME "-GET-HANDLER-FOR"))
	(METHOD-LIST 'SI:UNCLAIMED-MESSAGE))
    (DOLIST (MESSAGE (SYMBOL-VALUE METHOD-LIST-NAME))
      (LET ((METHOD-NAME (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL NAME #\- MESSAGE "-METHOD")))
	(PUSH (CONS MESSAGE METHOD-NAME) METHOD-LIST)))
    (PUSH (CONS ':WHICH-OPERATIONS METHOD-LIST-NAME) METHOD-LIST)
    (PUSH (CONS ':SEND-IF-HANDLES SEND-IF-HANDLES-METHOD-NAME) METHOD-LIST)
    (PUSH (CONS ':OPERATION-HANDLED-P OPERATION-HANDLED-P-METHOD-NAME) METHOD-LIST)
    (PUSH (CONS ':GET-HANDLER-FOR GET-HANDLER-FOR-METHOD-NAME) METHOD-LIST)
    `(PROGN 'COMPILE
	    (DEFUN ,SEND-IF-HANDLES-METHOD-NAME (IGNORE OPERATION &REST ARGS)
	      (IF (MEMBER OPERATION (,METHOD-LIST-NAME NIL))
		  (LEXPR-SEND SELF OPERATION ARGS)))
	    (DEFUN ,OPERATION-HANDLED-P-METHOD-NAME (IGNORE OPERATION)
	      (MEMBER OPERATION (,METHOD-LIST-NAME NIL)))
	    (DEFUN ,GET-HANDLER-FOR-METHOD-NAME (IGNORE OPERATION)
	      (IF (MEMBER OPERATION (,METHOD-LIST-NAME NIL))
		  (MAKE-SYMBOL-FROM-CONCATENATED-NAMES NIL ',NAME "-" OPERATION)
		',(PKG-NAME PACKAGE)))
	    (DEFUN ,METHOD-LIST-NAME (IGNORE)
	      ',(SYMBOL-VALUE METHOD-LIST-NAME))
	    (SETQ ,NAME (FAKE-UP-INSTANCE ',NAME ',(SYMBOL-VALUE INSTANCE-VARIABLE-LIST-NAME)
					  ',METHOD-LIST ',INIT-PLIST-GENERATOR)))))