<commit_before>(in-package :json)

(defvar *prototype-name* 'prototype)

(defun find-class* (class-designator)
  (if (typep class-designator
             '(or standard-class structure-class built-in-class))
      class-designator
      (find-class class-designator)))

(defun old-and-new-slots (bindings superclasses)
  (let ((superclasses-slots
         (mapcar #'slot-definition-name
                 (reduce #'union (mapcar #'class-slots superclasses)
                         :initial-value nil))))
    (loop for binding in bindings
      if (member (car binding) superclasses-slots) collect binding into old
      else collect binding into new
      finally (return (values old new)))))

(defun make-and-populate-instance (class bindings)
  (let ((object (make-instance class)))
    (loop for (slot . value) in bindings
      do (setf (slot-value object slot) value))
    object))

(defmethod make-object (bindings (class (eql nil)) &key (superclasses nil))
  (let ((superclasses (mapcar #'find-class* superclasses)))
    (multiple-value-bind (old-slot-bindings new-slot-bindings)
        (old-and-new-slots bindings superclasses)
      (if (and (null new-slot-bindings) (<= 0 (length superclasses) 1))
          (setq class (or (first superclasses) 'standard-object))
          (let ((anonymous-class
                 (make-instance 'standard-class
                   :direct-superclasses superclasses
                   :direct-slots (mapcar
                                  (lambda (binding) `(:name ,(car binding)))
                                  new-slot-bindings))))
            (dolist (superclass superclasses)
              ;; The anonymous class should be removed from the
              ;; superclasses' direct-subclasses lists right away because
              ;; it is purely interim.  If it is not removed, it remains
              ;; after its (single) instance is disused and so never GCs.
              (remove-direct-subclass superclass anonymous-class))
            (setq class anonymous-class)))
      (make-and-populate-instance
       class (nconc new-slot-bindings old-slot-bindings)))))

(defmethod make-object (bindings class &key &allow-other-keys)
  (let ((class (find-class* class)))
    (make-and-populate-instance
     class (old-and-new-slots bindings (list class)))))

(defmethod make-object (bindings (class (eql (find-class 'cons)))
                        &key &allow-other-keys)
  (copy-seq bindings))

(defmethod make-object (bindings (class (eql (find-class 'hash-table)))
                        &key &allow-other-keys)
  (let ((table (make-hash-table)))
    (loop for (key . value) in bindings
      do (setf (gethash key table) value))
    table))

(defmethod make-object (bindings (class symbol) &key &allow-other-keys)
  (make-object bindings (find-class class)))

(defclass prototype ()
  ((lisp-class :initarg :lisp-class :reader lisp-class)
   (lisp-superclasses :initarg :lisp-superclasses :reader lisp-superclasses)
   (lisp-package :initarg :lisp-package :reader lisp-package))
  (:default-initargs :lisp-class nil :lisp-superclasses nil
                     :lisp-package nil))

(defun max-package (symbols &key ((:initial-value package)
                                  (find-package '#:common-lisp)))
  (labels ((symbol-in-package-p (symbol)
             (eq (find-symbol (symbol-name symbol) package) symbol))
           (update-package-for-symbol (symbol)
             (if (not (symbol-in-package-p symbol))
                 (setq package (symbol-package symbol))))
           (check-symbol (symbol)
             (if (not (symbol-in-package-p symbol))
                 (warn "Symbol ~S cannot be found in apparent package ~S."
                       symbol package))))
    (mapc #'update-package-for-symbol symbols)
    (mapc #'check-symbol symbols)
    package))

(defun package-name* (package)
  (let ((name (package-name package)))
    (if (stringp name) (make-symbol name) name)))

(defmethod make-object-prototype (object &optional slot-names)
  (let* ((class (class-of object))
         (class-name (if class (class-name class)))
         (superclass-names
          (if (not class-name)
              (mapcar #'class-name (class-direct-superclasses class))))
         (package
          (max-package superclass-names
            :initial-value
              (max-package slot-names
                :initial-value (if class-name
                                   (symbol-package class-name)
                                   (find-package '#:common-lisp))))))<commit_msg>Fixed MAKE-OBJECT-PROTOTYPE (T) so that MAX-PACKAGE ignores STANDARD-OBJECT superclass.<commit_after>(in-package :json)

(defvar *prototype-name* 'prototype)

(defun find-class* (class-designator)
  (if (typep class-designator
             '(or standard-class structure-class built-in-class))
      class-designator
      (find-class class-designator)))

(defun old-and-new-slots (bindings superclasses)
  (let ((superclasses-slots
         (mapcar #'slot-definition-name
                 (reduce #'union (mapcar #'class-slots superclasses)
                         :initial-value nil))))
    (loop for binding in bindings
      if (member (car binding) superclasses-slots) collect binding into old
      else collect binding into new
      finally (return (values old new)))))

(defun make-and-populate-instance (class bindings)
  (let ((object (make-instance class)))
    (loop for (slot . value) in bindings
      do (setf (slot-value object slot) value))
    object))

(defmethod make-object (bindings (class (eql nil)) &key (superclasses nil))
  (let ((superclasses (mapcar #'find-class* superclasses)))
    (multiple-value-bind (old-slot-bindings new-slot-bindings)
        (old-and-new-slots bindings superclasses)
      (if (and (null new-slot-bindings) (<= 0 (length superclasses) 1))
          (setq class (or (first superclasses) 'standard-object))
          (let ((anonymous-class
                 (make-instance 'standard-class
                   :direct-superclasses superclasses
                   :direct-slots (mapcar
                                  (lambda (binding) `(:name ,(car binding)))
                                  new-slot-bindings))))
            (dolist (superclass superclasses)
              ;; The anonymous class should be removed from the
              ;; superclasses' direct-subclasses lists right away because
              ;; it is purely interim.  If it is not removed, it remains
              ;; after its (single) instance is disused and so never GCs.
              (remove-direct-subclass superclass anonymous-class))
            (setq class anonymous-class)))
      (make-and-populate-instance
       class (nconc new-slot-bindings old-slot-bindings)))))

(defmethod make-object (bindings class &key &allow-other-keys)
  (let ((class (find-class* class)))
    (make-and-populate-instance
     class (old-and-new-slots bindings (list class)))))

(defmethod make-object (bindings (class (eql (find-class 'cons)))
                        &key &allow-other-keys)
  (copy-seq bindings))

(defmethod make-object (bindings (class (eql (find-class 'hash-table)))
                        &key &allow-other-keys)
  (let ((table (make-hash-table)))
    (loop for (key . value) in bindings
      do (setf (gethash key table) value))
    table))

(defmethod make-object (bindings (class symbol) &key &allow-other-keys)
  (make-object bindings (find-class class)))

(defclass prototype ()
  ((lisp-class :initarg :lisp-class :reader lisp-class)
   (lisp-superclasses :initarg :lisp-superclasses :reader lisp-superclasses)
   (lisp-package :initarg :lisp-package :reader lisp-package))
  (:default-initargs :lisp-class nil :lisp-superclasses nil
                     :lisp-package nil))

(defun max-package (symbols &key ((:initial-value package)
                                  (find-package '#:common-lisp)))
  (labels ((symbol-in-package-p (symbol)
             (eq (find-symbol (symbol-name symbol) package) symbol))
           (update-package-for-symbol (symbol)
             (if (not (symbol-in-package-p symbol))
                 (setq package (symbol-package symbol))))
           (check-symbol (symbol)
             (if (not (symbol-in-package-p symbol))
                 (warn "Symbol ~S cannot be found in apparent package ~S."
                       symbol package))))
    (mapc #'update-package-for-symbol symbols)
    (mapc #'check-symbol symbols)
    package))

(defun package-name* (package)
  (let ((name (package-name package)))
    (if (stringp name) (make-symbol name) name)))

(defmethod make-object-prototype (object &optional slot-names)
  (let* ((class (class-of object))
         (class-name (if class (class-name class)))
         (superclass-names
          (if (not class-name)
              (remove 'standard-object
                      (mapcar #'class-name
                              (class-direct-superclasses class)))))
         (package
          (max-package (append superclass-names slot-names)
            :initial-value (if class-name
                               (symbol-package class-name)
                               (find-package '#:common-lisp)))))
{'fraction_non_alphanumeric': 0.12358326068003488, 'fraction_numerical': 0.00043591979075850045, 'mean_word_length': 2.289247311827957, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 8, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4963656', 'n_tokens_mistral': 2643, 'n_tokens_neox': 2585, 'n_words': 734}