<commit_before>;;; functions to construct residual code

(define (make-residual-apply fn fa)
  (cond
   ((and (pair? fa) (eq? (car fa) 'QUOTE) (eq? (cadr fa) '()))
    `(,fn))
   ((and (pair? fa) (eq? (car fa) 'LIST))
    `(,fn ,@(cdr fa)))
   (else
    `(APPLY ,fn ,fa))))

(define (make-residual-let var exp body)
  (cond
   ((and (pair? exp)			; kludge
	 (eq? (car exp) 'SET!))
    (if (and (pair? body) (eq? (car body) 'BEGIN))
	`(BEGIN ,exp ,@(cdr body))
	`(BEGIN ,exp ,body)))
   ((and (pair? body) (memq (car body) '(LET LET*)))
    (let ((header (cadr body))
	  (bodies (cddr body)))
      `(LET* ((,var ,exp) ,@header) ,@bodies)))
   ((and (pair? body) (eq? (car body) 'BEGIN))
    `(LET ((,var ,exp)) ,@(cdr body)))
   ((eq? var body)
    exp)
   (else
    `(LET ((,var ,exp)) ,body))))

(define make-residual-let-serious make-residual-let)
(define make-residual-let-trivial make-residual-let)

(define (make-residual-begin exp1 exp2)
  (if (and (pair? exp1) (not (eq? (car exp1) 'QUOTE)))
      (let ((exp2-begin (and (pair? exp2) (eq? (car exp2) 'BEGIN))))
	(cond
	 ((eq? (car exp1) 'BEGIN)
	  (if exp2-begin
	      `(BEGIN ,@(cdr exp1) ,@(cdr exp2))
	      `(BEGIN ,@(cdr exp1) ,exp2)))
	 (else
	  (if exp2-begin
	      `(BEGIN ,exp1 ,@(cdr exp2))
	      `(BEGIN ,exp1 ,exp2)))))
      exp2))

(define (make-residual-cons exp1 exp2)
  (if (pair? exp2)
      (let ((tag (car exp2)))
	(cond
	 ((and (eq? tag 'QUOTE) (eq? (cadr exp2) '()))
	  `(LIST ,exp1))
	 ((eq? tag 'LIST)
	  `(LIST ,exp1 ,@(cdr exp2)))
	 (else
	  `(CONS ,exp1 ,exp2))))
      `(CONS ,exp1 ,exp2)))

(define (make-residual-generator name lv . args)
  `(,name ,lv ,@args))

(define (make-residual-define-data lv arg)
  (let ((real-arg
	 (let loop ((arg arg))
	   (cond
	    ((and (pair? arg) (eq? (car arg) 'QUOTE))
	     (cadr arg))
	    ((and (pair? arg) (eq? (car arg) '_LIFT0))
	     (loop (caddr arg)))
	    ((and (pair? arg) (eq? (car arg) '_LIFT))
	     (loop (cadddr arg)))
	    (else
	     arg)))))
    (add-to-support-code! `(define-data ,@real-arg))
    (if (zero? lv)
	'pooof				;ignored
	`(_OP ,(- lv 1) _DEFINE_DATA ,arg))))

(define (make-residual-define-mutable lv var arg)
  (add-to-support-code! `(define ,var ,arg))
  (if (zero? lv)
      'pooof				;ignored
      `(_OP ,(- lv 1) _DEFINE ,var ,arg)))

(define (make-residual-if c t e)
  (cond
   ((eq? c #t)
    t)
   ((eq? c #f)
    e)
   ((and (pair? e) (eq? 'IF (car e)))
    `(COND
      (,c ,t)
      (,(cadr e) ,(caddr e))
      (else ,(cadddr e))))
   ((and (pair? e) (eq? 'COND (car e)))
    `(COND
      (,c ,t)
      ,@(cdr e)))
   (else<commit_msg>Great hacks to make residual code beautiful.<commit_after>;;; functions to construct residual code

(define (make-residual-apply fn fa)
  (cond
   ((and (pair? fa) (eq? (car fa) 'QUOTE) (eq? (cadr fa) '()))
    `(,fn))
   ((and (pair? fa) (eq? (car fa) 'LIST))
    `(,fn ,@(cdr fa)))
   (else
    `(APPLY ,fn ,fa))))

(define (make-residual-let var exp body)
  (cond
   ((and (pair? exp)			; kludge
	 (eq? (car exp) 'SET!))
    (if (and (pair? body) (eq? (car body) 'BEGIN))
	`(BEGIN ,exp ,@(cdr body))
	`(BEGIN ,exp ,body)))
   ((and (pair? body) (memq (car body) '(LET LET*)))
    (let ((header (cadr body))
	  (bodies (cddr body)))
      `(LET* ((,var ,exp) ,@header) ,@bodies)))
   ((and (pair? body) (eq? (car body) 'BEGIN))
    `(LET ((,var ,exp)) ,@(cdr body)))
   ((eq? var body)
    exp)
   (else
    `(LET ((,var ,exp)) ,body))))

(define make-residual-let-serious make-residual-let)
(define make-residual-let-trivial make-residual-let)

(define (make-residual-begin exp1 exp2)
  (if (and (pair? exp1) (not (eq? (car exp1) 'QUOTE)))
      (let ((exp2-begin (and (pair? exp2) (eq? (car exp2) 'BEGIN))))
	(cond
	 ((eq? (car exp1) 'BEGIN)
	  (if exp2-begin
	      `(BEGIN ,@(cdr exp1) ,@(cdr exp2))
	      `(BEGIN ,@(cdr exp1) ,exp2)))
	 (else
	  (if exp2-begin
	      `(BEGIN ,exp1 ,@(cdr exp2))
	      `(BEGIN ,exp1 ,exp2)))))
      exp2))

(define (make-residual-cons exp1 exp2)
  (if (pair? exp2)
      (let ((tag (car exp2)))
	(cond
	 ((and (eq? tag 'QUOTE) (eq? (cadr exp2) '()))
	  `(LIST ,exp1))
	 ((eq? tag 'LIST)
	  `(LIST ,exp1 ,@(cdr exp2)))
	 (else
	  `(CONS ,exp1 ,exp2))))
      `(CONS ,exp1 ,exp2)))

(define (make-residual-generator name lv . args)
  `(,name ,lv ,@args))

(define (make-residual-define-data lv arg)
  (let ((real-arg
	 (let loop ((arg arg))
	   (cond
	    ((and (pair? arg) (eq? (car arg) 'QUOTE))
	     (cadr arg))
	    ((and (pair? arg) (eq? (car arg) '_LIFT0))
	     (loop (caddr arg)))
	    ((and (pair? arg) (eq? (car arg) '_LIFT))
	     (loop (cadddr arg)))
	    (else
	     arg)))))
    (add-to-support-code! `(define-data ,@real-arg))
    (if (zero? lv)
	'pooof				;ignored
	`(_OP ,(- lv 1) _DEFINE_DATA ,arg))))

(define (make-residual-define-mutable lv var arg)
  (add-to-support-code! `(define ,var ,arg))
  (if (zero? lv)
      'pooof				;ignored
      `(_OP ,(- lv 1) _DEFINE ,var ,arg)))

(define (make-branch branch) 
  (let ((code (cadr branch)))
    (if (and (pair? code)
	     (eq? 'BEGIN (car code)))
	(cons (car branch)
	      (cdr code))
	branch)))

(define (constant-expression? exp)
  (cond
   ((boolean? exp) #t)
   ((number? exp) #t)
   ((char? exp) #t)
   ((string? exp) #t)
   ((and (pair? exp)
	 (eq? 'QUOTE (car exp)))
    #t)
   (else #f)))

(define (constant-expression-constant exp)
  (if (pair? exp)
      (cadr exp)
      exp))
   
(define (detect-constant-test test)
  (cond
   ((not (pair? test))
    #f)
   ((not (eq? 'EQV? (car test)))
    #f)
   ((constant-expression? (cadr test))
    (cons 
     (caddr test)
     (constant-expression-constant (cadr test))))
   ((constant-expression? (caddr test))
    (cons
     (cadr test)
     (constant-expression-constant (caddr test))))
   (else
    #f)))

(define (make-residual-if c t e)
  (cond
   ((eq? c #t)
    t)
   ((eq? c #f)
    e)
   ((detect-constant-test c)
    => (lambda (stuff)
	 (let ((exp (car stuff))
	       (constant (cdr stuff)))
	   (if (and (pair? e) (eq? 'CASE (car e))
		    (equal? (cadr e) exp))
	       `(CASE ,exp
		  ,(make-branch `((,constant) ,t))
		  ,@(cddr e))
	       `(CASE ,exp
		  ,(make-branch `((,constant) ,t))
		  (else ,e))))))
   ((and (pair? e) (eq? 'IF (car e)))
    `(COND
      ,(make-branch `(,c ,t))
      (,(cadr e) ,(caddr e))
      (else ,(cadddr e))))
   ((and (pair? e) (eq? 'COND (car e)))
     `(COND
       ,(make-branch `(,c ,t))
       ,@(cdr e)))
   (else
{'fraction_non_alphanumeric': 0.2234801488833747, 'fraction_numerical': 0.01054590570719603, 'mean_word_length': 2.7515997673065735, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 4, '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': '1502164', 'n_tokens_mistral': 2863, 'n_tokens_neox': 2712, 'n_words': 780}