[wip] implement the operator defglobal

DEFGLOBAL defines a global lexical variable. It may be reassigned but it can't
be bound.

fixme: allow specifying GLOBAL_SYMBOL in all_symbols.d -- the bitfield for
symbols/packages needs to be adjusted.

src/c/all_symbols.d

@@ -17,6 +17,8 @@
 #define ORDINARY_SYMBOL 0
 #define CONSTANT_SYMBOL 1
 #define SPECIAL_SYMBOL 2
+/* FIXME */
+/* #define GLOBAL_SYMBOL 3 */
 #define FORM_SYMBOL 3
 #define PRIVATE 256
 
@@ -218,6 +220,8 @@ make_this_symbol(int i, cl_object s, int code,
   switch (code & 3) {
   case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break;
   case SPECIAL_SYMBOL: stp = ecl_stp_special; break;
+    /* fiXME */
+  /* case GLOBAL_SYMBOL: stp = ecl_stp_global; break; */
   case CONSTANT_SYMBOL: stp = ecl_stp_constant; break;
   case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary;
   }

src/c/cmpaux.d

@@ -22,12 +22,24 @@ si_specialp(cl_object sym)
   @(return ((ecl_symbol_type(sym) & ecl_stp_special)? ECL_T : ECL_NIL))
 }
 
+cl_object
+si_globalp(cl_object sym)
+{
+  @(return ((ecl_symbol_type(sym) & ecl_stp_global)? ECL_T : ECL_NIL))
+}
+
 cl_object
 si_constp(cl_object sym)
 {
   @(return ((ecl_symbol_type(sym) & ecl_stp_constant)? ECL_T : ECL_NIL))
 }
 
+bool
+ecl_symbol_unbindable_p(cl_object sym)
+{
+  return (ecl_symbol_type(sym) & (ecl_stp_constant | ecl_stp_global));
+}
+
 cl_fixnum
 ecl_ifloor(cl_fixnum x, cl_fixnum y)
 {

src/c/compiler.d

@@ -1617,8 +1617,8 @@ c_let_leta(cl_env_ptr env, int op, cl_object args, int flags) {
     }
     if (!ECL_SYMBOLP(var))
       FEillegal_variable_name(var);
-    if (ecl_symbol_type(var) & ecl_stp_constant)
-      FEbinding_a_constant(var);
+    if (ecl_symbol_unbindable_p(var))
+      FEbinding_impossible(var);
     if (op == OP_PBIND) {
       compile_form(env, value, FLAG_PUSH);
       if (ecl_member_eq(var, vars))
@@ -1754,8 +1754,8 @@ c_multiple_value_bind(cl_env_ptr env, cl_object args, int flags)
       cl_object var = pop(&vars);
       if (!ECL_SYMBOLP(var))
         FEillegal_variable_name(var);
-      if (ecl_symbol_type(var) & ecl_stp_constant)
-        FEbinding_a_constant(var);
+      if (ecl_symbol_unbindable_p(var))
+        FEbinding_impossible(var);
       c_vbind(env, var, n, specials);
     }
     c_declare_specials(env, specials);
@@ -2913,10 +2913,10 @@ cl_object
 si_process_lambda_list(cl_object org_lambda_list, cl_object context)
 {
 #define push(v,l) { cl_object c = *l = CONS(v, *l); l = &ECL_CONS_CDR(c); }
-#define assert_var_name(v)                              \
+#define assert_var_name(var)                              \
   if (context == @'function') {                         \
-    unlikely_if (ecl_symbol_type(v) & ecl_stp_constant) \
-      FEillegal_variable_name(v); }
+    unlikely_if (ecl_symbol_unbindable_p(var))           \
+      FEillegal_variable_name(var); }
   cl_object lists[4] = {ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL};
   cl_object *reqs = lists, *opts = lists+1, *keys = lists+2, *auxs = lists+3;
   cl_object v, rest = ECL_NIL, lambda_list = org_lambda_list;

src/c/error.d

@@ -447,9 +447,9 @@ FEassignment_to_constant(cl_object v)
 }
 
 void
-FEbinding_a_constant(cl_object v)
+FEbinding_impossible(cl_object v)
 {
-  FEprogram_error("The constant ~S is being bound.", 1, v);
+  FEprogram_error("The variable ~S can't be bound.", 1, v);
 }
 
 void

src/c/package.d

