<commit_before>;;; binding-time analysis based on annotated type systems


;;; step 0
;;; the driver for the bta

(define *bta-max-bt* #f)

;;; debugging and trace aids
(define *bta-display-level* 1)
(define-syntax debug-level
  (syntax-rules ()
    ((_ level arg ...)
     (if (>= *bta-display-level* level)
	 (begin arg ...)))))

(define *bta-bt-points* '())
(define (bta-note-dynamic! ann)
  (set! *bta-bt-points* (cons (cons *bta-max-bt* ann) *bta-bt-points*)))
(define (bta-note-level! lv ann)
  (set! *bta-bt-points* (cons (cons lv ann) *bta-bt-points*)))

;;; binding-time analysis
;;; `d*' list of function definitions
;;; `symtab' is an initial symbol table where only constructors,
;;; selectors, and constructor tests are defined
;;; `skeleton' function call with arguments replaced by binding times
;;; `def-typesig*' is a list of type signatures of defined operations
;;; `def-opsig*' is a list of type signature of primitive operators
(define (bta-run d* symtab skeleton def-datatype* def-typesig* def-opsig*)
  (debug-level 1 (display "bta-run") (newline))
  (set! *bta-max-bt*
	(apply max (cdr skeleton)))
  (type->btann! the-top-type (make-ann))
  (set! *bta-bt-points* '())
  (bta-note-dynamic! (type->btann the-top-type))
  (let* ((goal-proc (car skeleton))
	 (bts (cdr skeleton))
	 (d (annDefLookup goal-proc d*))
	 (formals (annDefFetchProcFormals d))
	 (d0 (annMakeDef '$goal formals
			 (bta-insert-def-data def-datatype*
					      (annMakeCall goal-proc (map annMakeVar formals)))))
	 (d* (cons d0 d*))
	 (do-type-inference (full-collect-d* symtab d*))
	 (proc-node (full-ecr (annDefFetchProcBTVar d0)))
	 (proc-type (node-fetch-type proc-node))
	 (proc-type-tcargs (type-fetch-args proc-type))
	 (proc-type-args
	  (let loop ((node (car proc-type-tcargs)))
	    (let ((type (node-fetch-type (full-ecr node))))
	      (let ((args (type-fetch-args type))
		    (ctor (type-fetch-ctor type)))
		(if (equal? ctor ctor-product)
		    (cons (node-fetch-type (full-ecr (car args)))
			  (loop (cadr args)))
		    '())))))
	 (proc-type-result (full-ecr (cadr proc-type-tcargs)))<commit_msg>Hack for result bt 0.<commit_after>;;; binding-time analysis based on annotated type systems


;;; step 0
;;; the driver for the bta

(define *bta-max-bt* #f)

;;; debugging and trace aids
(define *bta-display-level* 1)
(define-syntax debug-level
  (syntax-rules ()
    ((_ level arg ...)
     (if (>= *bta-display-level* level)
	 (begin arg ...)))))

(define *bta-bt-points* '())
(define (bta-note-dynamic! ann)
  (set! *bta-bt-points* (cons (cons *bta-max-bt* ann) *bta-bt-points*)))
(define (bta-note-level! lv ann)
  (set! *bta-bt-points* (cons (cons lv ann) *bta-bt-points*)))

;;; binding-time analysis
;;; `d*' list of function definitions
;;; `symtab' is an initial symbol table where only constructors,
;;; selectors, and constructor tests are defined
;;; `skeleton' function call with arguments replaced by binding times
;;; `def-typesig*' is a list of type signatures of defined operations
;;; `def-opsig*' is a list of type signature of primitive operators
(define (bta-run d* symtab skeleton def-datatype* def-typesig* def-opsig*)
  (debug-level 1 (display "bta-run") (newline))
  (set! *bta-max-bt*
	(apply max (cdr skeleton)))
  (if (zero? *bta-max-bt*)
      (set! *bta-max-bt* 1))
  (type->btann! the-top-type (make-ann))
  (set! *bta-bt-points* '())
  (bta-note-dynamic! (type->btann the-top-type))
  (let* ((goal-proc (car skeleton))
	 (bts (cdr skeleton))
	 (d (annDefLookup goal-proc d*))
	 (formals (annDefFetchProcFormals d))
	 (d0 (annMakeDef '$goal formals
			 (bta-insert-def-data
			  def-datatype*
			  (scheme->abssyn-maybe-coerce
			   (annMakeCall goal-proc (map annMakeVar formals))))))
	 (d* (cons d0 d*))
	 (do-type-inference (full-collect-d* symtab d*))
	 (proc-node (full-ecr (annDefFetchProcBTVar d0)))
	 (proc-type (node-fetch-type proc-node))
	 (proc-type-tcargs (type-fetch-args proc-type))
	 (proc-type-args
	  (let loop ((node (car proc-type-tcargs)))
	    (let ((type (node-fetch-type (full-ecr node))))
	      (let ((args (type-fetch-args type))
		    (ctor (type-fetch-ctor type)))
		(if (equal? ctor ctor-product)
		    (cons (node-fetch-type (full-ecr (car args)))
			  (loop (cadr args)))
		    '())))))
	 (proc-type-result (full-ecr (cadr proc-type-tcargs)))
{'fraction_non_alphanumeric': 0.1805330243337196, 'fraction_numerical': 0.0032444959443800694, 'mean_word_length': 3.737650933040615, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 10, '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': '1728852', 'n_tokens_mistral': 1680, 'n_tokens_neox': 1576, 'n_words': 436}