diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 59027bc1140ae2ed2da67bfba0217a65314e3fd5..65b67b77cd66ec2f2c7936182a8d1d163fd74119 100644 --- a/src/c/all_symbols.d +++ b/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; } diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index 331d5cfd571ac76a3403d6cb7f1cd165558b2db3..40d5248d94877077e8fd8f3c9c8d9b4647dca33e 100644 --- a/src/c/cmpaux.d +++ b/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) { diff --git a/src/c/compiler.d b/src/c/compiler.d index 9be698e234a83c97334338bbdeadbdca647e044d..5d00594fbc46e6f2f6bd7c23f3a5d034d0f04bbc 100644 --- a/src/c/compiler.d +++ b/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; diff --git a/src/c/error.d b/src/c/error.d index bd7d7965fc0ebfffccb8de7ef5155faea474d994..6f20f5cbf7d4ef0fa97d859c5a278f53ac5da8ff 100644 --- a/src/c/error.d +++ b/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 diff --git a/src/c/package.d b/src/c/package.d index aa00c51b46c7cfa0e83889aa84f6699e7e7d5cfe..2105e8bcc90fab4978d1ccfeaff639a04114f514 100644 --- a/src/c/package.d +++ b/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; } diff --git a/src/c/stacks.d b/src/c/stacks.d index 7cefe8cf3f4b7725e5f7be46c02e552b7a0a6d38..2332b1acc223dfbac9328449281b97b7fb4fc8fc 100644 --- a/src/c/stacks.d +++ b/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 { diff --git a/src/c/symbol.d b/src/c/symbol.d index a1000709a723278c18f80b99496ad1cb2ff43f60..55988785922a79ecceda1881fcc8a4bbd87355f6 100644 --- a/src/c/symbol.d +++ b/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); } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 5379959ac34e92f27f7f3ad326b50b669310097a..479edad7168a2562e82736011bb75a90819909f4 100644 --- a/src/c/symbols_list.h +++ b/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)}, diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 849258d6cd84f84ea350424f6664f0a8240bee21..2ef6d6d94f2a467f14db15e323b5e67cb95c43d8 100644 --- a/src/cmp/proclamations.lsp +++ b/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)) diff --git a/src/doc/help.lsp b/src/doc/help.lsp index 6ff8608edfaec810bcb06b93b897e3aa1b461438..ad79932463a657f878914e2c07a182aa5d84a3af 100644 --- a/src/doc/help.lsp +++ b/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.") diff --git a/src/h/external.h b/src/h/external.h index 8638a8eebb02c10ed7ca52e1bcb80c88a50c3cf9..b7df722ba6150d3b150552e5b936ecc960488c64 100755 --- a/src/h/external.h +++ b/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, ...)); diff --git a/src/h/object.h b/src/h/object.h index 915cd2604de64b4fff339355f2b5cb323618759b..17e9897bcefb092edaf607cf1878908df455e768 100644 --- a/src/h/object.h +++ b/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) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 9bf0c456f8f232b345448eaa29c0c0c37ccc7ee7..2581746993c83e3668b9d300c88f3c3a471ec955 100644 --- a/src/lsp/evalmacros.lsp +++ b/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)) - -(defmacro defconstant (&whole whole var form &optional doc-string) + (si::register-global ',name))) + ',name)) + +(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-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 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)." +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 ',var ,form) - ,@(si::expand-set-documentation var 'variable doc-string) + (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)