[MOP] #'(SETF CLASS-NAME) does not accept non-symbol data as class name

[Michał "phoe" Herda]

The MOP states that the class's name is allowed to be arbitrary Lisp data, not just a symbol. See http://metamodular.com/CLOS-MOP/class-name.html and http://metamodular.com/CLOS-MOP/setf-class-name.html

Therefore:

CL-USER> (defclass quux () ((fred :accessor fred)))
#<STANDARD-CLASS QUUX>
CL-USER> (setf (class-name *) '(quux))

This produces an error:

Required argument is not a symbol: (QUUX)
   [Condition of type SB-INT:SIMPLE-PROGRAM-ERROR]

Restarts:
 0: [RETRY] Retry SLIME REPL evaluation request.
 1: [*ABORT] Return to SLIME's top level.
 2: [ABORT] abort thread (#<THREAD "repl-thread" RUNNING {100C510603}>)

Backtrace:
  0: (SB-PCL::REAL-ADD-METHOD #<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::FRED (0)> #<SB-MOP:STANDARD-READER-METHOD COMMON-LISP:NIL, slot:FRED, (#<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>) {..
      Locals:
        GENERIC-FUNCTION = #<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::FRED (0)>
        METHOD = #<SB-MOP:STANDARD-READER-METHOD COMMON-LISP:NIL, slot:FRED, (#<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>) {100C5AA243}>
        SKIP-DFUN-UPDATE-P = NIL
  1: (SB-PCL::FIX-SLOT-ACCESSORS #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}> (#<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION COMMON-LISP-USER::FRED>) SB-PCL::ADD)
      Locals:
        ADD/REMOVE = SB-PCL::ADD
        CLASS = #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>
        DSLOTD = #<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION COMMON-LISP-USER::FRED>
        DSLOTDS = (#<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION COMMON-LISP-USER::FRED>)
        LOCATION = #S(SB-C:DEFINITION-SOURCE-LOCATION :NAMESTRING NIL :INDICES 0)
        SLOT-DOC = NIL
        SLOT-NAME = FRED
  2: ((:METHOD SHARED-INITIALIZE :AFTER (SB-PCL::STD-CLASS T)) #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}> NIL :DIRECT-SUPERCLASSES NIL :DIRECT-SLOTS NIL :DIRECT-DEFAULT-INITARGS NIL) [fast-met..
      Locals:
        #:.DEFAULTING-TEMP. = NIL
        #:.DEFAULTING-TEMP.#1 = NIL
        #:.DEFAULTING-TEMP.#2 = NIL
        SB-PCL::.PV. = #(17 ..)
        CLASS = #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>
        #:N-SUPPLIED-23 = NIL
        #:N-SUPPLIED-24 = NIL
        #:N-SUPPLIED-25 = NIL
        SB-PCL::SLOT-NAMES = NIL
  3: ((SB-PCL::EMF SHARED-INITIALIZE) #<unused argument> #<unused argument> #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}> NIL :NAME (QUUX))
      Locals:
        SB-PCL::.ARG0. = #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>
        SB-PCL::.ARG1. = NIL
        SB-DEBUG::MORE = (:NAME (QUUX))
  4: ((:METHOD REINITIALIZE-INSTANCE (SB-PCL::SLOT-OBJECT)) #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}> :NAME (QUUX)) [fast-method]
      Locals:
        SB-PCL::INITARGS = (:NAME (QUUX))
        SB-KERNEL:INSTANCE = #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>
  5: ((SB-PCL::EMF REINITIALIZE-INSTANCE) #<unused argument> #<unused argument> #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}> :NAME (QUUX))
      Locals:
        SB-PCL::.ARG0. = #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>
        SB-DEBUG::MORE = (:NAME (QUUX))
  6: ((:METHOD (SETF CLASS-NAME) (T T)) (QUUX) #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>) [fast-method]
      Locals:
        CLASS = #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>
        SB-PCL::NEW-VALUE = (QUUX)
  7: ((LAMBDA ()))
      Locals:
        #:*504 = #<STANDARD-CLASS (COMMON-LISP-USER::QUUX) {100C54D093}>
        #:NEW1 = (QUUX)
  8: (SB-INT:SIMPLE-EVAL-IN-LEXENV (SETF (CLASS-NAME *) (QUOTE (QUUX))) #<NULL-LEXENV>)
      Locals:
        SB-KERNEL:LEXENV = #<NULL-LEXENV>
        SB-IMPL::ORIGINAL-EXP = (SETF (CLASS-NAME *) '(QUUX))
  9: (EVAL (SETF (CLASS-NAME *) (QUOTE (QUUX))))
      Locals:
        SB-IMPL::ORIGINAL-EXP = (SETF (CLASS-NAME *) '(QUUX))

Inspecting the class object shows that the class's name was changed, though:

CL-USER> (class-name *)
(FROB)

The error was in the fixup, as hinted by SHARED-INITIALIZE :AFTER and SB-PCL::FIX-SLOT-ACCESSORS in the backtrace.

I have traced the further sources of the error to:
https://github.com/sbcl/sbcl/blob/e98378ca004ef6d101b384f6c3130f24b7a1bc1f/src/compiler/parse-lambda-list.lisp#L299
https://github.com/sbcl/sbcl/blob/e98378ca004ef6d101b384f6c3130f24b7a1bc1f/src/compiler/parse-lambda-list.lisp#L138

SBCL 1.4.11.

[Michał "phoe" Herda (phoe-krk)]

Further investigation shows that SB-MOP:METHOD-LAMBDA-LIST returns an erroneous value.

CL-USER> (defclass quux () ((fred :accessor fred :initform 42)))
#<STANDARD-CLASS COMMON-LISP-USER::QUUX>
CL-USER> (trace sb-mop:method-lambda-list)
(SB-MOP:METHOD-LAMBDA-LIST)
CL-USER> (setf (class-name (find-class 'quux)) '(frob))
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD (COMMON-LISP:SETF COMMON-LISP:CLASS-NAME) (T T) {10008A0023}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned (SB-PCL::NEW-VALUE CLASS)
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:REINITIALIZE-INSTANCE :BEFORE (SB-PCL::SLOT-CLASS) {10009F6043}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned (CLASS &KEY SB-PCL::DIRECT-SUPERCLASSES)
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:REINITIALIZE-INSTANCE :AFTER (SB-PCL::SLOT-CLASS) {10009F6053}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned (CLASS &REST SB-PCL::INITARGS &KEY)
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:REINITIALIZE-INSTANCE (SB-PCL::SLOT-OBJECT) {10008A21F3}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned
       (SB-KERNEL:INSTANCE &REST SB-PCL::INITARGS)
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:SHARED-INITIALIZE :AFTER (SB-PCL::STD-CLASS T) {1000598433}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned
       (CLASS SB-PCL::SLOT-NAMES &KEY
        (SB-PCL::DIRECT-SUPERCLASSES NIL SB-PCL::DIRECT-SUPERCLASSES-P)
        (SB-PCL::DIRECT-SLOTS NIL SB-PCL::DIRECT-SLOTS-P)
        (SB-PCL::DIRECT-DEFAULT-INITARGS NIL SB-PCL::DIRECT-DEFAULT-INITARGS-P))
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:SHARED-INITIALIZE :BEFORE (CLASS T) {1000598453}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned
       (CLASS SB-PCL::SLOT-NAMES &KEY SB-PCL::NAME)
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:SHARED-INITIALIZE (SB-PCL::SLOT-OBJECT T) {1000164C23}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned
       (SB-KERNEL:INSTANCE SB-PCL::SLOT-NAMES &REST SB-PCL::INITARGS)
  0: (SB-MOP:METHOD-LAMBDA-LIST #<SB-MOP:STANDARD-READER-METHOD COMMON-LISP-USER::FRED, slot:FRED, ((CLASS #<STANDARD-CLASS (COMMON-LISP-USER::FROB) {100C572303}>)) {100CC3C6F3}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned ((FROB))
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:INITIALIZE-INSTANCE (SB-PCL::SLOT-OBJECT) {1000164CF3}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned
       (SB-KERNEL:INSTANCE &REST SB-PCL::INITARGS)
  0: (SB-MOP:METHOD-LAMBDA-LIST #<STANDARD-METHOD COMMON-LISP:SHARED-INITIALIZE (SB-PCL::SLOT-OBJECT T) {1000164C23}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned
       (SB-KERNEL:INSTANCE SB-PCL::SLOT-NAMES &REST SB-PCL::INITARGS)
;; Error signaled here

In particular:

  0: (SB-MOP:METHOD-LAMBDA-LIST #<SB-MOP:STANDARD-READER-METHOD COMMON-LISP-USER::FRED, slot:FRED, ((CLASS #<STANDARD-CLASS (COMMON-LISP-USER::FROB) {100C572303}>)) {100CC3C6F3}>)
  0: SB-MOP:METHOD-LAMBDA-LIST returned ((FROB))

((FROB)) is not a valid unspecialized lambda list. This lambda list should have had a single mandatory argument that is a symbol, so, something like (OBJECT).

METHOD-LAMBDA-LIST is only a reader, which means that the lambda list is set to the method metaobject in a different way.

[Michał "phoe" Herda (phoe-krk)]

Bug pinpointed.

https://github.com/sbcl/sbcl/blob/master/src/pcl/std-class.lisp#L1299

This assumes that (CLASS-NAME CLASS) is a symbol, which conflicts with the MOP passages stated above.

A possible fix would be changing

  (list (or (class-name class) 'object))

to

  (list (let ((name (class-name class))) (if (and name (symbolp name)) name 'object)))

[Michał "phoe" Herda (phoe-krk)]

Clarification: the above fix needs to be applied to ADD-READER-METHOD (L1299), ADD-WRITER-METHOD (L1316) and ADD-BOUNDP-METHOD (L1330).

[Michał "phoe" Herda (phoe-krk)]

Can confirm that, after making the above fix in the above methods and redefining them in a live SBCL image, SETF CLASS-NAME works as intended.

CL-USER> (defclass quux () ((fred :accessor fred :initform 42)))
#<STANDARD-CLASS COMMON-LISP-USER::QUUX>
CL-USER> (setf (class-name (find-class 'quux)) '(frob))
(FROB)
CL-USER> **
#<STANDARD-CLASS (COMMON-LISP-USER::FROB) {100FF27103}>
CL-USER> (make-instance *)
#<#<STANDARD-CLASS (COMMON-LISP-USER::FROB) {100FF27103}> {1010049DD3}>