<commit_before>;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; ** Handlres for common-lisp special operators

;;;; Variable References

(defmethod evaluate/cc ((var local-variable-reference) lex-env dyn-env k)
  (declare (ignore dyn-env))
  (kontinue k (lookup lex-env :let (name var) :error-p t)))

(defmethod evaluate/cc ((var local-lexical-variable-reference) lex-env dyn-env k)
  (declare (ignore dyn-env))
  (kontinue k (funcall (first (lookup lex-env :lexical-let (name var) :error-p t)))))

(defmethod evaluate/cc ((var free-variable-reference) lex-env dyn-env k)
  (declare (ignore lex-env))
  (multiple-value-bind (value foundp)
      (lookup dyn-env :let (name var))
    (if foundp
        (kontinue k value)
        (kontinue k (symbol-value (name var))))))

;;;; Constants

(defmethod evaluate/cc ((c constant-form) lex-env dyn-env k)
  (declare (ignore lex-env dyn-env))
  (kontinue k (value c)))

;;;; BLOCK/RETURN-FROM

(defmethod evaluate/cc ((block block-form) lex-env dyn-env k)
  (evaluate-progn/cc (body block)
                     (register lex-env :block (name block) k)
                     dyn-env k))

(defmethod evaluate/cc ((return return-from-form) lex-env dyn-env k)
  (declare (ignore k))
  (evaluate/cc (result return)
               lex-env dyn-env
               (lookup lex-env :block (name (target-block return)) :error-p t)))

;;;; CATCH/THROW

(defmethod evaluate/cc ((catch catch-form) lex-env dyn-env k)
  (evaluate/cc (tag catch) lex-env dyn-env
               `(catch-tag-k ,catch ,lex-env ,dyn-env ,k)))

(defk catch-tag-k (catch lex-env dyn-env k)
    (tag)
  (evaluate-progn/cc (body catch) lex-env (register dyn-env :catch tag k) k))

(defmethod evaluate/cc ((throw throw-form) lex-env dyn-env k)
  (evaluate/cc (tag throw) lex-env dyn-env
               `(throw-tag-k ,throw ,lex-env ,dyn-env ,k)))

(defk throw-tag-k (throw lex-env dyn-env k)
    (tag)
  (evaluate/cc (value throw) lex-env dyn-env
               (lookup dyn-env :catch tag :error-p t)))

;;;; FLET/LABELS

(defmethod evaluate/cc ((flet flet-form) lex-env dyn-env k)
  (let ((new-env lex-env))
    (dolist* ((name . form) (binds flet))
      (setf new-env (register new-env :flet name (make-instance 'closure/cc
                                                                :code form
                                                                :env lex-env))))
    (evaluate-progn/cc (body flet) new-env dyn-env k)))

