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

@@ -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

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_O>())) {
+    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<Symbol_sp>(oCar(cur2));
         if (symbol.notnilp() && oCdr(cur2).nilp()) {
+          symbol->check_package_lock("setting (setf ~s)'s fdefinition");
           symbol->setSetfFdefinition(function);
           return function;
         }

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_O>()) {
+    Package_sp pkg = p.as_unsafe<Package_O>();
+    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_()); }
 

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)