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