<commit_before>#lang scheme/base

(require rnrs/records/syntactic-6
         rnrs/records/procedural-6
         r6rs/private/conds
         scheme/mpair
         (for-syntax scheme/base))

(provide &condition
         condition?
         condition
         simple-conditions
         condition-predicate
         condition-accessor
         define-condition-type

         &message make-message-condition message-condition? condition-message
         &warning make-warning warning?
         &serious make-serious-condition serious-condition?
         &error make-error error?
         &violation make-violation violation?
         &assertion make-assertion-violation assertion-violation?
         &irritants make-irritants-condition irritants-condition? condition-irritants
         &who make-who-condition who-condition? condition-who
         &non-continuable make-non-continuable-violation non-continuable-violation?
         &implementation-restriction make-implementation-restriction-violation implementation-restriction-violation?
         &lexical make-lexical-violation lexical-violation?
         &syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform
         &undefined make-undefined-violation undefined-violation?)

(define-record-type &condition (fields))

(define-struct (compound-condition exn) (conditions) #:transparent)
(define-struct (compound-condition:fail exn:fail) (conditions) #:transparent)

(define (condition? v)
  (or (&condition? v)
      (compound-condition? v)
      (compound-condition:fail? v)
      (exn? v)))

(define (condition . conds)
  (for-each (lambda (c)
              (unless (condition? c)
                (raise-type-error 'condition "condition" c)))
            conds)
  (let ([conditions
         (apply append
                (map simple-conditions/list conds))])
    ((if (ormap serious-condition? conditions)
         make-compound-condition:fail
         make-compound-condition)
     (or (ormap (lambda (c)
                  (and (message-condition? c)
                       (condition-message c)))
                conditions)
         "exception")
     (or (ormap (lambda (c)
                  (and (has-continuation-marks? c)
                       (has-continuation-marks-marks c)))
                conditions)
         (current-continuation-marks))
     conditions)))

(define (condition-predicate rtd)
  (let ([pred (record-predicate rtd)])
    (lambda (v)
      (and (condition? v)
           (ormap pred (simple-conditions/list v))))))

(define (condition-accessor rtd proc)
  (let ([pred (record-predicate rtd)])
    (unless (and (procedure? proc)
                 (procedure-arity-includes? proc 1))
      (raise-type-error 'condition-accessor "procedure (arity 1)" proc))
    (lambda (v)
      (let ([v (ormap (lambda (x) 
                        (and (pred x) x))
                      (simple-conditions/list v))])
        (if v
            (proc v)
            (raise-type-error 'a-condition-accessor "specific kind of condition" v))))))

(define (simple-conditions/list c)
  (cond
   [(&condition? c) (list c)]
   [(compound-condition? c)
    (compound-condition-conditions c)]
   [(compound-condition:fail? c)
    (compound-condition:fail-conditions c)]
   [(exn? c)
    (append
     (list
      (make-message-condition (exn-message c))
      (make-has-continuation-marks (exn-continuation-marks c)))
     (if (exn:fail? c)
         (list (make-error))
         null)     
     (if (exn:fail:contract? c)
         (list (make-assertion-violation))
         null)
     (if (exn:fail:r6rs? c)
         (append
          (if (exn:fail:r6rs-who c)
              (list (make-who-condition (exn:fail:r6rs-who c)))
              null)
          (list (make-irritants-condition (exn:fail:r6rs-irritants c))))
         null)
     (if (exn:fail:contract:r6rs? c)
         (append
          (if (exn:fail:contract:r6rs-who c)
              (list (make-who-condition (exn:fail:contract:r6rs-who c)))
              null)
          (list (make-irritants-condition (exn:fail:contract:r6rs-irritants c))))
         null)
     (list (make-non-continuable-violation))
     (if (or (exn:fail:unsupported? c)
             (exn:fail:contract:divide-by-zero? c))
         (list (make-implementation-restriction-violation))
         null)
     (if (exn:fail:read? c)
         (list (make-lexical-violation))
         null)
     (if (exn:fail:syntax? c)
         (let ([forms (exn:fail:syntax-exprs c)])
           (list (make-syntax-violation
                  (if (pair? forms)
                      (car forms)
                      #f)
                  (if (and (pair? forms)
                           (pair? (cdr forms)))
                      (cadr forms)
                      #f))))
         null)
     (if (exn:fail:contract:variable? c)
         (make-undefined-violation)<commit_msg>fix coercion to r6rs &undefined condition<commit_after>#lang scheme/base

(require rnrs/records/syntactic-6
         rnrs/records/procedural-6
         r6rs/private/conds
         scheme/mpair
         (for-syntax scheme/base))

(provide &condition
         condition?
         condition
         simple-conditions
         condition-predicate
         condition-accessor
         define-condition-type

         &message make-message-condition message-condition? condition-message
         &warning make-warning warning?
         &serious make-serious-condition serious-condition?
         &error make-error error?
         &violation make-violation violation?
         &assertion make-assertion-violation assertion-violation?
         &irritants make-irritants-condition irritants-condition? condition-irritants
         &who make-who-condition who-condition? condition-who
         &non-continuable make-non-continuable-violation non-continuable-violation?
         &implementation-restriction make-implementation-restriction-violation implementation-restriction-violation?
         &lexical make-lexical-violation lexical-violation?
         &syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform
         &undefined make-undefined-violation undefined-violation?)

(define-record-type &condition (fields))

(define-struct (compound-condition exn) (conditions) #:transparent)
(define-struct (compound-condition:fail exn:fail) (conditions) #:transparent)

(define (condition? v)
  (or (&condition? v)
      (compound-condition? v)
      (compound-condition:fail? v)
      (exn? v)))

(define (condition . conds)
  (for-each (lambda (c)
              (unless (condition? c)
                (raise-type-error 'condition "condition" c)))
            conds)
  (let ([conditions
         (apply append
                (map simple-conditions/list conds))])
    ((if (ormap serious-condition? conditions)
         make-compound-condition:fail
         make-compound-condition)
     (or (ormap (lambda (c)
                  (and (message-condition? c)
                       (condition-message c)))
                conditions)
         "exception")
     (or (ormap (lambda (c)
                  (and (has-continuation-marks? c)
                       (has-continuation-marks-marks c)))
                conditions)
         (current-continuation-marks))
     conditions)))

(define (condition-predicate rtd)
  (let ([pred (record-predicate rtd)])
    (lambda (v)
      (and (condition? v)
           (ormap pred (simple-conditions/list v))))))

(define (condition-accessor rtd proc)
  (let ([pred (record-predicate rtd)])
    (unless (and (procedure? proc)
                 (procedure-arity-includes? proc 1))
      (raise-type-error 'condition-accessor "procedure (arity 1)" proc))
    (lambda (v)
      (let ([v (ormap (lambda (x) 
                        (and (pred x) x))
                      (simple-conditions/list v))])
        (if v
            (proc v)
            (raise-type-error 'a-condition-accessor "specific kind of condition" v))))))

(define (simple-conditions/list c)
  (cond
   [(&condition? c) (list c)]
   [(compound-condition? c)
    (compound-condition-conditions c)]
   [(compound-condition:fail? c)
    (compound-condition:fail-conditions c)]
   [(exn? c)
    (append
     (list
      (make-message-condition (exn-message c))
      (make-has-continuation-marks (exn-continuation-marks c)))
     (if (exn:fail? c)
         (list (make-error))
         null)     
     (if (exn:fail:contract? c)
         (list (make-assertion-violation))
         null)
     (if (exn:fail:r6rs? c)
         (append
          (if (exn:fail:r6rs-who c)
              (list (make-who-condition (exn:fail:r6rs-who c)))
              null)
          (list (make-irritants-condition (exn:fail:r6rs-irritants c))))
         null)
     (if (exn:fail:contract:r6rs? c)
         (append
          (if (exn:fail:contract:r6rs-who c)
              (list (make-who-condition (exn:fail:contract:r6rs-who c)))
              null)
          (list (make-irritants-condition (exn:fail:contract:r6rs-irritants c))))
         null)
     (list (make-non-continuable-violation))
     (if (or (exn:fail:unsupported? c)
             (exn:fail:contract:divide-by-zero? c))
         (list (make-implementation-restriction-violation))
         null)
     (if (exn:fail:read? c)
         (list (make-lexical-violation))
         null)
     (if (exn:fail:syntax? c)
         (let ([forms (exn:fail:syntax-exprs c)])
           (list (make-syntax-violation
                  (if (pair? forms)
                      (car forms)
                      #f)
                  (if (and (pair? forms)
                           (pair? (cdr forms)))
                      (cadr forms)
                      #f))))
         null)
     (if (exn:fail:contract:variable? c)
         (list (make-undefined-violation))
{'fraction_non_alphanumeric': 0.12524242114933143, 'fraction_numerical': 0.00275594569766255, 'mean_word_length': 2.0762951334379904, 'pattern_counts': {'":': 0, '<': 3, '<?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': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6788623', 'n_tokens_mistral': 3025, 'n_tokens_neox': 2917, 'n_words': 637}