<commit_before>;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT 
;; Scheme.
;; Copyright (C) 2007 <NAME>

;; Released under the same terms as the SRFI reference implementation.

;; Parts of this file are based on SLIB "array.scm" Arrays for Scheme.
;; Copyright (C) 2001, 2003, 2005, 2006 <NAME>

(module |63| mzscheme
  
  (require (lib "4.ss" "srfi")
           (lib "contract.ss"))
  
  (define-syntax make-cvector
    (syntax-rules ()
      ((_ make-fvector)
       (case-lambda
         ((n)
          (cons (make-fvector n)
                (make-fvector n)))
         ((n fill)
          (cons (make-fvector n (real-part fill))
                (make-fvector n (imag-part fill))))))))
  (define-syntax cvector-ref
    (syntax-rules ()
      ((_ fvector-ref)
       (lambda (v n)
         (make-rectangular (fvector-ref (car v) n)
                           (fvector-ref (cdr v) n))))))
  (define-syntax cvector-set!
    (syntax-rules ()
      ((_ fvector-set!)
       (lambda (v n z)
         (fvector-set! (car v) n (real-part z))
         (fvector-set! (cdr v) n (imag-part z))))))
  
  (define make-c64vector
    (make-cvector make-f64vector))
  (define c64vector-ref
    (cvector-ref f64vector-ref))
  (define c64vector-set!
    (cvector-set! f64vector-set!))
  (define make-c32vector
    (make-cvector make-f32vector))
  (define c32vector-ref
    (cvector-ref f32vector-ref))
  (define c32vector-set!
    (cvector-set! f32vector-set!))
  
  (define (make-floc/c _) complex?)
  (define (make-flor/c _) real?)
  (define (make-fix/c n signed?)
    (and/c exact?
           (if signed?
               (let ((x (arithmetic-shift 1 (sub1 n))))
                 (integer-in (- x) (sub1 x)))
               (integer-in 0 (sub1 (arithmetic-shift 1 n))))))
  
  (define implementations
    (let ((table
           (make-immutable-hash-table
            (list (list 'char     make-string    string-ref    string-set!    char?)
                  (list 'byte     make-bytes     bytes-ref     bytes-set!     byte?)
                  (list 'vector   make-vector    vector-ref    vector-set!    any/c)
                  (list 'bool     make-vector    vector-ref    vector-set!    boolean?)
                  (list 'floC64b  make-c64vector c64vector-ref c64vector-set! (make-floc/c 64))
                  (list 'floC32b  make-c32vector c32vector-ref c32vector-set! (make-floc/c 32))
                  (list 'floR64b  make-f64vector f64vector-ref f64vector-set! (make-flor/c 64))
                  (list 'floR32b  make-f32vector f32vector-ref f32vector-set! (make-flor/c 32))
                  (list 'fixZ64b  make-s64vector s64vector-ref s64vector-set! (make-fix/c 64 #t))
                  (list 'fixZ32b  make-s32vector s32vector-ref s32vector-set! (make-fix/c 32 #t))
                  (list 'fixZ16b  make-s16vector s16vector-ref s16vector-set! (make-fix/c 16 #t))
                  (list 'fixZ8b   make-s8vector  s8vector-ref  s8vector-set!  (make-fix/c  8 #t))
                  (list 'fixN64b  make-u64vector u64vector-ref u64vector-set! (make-fix/c 64 #f))
                  (list 'fixN32b  make-u32vector u32vector-ref u32vector-set! (make-fix/c 32 #f))
                  (list 'fixN16b  make-u16vector u16vector-ref u16vector-set! (make-fix/c 16 #f))
                  (list 'fixN8b   make-u8vector  u8vector-ref  u8vector-set!  (make-fix/c  8 #f))))))
      (lambda (type pos)
        (list-ref (hash-table-get table type) pos))))
  
  (define (array-print array port write?)
    (display "#" port)
    (display (length (my-array-ref array 0)) port)
    (display "A" port)
    (let ((type (my-array-ref array 4)))
      (unless (eq? type 'vector)
        (display ":" port)
        (display type port)))
    (display (array->list array) port))
  
  (define-values (struct:array my-make-array my-array? my-array-ref my-array-set!)
    (make-struct-type 'array #f 5 0 #f
                      (list (cons prop:custom-write array-print))
                      #f))
  
  (define (array-dimensions array)
    (cond ((vector? array) (list (vector-length array)))
          ((string? array) (list (string-length array)))
          ((bytes? array) (list (bytes-length array)))
          (else (my-array-ref array 0))))
  (define (array-scales obj)
    (if (or (string? obj)
            (bytes? obj)
            (vector? obj))
        '(1)
        (my-array-ref obj 1)))
  (define (array-offset obj)
    (if (or (string? obj)
            (bytes? obj)
            (vector? obj))
        0
        (my-array-ref obj 2)))
  (define (array-store obj)
    (if (or (string? obj)
            (bytes? obj)
            (vector? obj))
        obj
        (my-array-ref obj 3)))
  (define (array-store-type obj)
    (cond ((string? obj) 'char)
          ((bytes? obj)  'byte)
          ((vector? obj) 'vector)
          (else (my-array-ref obj 4))))
  
  (define (array-store-maker array-type)
    (implementations array-type 0))
  (define (array-store-ref array)
    (implementations (array-store-type array) 1))
  (define (array-store-set array)
    (implementations (array-store-type array) 2))
  
  (define (array? obj)
    (or (string? obj)
        (bytes? obj)
        (vector? obj)
        (my-array? obj)))
  
  (define (s:equal? obj1 obj2)
    (or (equal? obj1 obj2)
        (and (box? obj1)
             (box? obj2)
             (s:equal? (unbox obj1)
                       (unbox obj2)))
        (and (pair? obj1)
             (pair? obj2)
             (s:equal? (car obj1) (car obj2))
             (s:equal? (cdr obj1) (cdr obj2)))
        (and (vector? obj1)
             (vector? obj2)
             (equal? (vector-length obj1) (vector-length obj2))
             (let lp ((idx (sub1 (vector-length obj1))))
               (or (negative? idx)
                   (and (s:equal? (vector-ref obj1 idx)
                                  (vector-ref obj2 idx))
                        (lp (sub1 idx))))))
          ((my-array? obj1)                
           (and (array? obj2)
                (equal? (array-dimensions obj1) (array-dimensions obj2))
                (s:equal? (array->vector obj1) (array->vector obj2))))
          ((struct? obj1)
           (and (struct? obj2)
                (let-values (((obj1-type obj1-skipped?)
                              (struct-info obj1))
                             ((obj2-type obj2-skipped?)
                              (struct-info obj2)))
                  (and (eq? obj1-type obj2-type)
                       (not obj1-skipped?)
                       (not obj2-skipped?)
                       (s:equal? (struct->vector obj1)
                                 (struct->vector obj2))))))
          (else #f)))
  
  (define (array-rank obj)
    (if (array? obj) (length (array-dimensions obj)) 0))
  
  (define (make-array prototype . dimensions)
    (let ((prot    (array-store prototype))
          (pdims   (array-dimensions prototype))
          (onedim? (eqv? 1 (length dimensions)))
          (tcnt    (apply * dimensions)))    
      (let ((initializer
             (if (zero? (apply * pdims)) '()
                 (list      ;; a list with single element at origin
                  (apply array-ref prototype
                         (map (lambda (x) 0) pdims))))))    
        
        (cond ((and onedim? (string? prot))
               (apply make-string (car dimensions) initializer))
              ((and onedim? (vector? prot))
               (apply make-vector (car dimensions) initializer))            
              (else
               (let* ((store-type (array-store-type prototype))
                      (store (apply (array-store-maker store-type)
                                    tcnt initializer)))
                 (let loop ((dims (reverse dimensions)) (scales '(1)))
                   (if (null? dims)
                       (my-make-array dimensions (cdr scales) 0 
                                      store<commit_msg>add a cond (the indentation suggests that it used to be there) to make 63.ss file compile<commit_after>;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT 
;; Scheme.
;; Copyright (C) 2007 <NAME>

;; Released under the same terms as the SRFI reference implementation.

;; Parts of this file are based on SLIB "array.scm" Arrays for Scheme.
;; Copyright (C) 2001, 2003, 2005, 2006 <NAME>

(module |63| mzscheme
  
  (require (lib "4.ss" "srfi")
           (lib "contract.ss"))
  
  (define-syntax make-cvector
    (syntax-rules ()
      ((_ make-fvector)
       (case-lambda
         ((n)
          (cons (make-fvector n)
                (make-fvector n)))
         ((n fill)
          (cons (make-fvector n (real-part fill))
                (make-fvector n (imag-part fill))))))))
  (define-syntax cvector-ref
    (syntax-rules ()
      ((_ fvector-ref)
       (lambda (v n)
         (make-rectangular (fvector-ref (car v) n)
                           (fvector-ref (cdr v) n))))))
  (define-syntax cvector-set!
    (syntax-rules ()
      ((_ fvector-set!)
       (lambda (v n z)
         (fvector-set! (car v) n (real-part z))
         (fvector-set! (cdr v) n (imag-part z))))))
  
  (define make-c64vector
    (make-cvector make-f64vector))
  (define c64vector-ref
    (cvector-ref f64vector-ref))
  (define c64vector-set!
    (cvector-set! f64vector-set!))
  (define make-c32vector
    (make-cvector make-f32vector))
  (define c32vector-ref
    (cvector-ref f32vector-ref))
  (define c32vector-set!
    (cvector-set! f32vector-set!))
  
  (define (make-floc/c _) complex?)
  (define (make-flor/c _) real?)
  (define (make-fix/c n signed?)
    (and/c exact?
           (if signed?
               (let ((x (arithmetic-shift 1 (sub1 n))))
                 (integer-in (- x) (sub1 x)))
               (integer-in 0 (sub1 (arithmetic-shift 1 n))))))
  
  (define implementations
    (let ((table
           (make-immutable-hash-table
            (list (list 'char     make-string    string-ref    string-set!    char?)
                  (list 'byte     make-bytes     bytes-ref     bytes-set!     byte?)
                  (list 'vector   make-vector    vector-ref    vector-set!    any/c)
                  (list 'bool     make-vector    vector-ref    vector-set!    boolean?)
                  (list 'floC64b  make-c64vector c64vector-ref c64vector-set! (make-floc/c 64))
                  (list 'floC32b  make-c32vector c32vector-ref c32vector-set! (make-floc/c 32))
                  (list 'floR64b  make-f64vector f64vector-ref f64vector-set! (make-flor/c 64))
                  (list 'floR32b  make-f32vector f32vector-ref f32vector-set! (make-flor/c 32))
                  (list 'fixZ64b  make-s64vector s64vector-ref s64vector-set! (make-fix/c 64 #t))
                  (list 'fixZ32b  make-s32vector s32vector-ref s32vector-set! (make-fix/c 32 #t))
                  (list 'fixZ16b  make-s16vector s16vector-ref s16vector-set! (make-fix/c 16 #t))
                  (list 'fixZ8b   make-s8vector  s8vector-ref  s8vector-set!  (make-fix/c  8 #t))
                  (list 'fixN64b  make-u64vector u64vector-ref u64vector-set! (make-fix/c 64 #f))
                  (list 'fixN32b  make-u32vector u32vector-ref u32vector-set! (make-fix/c 32 #f))
                  (list 'fixN16b  make-u16vector u16vector-ref u16vector-set! (make-fix/c 16 #f))
                  (list 'fixN8b   make-u8vector  u8vector-ref  u8vector-set!  (make-fix/c  8 #f))))))
      (lambda (type pos)
        (list-ref (hash-table-get table type) pos))))
  
  (define (array-print array port write?)
    (display "#" port)
    (display (length (my-array-ref array 0)) port)
    (display "A" port)
    (let ((type (my-array-ref array 4)))
      (unless (eq? type 'vector)
        (display ":" port)
        (display type port)))
    (display (array->list array) port))
  
  (define-values (struct:array my-make-array my-array? my-array-ref my-array-set!)
    (make-struct-type 'array #f 5 0 #f
                      (list (cons prop:custom-write array-print))
                      #f))
  
  (define (array-dimensions array)
    (cond ((vector? array) (list (vector-length array)))
          ((string? array) (list (string-length array)))
          ((bytes? array) (list (bytes-length array)))
          (else (my-array-ref array 0))))
  (define (array-scales obj)
    (if (or (string? obj)
            (bytes? obj)
            (vector? obj))
        '(1)
        (my-array-ref obj 1)))
  (define (array-offset obj)
    (if (or (string? obj)
            (bytes? obj)
            (vector? obj))
        0
        (my-array-ref obj 2)))
  (define (array-store obj)
    (if (or (string? obj)
            (bytes? obj)
            (vector? obj))
        obj
        (my-array-ref obj 3)))
  (define (array-store-type obj)
    (cond ((string? obj) 'char)
          ((bytes? obj)  'byte)
          ((vector? obj) 'vector)
          (else (my-array-ref obj 4))))
  
  (define (array-store-maker array-type)
    (implementations array-type 0))
  (define (array-store-ref array)
    (implementations (array-store-type array) 1))
  (define (array-store-set array)
    (implementations (array-store-type array) 2))
  
  (define (array? obj)
    (or (string? obj)
        (bytes? obj)
        (vector? obj)
        (my-array? obj)))
  
  (define (s:equal? obj1 obj2)
    (or (equal? obj1 obj2)
        (and (box? obj1)
             (box? obj2)
             (s:equal? (unbox obj1)
                       (unbox obj2)))
        (and (pair? obj1)
             (pair? obj2)
             (s:equal? (car obj1) (car obj2))
             (s:equal? (cdr obj1) (cdr obj2)))
        (and (vector? obj1)
             (vector? obj2)
             (equal? (vector-length obj1) (vector-length obj2))
             (let lp ((idx (sub1 (vector-length obj1))))
               (or (negative? idx)
                   (and (s:equal? (vector-ref obj1 idx)
                                  (vector-ref obj2 idx))
                        (lp (sub1 idx))))))
        (cond
          ((my-array? obj1)                
           (and (array? obj2)
                (equal? (array-dimensions obj1) (array-dimensions obj2))
                (s:equal? (array->vector obj1) (array->vector obj2))))
          ((struct? obj1)
           (and (struct? obj2)
                (let-values (((obj1-type obj1-skipped?)
                              (struct-info obj1))
                             ((obj2-type obj2-skipped?)
                              (struct-info obj2)))
                  (and (eq? obj1-type obj2-type)
                       (not obj1-skipped?)
                       (not obj2-skipped?)
                       (s:equal? (struct->vector obj1)
                                 (struct->vector obj2))))))
          (else #f))))
  
  (define (array-rank obj)
    (if (array? obj) (length (array-dimensions obj)) 0))
  
  (define (make-array prototype . dimensions)
    (let ((prot    (array-store prototype))
          (pdims   (array-dimensions prototype))
          (onedim? (eqv? 1 (length dimensions)))
          (tcnt    (apply * dimensions)))    
      (let ((initializer
             (if (zero? (apply * pdims)) '()
                 (list      ;; a list with single element at origin
                  (apply array-ref prototype
                         (map (lambda (x) 0) pdims))))))    
        
        (cond ((and onedim? (string? prot))
               (apply make-string (car dimensions) initializer))
              ((and onedim? (vector? prot))
               (apply make-vector (car dimensions) initializer))            
              (else
               (let* ((store-type (array-store-type prototype))
                      (store (apply (array-store-maker store-type)
                                    tcnt initializer)))
                 (let loop ((dims (reverse dimensions)) (scales '(1)))
                   (if (null? dims)
                       (my-make-array dimensions (cdr scales) 0 
                                      store
{'fraction_non_alphanumeric': 0.1369252963683121, 'fraction_numerical': 0.028601894248259423, 'mean_word_length': 1.667558976074954, 'pattern_counts': {'":': 2, '<': 7, '<?xml version=': 0, '>': 17, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 10, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2844746', 'n_tokens_mistral': 5380, 'n_tokens_neox': 5047, 'n_words': 1352}