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

;;;; Lower anything that modifies the special stack to explicit compiler builtins.

(in-package :sys.c)

(defvar *special-bindings*)
(defvar *verify-special-stack* nil)

(defun lower-special-bindings (lambda)
  (lsb-form lambda))

(defgeneric lsb-form (form))

(defmethod lsb-form ((lambda lambda-information))
  (let ((*current-lambda* lambda)
        (*special-bindings* '()))
    ;; Check some assertions.
    ;; No keyword arguments, no special arguments, no non-constant
    ;; &optional init-forms and no non-local arguments.
    (assert (not (lambda-information-enable-keys lambda)) (lambda)
            "&KEY arguments did not get lowered!")
    (assert (every (lambda (arg)
                     (lexical-variable-p arg))
                   (lambda-information-required-args lambda))
            (lambda) "Special required arguments did not get lowered!")
    (assert (every (lambda (arg)
                     (and (lexical-variable-p (first arg))
                          (quoted-form-p (second arg))
                          (or (null (third arg))
                              (lexical-variable-p (first arg)))))
                   (lambda-information-optional-args lambda))
            (lambda) "Special or complex optional arguments did not get lowered!")
    (assert (or (null (lambda-information-rest-arg lambda))
                (lexical-variable-p (lambda-information-rest-arg lambda)))
            (lambda) "Special rest argument did not get lowered!")
    (assert (or (null (lambda-information-fref-arg lambda))
                (lexical-variable-p (lambda-information-fref-arg lambda)))
            (lambda) "Special fref argument did not get lowered!")
    (assert (or (null (lambda-information-closure-arg lambda))
                (lexical-variable-p (lambda-information-closure-arg lambda)))
            (lambda) "Special closure argument did not get lowered!")
    (assert (or (null (lambda-information-count-arg lambda))
                (lexical-variable-p (lambda-information-count-arg lambda)))
            (lambda) "Special count argument did not get lowered!")
    (setf (lambda-information-body lambda)
          (lsb-form (lambda-information-body lambda)))
    (when (and *verify-special-stack*
               (not (find 'sys.int::suppress-ssp-checking
                          (getf (lambda-information-plist lambda) :declares)
                          :key #'first)))
      (setf (lambda-information-body lambda)
            (ast `(let ((ssp (call sys.int::%%special-stack-pointer)))
                    (multiple-value-prog1 ,(lambda-information-body lambda)
                      (if (call eq ssp (call sys.int::%%special-stack-pointer))
                          'nil
                          (call error '"SSP mismatch"))))
                 lambda)))
    lambda))

(defmethod lsb-form ((form ast-block))
  (let ((*special-bindings* *special-bindings*)
        (info (info form)))
    (push (list :block-or-tagbody
                info
                (block-information-env-var info)
                (block-information-env-offset info))
          *special-bindings*)
    (cond
      ((block-information-env-var info)
       ;; Escaping block.
       (ast `(block ,info
               (progn
                 ;; Must be inside the block, so the special stack pointer is saved correctly.
                 (call sys.int::%%push-special-stack
                       ,(block-information-env-var info)
                       (quote ,(block-information-env-offset info)))
                 (multiple-value-prog1 ,(lsb-form (body form))
                   (call sys.int::%%disestablish-block-or-tagbody))))
            form))
      (t ;; Local block.
       (ast `(block ,info
               ,(lsb-form (body form)))
            form)))))

(defmethod lsb-form ((form ast-function))
  form)

(defmethod lsb-form ((form ast-go))
  (let ((tag (target form))
        (location (info form)))
    (cond ((eql (go-tag-tagbody tag) location)
           ;; Local GO, locate the matching TAGBODY and emit any unwind forms required.
           (ast `(progn ,@(lsb-unwind-to (lsb-find-b-or-t-binding location))
                        (go ,tag ,location))
                form))
          (t ;; Non-local GO, do the full unwind.
           (ast `(let ((info ,(lsb-form location)))
                   (progn
                     ;; Ensure it's still valid.
                     (if info
                         (quote nil)
                         (call sys.int::raise-bad-go-tag (quote (go-tag-name tag))))
                     (call sys.int::%%unwind-to
                           (call sys.int::%%tagbody-info-binding-stack-pointer info))
                     (go ,tag info)))
                form)))))

(defmethod lsb-form ((form ast-if))
  (ast `(if ,(lsb-form (test form))
            ,(lsb-form (if-then form))
            ,(lsb-form (if-else form)))
       form))

(defmethod lsb-form ((form ast-let))
  (let ((*special-bindings* *special-bindings*))
    (labels ((frob (bindings)
               (cond (bindings
                      (let* ((binding (first bindings))
                             (variable (first binding))
                             (init-form (second binding)))
                        (etypecase variable
                          (lexical-variable
                           (ast `(let ((,variable ,(lsb-form init-form)))
                                   ,(frob (rest bindings)))
                                form))
                          (special-variable
                           (push (list :special (first binding))
                                 *special-bindings*)
                           (ast `(progn
                                   (call sys.int::%%bind
                                         (quote ,(name variable))
                                         ,(lsb-form init-form))
                                   (multiple-value-prog1 ,(frob (rest bindings))
                                     (call sys.int::%%unbind)))
                                form)))))
                     (t (lsb-form (body form))))))
      (frob (bindings form)))))

(defmethod lsb-form ((form ast-multiple-value-bind))
  (ast `(multiple-value-bind ,(bindings form)
            ,(lsb-form (value-form form))
          ,(lsb-form (body form)))
       form))

(defmethod lsb-form ((form ast-multiple-value-call))
  (ast `(multiple-value-call ,(lsb-form (function-form form))
          ,(lsb-form (value-form form)))
       form))

(defmethod lsb-form ((form ast-multiple-value-prog1))
  (ast `(multiple-value-prog1 ,(lsb-form (value-form form))
          ,(lsb-form (body form)))
       form))

(defmethod lsb-form ((form ast-progn))
  (ast `(progn ,@(mapcar #'lsb-form (forms form)))
       form))

(defmethod lsb-form ((form ast-quote))
  form)

(defmethod lsb-form ((form ast-return-from))<commit_msg>LET special bindings are established after all init-forms are evaluated.<commit_after>;;;; Copyright (c) 2011-2016 <NAME> <<EMAIL>>
;;;; This code is licensed under the MIT license.

;;;; Lower anything that modifies the special stack to explicit compiler builtins.

(in-package :sys.c)

(defvar *special-bindings*)
(defvar *verify-special-stack* nil)

(defun lower-special-bindings (lambda)
  (lsb-form lambda))

(defgeneric lsb-form (form))

(defmethod lsb-form ((lambda lambda-information))
  (let ((*current-lambda* lambda)
        (*special-bindings* '()))
    ;; Check some assertions.
    ;; No keyword arguments, no special arguments, no non-constant
    ;; &optional init-forms and no non-local arguments.
    (assert (not (lambda-information-enable-keys lambda)) (lambda)
            "&KEY arguments did not get lowered!")
    (assert (every (lambda (arg)
                     (lexical-variable-p arg))
                   (lambda-information-required-args lambda))
            (lambda) "Special required arguments did not get lowered!")
    (assert (every (lambda (arg)
                     (and (lexical-variable-p (first arg))
                          (quoted-form-p (second arg))
                          (or (null (third arg))
                              (lexical-variable-p (first arg)))))
                   (lambda-information-optional-args lambda))
            (lambda) "Special or complex optional arguments did not get lowered!")
    (assert (or (null (lambda-information-rest-arg lambda))
                (lexical-variable-p (lambda-information-rest-arg lambda)))
            (lambda) "Special rest argument did not get lowered!")
    (assert (or (null (lambda-information-fref-arg lambda))
                (lexical-variable-p (lambda-information-fref-arg lambda)))
            (lambda) "Special fref argument did not get lowered!")
    (assert (or (null (lambda-information-closure-arg lambda))
                (lexical-variable-p (lambda-information-closure-arg lambda)))
            (lambda) "Special closure argument did not get lowered!")
    (assert (or (null (lambda-information-count-arg lambda))
                (lexical-variable-p (lambda-information-count-arg lambda)))
            (lambda) "Special count argument did not get lowered!")
    (setf (lambda-information-body lambda)
          (lsb-form (lambda-information-body lambda)))
    (when (and *verify-special-stack*
               (not (find 'sys.int::suppress-ssp-checking
                          (getf (lambda-information-plist lambda) :declares)
                          :key #'first)))
      (setf (lambda-information-body lambda)
            (ast `(let ((ssp (call sys.int::%%special-stack-pointer)))
                    (multiple-value-prog1 ,(lambda-information-body lambda)
                      (if (call eq ssp (call sys.int::%%special-stack-pointer))
                          'nil
                          (call error '"SSP mismatch"))))
                 lambda)))
    lambda))

(defmethod lsb-form ((form ast-block))
  (let ((*special-bindings* *special-bindings*)
        (info (info form)))
    (push (list :block-or-tagbody
                info
                (block-information-env-var info)
                (block-information-env-offset info))
          *special-bindings*)
    (cond
      ((block-information-env-var info)
       ;; Escaping block.
       (ast `(block ,info
               (progn
                 ;; Must be inside the block, so the special stack pointer is saved correctly.
                 (call sys.int::%%push-special-stack
                       ,(block-information-env-var info)
                       (quote ,(block-information-env-offset info)))
                 (multiple-value-prog1 ,(lsb-form (body form))
                   (call sys.int::%%disestablish-block-or-tagbody))))
            form))
      (t ;; Local block.
       (ast `(block ,info
               ,(lsb-form (body form)))
            form)))))

(defmethod lsb-form ((form ast-function))
  form)

(defmethod lsb-form ((form ast-go))
  (let ((tag (target form))
        (location (info form)))
    (cond ((eql (go-tag-tagbody tag) location)
           ;; Local GO, locate the matching TAGBODY and emit any unwind forms required.
           (ast `(progn ,@(lsb-unwind-to (lsb-find-b-or-t-binding location))
                        (go ,tag ,location))
                form))
          (t ;; Non-local GO, do the full unwind.
           (ast `(let ((info ,(lsb-form location)))
                   (progn
                     ;; Ensure it's still valid.
                     (if info
                         (quote nil)
                         (call sys.int::raise-bad-go-tag (quote (go-tag-name tag))))
                     (call sys.int::%%unwind-to
                           (call sys.int::%%tagbody-info-binding-stack-pointer info))
                     (go ,tag info)))
                form)))))

(defmethod lsb-form ((form ast-if))
  (ast `(if ,(lsb-form (test form))
            ,(lsb-form (if-then form))
            ,(lsb-form (if-else form)))
       form))

(defmethod lsb-form ((form ast-let))
  (let ((updated-special-bindings *special-bindings*))
    (labels ((frob (bindings)
               (cond (bindings
                      (let* ((binding (first bindings))
                             (variable (first binding))
                             (init-form (second binding)))
                        (etypecase variable
                          (lexical-variable
                           (ast `(let ((,variable ,(lsb-form init-form)))
                                   ,(frob (rest bindings)))
                                form))
                          (special-variable
                           (push (list :special (first binding))
                                 updated-special-bindings)
                           (ast `(progn
                                   (call sys.int::%%bind
                                         (quote ,(name variable))
                                         ,(lsb-form init-form))
                                   (multiple-value-prog1 ,(frob (rest bindings))
                                     (call sys.int::%%unbind)))
                                form)))))
                     (t
                      (let ((*special-bindings* updated-special-bindings))
                        (lsb-form (body form)))))))
      (frob (bindings form)))))

(defmethod lsb-form ((form ast-multiple-value-bind))
  (ast `(multiple-value-bind ,(bindings form)
            ,(lsb-form (value-form form))
          ,(lsb-form (body form)))
       form))

(defmethod lsb-form ((form ast-multiple-value-call))
  (ast `(multiple-value-call ,(lsb-form (function-form form))
          ,(lsb-form (value-form form)))
       form))

(defmethod lsb-form ((form ast-multiple-value-prog1))
  (ast `(multiple-value-prog1 ,(lsb-form (value-form form))
          ,(lsb-form (body form)))
       form))

(defmethod lsb-form ((form ast-progn))
  (ast `(progn ,@(mapcar #'lsb-form (forms form)))
       form))

(defmethod lsb-form ((form ast-quote))
  form)

(defmethod lsb-form ((form ast-return-from))
{'fraction_non_alphanumeric': 0.1322811239295067, 'fraction_numerical': 0.001840186849741666, 'mean_word_length': 1.6500375093773443, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 18, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1992253', 'n_tokens_mistral': 3954, 'n_tokens_neox': 3794, 'n_words': 1033}