;;; -*- Mode:LISP; Package:USER; Syntax:COMMON-LISP; Base:10 -*-

;;; Copyright (c) 1988 by Robert W. Kerns.
;;; Permission is granted to distribute this freely, or to
;;; incorporate this in any commercial product, so long as this
;;; copyright notice remains intact.

;;; This is where the handlers live.

(defvar *definition-spec-handlers* (make-hash-table :test 'equal))

;;; This is used by the expansion of the FUNCTION-SPEC-INVOKE macro.

(defun lookup-spec-handler (spec)
  (multiple-value-bind (spec-type spec)
                       (etypecase spec
                         (symbol (values 'symbol `(symbol ,spec)))
                         (list (values (first spec) spec)))
    (let ((spec-handler
           (gethash spec-type *definition-spec-handlers*)))
      (unless spec-handler
        (error "Definition spec type ~S not recognized." spec-type))
      (values spec-handler spec))))


;;; This is here just to avoid having to redefine the DEFUN in the working system,
;;; which cannot be done portably.  When you install this for real in your system,
;;; replace the usage of this in DEF-DEFINITION-SPEC-HANDLER with DEFUN, and modify
;;; whatever DEFUN uses to store the definition (compiled and interpreted) to use
;;; (SETF (FDEFINITION <spec>) <function>)

;;; Note that this kludging of a temporary name is not satisfactory for use as a substitute
;;; for this mechanism.  Consider, for example, what happens if you export a symbol after defining
;;; the function.

(defmacro defun-dummy (spec arglist &body body)
  (let ((temp-name (make-symbol (let ((*package* (find-package "LISP")))
                                  (format nil "~S" spec)))))
    (if (symbolp spec)
      `(defun ,spec ,arglist ,@body)
      `(progn (defun ,temp-name ,arglist ,@body)
              (setf (fdefinition ',spec) #',temp-name)))))

;;; Run-time subroutine:  Verify that the list of the required length.
;;; Does so carefully, so as to not blow out on dotted lists; otherwise we'd
;;; just use LENGTH.

(defun verify-list-of-length (list length)
  (do ((list list (rest list))
       (n length (1- n)))
      ((zerop n) (return t))
    (when (atom list)
      (return nil))))

;;; Run-time subroutine:  Verify that the list is at least of the required length.
;;; Does so carefully, so as to not blow out on dotted lists; otherwise we'd
;;; just use LENGTH.

(defun verify-list-over-length (arglist-var length)
  (do ((n 0 (1+ n))
       (list arglist-var (rest list)))
      ((>= n length) (return t))
    (when (atom list)
      (return nil))))

;;; Run-time subroutine:  Verify that only valid keywords are supplied.

(defun verify-keyword-arguments (arglist valid-keys)
  (do ((key (car arglist) (car arglist))
       (arglist arglist (cddr arglist)))
      ((endp arglist))
    (unless (find key valid-keys :key #'key-arg-keyword)
      (return-from verify-keyword-arguments nil)))
  (return-from verify-keyword-arguments t))


;;; Default place to put properties.

(defvar *definition-spec-properties* (make-hash-table :test #'equal))

;;; This one is separate so nobody things DOCUMENTATION is a
;;; "standard property".

(defvar *definition-spec-documentation* (make-hash-table :test #'equal))

;;; On LMI, TI, or Symbolics machines, we use FDEFINITION-1 to avoid clobbering
;;; the already-defined system version.

(defun #-(or Symbolics TI LMI) FDEFINITION #+(or Symbolics TI LMI) FDEFINITION-1 (spec)
  (function-spec-invoke fdefinition spec))

(defsetf #-(or Symbolics TI LMI) FDEFINITION #+(or Symbolics TI LMI) FDEFINITION-1 set-fdefinition)

(defun set-fdefinition (spec new-definition)
  (etypecase spec
    (symbol (setf (symbol-function spec) new-definition))
    (list
     (function-spec-invoke (setf fdefinition) spec new-definition)
     new-definition)))

;;; This gets called when the user's code doesn't handle something.

(defun default-definition-spec-handler (spec operation &rest arglist)
  (case operation
    (documentation (gethash spec *definition-spec-documentation*))
    (setf-documentation 
     (let ((new-doc (first arglist)))
       (setf (gethash spec *definition-spec-documentation*) new-doc)))
    (otherwise (error "Unimplemented operation on definition-spec ~S: ~S."
                      spec
                      (or (first (find operation *definition-spec-messages* :key #'second))
                          operation)))))