;;; -*- 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.


;;; New symbols in LISP package:
;;;   DEF-definition-spec-HANDLER:  Define a new kind of definition-spec.
;;;   FDEFINITION:  Get a function from its definition-spec.  (SETFable).
;;;   DEFAULT-definition-spec-HANDLER:  Handles reporting errors for unhandled cases
;;;     or illegal messages.  Only used with OTHERWISE.
;;;   definition-spec-GET:  Get a property associated with a function.  (SETFable).
;;;   valid-definition-spec:  Verify that a definition-spec is syntactically legal.
;;;     This only verifies syntax, not whether the location named exists or is defined.
;;;     Returns NIL if the syntax is not valid.

;;; This is where the handlers live.

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

;;; Hack for efficiency in dispatch.
;;; Entries are (function internal-indicator arglist &key required)
;;; function is what the user writes as the name of the operation
;;;   in his DEF-definition-spec-HANDLER form.
;;; internal-indicator is what the program actually calls the handler with.
;;; arglist is a template for the argument list.  It is checked to be sure the
;;;   user's supplied arglist matches the actual protocol.

(eval-when (eval compile load)
(defvar *definition-spec-messages*
  '((fdefinition fdefinition () :required t)
    ((setf fdefinition) set-definition (new-function))
    (fmakunbound fmakunbound ())
    ((compile fdefinition) compile-definition (environment))
    ((compile (setf fdefinition)) setf-compile-definition (environment new-function-form))
    (documentation documentation ())
    ((setf documentation) setf-documentation (new-documentation))
    (valid-definition-spec valid-definition-spec ())
    (definedp definedp ())
    (which-operations which-operations ())))
)

(defvar *gensymbol* 0)

