From c0de8e4df9156b7b30a736790a1f4885d93be744 Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 13 Aug 2024 13:24:13 -0400 Subject: [PATCH] Check package locks on most global environment access Doing it in macros is too high level, I've realized belatedly. This might not be low level enough - in particular there are cells to worry about - but it's something. --- include/clasp/core/symbol.h | 3 +++ src/core/primitives.cc | 4 ++++ src/core/symbol.cc | 15 ++++++++++++++- src/lisp/kernel/lsp/evalmacros.lisp | 11 +++-------- 4 files changed, 24 insertions(+), 9 deletions(-) diff --git a/include/clasp/core/symbol.h b/include/clasp/core/symbol.h index 9bf1289667..aceff1856d 100644 --- a/include/clasp/core/symbol.h +++ b/include/clasp/core/symbol.h @@ -385,6 +385,9 @@ class Symbol_O : public General_O { /*! Convenience function, export yourself and return yourself */ Symbol_sp exportYourself(bool doit = true); + // Error if our package is locked. fmt takes one argument (the sym) + void check_package_lock(const char* fmt); + void dump() override; void __write__(T_sp stream) const override; // in write_symbol.cc diff --git a/src/core/primitives.cc b/src/core/primitives.cc index 162f151214..c43914adb9 100644 --- a/src/core/primitives.cc +++ b/src/core/primitives.cc @@ -722,6 +722,7 @@ DOCGROUP(clasp); CL_DEFUN_SETF T_sp setf_macro_function(Function_sp function, Symbol_sp symbol, T_sp env) { Function_sp namedFunction; (void)env; // ignore + symbol->check_package_lock("setting ~s's macro-function"); symbol->setf_macroP(true); symbol->setf_symbolFunction(function); return function; @@ -891,6 +892,7 @@ CL_DECLARE(); CL_DOCSTRING(R"dx(Set whether SYMBOL is known to be a constant. Use cautiously.)dx"); DOCGROUP(clasp); CL_DEFUN_SETF T_sp setf_symbol_constantp(T_sp value, Symbol_sp symbol) { + symbol->check_package_lock("defining ~s as constant"); symbol->setReadOnly(value.notnilp()); return value; } @@ -1014,6 +1016,7 @@ CL_DEFUN_SETF T_sp setf_fdefinition(Function_sp function, T_sp name) { Symbol_sp symbol; Function_sp functionObject; if ((symbol = name.asOrNull())) { + symbol->check_package_lock("setting ~s's fdefinition"); symbol->setf_macroP(false); symbol->setf_symbolFunction(function); return function; @@ -1024,6 +1027,7 @@ CL_DEFUN_SETF T_sp setf_fdefinition(Function_sp function, T_sp name) { if (cur2.consp()) { symbol = gc::As(oCar(cur2)); if (symbol.notnilp() && oCdr(cur2).nilp()) { + symbol->check_package_lock("setting (setf ~s)'s fdefinition"); symbol->setSetfFdefinition(function); return function; } diff --git a/src/core/symbol.cc b/src/core/symbol.cc index 7dea11ff9c..30ca33dfad 100644 --- a/src/core/symbol.cc +++ b/src/core/symbol.cc @@ -507,7 +507,10 @@ ClassHolder_sp Symbol_O::find_class_holder() { } #endif -void Symbol_O::makeSpecial() { this->setf_specialP(true); } +void Symbol_O::makeSpecial() { + this->check_package_lock("proclaiming ~s special"); + this->setf_specialP(true); +} CL_LISPIFY_NAME("core:STARmakeSpecial"); CL_LAMBDA(symbol); @@ -699,6 +702,16 @@ void Symbol_O::remove_package(Package_sp pkg) { } }; +// Signal an error if this is a symbol in a locked package. +void Symbol_O::check_package_lock(const char* fmt) { + T_sp p = this->homePackage(); + if (p.isA()) { + Package_sp pkg = p.as_unsafe(); + if (pkg->getSystemLockedP() || pkg->getUserLockedP()) + FEpackage_lock_violation(pkg, fmt, 1, this->asSmartPtr()); + } +} + DOCGROUP(clasp); CL_DEFUN bool core__no_thread_local_bindingp(T_sp object) { return gctools::tagged_no_thread_local_bindingp(object.raw_()); } diff --git a/src/lisp/kernel/lsp/evalmacros.lisp b/src/lisp/kernel/lsp/evalmacros.lisp index f141472b68..b970b3fb13 100644 --- a/src/lisp/kernel/lsp/evalmacros.lisp +++ b/src/lisp/kernel/lsp/evalmacros.lisp @@ -28,7 +28,6 @@ last FORM. If not, simply returns NIL." (defmacro defmacro (name lambda-list &body body &environment env) `(eval-when (:compile-toplevel :load-toplevel :execute) - (check-package-lock ',name 'defmacro) (funcall #'(setf macro-function) #',(ext:parse-macro name lambda-list body env) ',name) @@ -53,7 +52,6 @@ variable. FORM defaults to NIL. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." `(LOCALLY (DECLARE (SPECIAL ,var)) (eval-when (:compile-toplevel :load-toplevel :execute) - (check-package-lock ',var 'defvar) (SYS:*MAKE-SPECIAL ',var)) ,@(when form-sp `((UNLESS (BOUNDP ',var) @@ -75,7 +73,6 @@ the value of FORM to the variable. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." `(LOCALLY (DECLARE (SPECIAL ,var)) (eval-when (:compile-toplevel :load-toplevel :execute) - (check-package-lock ',var 'defparameter) (SYS:*MAKE-SPECIAL ',var)) (SETQ ,var ,form) ,@(when (and core:*current-source-pos-info* @@ -91,7 +88,6 @@ existing value." (let ((value (gensym))) `(PROGN (eval-when (:compile-toplevel :load-toplevel :execute) - (check-package-lock ',var 'defconstant) (let ((,value ,form)) (cond ((core:symbol-constantp ',var) (unless (,test ,value (symbol-value ',var)) @@ -130,9 +126,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (declare (core:lambda-name ,name) ,@decls) ,@doclist (block ,sname ,@body)))) - `(progn - (eval-when (:execute) - (check-package-lock ',sname 'defun)) + `(progn (eval-when (:compile-toplevel) ;; this function won't be ready for a while, but it's okay as there's no ;; compiler to run :compile-toplevel forms anyway. @@ -150,6 +144,8 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (defun (setf compiler-macro-function) (cmf name &optional environment) (declare (ignore environment)) + (check-package-lock (core::function-block-name name) + 'define-compiler-macro) ;; Basically ETYPECASE. (if (functionp cmf) (funcall #'(setf gethash) cmf name *compiler-macros*) @@ -160,7 +156,6 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (defmacro define-compiler-macro (name vl &rest body &environment env) ;; CLHS doesn't actually say d-c-m has compile time effects, but it's nice to match defmacro `(eval-when (:compile-toplevel :load-toplevel :execute) - (check-package-lock ',(core::function-block-name name) 'define-compiler-macro) (funcall #'(setf compiler-macro-function) (function ,(ext:parse-compiler-macro name vl body env)) ',name)