<commit_before>;;;; Copyright (c) 2011-2016 <NAME> <<EMAIL>>
;;;; This code is licensed under the MIT license.

;;;; type.lisp - Type management.

(in-package :sys.int)

(defmacro deftype (name lambda-list &body body)
  (let ((whole (gensym "WHOLE"))
        (env (gensym "ENV")))
    (multiple-value-bind (new-lambda-list env-binding)
        (fix-lambda-list-environment lambda-list)
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         (%deftype ',name
                   (lambda (,whole ,env)
                     (declare (lambda-name (deftype ,name))
                              (ignorable ,whole ,env))
                     ,(expand-destructuring-lambda-list new-lambda-list name body
                                                        whole `(cdr ,whole)
                                                        (when env-binding
                                                          (list `(,env-binding ,env)))
                                                        :default-value ''*
                                                        :permit-docstring t)))
         ',name))))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %deftype (name expander)
  (setf (get name 'type-expander) expander))
(defun %define-compound-type (name function)
  (setf (get name 'compound-type) function))
(defun %define-compound-type-optimizer (name function)
  (setf (get name 'compound-type-optimizer) function))
(defun %define-type-symbol (name function)
  (setf (get name 'type-symbol) function))
)

(deftype bit ()
  '(integer 0 1))

(deftype unsigned-byte (&optional s)
  (cond ((eql s '*)
         `(integer 0))
        (t (unless (and (integerp s) (plusp s))
             (error 'type-error :expected-type '(integer 1) :datum s))
           `(integer 0 ,(1- (expt 2 s))))))

(deftype signed-byte (&optional s)
  (cond ((eql s '*)
         'integer)
        (t (unless (and (integerp s) (plusp s))
             (error 'type-error :expected-type '(integer 1) :datum s))
           `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s)))))))

(deftype mod (n)
  (unless (and (integerp n) (plusp n))
    (error 'type-error :expected-type '(integer 1) :datum n))
  `(integer 0 (,n)))

(deftype short-float ()
  'single-float)
(deftype long-float ()
  'double-float)

(deftype fixnum ()
  `(integer ,most-negative-fixnum ,most-positive-fixnum))

(deftype bignum ()
  `(and integer (not fixnum)))

(deftype positive-fixnum ()
  `(integer 1 ,most-positive-fixnum))

(deftype non-negative-fixnum ()
  `(integer 0 ,most-positive-fixnum))

(deftype negative-fixnum ()
  `(integer ,most-negative-fixnum -1))

(deftype non-positive-fixnum ()
  `(integer ,most-negative-fixnum 0))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun typeexpand-1 (type &optional environment)
  (when (not (or (symbolp type)
                 (listp type)))
    (return-from typeexpand-1 (values type nil)))
  (let ((expander (get (if (symbolp type)
                           type
                           (first type))
                       'type-expander)))
    (cond (expander
           (when (symbolp type)
             (setf type (list type)))
           (values (funcall expander type environment) t))
          ((and (consp type)
                (member (first type) '(array simple-array))
                (second type))
           (multiple-value-bind (expanded-inner expandedp)
               (typeexpand (second type) environment)
             (if expandedp
                 (values (list* (first type)
                                expanded-inner
                                (cddr type))
                         t)
                 (values type nil))))
          ((or (eql type 'complex)
               (and (consp type)
                    (eql (first type) 'complex)
                    (or (null (rest type))
                        (eql (second type) '*))))
           '(or (complex rational)
                (complex single-float)
                (complex double-float)))
          (t (values type nil)))))

(defun typeexpand (type &optional environment)
  (do ((have-expanded nil)) (nil)
    (multiple-value-bind (expansion expanded-p)
        (typeexpand-1 type environment)
      (unless expanded-p
        (return (values expansion have-expanded)))
      (setf have-expanded t
            type expansion))))
)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun canonicalize-real-type (type name)
  (if (consp type)
      (destructuring-bind (&optional (min '*) (max '*))
          (cdr type)
        (when (consp min)
          (when (rest min)
            (error "Bad ~S type: ~S." name type))
          (setf min (1- (first min))))
        (unless (or (eql min '*) (typep min name))
          (error "Bad ~S type: ~S." name type))
        (when (consp max)
          (when (rest max)
            (error "Bad ~S type: ~S." name type))
          (setf max (1- (first max))))
        (unless (or (eql max '*) (typep min name))
          (error "Bad ~S type: ~S." name type))
        (values min max))
      (values '* '*)))
)

(defun satisfies-type-p (object type)
  (destructuring-bind (function) (cdr type)
    (funcall function object)))

(%define-compound-type 'satisfies 'satisfies-type-p)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun compile-satisfies-type (object type)
  (destructuring-bind (predicate-name) (rest type)
    `(,predicate-name ,object)))
(%define-compound-type-optimizer 'satisfies 'compile-satisfies-type)
)

(defun integer-type-p (object type)
  (multiple-value-bind (min max)
      (canonicalize-real-type type 'integer)
    (and (integerp object)
         (or (eql min '*)
             (>= object min))<commit_msg>Fix numeric types with an upper bound and no lower bound.<commit_after>;;;; Copyright (c) 2011-2016 <NAME> <<EMAIL>>
;;;; This code is licensed under the MIT license.

;;;; type.lisp - Type management.

(in-package :sys.int)

(defmacro deftype (name lambda-list &body body)
  (let ((whole (gensym "WHOLE"))
        (env (gensym "ENV")))
    (multiple-value-bind (new-lambda-list env-binding)
        (fix-lambda-list-environment lambda-list)
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         (%deftype ',name
                   (lambda (,whole ,env)
                     (declare (lambda-name (deftype ,name))
                              (ignorable ,whole ,env))
                     ,(expand-destructuring-lambda-list new-lambda-list name body
                                                        whole `(cdr ,whole)
                                                        (when env-binding
                                                          (list `(,env-binding ,env)))
                                                        :default-value ''*
                                                        :permit-docstring t)))
         ',name))))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %deftype (name expander)
  (setf (get name 'type-expander) expander))
(defun %define-compound-type (name function)
  (setf (get name 'compound-type) function))
(defun %define-compound-type-optimizer (name function)
  (setf (get name 'compound-type-optimizer) function))
(defun %define-type-symbol (name function)
  (setf (get name 'type-symbol) function))
)

(deftype bit ()
  '(integer 0 1))

(deftype unsigned-byte (&optional s)
  (cond ((eql s '*)
         `(integer 0))
        (t (unless (and (integerp s) (plusp s))
             (error 'type-error :expected-type '(integer 1) :datum s))
           `(integer 0 ,(1- (expt 2 s))))))

(deftype signed-byte (&optional s)
  (cond ((eql s '*)
         'integer)
        (t (unless (and (integerp s) (plusp s))
             (error 'type-error :expected-type '(integer 1) :datum s))
           `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s)))))))

(deftype mod (n)
  (unless (and (integerp n) (plusp n))
    (error 'type-error :expected-type '(integer 1) :datum n))
  `(integer 0 (,n)))

(deftype short-float ()
  'single-float)
(deftype long-float ()
  'double-float)

(deftype fixnum ()
  `(integer ,most-negative-fixnum ,most-positive-fixnum))

(deftype bignum ()
  `(and integer (not fixnum)))

(deftype positive-fixnum ()
  `(integer 1 ,most-positive-fixnum))

(deftype non-negative-fixnum ()
  `(integer 0 ,most-positive-fixnum))

(deftype negative-fixnum ()
  `(integer ,most-negative-fixnum -1))

(deftype non-positive-fixnum ()
  `(integer ,most-negative-fixnum 0))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun typeexpand-1 (type &optional environment)
  (when (not (or (symbolp type)
                 (listp type)))
    (return-from typeexpand-1 (values type nil)))
  (let ((expander (get (if (symbolp type)
                           type
                           (first type))
                       'type-expander)))
    (cond (expander
           (when (symbolp type)
             (setf type (list type)))
           (values (funcall expander type environment) t))
          ((and (consp type)
                (member (first type) '(array simple-array))
                (second type))
           (multiple-value-bind (expanded-inner expandedp)
               (typeexpand (second type) environment)
             (if expandedp
                 (values (list* (first type)
                                expanded-inner
                                (cddr type))
                         t)
                 (values type nil))))
          ((or (eql type 'complex)
               (and (consp type)
                    (eql (first type) 'complex)
                    (or (null (rest type))
                        (eql (second type) '*))))
           '(or (complex rational)
                (complex single-float)
                (complex double-float)))
          (t (values type nil)))))

(defun typeexpand (type &optional environment)
  (do ((have-expanded nil)) (nil)
    (multiple-value-bind (expansion expanded-p)
        (typeexpand-1 type environment)
      (unless expanded-p
        (return (values expansion have-expanded)))
      (setf have-expanded t
            type expansion))))
)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun canonicalize-real-type (type name)
  (if (consp type)
      (destructuring-bind (&optional (min '*) (max '*))
          (cdr type)
        (when (consp min)
          (when (rest min)
            (error "Bad ~S type: ~S." name type))
          (setf min (1- (first min))))
        (unless (or (eql min '*) (typep min name))
          (error "Bad ~S type: ~S." name type))
        (when (consp max)
          (when (rest max)
            (error "Bad ~S type: ~S." name type))
          (setf max (1- (first max))))
        (unless (or (eql max '*) (typep max name))
          (error "Bad ~S type: ~S." name type))
        (values min max))
      (values '* '*)))
)

(defun satisfies-type-p (object type)
  (destructuring-bind (function) (cdr type)
    (funcall function object)))

(%define-compound-type 'satisfies 'satisfies-type-p)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun compile-satisfies-type (object type)
  (destructuring-bind (predicate-name) (rest type)
    `(,predicate-name ,object)))
(%define-compound-type-optimizer 'satisfies 'compile-satisfies-type)
)

(defun integer-type-p (object type)
  (multiple-value-bind (min max)
      (canonicalize-real-type type 'integer)
    (and (integerp object)
         (or (eql min '*)
             (>= object min))
{'fraction_non_alphanumeric': 0.142571329157968, 'fraction_numerical': 0.0055671537926235215, 'mean_word_length': 1.9344053088310362, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 11, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 20, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5127839', 'n_tokens_mistral': 3628, 'n_tokens_neox': 3448, 'n_words': 1001}