(defun gensymbol (&rest strings)
  (unless strings
    (setq strings '("GS")))
  (let* ((previous t)
         (string
          (with-output-to-string (stream)
            (mapc #'(lambda (string)
                      (unless previous
                        (write-char #\- stream))
                      (princ string stream)
                      (setq previous
                            (and (> (length string) 0)
                                 (eql (char string (1- (length string)))
                                      #\-))))
                  strings)
            (unless previous
              (write-char #\- stream))
            (write (incf *gensymbol*) 
                   :stream stream
                   :base 10.
                   :radix nil))))
    (make-symbol string)))

(defmacro function-spec-invoke (operation spec &rest arglist)
  (let* ((handler-var (gensymbol "HANDLER"))
         (spec-var (gensymbol "SPEC"))
         (real-message (second (assoc operation *definition-spec-messages* :test #'equal))))
    (unless real-message
      (error "Definition spec operation ~S not recognized." operation))
    `(multiple-value-bind (,handler-var ,spec-var)
                          (lookup-spec-handler ,spec)
       (funcall ,handler-var ,spec-var ',real-message ,@arglist))))

(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)))))

;;; Define a definition-spec handler

(defmacro def-definition-spec-handler (type type-arglist &body message-clauses)
  (let* ((arglist-var (make-symbol "MESSAGE-ARGLIST"))
         (spec-var (make-symbol "definition-spec"))
         (operation-var (make-symbol "operation"))
         (message-body (compute-definition-spec-handler-body message-clauses type-arglist
                                                           arglist-var operation-var spec-var)))
    `(defun-dummy ,(if (eq type 'def-definition-spec-handler)
                     'def-definition-spec-handler-handler     ; Avoid the circular dependency
                     `(def-definition-spec-handler ,type))
       (,spec-var ,operation-var &rest ,arglist-var)
       ,@message-body)))

;;; Expand the clauses into a case statement.

(defun compute-definition-spec-handler-body (message-clauses type-arglist
                                                             arglist-var operation-var spec-var)
  (let ((doc-string (when (stringp (first message-clauses))
                      (pop message-clauses)))
        (validate-fun (gensymbol "VALIDATE"))
        (required-messages nil)
        (validate-clause (assoc 'valid-definition-spec message-clauses))
        (otherwise-clause (assoc 'otherwise message-clauses))
        (pre-validate-clause (compute-pre-validation type-arglist arglist-var)))
    (labels ((check-required-message (message)
             ;; Lexical scoping bug in Allegro CL
             ;  (apply #'decode-check-required-message message message)
                (decode-check-required-message message (first message) 
                                               (second message) (third message)))
             (decode-check-required-message (message spec spec-sym arglist &key required)
               (declare (ignore spec spec-sym arglist))
               (when required
                 (push message required-messages)))
             ;; Compute the CASE clause for this message clause.
             (compute-clause (clause)
               (let* ((indicator (pop clause))
                      (arglist (pop clause))
                      (message (assoc indicator *definition-spec-messages* :test #'equal)))
                 (unless message
                   (warn "~S is not a known operation for function specs." indicator))
                 ;; Bug in Allegro CL
                 ;; (apply #'decode-message arglist clause message)
                 (decode-message arglist clause (first message) (second message) (third message))
                 ))
             ;; Decode the message-spec and compute the CASE clause.
             ;; If it's a required clause, notice that it's been satisfied.
             (decode-message (arglist clause-body spec indicator-symbol test-arglist &key required)
               (when required
                 ;; Remove from list of unseen required messages.
                 (setq required-messages (delete spec required-messages
                                                 :key #'car :test #'equal)))
               ;; Check that the arglist matches what it's supposed to be.
               (compare-arglists arglist test-arglist spec)
               `(,indicator-symbol 
                 (flet ((,indicator-symbol ,arglist ,@clause-body))
                   (apply #',indicator-symbol ,arglist-var)))))
      ;; Check to see what messages are required.
      (mapc #'check-required-message *definition-spec-messages*)
      ;; Extract out the clauses we handle specially
      (setq message-clauses (remove otherwise-clause (remove validate-clause message-clauses)))
      ;; If the user didn't specify an OTHERWISE clause, supply one that invokes
      ;; the default handler.
      (unless otherwise-clause
        (setq otherwise-clause `(otherwise (apply #'default-definition-spec-handler
                                                  ,spec-var ,operation-var ,arglist-var))))
      ;; Construct the answer, and check for any missing required clauses.
      (prog1`(,@(when doc-string
                  (list doc-string))
              (case ,operation-var
                ;; valid-definition-spec has to be handled specially, because we don't
                ;; know yet whether the syntax is valid.
                (valid-definition-spec
                 ;; Destructure the spec and the arguments.  Too bad we don't have
                 ;; DESTRUCTURING-BIND...
                 (flet ((,validate-fun ,type-arglist
                          (flet ((validate-1 ,@(cdr validate-clause)))
                            (apply #'validate-1 ,arglist-var))))
                   (and ,pre-validate-clause
                        (apply #',validate-fun (cdr ,spec-var)))))
                (otherwise
                 ;; The syntax is expected to be valid.
                 (flet ((with-spec-pieces ,type-arglist
                          (case ,operation-var
                            ,@(mapcar #'compute-clause message-clauses)
                            ,otherwise-clause)))
                   (apply #'with-spec-pieces (cdr ,spec-var))))))
        (when required-messages
          (warn "The following required operations were not supplied:  ~{~S~}"
                required-messages))))))

;;; Compute the very basic validation that needs to happen before we
;;; start destructuring the arglist for the user to validate further.

(defun compute-pre-validation (arglist arglist-var)
  (let ((tests `((not (atom ,arglist-var)))))
    (multiple-value-bind (required optional rest key allow-other-keys)
          (analyze-arglist arglist)
      (macrolet ((make-check-and-pop (form)
                   `(push `(multiple-value-bind (ok new-arglist)
                                                ,,form                     
                             (setq ,arglist-var new-arglist)
                             ok)
                          tests)))
        (make-check-and-pop `(verify-list-of-length ,arglist-var ,(length required)))
        (when optional
          (make-check-and-pop `(verify-list-over-length ,arglist-var ,(length optional))))
        (if (and (null rest) (null key))
            (push `(null ,arglist-var) tests)
          (when key
            (if allow-other-keys
                (push `(evenp (length ,arglist-var)) tests)
               (make-check-and-pop `(verify-keyword-arguments ,arglist-var
                                                              ',(mapcar #'key-arg-keyword key))))))))
    `(and ,@(nreverse tests))))

;;; 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))

;;; Parses an arglist into its component pieces.  CL badly needs a standard
;;; way of doing this.

(defun analyze-arglist (arglist)
  (declare (values required optional rest key allow-other-keys aux))
  (let ((required nil)
        (optional nil)
        (rest nil)
        (keys nil)
        (allow-other-keys nil)
        (aux nil))
    (block parse-arglist
      (macrolet ((&state-dispatch ((keys arg arglist) &body otherwise-clauses)
                   (let ((clauses nil))
                     (dolist (key keys)
                       (push `(,key ,(ecase key
                                        (&optional `(do-optional (rest ,arglist)))
                                        ((&rest &body) `(do-rest (rest ,arglist)))
                                        (&key `(do-key (rest ,arglist)))
                                        (&allow-other-keys `(do-allow-other-keys (rest ,arglist)))
                                        (&aux `(do-aux (rest ,arglist)))))
                             clauses))
                     (push `(,(set-difference lambda-list-keywords keys)
                             (error "A ~S in the wrong position in a lambda list." ,arg))
                           clauses)
                     (push `(otherwise (return-from dispatch (progn,@otherwise-clauses))) clauses)
                     `(block dispatch (return-from parse-arglist (case ,arg ,@(nreverse clauses))))))
                 (doing-arglist ((argvar arglist-var) &body body)
                    `(do* ((,arglist-var ,arglist-var (rest ,arglist-var))
                           (,argvar (first ,arglist-var) (first ,arglist-var)))
                          ((null ,arglist-var))
                       ,@body)))
        (labels ((do-required (arglist)
                   (doing-arglist (arg arglist)
                     (&state-dispatch ((&optional &rest &body &key &aux) arg arglist)
                       (push arg required))))
                 (do-optional (arglist)
                   (doing-arglist (arg arglist)
                     (&state-dispatch ((&rest &body &key &aux) arg arglist)
                       (push arg optional))))
                 (do-rest (arglist)
                   (if (member (first arglist) lambda-list-keywords)
                       (error "~S found after &REST or &BODY; expected rest variable."
                              (first arglist))
                     (progn
                       (setq rest (pop arglist))
                       (let ((arg (first arglist))) ;; Pick up the arg for the error message.
                         (when arglist
                           (&state-dispatch ((&key &aux) arg arglist)
                             (error "Extra arguments found after &REST: ~S" (cons arg arglist))))))))
                 (do-key (arglist)
                   (doing-arglist (arg arglist)
                     (&state-dispatch ((&allow-other-keys &aux) arg arglist)
                       (push arg keys))))
                 (do-allow-other-keys (arglist)
                   (setq allow-other-keys t)
                   (doing-arglist (arg arglist)
                     (&state-dispatch ((&aux) arg arglist)
                       (error "Extra arguments found after &ALLOW-OTHER-KEYS: ~S"
                              (cons arg arglist)))))
                 (do-aux (arglist)
                   (doing-arglist (arg arglist)
                     (&state-dispatch (() arg arglist)
                       (push arg aux)))))
          (do-required arglist))))
    (values (nreverse required)
            (nreverse optional)
            rest
            (nreverse keys)
            allow-other-keys
            (nreverse aux))))

;;; Verify that the arglist of a method follows the protocol specified
;;; by the pattern arglist.

(defun compare-arglists (arglist pattern for-function)
  (multiple-value-bind (required optional rest key allow-other)
                       (analyze-arglist arglist)
    (multiple-value-bind (pat-required pat-optional pat-rest pat-key pat-allow-other)
                         (analyze-arglist pattern)
      (unless (and (= (length required) (length pat-required))
                   (or (= (length optional) (length pat-optional))
                       (and pat-rest (not pat-key)))
                   ;; Check for keys matching
                   ;; Check for &rest when that's required
                   ;; Disable check for extra keys when pattern says &allow-other-keys
                   ;; Disable check for missing keys when arglist says &allow-other-keys
                   )
        (warn "For ~S:  The argument list ~S does not match the pattern ~S"
              for-function arglist pattern)))))

;;; 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))

(defun fdefinition (spec)
  (function-spec-invoke fdefinition spec))

(defsetf fdefinition 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)))))