<commit_before>;;; -*- Gerbil -*-
;;; (C) vyzo
;;; Generics support macros
package: std

(import :gerbil/gambit
        (rename-in <MOP> (defmethod defmethod~)))
(export #t)

(begin-syntax
  (defclass (generic-info macro-object) (dispatch-table procedure)
    id: std/generic#generic-info::t)

  (defstruct generic-type-info (type predicate)
    id: std/generic#generic-type-info::t)
  )

(defsyntax (defgeneric stx)
  (def (generate-generic id default)
    (with-syntax* ((id id)
                   (default default)
                   (dispatch-table-id (stx-identifier #'id #'id "::t"))
                   (dispatch-table
                    #'(def dispatch-table-id
                        (make-generic 'id default)))
                   (procedure-id (stx-identifier #'id #'id "::apply"))
                   (procedure
                    (syntax/loc stx
                      (def (procedure-id . args)
                        (apply generic-dispatch dispatch-table-id args))))
                   (meta
                    #'(defsyntax id
                        (make-generic-info
                         dispatch-table: (quote-syntax dispatch-table-id)
                         procedure: (quote-syntax procedure-id)
                         macro:
                         (syntax-rules ()
                           ((_ arg (... ...))
                            (procedure-id arg (... ...)))
                           (id (identifier? #'id) procedure-id))))))
      #'(begin dispatch-table procedure meta)))

  (syntax-case stx ()
    ((_ id)
     (identifier? #'id)
     (generate-generic #'id #f))
    ((_ id default)
     (identifier? #'id)
     (generate-generic #'id #'default))))

(defrules defgeneric-type ()
  ((_ id (type-id ...) pred)
   (and (identifier? #'id)
        (identifier-list? #'(type-id ...))
        (identifier? #'pred))
   (defsyntax id
     (make-generic-type-info '(type-id ... t)
                             (quote-syntax pred)))))

(defsyntax (defmethod stx)
  (def (wrap e-stx)
    (stx-wrap-source e-stx (stx-source stx)))

  (def (class-method-option? x)
    (memq (stx-e x) '(rebind:)))

  (def (generic-type-id? id)
    (and (identifier? id)
         (let (info (syntax-local-value id false))
           (or (generic-type-info? info)
               (runtime-type-info? info)))))

  (def (generate-generic-dispatch arg-id type-info)
    (with-syntax ((arg-id arg-id))
      (cond
       ((generic-type-info? type-info)
        (with-syntax ((pred (generic-type-info-predicate type-info))
                      (type (generic-type-info-type type-info)))
          #'((pred arg-id) 'type)))
       ((runtime-struct-info? type-info)
        (with-syntax ((struct::t (@ type-info runtime-identifier)))
          #'((struct-instance? struct::t arg-id) struct::t)))
       ((runtime-class-info? type-info)
        (with-syntax ((class::t (@ type-info runtime-identifier)))
          #'((class-instace? class::t arg-id) class::t)))
       (else
        (raise-syntax-error #f "Bad syntax; unknown argument type" stx)))))

  (syntax-case stx (@method)
    ((_ (@method id type) impl . opts)
     (with-syntax ((body (stx-cdr stx)))
       (wrap #'(defmethod~ . body))))

    ((_ (generic-id (arg-id type-id) ...) body ...)
     (cond<commit_msg>std/generic: fix generic dispatch; s/class-instace?/class-instance?<commit_after>;;; -*- Gerbil -*-
;;; (C) vyzo
;;; Generics support macros
package: std

(import :gerbil/gambit
        (rename-in <MOP> (defmethod defmethod~)))
(export #t)

(begin-syntax
  (defclass (generic-info macro-object) (dispatch-table procedure)
    id: std/generic#generic-info::t)

  (defstruct generic-type-info (type predicate)
    id: std/generic#generic-type-info::t)
  )

(defsyntax (defgeneric stx)
  (def (generate-generic id default)
    (with-syntax* ((id id)
                   (default default)
                   (dispatch-table-id (stx-identifier #'id #'id "::t"))
                   (dispatch-table
                    #'(def dispatch-table-id
                        (make-generic 'id default)))
                   (procedure-id (stx-identifier #'id #'id "::apply"))
                   (procedure
                    (syntax/loc stx
                      (def (procedure-id . args)
                        (apply generic-dispatch dispatch-table-id args))))
                   (meta
                    #'(defsyntax id
                        (make-generic-info
                         dispatch-table: (quote-syntax dispatch-table-id)
                         procedure: (quote-syntax procedure-id)
                         macro:
                         (syntax-rules ()
                           ((_ arg (... ...))
                            (procedure-id arg (... ...)))
                           (id (identifier? #'id) procedure-id))))))
      #'(begin dispatch-table procedure meta)))

  (syntax-case stx ()
    ((_ id)
     (identifier? #'id)
     (generate-generic #'id #f))
    ((_ id default)
     (identifier? #'id)
     (generate-generic #'id #'default))))

(defrules defgeneric-type ()
  ((_ id (type-id ...) pred)
   (and (identifier? #'id)
        (identifier-list? #'(type-id ...))
        (identifier? #'pred))
   (defsyntax id
     (make-generic-type-info '(type-id ... t)
                             (quote-syntax pred)))))

(defsyntax (defmethod stx)
  (def (wrap e-stx)
    (stx-wrap-source e-stx (stx-source stx)))

  (def (class-method-option? x)
    (memq (stx-e x) '(rebind:)))

  (def (generic-type-id? id)
    (and (identifier? id)
         (let (info (syntax-local-value id false))
           (or (generic-type-info? info)
               (runtime-type-info? info)))))

  (def (generate-generic-dispatch arg-id type-info)
    (with-syntax ((arg-id arg-id))
      (cond
       ((generic-type-info? type-info)
        (with-syntax ((pred (generic-type-info-predicate type-info))
                      (type (generic-type-info-type type-info)))
          #'((pred arg-id) 'type)))
       ((runtime-struct-info? type-info)
        (with-syntax ((struct::t (@ type-info runtime-identifier)))
          #'((struct-instance? struct::t arg-id) struct::t)))
       ((runtime-class-info? type-info)
        (with-syntax ((class::t (@ type-info runtime-identifier)))
          #'((class-instance? class::t arg-id) class::t)))
       (else
        (raise-syntax-error #f "Bad syntax; unknown argument type" stx)))))

  (syntax-case stx (@method)
    ((_ (@method id type) impl . opts)
     (with-syntax ((body (stx-cdr stx)))
       (wrap #'(defmethod~ . body))))

    ((_ (generic-id (arg-id type-id) ...) body ...)
     (cond
{'fraction_non_alphanumeric': 0.1668428204741054, 'fraction_numerical': 0.0, 'mean_word_length': 1.7715481171548118, 'pattern_counts': {'":': 4, '<': 5, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4779996', 'n_tokens_mistral': 2101, 'n_tokens_neox': 1990, 'n_words': 459}