(defmethod evaluate/cc ((labels labels-form) lex-env dyn-env k)
  (let ((closures '()))
    (dolist* ((name . form) (binds labels))
      (let ((closure (make-instance 'closure/cc :code form)))
        (setf lex-env (register lex-env :flet name closure))
        (push closure closures)))
    (dolist (closure closures)
      (setf (env closure) lex-env))
    (evaluate-progn/cc (body labels) lex-env dyn-env k)))

;;;; LET/LET*

;; returns a dynamic environment that holds the special variables imported for let
;; these variables are captured from the caller normal lisp code and stored within
;; the continuation. The mixin might be a binding-form-mixin and implicit-progn-with-declare-mixin.
(defun import-specials (mixin dyn-env)
  (dolist (declaration (declares mixin))
    (let ((name (name declaration)))
      (if (and (typep declaration 'special-declaration-form)
               (or (not (typep mixin 'binding-form-mixin))
                   (not (find name (binds mixin) :key 'first)))
               (not (lookup dyn-env :let name)))
          (setf dyn-env (register dyn-env :let name (symbol-value name))))))
  dyn-env)

(defmethod evaluate/cc ((let let-form) lex-env dyn-env k)
  (evaluate-let/cc (binds let) nil (body let) lex-env (import-specials let dyn-env) k))

(defk k-for-evaluate-let/cc (var remaining-bindings evaluated-bindings body lex-env dyn-env k)
    (value)
  (evaluate-let/cc remaining-bindings
                   (cons (cons var value) evaluated-bindings)
                   body lex-env dyn-env k))

(defun evaluate-let/cc (remaining-bindings evaluated-bindings body lex-env dyn-env k)
  (if remaining-bindings
      (destructuring-bind (var . initial-value)
          (car remaining-bindings)
        (evaluate/cc
         initial-value
         lex-env dyn-env
         `(k-for-evaluate-let/cc
           ,var
           ,(cdr remaining-bindings)
           ,evaluated-bindings
           ,body
           ,lex-env ,dyn-env ,k)))
      (dolist* ((var . value) evaluated-bindings
                (evaluate-progn/cc body lex-env dyn-env k))
        (if (special-var-p var (parent (first body)))
            (setf dyn-env (register dyn-env :let var value))
            (setf lex-env (register lex-env :let var value))))))

(defun special-var-p (var declares-mixin)
  (find-if (lambda (declaration)
             (and (typep declaration 'special-declaration-form)
                  (eq (name declaration) var)))
           (declares declares-mixin)))

(defmethod evaluate/cc ((let* let*-form) lex-env dyn-env k)
  (evaluate-let*/cc (binds let*) (body let*) lex-env (import-specials let* dyn-env) k))

(defk k-for-evaluate-let*/cc (var bindings body lex-env dyn-env k)
    (value)<commit_msg>Make the cc interpreter 'see' special variables<commit_after>;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; ** Handlres for common-lisp special operators

;;;; Variable References

(defmethod evaluate/cc ((var local-variable-reference) lex-env dyn-env k)
  (declare (ignore dyn-env))
  (kontinue k (lookup lex-env :let (name var) :error-p t)))

(defmethod evaluate/cc ((var local-lexical-variable-reference) lex-env dyn-env k)
  (declare (ignore dyn-env))
  (kontinue k (funcall (first (lookup lex-env :lexical-let (name var) :error-p t)))))

(defmethod evaluate/cc ((var free-variable-reference) lex-env dyn-env k)
  (declare (ignore lex-env))
  (multiple-value-bind (value foundp)
      (lookup dyn-env :let (name var))
    (if foundp
        (kontinue k value)
        (kontinue k (symbol-value (name var))))))

;;;; Constants

(defmethod evaluate/cc ((c constant-form) lex-env dyn-env k)
  (declare (ignore lex-env dyn-env))
  (kontinue k (value c)))

;;;; BLOCK/RETURN-FROM

(defmethod evaluate/cc ((block block-form) lex-env dyn-env k)
  (evaluate-progn/cc (body block)
                     (register lex-env :block (name block) k)
                     dyn-env k))

(defmethod evaluate/cc ((return return-from-form) lex-env dyn-env k)
  (declare (ignore k))
  (evaluate/cc (result return)
               lex-env dyn-env
               (lookup lex-env :block (name (target-block return)) :error-p t)))

;;;; CATCH/THROW

(defmethod evaluate/cc ((catch catch-form) lex-env dyn-env k)
  (evaluate/cc (tag catch) lex-env dyn-env
               `(catch-tag-k ,catch ,lex-env ,dyn-env ,k)))

(defk catch-tag-k (catch lex-env dyn-env k)
    (tag)
  (evaluate-progn/cc (body catch) lex-env (register dyn-env :catch tag k) k))

(defmethod evaluate/cc ((throw throw-form) lex-env dyn-env k)
  (evaluate/cc (tag throw) lex-env dyn-env
               `(throw-tag-k ,throw ,lex-env ,dyn-env ,k)))

(defk throw-tag-k (throw lex-env dyn-env k)
    (tag)
  (evaluate/cc (value throw) lex-env dyn-env
               (lookup dyn-env :catch tag :error-p t)))

;;;; FLET/LABELS

(defmethod evaluate/cc ((flet flet-form) lex-env dyn-env k)
  (let ((new-env lex-env))
    (dolist* ((name . form) (binds flet))
      (setf new-env (register new-env :flet name (make-instance 'closure/cc
                                                                :code form
                                                                :env lex-env))))
    (evaluate-progn/cc (body flet) new-env dyn-env k)))

(defmethod evaluate/cc ((labels labels-form) lex-env dyn-env k)
  (let ((closures '()))
    (dolist* ((name . form) (binds labels))
      (let ((closure (make-instance 'closure/cc :code form)))
        (setf lex-env (register lex-env :flet name closure))
        (push closure closures)))
    (dolist (closure closures)
      (setf (env closure) lex-env))
    (evaluate-progn/cc (body labels) lex-env dyn-env k)))

;;;; LET/LET*

;; returns a dynamic environment that holds the special variables imported for let
;; these variables are captured from the caller normal lisp code and stored within
;; the continuation. The mixin might be a binding-form-mixin and implicit-progn-with-declare-mixin.
(defun import-specials (mixin dyn-env)
  (dolist (declaration (declares mixin))
    (let ((name (name declaration)))
      (if (and (typep declaration 'special-declaration-form)
               (or (not (typep mixin 'binding-form-mixin))
                   (not (find name (binds mixin) :key 'first)))
               (not (lookup dyn-env :let name)))
          (setf dyn-env (register dyn-env :let name (symbol-value name))))))
  dyn-env)

(defmethod evaluate/cc ((let let-form) lex-env dyn-env k)
  (evaluate-let/cc (binds let) nil (body let) lex-env (import-specials let dyn-env) k))

(defk k-for-evaluate-let/cc (var remaining-bindings evaluated-bindings body lex-env dyn-env k)
    (value)
  (evaluate-let/cc remaining-bindings
                   (cons (cons var value) evaluated-bindings)
                   body lex-env dyn-env k))

(defun evaluate-let/cc (remaining-bindings evaluated-bindings body lex-env dyn-env k)
  (if remaining-bindings
      (destructuring-bind (var . initial-value)
          (car remaining-bindings)
        (evaluate/cc
         initial-value
         lex-env dyn-env
         `(k-for-evaluate-let/cc
           ,var
           ,(cdr remaining-bindings)
           ,evaluated-bindings
           ,body
           ,lex-env ,dyn-env ,k)))
      (dolist* ((var . value) evaluated-bindings
                (evaluate-progn/cc body lex-env dyn-env k))
        (if (special-var-p var (parent (first body)))
            (setf dyn-env (register dyn-env :let var value))
            (setf lex-env (register lex-env :let var value))))))

(defun special-var-p (var declares-mixin)
  (or (find-if (lambda (declaration)
                 (and (typep declaration 'special-declaration-form)
                      (eq (name declaration) var)))
               (declares declares-mixin))
      (boundp var)))

(defmethod evaluate/cc ((let* let*-form) lex-env dyn-env k)
  (evaluate-let*/cc (binds let*) (body let*) lex-env (import-specials let* dyn-env) k))

(defk k-for-evaluate-let*/cc (var bindings body lex-env dyn-env k)
    (value)
{'fraction_non_alphanumeric': 0.1406039623004424, 'fraction_numerical': 0.0, 'mean_word_length': 2.4849195710455763, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 8, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6927926', 'n_tokens_mistral': 3517, 'n_tokens_neox': 3338, 'n_words': 1012}