<commit_before>(in-package :sys.int)

(defun proclaim (declaration-specifier)
  (case (first declaration-specifier)
    (special (dolist (var (rest declaration-specifier))
               (setf (system:symbol-mode var) :special)))
    (constant (dolist (var (rest declaration-specifier))
                (setf (system:symbol-mode var) :constant)))
    (inline
     (dolist (name (rest declaration-specifier))
       (let ((sym (function-symbol name)))
         (setf (get sym 'inline-mode) t))))
    (notinline
     (dolist (name (rest declaration-specifier))
       (let ((sym (function-symbol name)))
         (setf (get sym 'inline-mode) nil))))))

(defun system:symbol-mode (symbol)
  (svref #(nil :special :constant :symbol-macro)
         (ldb (byte 2 0) (%symbol-flags symbol))))

(defun (setf system:symbol-mode) (value symbol)
  (setf (ldb (byte 2 0) (%symbol-flags symbol))
        (ecase value
          ((nil) +symbol-mode-nil+)
          ((:special) +symbol-mode-special+)
          ((:constant) +symbol-mode-constant+)
          ((:symbol-macro) +symbol-mode-symbol-macro+)))
  value)

(defun variable-information (symbol)
  (symbol-mode symbol))

;;; The compiler can only handle (apply function arg-list).
(defun apply (function arg &rest more-args)
  (declare (dynamic-extent more-args))
  (cond (more-args
         ;; Convert (... (final-list ...)) to (... final-list...)
         (do* ((arg-list (cons arg more-args))
               (i arg-list (cdr i)))
              ((null (cddr i))
               (setf (cdr i) (cadr i))
               (apply function arg-list))))
        (t (apply function arg))))

;;; TODO: This requires a considerably more flexible mechanism.
;;; 12 is where the TLS slots in a stack group start.
;;; NOTE: Is set by initialize-lisp during cold boot.
(defvar *next-symbol-tls-slot* 12)
(defconstant +maximum-tls-slot+ 512)
(defun %allocate-tls-slot (symbol)
  (when (>= *next-symbol-tls-slot* +maximum-tls-slot+)
    (error "Critial error! TLS slots exhausted!"))
  (let ((slot *next-symbol-tls-slot*))
    (incf *next-symbol-tls-slot*)
    (setf (ldb (byte 16 8) (%symbol-flags symbol)) slot)
    slot))

(defun %symbol-tls-slot (symbol)
  (ldb (byte 16 8) (%symbol-flags symbol)))

(defun symbol-tls-slot (symbol)
  (let ((slot (ldb (byte 16 8) (%symbol-flags symbol))))
    (if (zerop slot) nil slot)))

(defun funcall (function &rest arguments)
  (declare (dynamic-extent arguments))
  (apply function arguments))

(defun values (&rest values)
  (declare (dynamic-extent values))
  (values-list values))

(defun constantly (value)
  (lambda (&rest arguments)
    (declare (ignore arguments))
    value))

(defun fboundp (name)
  (%fboundp (function-symbol name)))

(defun fmakunbound (name)
  (%fmakunbound (function-symbol name))
  name)

(defun macro-function (symbol &optional env)
  (dolist (e env
           (get symbol '%macro-function))
    (when (eql (first e) :macros)
      (let ((fn (assoc symbol (rest e))))
        (when fn (return (cdr fn)))))))

(defun (setf macro-function) (value symbol &optional env)
  (when env
    (error "TODO: (Setf Macro-function) in environment."))
  (setf (symbol-function symbol) (lambda (&rest r)
                                   (declare (ignore r))
                                   (error 'undefined-function :name symbol))
        (get symbol '%macro-function) value))

;;; Calls to these functions are generated by the compiler to
;;; signal errors.
(defun raise-undefined-function (invoked-through &rest args)
  ;; Convert setf-symbols back to (setf foo).
  (when (and (symbolp invoked-through)
             (get invoked-through 'setf-symbol-backlink))
    (setf invoked-through `(setf ,(get invoked-through 'setf-symbol-backlink))))
  ;; Allow restarting.
  (restart-case (error 'undefined-function :name invoked-through)
    (use-value (v)
      :interactive (lambda ()
                     (format t "Enter a new value (evaluated): ")
                     (list (eval (read))))
      :report (lambda (s) (format s "Input a value to be used in place of ~S." `(fdefinition ',invoked-through)))
      (apply v args))))

(defun raise-undefined-function-via-%symbol-function (invoked-through)
  ;; Convert setf-symbols back to (setf foo).
  (when (and (symbolp invoked-through)
             (get invoked-through 'setf-symbol-backlink))
    (setf invoked-through `(setf ,(get invoked-through 'setf-symbol-backlink))))
  (error 'undefined-function :name invoked-through))

(defun raise-unbound-error (symbol)
  (error 'unbound-variable :name symbol))

(defun raise-type-error (datum expected-type)
  (error 'type-error :datum datum :expected-type expected-type))

(defun %invalid-argument-error (&rest args)
  (declare (ignore args))
  (error 'invalid-arguments))

(defun endp (list)
  (cond ((null list) t)
        ((consp list) nil)
        (t (error 'type-error
                  :datum list
                  :expected-type 'list))))

(defun list (&rest args)
  args)

(defun copy-list-in-area (list &optional area)
  (do* ((result (cons nil nil))
        (tail result)
        (l list (cdr l)))
       ((null l)
        (cdr result))
    (setf (cdr tail) (cons-in-area (car l) nil area)
          tail (cdr tail))))

(defun copy-list (list)
  (copy-list-in-area list))

;;; Will be overriden later in the init process.
(defun funcallable-instance-lambda-expression (function)
  (values nil t nil))
(defun funcallable-instance-debug-info (function)
  nil)

(defun function-name (function)
  (check-type function function)
  (let* ((address (logand (lisp-object-address function) -16))
         (info (memref-unsigned-byte-64 address 0)))
    (ecase (logand info #xFF)
      (#.+function-type-function+ ;; Regular function. First entry in the constant pool.
       (memref-t address (* (logand (ash info -16) #xFFFF) 2)))
      (#.+function-type-closure+ ;; Closure.
       (function-name (memref-t address 4)))
      (#.+function-type-funcallable-instance+
       (multiple-value-bind (lambda closurep name)
           (funcallable-instance-lambda-expression function)
         (declare (ignore lambda closurep))
         name)))))

(defun function-lambda-expression (function)
  (check-type function function)
  (let* ((address (logand (lisp-object-address function) -16))
         (info (memref-unsigned-byte-64 address 0)))
    (ecase (logand info #xFF)
      (#.+function-type-function+ ;; Regular function. First entry in the constant pool.
       (values nil nil (memref-t address (* (logand (ash info -16) #xFFFF) 2))))
      (#.+function-type-closure+ ;; Closure.
       (values nil t (function-name (memref-t address 4))))
      (#.+function-type-funcallable-instance+
       (funcallable-instance-lambda-expression function)))))

(defun function-debug-info (function)
  (check-type function function)
  (let* ((address (logand (lisp-object-address function) -16))
         (info (memref-unsigned-byte-64 address 0)))
    (ecase (logand info #xFF)
      (#.+function-type-function+ ;; Regular function. second entry in the constant pool.
       (memref-t address (1+ (* (logand (ash info -16) #xFFFF) 2))))
      (#.+function-type-closure+ ;; Closure.
       (function-debug-info (memref-t address 4)))
      (#.+function-type-funcallable-instance+
       (funcallable-instance-debug-info function)))))

(defun funcallable-std-instance-p (object)
  (when (functionp object)
    (let* ((address (logand (lisp-object-address object) -16))
           (info (memref-unsigned-byte-64 address 0)))
      (eql (ldb (byte 8 0) info) +function-type-funcallable-instance+))))

(defun funcallable-std-instance-function (funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (memref-t address 4)))
(defun (setf funcallable-std-instance-function) (value funcallable-instance)
  (check-type value function)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (setf (memref-t address 4) value)))

(defun funcallable-std-instance-class (funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (memref-t address 5)))
(defun (setf funcallable-std-instance-class) (value funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (setf (memref-t address 5) value)))

(defun funcallable-std-instance-slots (funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (memref-t address 6)))
(defun (setf funcallable-std-instance-slots) (value funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (setf (memref-t address 6) value)))

(defun compiled-function-p (object)
  (when (functionp object)
    (let* ((address (logand (lisp-object-address object) -16))
           (info (memref-unsigned-byte-64 address 0)))
      (not (eql (logand info #xFF) +function-type-interpreted-function+)))))

(defvar *gensym-counter* 0)
(defun gensym (&optional (thing "G"))
  (check-type thing (or string (integer 0)))
  (if (integerp thing)
      (make-symbol (format nil "G~D" thing))
      (prog1 (make-symbol (format nil "~A~D" thing *gensym-counter*))
        (incf *gensym-counter*))))

;;; TODO: Expand this so it knows about the compiler's constant folders.
(defun constantp (form &optional environment)
  (declare (ignore environment))
  (typecase form
    (symbol (eql (symbol-mode form) :constant))
    (cons (eql (first form) 'quote))
    (t t)))

(defvar *active-catch-handlers* '())
(defun %catch (tag fn)
  (let ((*active-catch-handlers* (cons (cons tag
                                             (lambda (values)
                                               (return-from %catch (values-list values))))
                                       *active-catch-handlers*)))
    (funcall fn)))

(defun %throw (tag values)
  (let ((target (assoc tag *active-catch-handlers* :test 'eq)))
    (if target
        (funcall (cdr target) values)
        (error 'bad-catch-tag-error
               :tag tag))))

(defun %progv (symbols values fn)
  ;; Save the special-stack
  (let ((special-stack (%%special-stack-pointer)))
    ;; Bind each variable.
    (do ((s symbols (rest s))
         (v values (rest v)))
        ((null s))
      (check-type (first s) symbol)
      (%%bind (first s) (if v
                            (first v)
                            (%%assemble-value 0 +tag-unbound-value+))))
    (multiple-value-prog1 (funcall fn)
      ;; Now pop the special stack. This is not done with unwind-protect,
      ;; because a non-local exit with unwind the stack anyway.
      (%%unwind-to special-stack))))

(defun %%unwind-to (target-special-stack-pointer)
  (declare (suppress-ssp-checking))
  (loop (when (eq target-special-stack-pointer (%%special-stack-pointer))
          (return))
     (etypecase (memref-t (ash (%%special-stack-pointer) 3) 0)<commit_msg>Small sanity check in %%UNWIND and rewrite the MEMREF-T to avoid an ASH.<commit_after>(in-package :sys.int)

(defun proclaim (declaration-specifier)
  (case (first declaration-specifier)
    (special (dolist (var (rest declaration-specifier))
               (setf (system:symbol-mode var) :special)))
    (constant (dolist (var (rest declaration-specifier))
                (setf (system:symbol-mode var) :constant)))
    (inline
     (dolist (name (rest declaration-specifier))
       (let ((sym (function-symbol name)))
         (setf (get sym 'inline-mode) t))))
    (notinline
     (dolist (name (rest declaration-specifier))
       (let ((sym (function-symbol name)))
         (setf (get sym 'inline-mode) nil))))))

(defun system:symbol-mode (symbol)
  (svref #(nil :special :constant :symbol-macro)
         (ldb (byte 2 0) (%symbol-flags symbol))))

(defun (setf system:symbol-mode) (value symbol)
  (setf (ldb (byte 2 0) (%symbol-flags symbol))
        (ecase value
          ((nil) +symbol-mode-nil+)
          ((:special) +symbol-mode-special+)
          ((:constant) +symbol-mode-constant+)
          ((:symbol-macro) +symbol-mode-symbol-macro+)))
  value)

(defun variable-information (symbol)
  (symbol-mode symbol))

;;; The compiler can only handle (apply function arg-list).
(defun apply (function arg &rest more-args)
  (declare (dynamic-extent more-args))
  (cond (more-args
         ;; Convert (... (final-list ...)) to (... final-list...)
         (do* ((arg-list (cons arg more-args))
               (i arg-list (cdr i)))
              ((null (cddr i))
               (setf (cdr i) (cadr i))
               (apply function arg-list))))
        (t (apply function arg))))

;;; TODO: This requires a considerably more flexible mechanism.
;;; 12 is where the TLS slots in a stack group start.
;;; NOTE: Is set by initialize-lisp during cold boot.
(defvar *next-symbol-tls-slot* 12)
(defconstant +maximum-tls-slot+ 512)
(defun %allocate-tls-slot (symbol)
  (when (>= *next-symbol-tls-slot* +maximum-tls-slot+)
    (error "Critial error! TLS slots exhausted!"))
  (let ((slot *next-symbol-tls-slot*))
    (incf *next-symbol-tls-slot*)
    (setf (ldb (byte 16 8) (%symbol-flags symbol)) slot)
    slot))

(defun %symbol-tls-slot (symbol)
  (ldb (byte 16 8) (%symbol-flags symbol)))

(defun symbol-tls-slot (symbol)
  (let ((slot (ldb (byte 16 8) (%symbol-flags symbol))))
    (if (zerop slot) nil slot)))

(defun funcall (function &rest arguments)
  (declare (dynamic-extent arguments))
  (apply function arguments))

(defun values (&rest values)
  (declare (dynamic-extent values))
  (values-list values))

(defun constantly (value)
  (lambda (&rest arguments)
    (declare (ignore arguments))
    value))

(defun fboundp (name)
  (%fboundp (function-symbol name)))

(defun fmakunbound (name)
  (%fmakunbound (function-symbol name))
  name)

(defun macro-function (symbol &optional env)
  (dolist (e env
           (get symbol '%macro-function))
    (when (eql (first e) :macros)
      (let ((fn (assoc symbol (rest e))))
        (when fn (return (cdr fn)))))))

(defun (setf macro-function) (value symbol &optional env)
  (when env
    (error "TODO: (Setf Macro-function) in environment."))
  (setf (symbol-function symbol) (lambda (&rest r)
                                   (declare (ignore r))
                                   (error 'undefined-function :name symbol))
        (get symbol '%macro-function) value))

;;; Calls to these functions are generated by the compiler to
;;; signal errors.
(defun raise-undefined-function (invoked-through &rest args)
  ;; Convert setf-symbols back to (setf foo).
  (when (and (symbolp invoked-through)
             (get invoked-through 'setf-symbol-backlink))
    (setf invoked-through `(setf ,(get invoked-through 'setf-symbol-backlink))))
  ;; Allow restarting.
  (restart-case (error 'undefined-function :name invoked-through)
    (use-value (v)
      :interactive (lambda ()
                     (format t "Enter a new value (evaluated): ")
                     (list (eval (read))))
      :report (lambda (s) (format s "Input a value to be used in place of ~S." `(fdefinition ',invoked-through)))
      (apply v args))))

(defun raise-undefined-function-via-%symbol-function (invoked-through)
  ;; Convert setf-symbols back to (setf foo).
  (when (and (symbolp invoked-through)
             (get invoked-through 'setf-symbol-backlink))
    (setf invoked-through `(setf ,(get invoked-through 'setf-symbol-backlink))))
  (error 'undefined-function :name invoked-through))

(defun raise-unbound-error (symbol)
  (error 'unbound-variable :name symbol))

(defun raise-type-error (datum expected-type)
  (error 'type-error :datum datum :expected-type expected-type))

(defun %invalid-argument-error (&rest args)
  (declare (ignore args))
  (error 'invalid-arguments))

(defun endp (list)
  (cond ((null list) t)
        ((consp list) nil)
        (t (error 'type-error
                  :datum list
                  :expected-type 'list))))

(defun list (&rest args)
  args)

(defun copy-list-in-area (list &optional area)
  (do* ((result (cons nil nil))
        (tail result)
        (l list (cdr l)))
       ((null l)
        (cdr result))
    (setf (cdr tail) (cons-in-area (car l) nil area)
          tail (cdr tail))))

(defun copy-list (list)
  (copy-list-in-area list))

;;; Will be overriden later in the init process.
(defun funcallable-instance-lambda-expression (function)
  (values nil t nil))
(defun funcallable-instance-debug-info (function)
  nil)

(defun function-name (function)
  (check-type function function)
  (let* ((address (logand (lisp-object-address function) -16))
         (info (memref-unsigned-byte-64 address 0)))
    (ecase (logand info #xFF)
      (#.+function-type-function+ ;; Regular function. First entry in the constant pool.
       (memref-t address (* (logand (ash info -16) #xFFFF) 2)))
      (#.+function-type-closure+ ;; Closure.
       (function-name (memref-t address 4)))
      (#.+function-type-funcallable-instance+
       (multiple-value-bind (lambda closurep name)
           (funcallable-instance-lambda-expression function)
         (declare (ignore lambda closurep))
         name)))))

(defun function-lambda-expression (function)
  (check-type function function)
  (let* ((address (logand (lisp-object-address function) -16))
         (info (memref-unsigned-byte-64 address 0)))
    (ecase (logand info #xFF)
      (#.+function-type-function+ ;; Regular function. First entry in the constant pool.
       (values nil nil (memref-t address (* (logand (ash info -16) #xFFFF) 2))))
      (#.+function-type-closure+ ;; Closure.
       (values nil t (function-name (memref-t address 4))))
      (#.+function-type-funcallable-instance+
       (funcallable-instance-lambda-expression function)))))

(defun function-debug-info (function)
  (check-type function function)
  (let* ((address (logand (lisp-object-address function) -16))
         (info (memref-unsigned-byte-64 address 0)))
    (ecase (logand info #xFF)
      (#.+function-type-function+ ;; Regular function. second entry in the constant pool.
       (memref-t address (1+ (* (logand (ash info -16) #xFFFF) 2))))
      (#.+function-type-closure+ ;; Closure.
       (function-debug-info (memref-t address 4)))
      (#.+function-type-funcallable-instance+
       (funcallable-instance-debug-info function)))))

(defun funcallable-std-instance-p (object)
  (when (functionp object)
    (let* ((address (logand (lisp-object-address object) -16))
           (info (memref-unsigned-byte-64 address 0)))
      (eql (ldb (byte 8 0) info) +function-type-funcallable-instance+))))

(defun funcallable-std-instance-function (funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (memref-t address 4)))
(defun (setf funcallable-std-instance-function) (value funcallable-instance)
  (check-type value function)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (setf (memref-t address 4) value)))

(defun funcallable-std-instance-class (funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (memref-t address 5)))
(defun (setf funcallable-std-instance-class) (value funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (setf (memref-t address 5) value)))

(defun funcallable-std-instance-slots (funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (memref-t address 6)))
(defun (setf funcallable-std-instance-slots) (value funcallable-instance)
  (assert (funcallable-std-instance-p funcallable-instance) (funcallable-instance))
  (let* ((address (logand (lisp-object-address funcallable-instance) -16)))
    (setf (memref-t address 6) value)))

(defun compiled-function-p (object)
  (when (functionp object)
    (let* ((address (logand (lisp-object-address object) -16))
           (info (memref-unsigned-byte-64 address 0)))
      (not (eql (logand info #xFF) +function-type-interpreted-function+)))))

(defvar *gensym-counter* 0)
(defun gensym (&optional (thing "G"))
  (check-type thing (or string (integer 0)))
  (if (integerp thing)
      (make-symbol (format nil "G~D" thing))
      (prog1 (make-symbol (format nil "~A~D" thing *gensym-counter*))
        (incf *gensym-counter*))))

;;; TODO: Expand this so it knows about the compiler's constant folders.
(defun constantp (form &optional environment)
  (declare (ignore environment))
  (typecase form
    (symbol (eql (symbol-mode form) :constant))
    (cons (eql (first form) 'quote))
    (t t)))

(defvar *active-catch-handlers* '())
(defun %catch (tag fn)
  (let ((*active-catch-handlers* (cons (cons tag
                                             (lambda (values)
                                               (return-from %catch (values-list values))))
                                       *active-catch-handlers*)))
    (funcall fn)))

(defun %throw (tag values)
  (let ((target (assoc tag *active-catch-handlers* :test 'eq)))
    (if target
        (funcall (cdr target) values)
        (error 'bad-catch-tag-error
               :tag tag))))

(defun %progv (symbols values fn)
  ;; Save the special-stack
  (let ((special-stack (%%special-stack-pointer)))
    ;; Bind each variable.
    (do ((s symbols (rest s))
         (v values (rest v)))
        ((null s))
      (check-type (first s) symbol)
      (%%bind (first s) (if v
                            (first v)
                            (%%assemble-value 0 +tag-unbound-value+))))
    (multiple-value-prog1 (funcall fn)
      ;; Now pop the special stack. This is not done with unwind-protect,
      ;; because a non-local exit will unwind the stack anyway.
      (%%unwind-to special-stack))))

(defun %%unwind-to (target-special-stack-pointer)
  (declare (suppress-ssp-checking))
  (loop (when (eq target-special-stack-pointer (%%special-stack-pointer))
          (return))
     (assert (< (%%special-stack-pointer) target-special-stack-pointer))
     (etypecase (memref-t 0 (%%special-stack-pointer))
{'fraction_non_alphanumeric': 0.1507493900313698, 'fraction_numerical': 0.007363192750087138, 'mean_word_length': 3.0732919254658384, 'pattern_counts': {'":': 0, '<': 4, '<?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': 14, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2984252', 'n_tokens_mistral': 7560, 'n_tokens_neox': 7291, 'n_words': 2074}