;;;-*-lisp-*-
;;; Using the /#-SYMBOLIC-CHARACTERS-TABLE as a way of specifying options.
;;; The main use of this is to be able to specify options to functions
;;; symbolically without fear of wasting symbol space in the maclisp
;;; environment, and without the hair of macro expansions.
;;; 7:16pm  Sunday, 22 February 1981 -GJC

;;; N.B. Since the symbolic translation is done at read time, and since
;;; the implementation allows options from different sets to map into
;;; the same fixnum (in order that the fixnums may be most likey INUMS,
;;; which do not take up any extra space) validity of options is only
;;; checked in the obvious-call case of
;;; (FOOBAR #\<OPTION-SYMBOL> <VALUE> #\<OPTION-SYMBOL> <VALUE> ...)
;;; and this if and only if nobody has foolishly macroexpanded the
;;; arguments to FOOBAR before the syntax-checking SOURCE-TRANS property
;;; is invoked by the compiler. Oh yeah, you only get this error checking
;;; in the compiler, so much for people who debug code using the interpreter.

(OR (GET 'SHARPM 'VERSION) (LOAD '((LISP)SHARPM)))

(HERALD OPTDEF)

(DEFVAR OPTION-SETS NIL "List of symbols which have option properties")

(DECLARE (SPECIAL /#-SYMBOLIC-CHARACTERS-TABLE
		  ;; we assume that the implementation of #\FOO is that
		  ;; FOO is looked up in an ALIST which is the value
		  ;; of this variable. This is true in Maclisp, and
		  ;; will be in NIL. Off hand I don't know what to do
		  ;; about this on the lisp machine.
		  ))

(DEFUN ENTER-/#-SYMBOL (SYMBOL N)
  (LET ((CELL (ASSQ SYMBOL /#-SYMBOLIC-CHARACTERS-TABLE)))
    (IF CELL (SETF (CDR CELL) N)
	(PUSH (CONS SYMBOL N)
	      /#-SYMBOLIC-CHARACTERS-TABLE))))

(DEFUN (|op| MACRO) (FORM)
  ;; this macro does NOT want to displace, has no need of memoization for speed.
  (OR (GET (CADDR FORM)
	   (CADR FORM))
      (ERROR (LIST "has no" (CADDR FORM) "option") (CADR FORM))))

;; N.B. I am aware that the macro definition does not take effect inside
;; a QUOTE. However, a useratoms hook would, in the compiler, therefore
;; we must conclude that something is wrong with the implementation of
;; quote in the interpreter.

(progn 'compile
       ;; interface to the hackish maclisp grinder.

(defun (|op| grindmacro) ()
       (declare (special l m))	
       (princ "#\") (princ (caddr l)))

(defprop |op|
         +internal-dwim-predictfun
	 grindpredict)

(defun (|op| grindflatsize) (l)
       (+ 2 (flatsize (caddr l))))
)


(DEFUN OPTIONS-CHECK (FORM)
  ;; this catches most errors.
  (DO ((SET (CAR FORM))
       (ARGL (NTHCDR (1+ (OR (GET (CAR FORM) 'NUMBER-OF-LEADING-ARGUMENTS)
			     0))
		     FORM)
	     (CDDR ARGL)))
      ((NULL ARGL)
       (VALUES FORM NIL))
    (LET ((OPTION (CAR ARGL)))
      (COND ((ATOM OPTION))
	    ((EQ '|op| (CAR OPTION))
	     (OR (EQ (CADR OPTION) SET)
		 (ERROR (LIST "has option from outside set" OPTION)
			FORM)))))))

(DEFUN ENTER-OPTION-SYMBOL (SET SYMBOL)
  (DO ((L OPTION-SETS (CDR L)))
      ((NULL L))
    (IF (MEMQ SYMBOL (GET (CAR L) 'OPTIONS))
	;; this need not be an error, it could simply use the
	;; existing GOEDEL number on the option symbol if it did not
	;; conflict with the numbers already used by the SET in question.
	;; If it did conflict then we have a problem.
	;; Those familar with Pascal will recall a similar problem with
	;; set implementations in that language.
	;; You can't get something for nothing.
	(ERROR (LIST "is already defined as an option for" (CAR L))
	       SYMBOL)))
  (PUTPROP SYMBOL (LENGTH (GET SET 'OPTIONS)) SET)
  (ENTER-/#-SYMBOL SYMBOL `(|op| ,SET ,SYMBOL))
  (PUSH SYMBOL (GET SET 'OPTIONS)))


(DEFUN SETUP-OPTIONS (NAME NUMBER-OF-LEADING-ARGUMENTS OPTIONS)
  (OR (MEMQ NAME OPTION-SETS) (PUSH NAME OPTION-SETS))
  (OR (MEMQ 'OPTIONS-CHECK (GET NAME 'SOURCE-TRANS))
      (PUSH 'OPTIONS-CHECK (GET NAME 'SOURCE-TRANS)))
  (PUTPROP NAME NIL 'OPTIONS)
  (PUTPROP NAME NUMBER-OF-LEADING-ARGUMENTS 'NUMBER-OF-LEADING-ARGUMENTS)
  (MAPC #'(LAMBDA (OPTION)
	    (ENTER-OPTION-SYMBOL NAME OPTION))
	OPTIONS))

(SETUP-OPTIONS 'P-READ 1
	       '(STOP-CHARS
		 NUMBER-OF-CHARS
		 ECHO-P
		 COMPLETION-CHAR
		 COMPLETION-ALIST
		 COMPLETION-QUERY-CHAR
		 COMPLETION-QUERY-STREAM
		 STOP-FUNCTION
		 CHAR-TRANSLATION-FUNCTION))