diff --git a/src/c/assignment.d b/src/c/assignment.d index e18633cbf..81aa4817d 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -34,10 +34,31 @@ cl_set(cl_object var, cl_object value) unlikely_if (ecl_t_of(var) != t_symbol) { FEwrong_type_nth_arg(@[set], 1, var, @[symbol]); } + ecl_return1(env, ecl_cmp_setq(env, var, value)); +} + +cl_object +ecl_setq(cl_env_ptr env, cl_object var, cl_object value) +{ + unlikely_if (Null(var)) { + FEconstant_assignment(var); + } + unlikely_if (ecl_t_of(var) != t_symbol) { + FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); + } + return ecl_cmp_setq(env, var, value); +} + +/* ecl_cmp_setq does the minimal amount of checking necessary to + * implement SETQ for objects that have been checked to be non-null + * symbols by the compiler. */ +cl_object +ecl_cmp_setq(cl_env_ptr env, cl_object var, cl_object value) +{ unlikely_if (var->symbol.stype & ecl_stp_constant) { FEconstant_assignment(var); } - ecl_return1(env, ECL_SETQ(env, var, value)); + return ECL_SETQ(env, var, value); } #ifdef ECL_THREADS @@ -72,18 +93,6 @@ mp_atomic_incf_symbol_value(cl_object var, cl_object increment) } #endif /* ECL_THREADS */ -cl_object -ecl_setq(cl_env_ptr env, cl_object var, cl_object value) -{ - unlikely_if (Null(var)) { - FEconstant_assignment(var); - } - unlikely_if (ecl_t_of(var) != t_symbol) { - FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); - } - return ECL_SETQ(env, var, value); -} - static cl_object unbound_setf_function_error(cl_narg narg, ...) { diff --git a/src/c/compiler.d b/src/c/compiler.d index 93f665b19..24bd2cb5c 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -384,6 +384,7 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * macro-record = (function-name FUNCTION [| function-object]) | * (macro-name si::macro macro-function) | * (:declare name declaration) | + * (compiler-macro-name si::compiler-macro macro-function) | * SI:FUNCTION-BOUNDARY | * SI:UNWIND-PROTECT-BOUNDARY * @@ -680,7 +681,7 @@ c_var_ref(cl_env_ptr env, cl_object var, int allow_symbol_macro, bool ensure_def } } if (ensure_defined) { - l = ecl_symbol_value(@'ext::*action-on-undefined-variable*'); + l = ecl_cmp_symbol_value(env, @'ext::*action-on-undefined-variable*'); if (l != ECL_NIL) { funcall(3, l, undefined_variable, var); } @@ -3241,7 +3242,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { c_undo_bindings(env, old_c_env->variables, 1); asm_op(env, OP_EXIT); - if (Null(ecl_symbol_value(@'si::*keep-definitions*'))) + if (Null(ecl_cmp_symbol_value(env, @'si::*keep-definitions*'))) lambda = ECL_NIL; output = asm_end(env, handle, lambda); output->bytecodes.name = name; diff --git a/src/c/format.d b/src/c/format.d index 013a3f0c8..9dc5aff56 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -2194,7 +2194,7 @@ format(format_stack fmt, cl_index start, cl_index end) #endif null_strm = 1; } else if (strm == ECL_T) { - strm = ecl_symbol_value(@'*standard-output*'); + strm = ecl_cmp_symbol_value(the_env, @'*standard-output*'); } if (ecl_stringp(strm)) { output = strm; diff --git a/src/c/load.d b/src/c/load.d index 88e08fb56..3b5efe069 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -45,7 +45,7 @@ si_load_binary(cl_object filename, cl_object verbose, goto GO_ON; /* Next try to call "init_FILE()" where FILE is the file name */ - prefix = ecl_symbol_value(@'si::*init-function-prefix*'); + prefix = ecl_cmp_symbol_value(the_env, @'si::*init-function-prefix*'); init_prefix = _ecl_library_init_prefix(); if (Null(prefix)) { prefix = init_prefix; @@ -200,11 +200,11 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec } @(defun load (source - &key (verbose ecl_symbol_value(@'*load-verbose*')) - (print ecl_symbol_value(@'*load-print*')) + &key (verbose ecl_cmp_symbol_value(the_env, @'*load-verbose*')) + (print ecl_cmp_symbol_value(the_env, @'*load-print*')) (if_does_not_exist @':error') (external_format @':default') - (search_list ecl_symbol_value(@'si::*load-search-list*')) + (search_list ecl_cmp_symbol_value(the_env, @'si::*load-search-list*')) &aux pathname pntype hooks filename function ok file_kind) bool not_a_filename = 0; @ @@ -222,7 +222,7 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec pntype = pathname->pathname.type; filename = ECL_NIL; - hooks = ecl_symbol_value(@'ext::*load-hooks*'); + hooks = ecl_cmp_symbol_value(the_env, @'ext::*load-hooks*'); if (Null(pathname->pathname.directory) && Null(pathname->pathname.host) && Null(pathname->pathname.device) && @@ -284,8 +284,8 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec cl_format(3, ECL_T, @"~&;;; Loading ~s~%", filename); } - ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*')); - ecl_bds_bind(the_env, @'*readtable*', ecl_symbol_value(@'*readtable*')); + ecl_bds_bind(the_env, @'*package*', ecl_cmp_symbol_value(the_env, @'*package*')); + ecl_bds_bind(the_env, @'*readtable*', ecl_cmp_symbol_value(the_env, @'*readtable*')); ecl_bds_bind(the_env, @'*load-pathname*', not_a_filename? ECL_NIL : source); ecl_bds_bind(the_env, @'*load-truename*', not_a_filename? ECL_NIL : (filename = cl_truename(filename))); diff --git a/src/c/macros.d b/src/c/macros.d index e9ce12677..5dff42ccb 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -68,7 +68,6 @@ search_macro_function(cl_object name, cl_object env) return CADDR(record); if (tag == @'function') return ECL_NIL; - break; } } } @@ -102,7 +101,7 @@ search_macro_function(cl_object name, cl_object env) exp_fun = search_macro_function(head, env); } if (!Null(exp_fun)) { - cl_object hook = ecl_symbol_value(@'*macroexpand-hook*'); + cl_object hook = ecl_cmp_symbol_value(the_env, @'*macroexpand-hook*'); if (hook == @'funcall') form = _ecl_funcall3(exp_fun, form, env); else diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 5da8db4cb..afb2b3ee6 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -320,7 +320,7 @@ ecl_make_random_state(cl_object rs) return z; } -@(defun random (x &optional (rs ecl_symbol_value(@'*random-state*'))) +@(defun random (x &optional (rs ecl_cmp_symbol_value(the_env, @'*random-state*'))) @ rs = ecl_check_cl_type(@'random', rs, t_random); @(return rando(x, rs)); diff --git a/src/c/package.d b/src/c/package.d index aa00c51b4..e6d6e3238 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -378,9 +378,9 @@ si_coerce_to_package(cl_object p) cl_object ecl_current_package(void) { - cl_object x = ecl_symbol_value(@'*package*'); + const cl_env_ptr env = ecl_process_env(); + cl_object x = ecl_cmp_symbol_value(env, @'*package*'); unlikely_if (!ECL_PACKAGEP(x)) { - const cl_env_ptr env = ecl_process_env(); ECL_SETQ(env, @'*package*', cl_core.user_package); FEerror("The value of *PACKAGE*, ~S, was not a package", 1, x); diff --git a/src/c/pathname.d b/src/c/pathname.d index efeca5cab..3f1c93a66 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -724,9 +724,9 @@ si_default_pathname_defaults(void) * coerced to type PATHNAME. Special care is taken so that we do * not enter an infinite loop when using PARSE-NAMESTRING, because * this routine might itself try to use the value of this variable. */ - cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object path = ecl_cmp_symbol_value(the_env, @'*default-pathname-defaults*'); unlikely_if (!ECL_PATHNAMEP(path)) { - const cl_env_ptr the_env = ecl_process_env(); ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*], path, @'pathname'); diff --git a/src/c/print.d b/src/c/print.d index db60fed08..1b2464f22 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -29,10 +29,11 @@ _ecl_stream_or_default_output(cl_object stream) int ecl_print_base(void) { - cl_object object = ecl_symbol_value(@'*print-base*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object object = ecl_cmp_symbol_value(the_env, @'*print-base*'); cl_fixnum base; unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { - ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); + ECL_SETQ(the_env, @'*print-base*', ecl_make_fixnum(10)); FEerror("The value of *PRINT-BASE*~% ~S~%" "is not of the expected type (INTEGER 2 36)", 1, object); } @@ -42,14 +43,15 @@ ecl_print_base(void) cl_fixnum ecl_print_level(void) { - cl_object object = ecl_symbol_value(@'*print-level*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object object = ecl_cmp_symbol_value(the_env, @'*print-level*'); cl_fixnum level; if (object == ECL_NIL) { level = MOST_POSITIVE_FIXNUM; } else if (ECL_FIXNUMP(object)) { level = ecl_fixnum(object); if (level < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); + ERROR: ECL_SETQ(the_env, @'*print-level*', ECL_NIL); FEerror("The value of *PRINT-LEVEL*~% ~S~%" "is not of the expected type (OR NULL (INTEGER 0 *))", 1, object); @@ -65,14 +67,15 @@ ecl_print_level(void) cl_fixnum ecl_print_length(void) { - cl_object object = ecl_symbol_value(@'*print-length*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object object = ecl_cmp_symbol_value(the_env, @'*print-length*'); cl_fixnum length; if (object == ECL_NIL) { length = MOST_POSITIVE_FIXNUM; } else if (ECL_FIXNUMP(object)) { length = ecl_fixnum(object); unlikely_if (length < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); + ERROR: ECL_SETQ(the_env, @'*print-length*', ECL_NIL); FEerror("The value of *PRINT-LENGTH*~% ~S~%" "is not of the expected type (OR NULL (INTEGER 0 *))", 1, object); @@ -94,12 +97,13 @@ ecl_print_radix(void) cl_object ecl_print_case(void) { - cl_object output = ecl_symbol_value(@'*print-case*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object output = ecl_cmp_symbol_value(the_env, @'*print-case*'); unlikely_if (output != @':upcase' && output != @':downcase' && output != @':capitalize') { - ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); + ECL_SETQ(the_env, @'*print-case*', @':downcase'); FEerror("The value of *PRINT-CASE*~% ~S~%" "is not of the expected type " "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output); @@ -139,21 +143,21 @@ ecl_print_circle(void) @(defun write (x &key ((:stream strm) ECL_NIL) - (array ecl_symbol_value(@'*print-array*')) - (base ecl_symbol_value(@'*print-base*')) - ((:case cas) ecl_symbol_value(@'*print-case*')) - (circle ecl_symbol_value(@'*print-circle*')) - (escape ecl_symbol_value(@'*print-escape*')) - (gensym ecl_symbol_value(@'*print-gensym*')) - (length ecl_symbol_value(@'*print-length*')) - (level ecl_symbol_value(@'*print-level*')) - (lines ecl_symbol_value(@'*print-lines*')) - (miser_width ecl_symbol_value(@'*print-miser-width*')) - (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) - (pretty ecl_symbol_value(@'*print-pretty*')) - (radix ecl_symbol_value(@'*print-radix*')) - (readably ecl_symbol_value(@'*print-readably*')) - (right_margin ecl_symbol_value(@'*print-right-margin*'))) + (array ecl_cmp_symbol_value(the_env, @'*print-array*')) + (base ecl_cmp_symbol_value(the_env, @'*print-base*')) + ((:case cas) ecl_cmp_symbol_value(the_env, @'*print-case*')) + (circle ecl_cmp_symbol_value(the_env, @'*print-circle*')) + (escape ecl_cmp_symbol_value(the_env, @'*print-escape*')) + (gensym ecl_cmp_symbol_value(the_env, @'*print-gensym*')) + (length ecl_cmp_symbol_value(the_env, @'*print-length*')) + (level ecl_cmp_symbol_value(the_env, @'*print-level*')) + (lines ecl_cmp_symbol_value(the_env, @'*print-lines*')) + (miser_width ecl_cmp_symbol_value(the_env, @'*print-miser-width*')) + (pprint_dispatch ecl_cmp_symbol_value(the_env, @'*print-pprint-dispatch*')) + (pretty ecl_cmp_symbol_value(the_env, @'*print-pretty*')) + (radix ecl_cmp_symbol_value(the_env, @'*print-radix*')) + (readably ecl_cmp_symbol_value(the_env, @'*print-readably*')) + (right_margin ecl_cmp_symbol_value(the_env, @'*print-right-margin*'))) @ ecl_bds_bind(the_env, @'*print-array*', array); ecl_bds_bind(the_env, @'*print-base*', base); diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d index e6559a297..1a8a0d614 100644 --- a/src/c/printer/write_object.d +++ b/src/c/printer/write_object.d @@ -19,8 +19,9 @@ bool _ecl_will_print_as_hash(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object circle_counter = ecl_cmp_symbol_value(the_env, @'si::*circle-counter*'); + cl_object circle_stack = ecl_cmp_symbol_value(the_env, @'si::*circle-stack*'); cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); if (ECL_FIXNUMP(circle_counter)) { return !(code == OBJNULL || code == ECL_NIL); @@ -44,8 +45,9 @@ _ecl_will_print_as_hash(cl_object x) cl_object si_search_print_circle(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object circle_counter = ecl_cmp_symbol_value(the_env, @'si::*circle-counter*'); + cl_object circle_stack = ecl_cmp_symbol_value(the_env, @'si::*circle-stack*'); cl_object code; code = ecl_gethash_safe(x, circle_stack, OBJNULL); @@ -69,8 +71,7 @@ si_search_print_circle(cl_object x) /* This object is referenced twice, but has no code yet */ circle_counter = ecl_make_fixnum(ecl_fixnum(circle_counter) + 1); _ecl_sethash(x, circle_stack, circle_counter); - ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', - circle_counter); + ECL_SETQ(the_env, @'si::*circle-counter*', circle_counter); return ecl_make_fixnum(-ecl_fixnum(circle_counter)); } else { return code; @@ -89,9 +90,9 @@ si_write_object_with_circle(cl_object x, cl_object stream, cl_object print_funct possibly contain cycles */ cl_object circle_counter; cl_fixnum code; - circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + const cl_env_ptr env = ecl_process_env(); + circle_counter = ecl_cmp_symbol_value(env, @'si::*circle-counter*'); if (circle_counter == ECL_NIL) { - cl_env_ptr env = ecl_process_env(); cl_object hash = cl__make_hash_table(@'eq', ecl_make_fixnum(1024), diff --git a/src/c/read.d b/src/c/read.d index 6af306d83..cdeb392c5 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1023,7 +1023,7 @@ sharp_dot_reader(cl_object in, cl_object c, cl_object d) if (read_suppress) { @(return ECL_NIL); } - unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) + unlikely_if (ecl_cmp_symbol_value(env, @'*read-eval*') == ECL_NIL) FEreader_error("Cannot evaluate the form #.~A", in, 1, c); /* FIXME! We should do something here to ensure that the #. * only uses the #n# that have been defined */ diff --git a/src/c/symbol.d b/src/c/symbol.d index 79e3cdff0..b55d83c6c 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -136,6 +136,21 @@ ecl_make_symbol(const char *s, const char *p) cl_object ecl_symbol_value(cl_object s) +{ + if (ecl_unlikely(Null(s))) { + return s; + } + if (ecl_unlikely(ecl_t_of(s) != t_symbol)) { + FEwrong_type_nth_arg(@[symbol-value], 1, s, @[symbol]); + } + return ecl_cmp_symbol_value(ecl_process_env(), s); +} + +/* ecl_cmp_symbol_value does the minimal amount of checking necessary + * to implement SYMBOL-VALUE for objects that have been checked to be + * non-null symbols by the compiler. */ +cl_object +ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s) { #ifndef ECL_FINAL /* Symbols are not initialized yet. This test is issued only during ECL @@ -144,16 +159,12 @@ ecl_symbol_value(cl_object s) ecl_internal_error("SYMBOL-VALUE: symbols are not initialized yet."); } #endif - if (Null(s)) { - return s; - } else { - /* FIXME: Should we check symbol type? */ - const cl_env_ptr the_env = ecl_process_env(); - cl_object value = ECL_SYM_VAL(the_env, s); - unlikely_if (value == OBJNULL) - FEunbound_variable(s); - return value; + /* FIXME: Should we check symbol type? */ + cl_object value = ECL_SYM_VAL(the_env, s); + if (ecl_unlikely(value == OBJNULL)) { + FEunbound_variable(s); } + return value; } static void @@ -171,9 +182,6 @@ ecl_getf(cl_object place, cl_object indicator, cl_object deflt) { cl_object l; -#ifdef ECL_SAFE - assert_type_proper_list(place); -#endif for (l = place; CONSP(l); ) { cl_object cdr_l = ECL_CONS_CDR(l); if (!CONSP(cdr_l)) @@ -203,9 +211,6 @@ si_put_f(cl_object place, cl_object value, cl_object indicator) { cl_object l; -#ifdef ECL_SAFE - assert_type_proper_list(place); -#endif /* This loop guarantees finishing for circular lists */ for (l = place; CONSP(l); ) { cl_object cdr_l = ECL_CONS_CDR(l); @@ -295,9 +300,6 @@ cl_get_properties(cl_object place, cl_object indicator_list) const cl_env_ptr the_env = ecl_process_env(); cl_object l; -#ifdef ECL_SAFE - assert_type_proper_list(place); -#endif for (l = place; CONSP(l); ) { cl_object cdr_l = ECL_CONS_CDR(l); if (!CONSP(cdr_l)) diff --git a/src/c/threads/barrier.d b/src/c/threads/barrier.d index 3aaaf39d3..8a3d8a09c 100755 --- a/src/c/threads/barrier.d +++ b/src/c/threads/barrier.d @@ -149,9 +149,9 @@ mp_barrier_wait(cl_object barrier) { barrier->barrier.arrivers_count++; ECL_UNWIND_PROTECT_BEGIN(the_env) { do { - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); ecl_cond_var_wait(&barrier->barrier.cv, &barrier->barrier.mutex); - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); } while(!barrier->barrier.wakeup); wakeup = barrier->barrier.wakeup; if (barrier->barrier.arrivers_count - 1 == 0) { diff --git a/src/c/threads/process.d b/src/c/threads/process.d index b9bd18b00..96ef852b5 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -765,7 +765,7 @@ mp_block_signals(void) { #ifdef ECL_WINDOWS_THREADS cl_env_ptr the_env = ecl_process_env(); - cl_object previous = ecl_symbol_value(@'ext::*interrupts-enabled*'); + cl_object previous = ecl_cmp_symbol_value(the_env, @'ext::*interrupts-enabled*'); ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); @(return previous); #else diff --git a/src/c/threads/semaphore.d b/src/c/threads/semaphore.d index a8b542722..75cc973b3 100644 --- a/src/c/threads/semaphore.d +++ b/src/c/threads/semaphore.d @@ -92,9 +92,9 @@ semaphore_wait_unprotected(cl_object semaphore, cl_object count, cl_object timeo ecl_cond_var_t *cv = &semaphore->semaphore.cv; if (timeout == ECL_NIL) { do { - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_T); ecl_cond_var_wait(cv, mutex); - ecl_setq(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); } while (semaphore->semaphore.counter < counter); } else { cl_object deadline = ecl_plus(cl_get_internal_real_time(), diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp index 23baf92ec..da97389ad 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp @@ -105,16 +105,13 @@ (setf *tail-recursion-info* (cons *tail-recursion-info* requireds)) (setf *tail-recursion-info* nil)) - ;; check arguments - (when (policy-check-nargs) - (if (and use-narg (not varargs)) - (wt-nl "if (ecl_unlikely(narg!=" nreq ")) FEwrong_num_arguments_anonym();") - (when varargs - (when requireds - (wt-nl "if (ecl_unlikely(narg<" nreq ")) FEwrong_num_arguments_anonym();")) - (unless (or rest key-flag allow-other-keys) - (wt-nl "if (ecl_unlikely(narg>" (+ nreq nopt) ")) FEwrong_num_arguments_anonym();")))) - (open-inline-block)) + ;; check number of arguments + (wt-maybe-check-num-arguments use-narg + nreq + (if (or rest key-flag allow-other-keys) + nil + (+ nreq nopt)) + fname) ;; If the number of required arguments exceeds the number of variables we ;; want to pass on the C stack, we pass some of the arguments to the list @@ -286,3 +283,21 @@ (c2expr body) (close-inline-blocks)) + +(defun wt-maybe-check-num-arguments (use-narg minarg maxarg fname) + (when (and (policy-check-nargs) use-narg) + (flet ((wrong-num-arguments () + (if fname + (wt " FEwrong_num_arguments(" (add-symbol fname) ");") + (wt " FEwrong_num_arguments_anonym();")))) + (if (and maxarg (= minarg maxarg)) + (progn (wt-nl "if (ecl_unlikely(narg!=" minarg "))") + (wrong-num-arguments)) + (progn + (when (plusp minarg) + (wt-nl "if (ecl_unlikely(narg<" minarg "))") + (wrong-num-arguments)) + (when maxarg + (wt-nl "if (ecl_unlikely(narg>" maxarg "))") + (wrong-num-arguments))))) + (open-inline-block))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index 3d924b528..af4a3afe1 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -357,14 +357,14 @@ (LEXICAL (wt-lex var-loc)) ((SPECIAL GLOBAL) (if (safe-compile) - (wt "ecl_symbol_value(" var-loc ")") + (wt "ecl_cmp_symbol_value(cl_env_copy," var-loc ")") (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) (t (wt var-loc)) ))) (defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb (unless (var-p var) - (baboon :format-control "set-var: ~s is not a vairable." + (baboon :format-control "set-var: ~s is not a variable." :format-arguments (list var))) (case (var-kind var) (CLOSURE @@ -377,7 +377,7 @@ (wt #\;)) ((SPECIAL GLOBAL) (if (safe-compile) - (wt-nl "cl_set(" var-loc ",") + (wt-nl "ecl_cmp_setq(cl_env_copy," var-loc ",") (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) (wt-coerce-loc (var-rep-type var) loc) (wt ");")) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 8f4aed3fe..2253d7b62 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -93,6 +93,11 @@ that are susceptible to be changed by PROCLAIM." (cmp-env-variables env)) env) +(defun cmp-env-register-compiler-macro (name macro-function) + (push (list name 'si::compiler-macro macro-function) + (cmp-env-functions *cmp-env-root*)) + (values)) + (defun cmp-env-search-function (name &optional (env *cmp-env*)) (let ((cfb nil) (unw nil) @@ -106,7 +111,7 @@ that are susceptible to be changed by PROCLAIM." (baboon :format-control "Unknown record found in environment~%~S" :format-arguments (list record))) ;; We have to use EQUAL because the name can be a list (SETF whatever) - ((equal (first record) name) + ((and (equal (first record) name) (not (eq (second record) 'si::compiler-macro))) (setf found (first (last record))) (return)))) (values found cfb unw))) @@ -166,6 +171,17 @@ that are susceptible to be changed by PROCLAIM." (or (cmp-env-search-macro name) (macro-function name))) +(defun cmp-env-search-compiler-macro (name &optional (env *cmp-env*)) + (dolist (record (cmp-env-functions env)) + (when (and (consp record) + (equal (first record) name) + (eq (second record) 'si::compiler-macro)) + (return-from cmp-env-search-compiler-macro (third record))))) + +(defun cmp-compiler-macro-function (name) + (or (cmp-env-search-compiler-macro name) + (compiler-macro-function name))) + (defun cmp-env-search-ftype (name &optional (env *cmp-env*)) (dolist (i env nil) (when (and (consp i) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index cdf7e9c95..6e76b7e12 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -297,6 +297,7 @@ from the C language code. NIL means \"do not create the file\"." (let ((*compiler-output1* *standard-output*)) (apply t3local-fun args)))) (compiler-pass1 disassembled-form) + (compiler-pass/propagate-types) (ctop-write (compute-init-name "foo" :kind :fasl) (if h-file h-file "") (if data-file data-file "")) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index e4aafaaaf..15043babe 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -177,7 +177,7 @@ (setq fd (cmp-env-search-macro fname))) (cmp-expand-macro fd (list* fname args))) ((and (setq can-inline (inline-possible fname)) - (setq fd (compiler-macro-function fname)) + (setq fd (cmp-compiler-macro-function fname)) (progn (multiple-value-setq (fd success) (cmp-expand-compiler-macro fd fname args)) diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index 22f6df3ca..6d18e089e 100644 --- a/src/cmp/cmppass1-top.lsp +++ b/src/cmp/cmppass1-top.lsp @@ -43,7 +43,7 @@ (funcall fd args)) ((gethash fun *c1-dispatch-table*) (t1ordinary form)) - ((and (setq fd (compiler-macro-function fun)) + ((and (setq fd (cmp-compiler-macro-function fun)) (inline-possible fun) (let ((success nil)) (multiple-value-setq (fd success) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 9e337f308..45d000868 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -79,7 +79,7 @@ (defun trivial-type-p (type) (subtypep T type)) -(defun-equal-cached type-and (t1 t2) +(defun-cached type-and (t1 t2) type-specifier= ;; FIXME! Should we allow "*" as type name??? (when (or (eq t1 t2) (eq t2 '*)) (return-from type-and t1)) @@ -128,7 +128,7 @@ (let ((l (1- (length type)))) (values l l))))) -(defun-equal-cached values-type-primary-type (type) +(defun-cached values-type-primary-type (type) type-specifier= ;; Extract the type of the first value returned by this form. We are ;; pragmatic and thus (VALUES) => NULL [CHECKME!] (let (aux) @@ -144,7 +144,7 @@ (t aux)))) -(defun-equal-cached values-type-to-n-types (type length) +(defun-cached values-type-to-n-types (type length) type-specifier= (when (plusp length) (do-values-type-to-n-types type length))) @@ -195,7 +195,7 @@ (return (values (nreverse required) (nreverse optional) rest a-o-k))))) -(defun-equal-cached values-type-or (t1 t2) +(defun-cached values-type-or (t1 t2) type-specifier= (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) (return-from values-type-or t2)) (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) @@ -241,7 +241,7 @@ ,@(and opt (cons '&optional (nreverse opt))) ,@(and rest (cons '&optional rest))))))) -(defun-equal-cached values-type-and (t1 t2) +(defun-cached values-type-and (t1 t2) type-specifier= (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) (return-from values-type-and t1)) (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) @@ -277,7 +277,7 @@ ,@(and opt (cons '&optional (nreverse opt))) ,@(and rest (cons '&optional rest))))))) -(defun-equal-cached type-or (t1 t2) +(defun-cached type-or (t1 t2) type-specifier= ;; FIXME! Should we allow "*" as type name??? (when (or (eq t1 t2) (eq t2 '*)) (return-from type-or t1)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index c65412987..77c127f42 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -436,6 +436,24 @@ comparing circular objects." (equal-recursive (cdr x) (cdr y) x0 y0 t (ash path-spec 1) (the fixnum (1+ n)))))))) (equal-recursive x y nil nil t 0 -1))) +(defun type-specifier= (x y) + "Compares two type specifiers for syntactic equality." + ;; This function only checks if the arguments have the same name + ;; (and arguments in case of compound type specifiers) but not if + ;; they are aliases of each other. For example (OR REAL COMPLEX) and + ;; NUMBER are considered different by this function but are of + ;; course semantically equivalent. + ;; + ;; Note that type specifiers cannot be compared with EQUAL since in + ;; eql and member types the arguments have to compared using EQL. + (if (and (consp x) (consp y)) + (if (and (member (first x) '(eql member)) + (member (first y) '(eql member))) + (every #'eql x y) + (and (type-specifier= (car x) (car y)) + (type-specifier= (cdr x) (cdr y)))) + (eql x y))) + ;; ---------------------------------------------------------------------- ;; CACHED FUNCTIONS ;; @@ -447,7 +465,7 @@ comparing circular objects." (hash-function (case test (EQ 'SI::HASH-EQ) (EQL 'SI::HASH-EQL) - ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL) + ((EQUAL EQUAL-WITH-CIRCULARITY TYPE-SPECIFIER=) 'SI::HASH-EQUAL) (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) `(progn (defvar ,cache-name @@ -469,8 +487,5 @@ comparing circular objects." (setf (aref ,cache-name hash) (list ,@lambda-list output)) output)))))))) -(defmacro defun-equal-cached (name lambda-list &body body) - `(defun-cached ,name ,lambda-list equal-with-circularity ,@body)) - (defun same-fname-p (name1 name2) (equal name1 name2)) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 849258d6c..8108fd479 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -180,10 +180,10 @@ (proclamation compile (function-name &optional (or list function)) (values (or function-name function) gen-bool gen-bool)) (proclamation compiler-macro-function (function-name &optional environment) - function) + (or function null)) (proclamation constantp (t &optional environment) gen-bool) (proclamation eval (form) (values &rest t)) -(proclamation macro-function (symbol &optional environment) function) +(proclamation macro-function (symbol &optional environment) (or function null)) (proclamation macroexpand (form &optional environment) (values form gen-bool)) (proclamation macroexpand-1 (form &optional environment) (values form gen-bool)) (proclamation proclaim (declaration-specifier) (values &rest t)) diff --git a/src/h/config-internal.h.in b/src/h/config-internal.h.in index 7a6228fb9..e7fcdd59b 100644 --- a/src/h/config-internal.h.in +++ b/src/h/config-internal.h.in @@ -28,9 +28,6 @@ /* Allow loading dynamically linked code */ #undef ENABLE_DLOPEN -/* Undefine this if you do not want ECL to check for circular lists */ -#define ECL_SAFE - /* Activate Boehm-Weiser incremental garbage collector */ #undef GBC_BOEHM_GENGC diff --git a/src/h/external.h b/src/h/external.h index 8638a8eeb..3ad3ce805 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1733,7 +1733,9 @@ extern ECL_API void ecl_defparameter(cl_object s, cl_object v); extern ECL_API cl_object ecl_make_symbol(const char *s, const char*p); extern ECL_API cl_object ecl_make_keyword(const char *s); extern ECL_API cl_object ecl_symbol_value(cl_object s); +extern ECL_API cl_object ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s); extern ECL_API cl_object ecl_setq(cl_env_ptr env, cl_object var, cl_object value); +extern ECL_API cl_object ecl_cmp_setq(cl_env_ptr env, cl_object var, cl_object value); extern ECL_API cl_object ecl_symbol_name(cl_object s); extern ECL_API cl_object ecl_symbol_package(cl_object s); extern ECL_API int ecl_symbol_type(cl_object s); diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 9bf0c456f..763608e95 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -129,6 +129,9 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (print function) (setq function `(si::bc-disassemble ,function))) `(progn + ,(unless *bytecodes-compiler* + `(eval-when (:compile-toplevel) + (c::cmp-env-register-compiler-macro ',name ,function))) (put-sysprop ',name 'sys::compiler-macro ,function) ,@(si::expand-set-documentation name 'compiler-macro doc-string) ,(ext:register-with-pde whole)