@@ -425,11 +425,9 @@ ecl_intern(cl_object name, cl_object p, int *intern_flag)
       if (p == cl_core.keyword_package) {
         ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant);
         ECL_SET(s, s);
-        p->pack.external =
-          _ecl_sethash(name, p->pack.external, s);
+        p->pack.external = _ecl_sethash(name, p->pack.external, s);
       } else {
-        p->pack.internal =
-          _ecl_sethash(name, p->pack.internal, s);
+        p->pack.internal = _ecl_sethash(name, p->pack.internal, s);
       }
       error = 0;
     }

src/c/stacks.d

@@ -360,8 +360,8 @@ ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
       cl_object var = ECL_CONS_CAR(vars);
       if (!ECL_SYMBOLP(var))
         FEillegal_variable_name(var);
-      if (ecl_symbol_type(var) & ecl_stp_constant)
-        FEbinding_a_constant(var);
+      if (ecl_symbol_unbindable_p(var))
+        FEbinding_impossible(var);
       if (Null(values)) {
         ecl_bds_bind(env, var, OBJNULL);
       } else {

src/c/symbol.d

@@ -456,22 +456,34 @@ cl_object
 @si::*make-special(cl_object sym)
 {
   int type = ecl_symbol_type(sym);
-  if (type & ecl_stp_constant)
-    FEerror("~S is a constant.", 1, sym);
+  if (type & (ecl_stp_constant | ecl_stp_global))
+    FEerror("~S is a constant or global variable.", 1, sym);
   ecl_symbol_type_set(sym, type | ecl_stp_special);
   cl_remprop(sym, @'si::symbol-macro');
   @(return sym);
 }
 
+cl_object
+@si::*make-global(cl_object sym)
+{
+  int type = ecl_symbol_type(sym);
+  if (type & (ecl_stp_constant | ecl_stp_special))
+    FEerror("~S is a constant or special variable.", 1, sym);
+  ecl_symbol_type_set(sym, type | ecl_stp_global);
+  cl_remprop(sym, @'si::symbol-macro');
+  @(return sym);
+}
+
+/* FIXME we allow redefining constants with different values. */
 cl_object
 @si::*make-constant(cl_object sym, cl_object val)
 {
   int type = ecl_symbol_type(sym);
-  if (type & ecl_stp_special)
-    FEerror("The argument ~S to DEFCONSTANT is a special variable.",
-            1, sym);
+  if (type & (ecl_stp_special | ecl_stp_global))
+    FEerror("~S is a special or global variable.", 1, sym);
   ecl_symbol_type_set(sym, type | ecl_stp_constant);
   ECL_SET(sym, val);
+  cl_remprop(sym, @'si::symbol-macro');
   @(return sym);
 }
 

src/c/symbols_list.h

@@ -1139,6 +1139,7 @@ cl_symbols[] = {
 {SYS_ "*LOAD-SEARCH-LIST*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
 {SYS_ "*MAKE-CONSTANT" ECL_FUN("si_Xmake_constant", si_Xmake_constant, 2) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "*MAKE-SPECIAL" ECL_FUN("si_Xmake_special", si_Xmake_special, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "*MAKE-GLOBAL" ECL_FUN("si_Xmake_global", si_Xmake_global, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "*PRINT-PACKAGE*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
 {SYS_ "*PRINT-STRUCTURE*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
 {SYS_ "*SHARP-EQ-CONTEXT*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
@@ -1179,6 +1180,7 @@ cl_symbols[] = {
 {EXT_ "COMPILED-FUNCTION-NAME" ECL_FUN("si_compiled_function_name", si_compiled_function_name, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)},
 {SYS_ "COPY-STREAM" ECL_FUN("si_copy_stream", si_copy_stream, 3) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "DESTRUCTURE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{EXT_ "DEFGLOBAL" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)},
 {SYS_ "DO-READ-SEQUENCE" ECL_FUN("si_do_read_sequence", si_do_read_sequence, 4) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "DO-WRITE-SEQUENCE" ECL_FUN("si_do_write_sequence", si_do_write_sequence, 4) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "ELT-SET" ECL_FUN("si_elt_set", si_elt_set, 3) ECL_VAR(SI_ORDINARY, OBJNULL)},
@@ -1285,6 +1287,7 @@ cl_symbols[] = {
 {SYS_ "SIGNAL-SIMPLE-ERROR" ECL_FUN("si_signal_simple_error", si_signal_simple_error, -5) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "SIGNAL-TYPE-ERROR" ECL_FUN("si_signal_type_error", si_signal_type_error, 2) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "SPECIALP" ECL_FUN("si_specialp", si_specialp, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "GLOBALP" ECL_FUN("si_globalp", si_globalp, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "CONSTP" ECL_FUN("si_constp", si_constp, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "STANDARD-READTABLE" ECL_FUN("si_standard_readtable", si_standard_readtable, 0) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "STEPPER" ECL_FUN("OBJNULL", OBJNULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},

src/cmp/proclamations.lsp

@@ -414,6 +414,7 @@
 
 ;; ECL extensions:
 (proclamation si:*make-special (symbol) symbol)
+(proclamation si:*make-global (symbol) symbol)
 (proclamation si:*make-constant (symbol t) symbol)
 (proclamation si:put-f (list t t) list)
 (proclamation si:rem-f (list t) (values list boolean))

src/doc/help.lsp

@@ -259,6 +259,10 @@ its constant value.")
 ECL specific.
 Declares the variable named by NAME as a special variable.")
 
+(docfun si::*make-global function (symbol) "
+ECL specific.
+Declares the variable named by NAME as a global variable.")
+
 (docvar *package* variable "
 The current package.  The initial value is the USER package.")
 

src/h/external.h

@@ -489,7 +489,9 @@ extern ECL_API cl_object cl_class_of(cl_object x);
 /* cmpaux.c */
 
 extern ECL_API cl_object si_specialp(cl_object sym);
+extern ECL_API cl_object si_globalp(cl_object sym);
 extern ECL_API cl_object si_constp(cl_object sym);
+extern ECL_API bool ecl_symbol_unbindable_p(cl_object sym);
 
 extern ECL_API cl_fixnum ecl_ifloor(cl_fixnum x, cl_fixnum y);
 extern ECL_API cl_fixnum ecl_imod(cl_fixnum x, cl_fixnum y);
@@ -577,7 +579,8 @@ extern ECL_API void FEinvalid_macro_call(cl_object obj) ecl_attr_noreturn;
 extern ECL_API void FEinvalid_variable(const char *s, cl_object obj) ecl_attr_noreturn;
 extern ECL_API void FEillegal_variable_name(cl_object) ecl_attr_noreturn;
 extern ECL_API void FEassignment_to_constant(cl_object v) ecl_attr_noreturn;
-extern ECL_API void FEbinding_a_constant(cl_object v) ecl_attr_noreturn;
+extern ECL_API void FEbinding_impossible(cl_object v) ecl_attr_noreturn;
+#define FEbinding_a_constant FEbinding_impossible
 extern ECL_API void FEundefined_function(cl_object fname) ecl_attr_noreturn;
 extern ECL_API void FEinvalid_function(cl_object obj) ecl_attr_noreturn;
 extern ECL_API void FEinvalid_function_name(cl_object obj) ecl_attr_noreturn;
@@ -1720,6 +1723,7 @@ extern ECL_API cl_object si_rem_f(cl_object plist, cl_object indicator);
 extern ECL_API cl_object si_set_symbol_plist(cl_object sym, cl_object plist);
 extern ECL_API cl_object si_putprop(cl_object sym, cl_object value, cl_object indicator);
 extern ECL_API cl_object si_Xmake_special(cl_object sym);
+extern ECL_API cl_object si_Xmake_global(cl_object sym);
 extern ECL_API cl_object si_Xmake_constant(cl_object sym, cl_object val);
 extern ECL_API cl_object cl_get _ECL_ARGS((cl_narg narg, cl_object sym, cl_object indicator, ...));
 extern ECL_API cl_object cl_getf _ECL_ARGS((cl_narg narg, cl_object place, cl_object indicator, ...));

src/h/object.h

@@ -259,8 +259,9 @@ enum ecl_stype {                /*  symbol type  */
         ecl_stp_ordinary = 0,
         ecl_stp_constant = 1,
         ecl_stp_special = 2,
-        ecl_stp_macro = 4,
-        ecl_stp_special_form = 8
+        ecl_stp_global = 4,
+        ecl_stp_macro = 8,
+        ecl_stp_special_form = 16
 };
 
 #define ECL_NIL                 ((cl_object)t_list)

src/lsp/evalmacros.lsp

@@ -34,60 +34,78 @@ last FORM.  If not, simply returns NIL."
        ,@(si::expand-set-documentation name 'function doc-string)
        ',name)))
 
-(defmacro defvar (&whole whole var &optional (form nil form-sp) doc-string)
+(defmacro defvar (&whole whole name &optional (form nil form-sp) doc)
   "Syntax: (defvar name [form [doc]])
 Declares the variable named by NAME as a special variable.  If the variable
 does not have a value, then evaluates FORM and assigns the value to the
 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))
-    (SYS:*MAKE-SPECIAL ',var)
+  `(LOCALLY (DECLARE (SPECIAL ,name))
+    (SYS:*MAKE-SPECIAL ',name)
     ,@(when form-sp
-          `((UNLESS (BOUNDP ',var)
-              (SETQ ,var ,form))))
-    ,@(si::expand-set-documentation var 'variable doc-string)
+          `((UNLESS (BOUNDP ',name)
+              (SETQ ,name ,form))))
+    ,@(si::expand-set-documentation name 'variable doc)
     ,(ext:register-with-pde whole)
     ,(if *bytecodes-compiler*
          `(eval-when (:compile-toplevel)
-            (sys:*make-special ',var))
+            (sys:*make-special ',name))
          `(eval-when (:compile-toplevel)
-            (si::register-global ',var)))
-    ',var))
+            (si::register-global ',name)))
+    ',name))
 
-(defmacro defparameter (&whole whole var form &optional doc-string)
+(defmacro defparameter (&whole whole name form &optional doc)
   "Syntax: (defparameter name form [doc])
-Declares the global variable named by NAME as a special variable and assigns
+Declares the variable named by NAME as a special variable and assigns
 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))
-    (SYS:*MAKE-SPECIAL ',var)
-    (SETQ ,var ,form)
-    ,@(si::expand-set-documentation var 'variable doc-string)
+  `(LOCALLY (DECLARE (SPECIAL ,name))
+    (SYS:*MAKE-SPECIAL ',name)
+    (SETQ ,name ,form)
+    ,@(si::expand-set-documentation name 'variable doc)
     ,(ext:register-with-pde whole)
     ,(if *bytecodes-compiler*
          `(eval-when (:compile-toplevel)
-            (sys:*make-special ',var))
+            (sys:*make-special ',name))
          `(eval-when (:compile-toplevel)
-            (si::register-global ',var)))
-    ',var))
+            (si::register-global ',name)))
+    ',name))
 
-(defmacro defconstant (&whole whole var form &optional doc-string)
-  "Syntax: (defconstant symbol form [doc])
-
-Declares that the global variable named by SYMBOL is a constant with the value
-of FORM as its constant value.  The doc-string DOC, if supplied, is saved as a
-VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)."
+(defmacro ext::defglobal (&whole whole name form &optional doc)
+  "Syntax: (ext:defglobal symbol form [doc])
+Declares the variable named by NAME as a global variable and assigns
+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)."
   `(PROGN
-     (SYS:*MAKE-CONSTANT ',var ,form)
-    ,@(si::expand-set-documentation var 'variable doc-string)
+     (SYS:*MAKE-GLOBAL ',name)
+     (SETQ ,name ,form)
+     ,@(si::expand-set-documentation name 'variable doc)
+     ,(ext:register-with-pde whole)
+     ,(if *bytecodes-compiler*
+          `(eval-when (:compile-toplevel)
+             (sys:*make-global ',name))
+          `(eval-when (:compile-toplevel)
+             (si::register-global ',name)))
+     ',name))
+
+(defmacro defconstant (&whole whole name form &optional doc)
+  "Syntax: (defconstant symbol form [doc])
+Declares the variable named by NAME as a constant variable with the value of
+FORM as its constant value.
+The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be
+retrieved by (DOCUMENTATION 'NAME 'variable)."
+  `(PROGN
+     (SYS:*MAKE-CONSTANT ',name ,form)
+    ,@(si::expand-set-documentation name 'variable doc)
     ,(ext:register-with-pde whole)
     ,(if *bytecodes-compiler*
          `(eval-when (:compile-toplevel)
-            (sys:*make-constant ',var ,form))
+            (sys:*make-constant ',name ,form))
          `(eval-when (:compile-toplevel)
-            (sys:*make-constant ',var ,form)
-            (si::register-global ',var)))
-    ',var))
+            (sys:*make-constant ',name ,form)
+            (si::register-global ',name)))
+    ',name))
 
 (defparameter *defun-inline-hook*
   #'(lambda (fname form)