<commit_before>;;; hygienic macros
(define-library (picrin macro)
  (import (scheme base))

  (define (sc-macro-transformer f)
    (lambda (expr use-env mac-env)
      (make-syntactic-closure mac-env '() (f expr use-env))))

  (define (rsc-macro-transformer f)
    (lambda (expr use-env mac-env)
      (make-syntactic-closure use-env '() (f expr mac-env))))

  (define (er-macro-transformer f)
    (lambda (expr use-env mac-env)
      (define (rename identifier)
        (make-syntactic-closure mac-env '() identifier))
      (define (compare x y)
        (identifier=? use-env x use-env y))
      (make-syntactic-closure use-env '() (f expr rename compare))))

  (define (walk f obj)
    (if (pair? obj)
        (cons (walk f (car obj))
              (walk f (cdr obj)))
        (f obj)))

  ;; experimental support
  (define (ir-macro-transformer f)
    (lambda (expr use-env mac-env)
      (define (inject identifier)
        (make-syntactic-closure use-env '() identifier))
      (define (compare x y)
        (identifier=? mac-env x mac-env y))
      (define renamed
        (walk (lambda (x) (if (symbol? x) (inject x) x)) expr))
      (make-syntactic-closure mac-env '() (f renamed inject compare))))

  (export sc-macro-transformer
          rsc-macro-transformer
          er-macro-transformer
          ir-macro-transformer))

;;; core syntaces
(define-library (picrin core-syntax)
  (import (scheme base)
          (picrin macro))

  (define (list . args) args)

  (define (caar p) (car (car p)))
  (define (cadr p) (car (cdr p)))
  (define (cdar p) (cdr (car p)))
  (define (cddr p) (cdr (cdr p)))
  (define (cadar p) (car (cdar p)))
  (define (caddr p) (car (cddr p)))
  (define (cdddr p) (cdr (cddr p)))

  (define (map f list)
    (if (null? list)
        list
        (cons (f (car list))
              (map f (cdr list)))))

  (define-syntax let
    (er-macro-transformer
     (lambda (expr r compare)
       (if (identifier? (cadr expr))
           (begin
             (define name (cadr expr))
             (define bindings (caddr expr))
             (define body (cdddr expr))
             (list (r 'let) '()
                   (list (r 'define) name
                         (cons (r 'lambda) (cons (map car bindings) body)))
                   (cons name (map cadr bindings))))
           (begin
             (define bindings (cadr expr))
             (define body (cddr expr))
             (cons (cons (r 'lambda) (cons (map car bindings) body))
                   (map cadr bindings)))))))

  (define-syntax cond
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((clauses (cdr expr)))
         (if (null? clauses)
             #f
             (list (r 'if) (caar clauses)
                   (cons (r 'begin) (cdar clauses))
                   (cons (r 'cond) (cdr clauses))))))))

  (define-syntax and
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((exprs (cdr expr)))
         (if (null? exprs)
             #t
             (list (r 'if) (car exprs)
                   (cons (r 'and) (cdr exprs))
                   #f))))))

  (define-syntax or
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((exprs (cdr expr)))
         (if (null? exprs)
             #f
             (list (r 'let) (list (list (r 'it) (car exprs)))
                   (list (r 'if) (r 'it)
                         (r 'it)
                         (cons (r 'or) (cdr exprs)))))))))

  (define (append xs ys)
    (if (null? xs)
        ys
        (cons (car xs)
              (append (cdr xs) ys))))

  (define-syntax quasiquote
    (er-macro-transformer
     (lambda (expr r compare?)
       (let ((x (cadr expr)))
         (cond
          ((symbol? x) (list (r 'quote) x)) ; should test with identifier?
          ((pair? x) (cond
                      ((compare? (r 'unquote) (car x))
                       (cadr x))
                      ((and (pair? (car x))
                            (compare? (r 'unquote-splicing) (caar x)))
                       (list (r 'append) (cadar x)
                             (list (r 'quasiquote) (cdr x))))
                      (#t
                       (list (r 'cons)
                             (list (r 'quasiquote) (car x))
                             (list (r 'quasiquote) (cdr x))))))
          (#t x))))))

  #;
  (define-syntax let*
    (ir-macro-transformer
     (lambda (form inject compare)
       (let ((bindings (cadr form))
             (body (cddr form)))
         (if (null? bindings)
             `(let () ,@body)
             `(let ((,(caar bindings)
                     ,@(cdar bindings)))
                (let* (,@(cdr bindings))
                  ,@body)))))))

  (define-syntax let*
    (er-macro-transformer
     (lambda (form r compare)
       (let ((bindings (cadr form))
             (body (cddr form)))
         (if (null? bindings)
             `(,(r 'let) () ,@body)
             `(,(r 'let) ((,(caar bindings)
                           ,@(cdar bindings)))
               (,(r 'let*) (,@(cdr bindings))
                ,@body)))))))

  (define-syntax letrec*
    (er-macro-transformer
     (lambda (form r compare)
       (let ((bindings (cadr form))
             (body (cddr form)))
         (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
               (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
           `(,(r 'let) (,@vars)
             ,@initials
             ,@body))))))

  (define-syntax letrec
    (er-macro-transformer
     (lambda (form rename compare)
       `(,(rename 'letrec*) ,@(cdr form)))))

  (define-syntax do
    (er-macro-transformer
     (lambda (form r compare)
       (let ((bindings (cadr form))
             (finish (caddr form))
             (body (cdddr form)))
         `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
                                        (list (car x) (cadr x)))
                                      bindings)
           (,(r 'if) ,(car finish)
            (,(r 'begin) ,@body
             (,(r 'loop) ,@(map (lambda (x)
                                  (if (null? (cddr x))
                                      (car x)
                                      (car (cddr x))))
                                bindings)))
            (,(r 'begin) ,@(cdr finish))))))))

  (define-syntax when
    (er-macro-transformer
     (lambda (expr rename compare)
       (let ((test (cadr expr))
             (body (cddr expr)))
         `(,(rename 'if) ,test
              (,(rename 'begin) ,@body)
              #f)))))

  (define-syntax unless
    (er-macro-transformer
     (lambda (expr rename compare)
       (let ((test (cadr expr))
             (body (cddr expr)))
         `(,(rename 'if) ,test
              #f
              (,(rename 'begin) ,@body))))))

  (define-syntax case
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((key (cadr expr))
             (clauses (cddr expr)))
         `(,(r 'let) ((,(r 'key) ,key))
            ,(let loop ((clauses clauses))
               (if (null? clauses)
                   #f
                   `(,(r 'if) (,(r 'or)
                               ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
                                      (caar clauses)))
                        (begin ,@(cdar clauses))
                        ,(loop (cdr clauses))))))))))

  (define-syntax syntax-error
    (er-macro-transformer
     (lambda (expr rename compare)
       (apply error (cdr expr)))))

  (define-syntax define-auxiliary-syntax
    (er-macro-transformer
     (lambda (expr r c)
       `(,(r 'define-syntax) ,(cadr expr)
          ,(r '(sc-macro-transformer
                (lambda (expr env)
                  (error "invalid use of auxiliary syntax"))))))))

  (define-auxiliary-syntax else)
  (define-auxiliary-syntax =>)
  (define-auxiliary-syntax _)
  (define-auxiliary-syntax ...)
  (define-auxiliary-syntax unquote)
  (define-auxiliary-syntax unquote-splicing)

  (export let let* letrec letrec*
          quasiquote unquote unquote-splicing
          and or
          cond case else =>
          do when unless
          _ ... syntax-error))


;;; multiple value
(define-library (picrin multiple-value)
  (import (scheme base)
          (picrin macro)
          (picrin core-syntax))

  (define *values-tag* (cons #f '()))

  (define (values . args)
    (if (and (pair? args)
             (null? (cdr args)))
        (car args)
        (cons *values-tag* args)))

  (define (call-with-values producer consumer)
    (let ((res (producer)))
      (if (and (pair? res)
               (eq? *values-tag* (car res)))
          (apply consumer (cdr res))
          (consumer res))))

  (define (cadr p) (car (cdr p)))
  (define (cddr p) (cdr (cdr p)))
  (define (cdar p) (cdr (car p)))
  (define (caar p) (car (car p)))

  (define (map f list)
    (if (null? list)
        list
        (cons (f (car list))
              (map f (cdr list)))))

  (define-syntax let*-values
    (er-macro-transformer
     (lambda (form r c)
       (let ((formals (cadr form)))
         (if (null? formals)
             `(,(r 'let) () ,@(cddr form))
             `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))
               (,(r 'lambda) (,@(caar formals))
                (,(r 'let*-values) (,@(cdr formals))
                 ,@(cddr form)))))))))

  (define-syntax let-values
    (er-macro-transformer
     (lambda (form r c)
       `(,(r 'let*-values) ,@(cdr form)))))

  (define-syntax define-values
    (er-macro-transformer
     (lambda (form r c)
       (let ((formals (cadr form)))
         `(,(r 'begin)
            ,@(do ((vars formals (cdr vars))
                   (defs '()))<commit_msg>gather utility functions which are necessary in bootstrap stage<commit_after>;;; hygienic macros
(define-library (picrin macro)
  (import (scheme base))

  (define (sc-macro-transformer f)
    (lambda (expr use-env mac-env)
      (make-syntactic-closure mac-env '() (f expr use-env))))

  (define (rsc-macro-transformer f)
    (lambda (expr use-env mac-env)
      (make-syntactic-closure use-env '() (f expr mac-env))))

  (define (er-macro-transformer f)
    (lambda (expr use-env mac-env)
      (define (rename identifier)
        (make-syntactic-closure mac-env '() identifier))
      (define (compare x y)
        (identifier=? use-env x use-env y))
      (make-syntactic-closure use-env '() (f expr rename compare))))

  (define (walk f obj)
    (if (pair? obj)
        (cons (walk f (car obj))
              (walk f (cdr obj)))
        (f obj)))

  ;; experimental support
  (define (ir-macro-transformer f)
    (lambda (expr use-env mac-env)
      (define (inject identifier)
        (make-syntactic-closure use-env '() identifier))
      (define (compare x y)
        (identifier=? mac-env x mac-env y))
      (define renamed
        (walk (lambda (x) (if (symbol? x) (inject x) x)) expr))
      (make-syntactic-closure mac-env '() (f renamed inject compare))))

  (export sc-macro-transformer
          rsc-macro-transformer
          er-macro-transformer
          ir-macro-transformer))

;;; bootstrap utilities
(define-library (picrin bootstrap-tools)
  (import (scheme base))

  (define (list . args) args)

  (define (caar p) (car (car p)))
  (define (cadr p) (car (cdr p)))
  (define (cdar p) (cdr (car p)))
  (define (cddr p) (cdr (cdr p)))
  (define (cadar p) (car (cdar p)))
  (define (caddr p) (car (cddr p)))
  (define (cdddr p) (cdr (cddr p)))

  (define (map f list)
    (if (null? list)
        list
        (cons (f (car list))
              (map f (cdr list)))))

  (define (append xs ys)
    (if (null? xs)
        ys
        (cons (car xs)
              (append (cdr xs) ys))))

  (export list map append
          caar cadr cdar cddr
          cadar caddr cdddr))

;;; core syntaces
(define-library (picrin core-syntax)
  (import (scheme base)
          (picrin macro)
          (picrin bootstrap-tools))

  (define-syntax let
    (er-macro-transformer
     (lambda (expr r compare)
       (if (identifier? (cadr expr))
           (begin
             (define name (cadr expr))
             (define bindings (caddr expr))
             (define body (cdddr expr))
             (list (r 'let) '()
                   (list (r 'define) name
                         (cons (r 'lambda) (cons (map car bindings) body)))
                   (cons name (map cadr bindings))))
           (begin
             (define bindings (cadr expr))
             (define body (cddr expr))
             (cons (cons (r 'lambda) (cons (map car bindings) body))
                   (map cadr bindings)))))))

  (define-syntax cond
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((clauses (cdr expr)))
         (if (null? clauses)
             #f
             (list (r 'if) (caar clauses)
                   (cons (r 'begin) (cdar clauses))
                   (cons (r 'cond) (cdr clauses))))))))

  (define-syntax and
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((exprs (cdr expr)))
         (if (null? exprs)
             #t
             (list (r 'if) (car exprs)
                   (cons (r 'and) (cdr exprs))
                   #f))))))

  (define-syntax or
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((exprs (cdr expr)))
         (if (null? exprs)
             #f
             (list (r 'let) (list (list (r 'it) (car exprs)))
                   (list (r 'if) (r 'it)
                         (r 'it)
                         (cons (r 'or) (cdr exprs)))))))))

  (define-syntax quasiquote
    (er-macro-transformer
     (lambda (expr r compare?)
       (let ((x (cadr expr)))
         (cond
          ((symbol? x) (list (r 'quote) x)) ; should test with identifier?
          ((pair? x) (cond
                      ((compare? (r 'unquote) (car x))
                       (cadr x))
                      ((and (pair? (car x))
                            (compare? (r 'unquote-splicing) (caar x)))
                       (list (r 'append) (cadar x)
                             (list (r 'quasiquote) (cdr x))))
                      (#t
                       (list (r 'cons)
                             (list (r 'quasiquote) (car x))
                             (list (r 'quasiquote) (cdr x))))))
          (#t x))))))

  #;
  (define-syntax let*
    (ir-macro-transformer
     (lambda (form inject compare)
       (let ((bindings (cadr form))
             (body (cddr form)))
         (if (null? bindings)
             `(let () ,@body)
             `(let ((,(caar bindings)
                     ,@(cdar bindings)))
                (let* (,@(cdr bindings))
                  ,@body)))))))

  (define-syntax let*
    (er-macro-transformer
     (lambda (form r compare)
       (let ((bindings (cadr form))
             (body (cddr form)))
         (if (null? bindings)
             `(,(r 'let) () ,@body)
             `(,(r 'let) ((,(caar bindings)
                           ,@(cdar bindings)))
               (,(r 'let*) (,@(cdr bindings))
                ,@body)))))))

  (define-syntax letrec*
    (er-macro-transformer
     (lambda (form r compare)
       (let ((bindings (cadr form))
             (body (cddr form)))
         (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
               (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
           `(,(r 'let) (,@vars)
             ,@initials
             ,@body))))))

  (define-syntax letrec
    (er-macro-transformer
     (lambda (form rename compare)
       `(,(rename 'letrec*) ,@(cdr form)))))

  (define-syntax do
    (er-macro-transformer
     (lambda (form r compare)
       (let ((bindings (cadr form))
             (finish (caddr form))
             (body (cdddr form)))
         `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
                                        (list (car x) (cadr x)))
                                      bindings)
           (,(r 'if) ,(car finish)
            (,(r 'begin) ,@body
             (,(r 'loop) ,@(map (lambda (x)
                                  (if (null? (cddr x))
                                      (car x)
                                      (car (cddr x))))
                                bindings)))
            (,(r 'begin) ,@(cdr finish))))))))

  (define-syntax when
    (er-macro-transformer
     (lambda (expr rename compare)
       (let ((test (cadr expr))
             (body (cddr expr)))
         `(,(rename 'if) ,test
              (,(rename 'begin) ,@body)
              #f)))))

  (define-syntax unless
    (er-macro-transformer
     (lambda (expr rename compare)
       (let ((test (cadr expr))
             (body (cddr expr)))
         `(,(rename 'if) ,test
              #f
              (,(rename 'begin) ,@body))))))

  (define-syntax case
    (er-macro-transformer
     (lambda (expr r compare)
       (let ((key (cadr expr))
             (clauses (cddr expr)))
         `(,(r 'let) ((,(r 'key) ,key))
            ,(let loop ((clauses clauses))
               (if (null? clauses)
                   #f
                   `(,(r 'if) (,(r 'or)
                               ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
                                      (caar clauses)))
                        (begin ,@(cdar clauses))
                        ,(loop (cdr clauses))))))))))

  (define-syntax syntax-error
    (er-macro-transformer
     (lambda (expr rename compare)
       (apply error (cdr expr)))))

  (define-syntax define-auxiliary-syntax
    (er-macro-transformer
     (lambda (expr r c)
       `(,(r 'define-syntax) ,(cadr expr)
          ,(r '(sc-macro-transformer
                (lambda (expr env)
                  (error "invalid use of auxiliary syntax"))))))))

  (define-auxiliary-syntax else)
  (define-auxiliary-syntax =>)
  (define-auxiliary-syntax _)
  (define-auxiliary-syntax ...)
  (define-auxiliary-syntax unquote)
  (define-auxiliary-syntax unquote-splicing)

  (export let let* letrec letrec*
          quasiquote unquote unquote-splicing
          and or
          cond case else =>
          do when unless
          _ ... syntax-error))


;;; multiple value
(define-library (picrin multiple-value)
  (import (scheme base)
          (picrin macro)
          (picrin core-syntax)
          (picrin bootstrap-tools))

  (define *values-tag* (cons #f '()))

  (define (values . args)
    (if (and (pair? args)
             (null? (cdr args)))
        (car args)
        (cons *values-tag* args)))

  (define (call-with-values producer consumer)
    (let ((res (producer)))
      (if (and (pair? res)
               (eq? *values-tag* (car res)))
          (apply consumer (cdr res))
          (consumer res))))

  (define-syntax let*-values
    (er-macro-transformer
     (lambda (form r c)
       (let ((formals (cadr form)))
         (if (null? formals)
             `(,(r 'let) () ,@(cddr form))
             `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))
               (,(r 'lambda) (,@(caar formals))
                (,(r 'let*-values) (,@(cdr formals))
                 ,@(cddr form)))))))))

  (define-syntax let-values
    (er-macro-transformer
     (lambda (form r c)
       `(,(r 'let*-values) ,@(cdr form)))))

  (define-syntax define-values
    (er-macro-transformer
     (lambda (form r c)
       (let ((formals (cadr form)))
         `(,(r 'begin)
            ,@(do ((vars formals (cdr vars))
                   (defs '()))
{'fraction_non_alphanumeric': 0.15877437325905291, 'fraction_numerical': 0.0, 'mean_word_length': 1.5928848468637153, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 7, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 14, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1635667', 'n_tokens_mistral': 6417, 'n_tokens_neox': 6068, 'n_words': 1803}