mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 09:20:23 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'various-compiler-improvements' into develop

Browse source
This commit is contained in:
Daniel Kochmański 2023-10-30 12:02:50 +01:00
commit 2eb24b09d7
27 changed files with 181 additions and 116 deletions
Download patch file Download diff file Expand all files Collapse all files

35
src/c/assignment.d
View file

@ -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, ...)
{

5
src/c/compiler.d
View file

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

2
src/c/format.d
View file

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

14
src/c/load.d
View file

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

3
src/c/macros.d
View file

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

2
src/c/num_rand.d
View file

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

4
src/c/package.d
View file

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

4
src/c/pathname.d
View file

@ -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');

50
src/c/print.d
View file

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

17
src/c/printer/write_object.d
View file

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

2
src/c/read.d
View file

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

38
src/c/symbol.d
View file

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

4
src/c/threads/barrier.d
View file

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

2
src/c/threads/process.d
View file

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

4
src/c/threads/semaphore.d
View file

@ -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(),

35
src/cmp/cmpbackend-cxx/cmppass2-fun.lsp
View file

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

6
src/cmp/cmpbackend-cxx/cmppass2-var.lsp
View file

@ -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 ");"))

18
src/cmp/cmpenv-api.lsp
View file

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

1
src/cmp/cmpmain.lsp
View file

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

2
src/cmp/cmppass1-call.lsp
View file

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

2
src/cmp/cmppass1-top.lsp
View file

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

12
src/cmp/cmptype-arith.lsp
View file

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

23
src/cmp/cmputil.lsp
View file

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

4
src/cmp/proclamations.lsp
View file

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

3
src/h/config-internal.h.in
View file

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

2
src/h/external.h
View file

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

3
src/lsp/evalmacros.lsp
View file

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