X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/01778b39c53316dda3f757c49276d034039ee9cb..7aa55c1174f170016d970a3f5e86d5115f02611c:/src/builtin.lisp?ds=inline diff --git a/src/builtin.lisp b/src/builtin.lisp index 77eca39..776d3a1 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -279,7 +279,7 @@ (default (sod-initarg-default initarg))) (definst suppliedp-struct (stream) (flags var) (format stream - "~@" + "~@" flags var)) ;; Initialization. @@ -294,18 +294,30 @@ (defmethod sod-message-effective-method-class ((message initialization-message)) 'initialization-effective-method) -(defmethod method-keyword-argument-lists - ((method initialization-effective-method) direct-methods) +(defmethod sod-message-keyword-argument-lists + ((message initialization-message) (class sod-class) direct-methods state) (append (call-next-method) (mapcan (lambda (class) - (let ((initargs (sod-class-initargs class))) + (let* ((initargs (sod-class-initargs class)) + (map (make-hash-table)) + (arglist (mapcar + (lambda (initarg) + (let ((arg (sod-initarg-argument + initarg))) + (setf (gethash arg map) initarg) + arg)) + initargs))) (and initargs - (list (cons (format nil "initargs for ~A" - class) - (mapcar #'sod-initarg-argument - initargs)))))) - (sod-class-precedence-list - (effective-method-class method))))) + (list (cons (lambda (arg) + (info-with-location + (gethash arg map) + "Type `~A' from initarg ~ + in class `~A' (here)" + (argument-type arg) class) + (report-inheritance-path + state class)) + arglist))))) + (sod-class-precedence-list class)))) (defmethod lifecycle-method-kernel ((method initialization-effective-method) codegen target) @@ -504,9 +516,11 @@ (defun bootstrap-classes (module) instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and an instance of itself)." (let* ((sod-object (make-sod-class "SodObject" nil - (make-property-set :nick 'obj))) + (make-property-set :nick 'obj + :%bootstrapping t))) (sod-class (make-sod-class "SodClass" (list sod-object) - (make-property-set :nick 'cls))) + (make-property-set :nick 'cls + :%bootstrapping t))) (classes (list sod-object sod-class))) ;; Attach the built-in messages.