<commit_before>(declare (usual-integrations))

(define (fol-shape? thing)
  ;; This will need to be updated when union types appear
  (or (null? thing)
      (and (symbol? thing)
           (memq thing '(real bool gensym)))
      (and (list? thing)
           (> (length thing) 0)
           (memq (car thing) '(cons vector values))
           (or (not (eq? 'cons (car thing)))
               (= 2 (length (cdr thing))))
           (every fol-shape? (cdr thing)))))

(define (check-program-types program)
  (define (empty-env) '())
  (define (augment-env env names shapes)
    (append (map list names shapes) env))
  (if (begin-form? program)
      (for-each
       (lambda (definition index)
         (if (not (definition? definition))
             (error "Non-definition a non-terminal program position" definition index))
         (if (not (= 4 (length definition)))
             (error "Malformed definition" definition index))
         (let ((formals (cadr definition))
               (types (caddr definition)))
           (if (not (list? formals))
               (error "Malformed formals list" definition index))
           (if (not (list? types))
               (error "Malformed type declaration" definition index))
           (if (not (= (length types) (+ 1 (length formals))))
               (error "Type declaration not parallel to formals list" definition index))
           (for-each
            (lambda (formal type sub-index)
              (if (not (and (list? type) (= 2 (length type))))
                  (error "Malformed type declaration" type definition index sub-index))
              (if (not (eq? formal (car type)))
                  (error "Type declaration for wrong formal parameter"
                         definition sub-index index))
              (if (not (fol-shape? (cadr type)))
                  (error "Type declaring a non-type" type definition index sub-index)))
            (cdr formals)
            (except-last-pair (cdr types))
            (iota (length (cdr formals))))))
       (except-last-pair (cdr program))
       (iota (- (length program) 2))))
  (let ((lookup-type (type-map program)))
    (define (check-entry-point expression)
      (check-expression-types expression (empty-env) lookup-type))
    (if (begin-form? program)
        (begin
          (for-each
           (lambda (definition index)
             (let ((formals (cadr definition))
                   (types (caddr definition))
                   (body (cadddr definition)))
               (let ((body-type
                      (check-expression-types
                       body
                       (augment-env (empty-env) (cdr formals)
                                    (arg-types (lookup-type (car formals))))
                       lookup-type)))
                 (if (not (equal? (car (last-pair types)) body-type))
                     (error "Return type declaration doesn't match" definition index body-type))
                 'done)
               'done))
           (except-last-pair (cdr program))
           (iota (- (length program) 2)))
          (check-entry-point (car (last-pair program))))
        (check-entry-point program))))

(define (check-expression-types expr env lookup-type)
  ;; A type environment maps every bound local name to its type.  The
  ;; lookup-type procedure returns the (function) type of any global
  ;; name passed to it.  CHECK-TYPE-CORRECT either returns the type of
  ;; the expression or signals an error if the expression is either
  ;; malformed or not type correct.
  (define (lookup-return-type thing)
    (return-type (lookup-type thing)))
  (define (lookup-arg-types thing)
    (arg-types (lookup-type thing)))
  ;; For this purpose, a VALUES is the same as any other construction,
  ;; but in other contexts they may need to be distinguished.
  (define (construction? expr)
    (and (pair? expr)<commit_msg>Slightly more informative error comment.<commit_after>(declare (usual-integrations))

(define (fol-shape? thing)
  ;; This will need to be updated when union types appear
  (or (null? thing)
      (and (symbol? thing)
           (memq thing '(real bool gensym)))
      (and (list? thing)
           (> (length thing) 0)
           (memq (car thing) '(cons vector values))
           (or (not (eq? 'cons (car thing)))
               (= 2 (length (cdr thing))))
           (every fol-shape? (cdr thing)))))

(define (check-program-types program)
  (define (empty-env) '())
  (define (augment-env env names shapes)
    (append (map list names shapes) env))
  (if (begin-form? program)
      (for-each
       (lambda (definition index)
         (if (not (definition? definition))
             (error "Non-definition a non-terminal program position" definition index))
         (if (not (= 4 (length definition)))
             (error "Malformed definition" definition index))
         (let ((formals (cadr definition))
               (types (caddr definition)))
           (if (not (list? formals))
               (error "Malformed formals list" definition index))
           (if (not (list? types))
               (error "Malformed type declaration" definition index))
           (if (not (= (length types) (+ 1 (length formals))))
               (error "Type declaration not parallel to formals list" definition index))
           (for-each
            (lambda (formal type sub-index)
              (if (not (and (list? type) (= 2 (length type))))
                  (error "Malformed type declaration" type definition index sub-index))
              (if (not (eq? formal (car type)))
                  (error "Type declaration for wrong formal parameter"
                         definition sub-index index))
              (if (not (fol-shape? (cadr type)))
                  (error "Type declaring a non-type" type definition index sub-index)))
            (cdr formals)
            (except-last-pair (cdr types))
            (iota (length (cdr formals))))))
       (except-last-pair (cdr program))
       (iota (- (length program) 2))))
  (let ((lookup-type (type-map program)))
    (define (check-entry-point expression)
      (check-expression-types expression (empty-env) lookup-type))
    (if (begin-form? program)
        (begin
          (for-each
           (lambda (definition index)
             (let ((formals (cadr definition))
                   (types (caddr definition))
                   (body (cadddr definition)))
               (let ((body-type
                      (check-expression-types
                       body
                       (augment-env (empty-env) (cdr formals)
                                    (arg-types (lookup-type (car formals))))
                       lookup-type)))
                 (if (not (equal? (car (last-pair types)) body-type))
                     (error "Return type declaration doesn't match"
                            definition index (car (last-pair types)) body-type))
                 'done)
               'done))
           (except-last-pair (cdr program))
           (iota (- (length program) 2)))
          (check-entry-point (car (last-pair program))))
        (check-entry-point program))))

(define (check-expression-types expr env lookup-type)
  ;; A type environment maps every bound local name to its type.  The
  ;; lookup-type procedure returns the (function) type of any global
  ;; name passed to it.  CHECK-TYPE-CORRECT either returns the type of
  ;; the expression or signals an error if the expression is either
  ;; malformed or not type correct.
  (define (lookup-return-type thing)
    (return-type (lookup-type thing)))
  (define (lookup-arg-types thing)
    (arg-types (lookup-type thing)))
  ;; For this purpose, a VALUES is the same as any other construction,
  ;; but in other contexts they may need to be distinguished.
  (define (construction? expr)
    (and (pair? expr)
{'fraction_non_alphanumeric': 0.11848643139253408, 'fraction_numerical': 0.0017836667091349217, 'mean_word_length': 1.9916158536585367, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5135388', 'n_tokens_mistral': 2123, 'n_tokens_neox': 2035, 'n_words': 752}