Commit 6b76d155 authored by jjgarcia's avatar jjgarcia

Create new functions SI::{GET,PUT,REM}-SYSPROP to handle vital information

about functions, SETF forms, DEFTYPEs, etc. Property lists are no longer
used for this task.
parent d8300559
......@@ -1335,6 +1335,12 @@ ECLS 0.9
- Implemented type EXTENDED-CHAR.
- Property lists are no longer used to store vital
information. Things like SETF expansions, DEFTYPEs, etc, are now
stored and retrieved using SI::{GET,PUT,REM}-SYSPROP. The current
implementation is based on a hash table, which means that some
symbols may not be garbage collected.
TODO:
=====
......
......@@ -33,20 +33,26 @@ setf_namep(cl_object fun_spec)
int intern_flag;
if (CONSP(fun_spec) && !endp(cdr = CDR(fun_spec)) &&
endp(CDR(cdr)) && CAR(fun_spec) == @'setf') {
cl_object sym, fn_name = CAR(cdr);
cl_object fn_str = fn_name->symbol.name;
cl_index l = fn_str->string.fillp + 7;
cl_object string = cl_alloc_simple_string(l);
char *str = string->string.self;
strncpy(str, "(SETF ", 6);
strncpy(str + 6, fn_str->string.self, fn_str->string.fillp);
str[l-1] = ')';
if (fn_name->symbol.hpack == Cnil)
sym = make_symbol(string);
else
sym = intern(string, fn_name->symbol.hpack, &intern_flag);
return(sym);
} else return(OBJNULL);
cl_object sym, fn_name = CAR(cdr);
sym = si_get_sysprop(fn_name, @'si::setf-symbol');
if (sym == Cnil) {
cl_object fn_str = fn_name->symbol.name;
cl_index l = fn_str->string.fillp + 7;
cl_object string = cl_alloc_simple_string(l);
char *str = string->string.self;
strncpy(str, "(SETF ", 6);
strncpy(str + 6, fn_str->string.self, fn_str->string.fillp);
str[l-1] = ')';
if (fn_name->symbol.hpack == Cnil)
sym = make_symbol(string);
else
sym = intern(string, fn_name->symbol.hpack, &intern_flag);
si_put_sysprop(fn_name, @'si::setf-symbol', sym);
}
return(sym);
} else {
return(OBJNULL);
}
}
cl_object
......@@ -70,10 +76,10 @@ si_setf_namep(cl_object arg)
if (mflag)
FEerror("Cannot define a macro with name (SETF ~S).", 1, fun);
fun = CADR(fun);
si_putprop(fun, sym, @'si::setf-symbol');
cl_remprop(fun, @'si::setf-lambda');
cl_remprop(fun, @'si::setf-method');
cl_remprop(fun, @'si::setf-update');
si_put_sysprop(fun, @'si::setf-symbol', sym);
si_rem_sysprop(fun, @'si::setf-lambda');
si_rem_sysprop(fun, @'si::setf-method');
si_rem_sysprop(fun, @'si::setf-update');
fun = sym;
}
if (fun->symbol.isform && !mflag)
......@@ -94,7 +100,7 @@ si_setf_namep(cl_object arg)
}
fun->symbol.mflag = !Null(macro);
if (pprint != Cnil)
si_putprop(fun, pprint, @'si::pretty-print-format');
si_put_sysprop(fun, @'si::pretty-print-format', pprint);
@(return fun)
@)
......@@ -152,10 +158,46 @@ record_source_pathname(cl_object sym, cl_object def)
}
#endif /* PDE */
static cl_object system_properties = OBJNULL;
cl_object
si_get_sysprop(cl_object sym, cl_object prop)
{
cl_object plist = gethash_safe(sym, system_properties, Cnil);
@(return ecl_getf(plist, prop, Cnil));
}
cl_object
si_put_sysprop(cl_object sym, cl_object prop, cl_object value)
{
cl_object plist;
assert_type_symbol(sym);
plist = gethash_safe(sym, system_properties, Cnil);
sethash(sym, system_properties, si_put_f(plist, value, prop));
@(return value);
}
cl_object
si_rem_sysprop(cl_object sym, cl_object prop)
{
cl_object plist, found;
assert_type_symbol(sym);
plist = gethash_safe(sym, system_properties, Cnil);
plist = si_rem_f(plist, prop);
found = VALUES(1);
sethash(sym, system_properties, plist);
@(return found);
}
void
init_assignment(void)
{
#ifdef PDE
SYM_VAL(@'si::*record-source-pathname-p*') = Cnil;
#endif
ecl_register_root(&system_properties);
system_properties =
cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */
make_shortfloat(1.5), /* rehash-size */
make_shortfloat(0.7)); /* rehash-threshold */
}
......@@ -127,10 +127,10 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args)
out = APPLY_fixed(narg, fun->cfun.entry, cl_stack_top - narg);
} else {
if (pLK) {
si_putprop(sym, CONS(CONS(make_unsigned_integer((cl_index)pLK),
make_unsigned_integer((cl_index)*pLK)),
ecl_get(sym, @'si::link-from', Cnil)),
@'si::link-from');
si_put_sysprop(sym, @'si::link-from',
CONS(CONS(make_unsigned_integer((cl_index)pLK),
make_unsigned_integer((cl_index)*pLK)),
si_get_sysprop(sym, @'si::link-from')));
*pLK = fun->cfun.entry;
}
out = APPLY(narg, fun->cfun.entry, cl_stack + sp);
......@@ -165,7 +165,7 @@ si_unlink_symbol(cl_object s)
if (!SYMBOLP(s))
FEtype_error_symbol(s);
pl = ecl_get(s, @'si::link-from', Cnil);
pl = si_get_sysprop(s, @'si::link-from');
if (!endp(pl)) {
for (; !endp(pl); pl = CDR(pl))
*(void **)(fixnnint(CAAR(pl))) = (void *)fixnnint(CDAR(pl));
......
......@@ -32,7 +32,7 @@ search_symbol_macro(cl_object name, cl_object env)
{
cl_object record = assq(name, CAR(env));
if (Null(record))
return ecl_get(name, @'si::symbol-macro', Cnil);
return si_get_sysprop(name, @'si::symbol-macro');
else if (CADR(record) == @'si::symbol-macro')
return CADDR(record);
else
......
......@@ -527,10 +527,10 @@ call_structure_print_function(cl_object x, int level)
#ifdef CLOS
funcall(3, @'print-object', x, PRINTstream);
#else
funcall(4, ecl_get(x->str.name, @'si::structure-print-function', Cnil),
funcall(4, si_get_sysprop(x->str.name, @'si::structure-print-function'),
x, PRINTstream, MAKE_FIXNUM(level));
#endif
bds_unwind_n(10);
bds_unwind_n(11);
} CL_UNWIND_PROTECT_EXIT {
memcpy(indent_stack, ois, oisp * sizeof(*ois));
iisp = oiisp;
......@@ -978,7 +978,7 @@ _write_object(cl_object x, int level)
write_ch(SET_INDENT);
if (PRINTpretty && CAR(x) != OBJNULL &&
type_of(CAR(x)) == t_symbol &&
(r = ecl_get(CAR(x), @'si::pretty-print-format', Cnil)) != Cnil)
(r = si_get_sysprop(CAR(x), @'si::pretty-print-format')) != Cnil)
goto PRETTY_PRINT_FORMAT;
for (i = 0; ; i++) {
if (!PRINTreadably && PRINTlength >= 0 && i >= PRINTlength) {
......@@ -1144,7 +1144,7 @@ _write_object(cl_object x, int level)
if (type_of(x->str.name) != t_symbol)
FEwrong_type_argument(@'symbol', x->str.name);
if (PRINTstructure ||
Null(ecl_get(x->str.name, @'si::structure-print-function', Cnil)))
Null(si_get_sysprop(x->str.name, @'si::structure-print-function')))
{
write_str("#S");
/* structure_to_list conses slot names and values into a list to be printed.
......
......@@ -41,7 +41,7 @@ structure_subtypep(cl_object x, cl_object y)
return(FALSE);
if (x == y)
return(TRUE);
x = ecl_get(x, @'si::structure-include', Cnil);
x = si_get_sysprop(x, @'si::structure-include');
} while (x != Cnil);
return(FALSE);
}
......@@ -62,7 +62,7 @@ structure_to_list(cl_object x)
cl_object *p, r, s;
int i, n;
s = ecl_get(SNAME(x), @'si::structure-slot-descriptions', Cnil);
s = si_get_sysprop(SNAME(x), @'si::structure-slot-descriptions');
p = &CDR(r = CONS(SNAME(x), Cnil));
for (i=0, n=SLENGTH(x); !endp(s) && i<n; s=CDR(s), i++) {
p = &(CDR(*p = CONS(cl_car(CAR(s)), Cnil)));
......
......@@ -271,6 +271,7 @@ cl_symbol_name(cl_object x)
x->symbol.mflag = sym->symbol.mflag;
SYM_FUN(x) = SYM_FUN(sym);
x->symbol.plist = cl_copy_list(sym->symbol.plist);
/* FIXME!!! We should also copy the system property list */
@(return x)
@)
......
......@@ -995,6 +995,7 @@ cl_symbols[] = {
{"SI::GENERIC-FUNCTION-METHOD-COMBINATION", SI_ORDINARY, NULL, -1},
{"SI::GENERIC-FUNCTION-METHOD-COMBINATION-ARGS", SI_ORDINARY, NULL, -1},
{"SI::GET-LOCAL-TIME-ZONE", SI_ORDINARY, si_get_local_time_zone, 0},
{"SI::GET-SYSPROP", SI_ORDINARY, si_get_sysprop, 2},
{"SI::GET-STRING-INPUT-STREAM-INDEX", SI_ORDINARY, si_get_string_input_stream_index, 1},
{"SI::GETENV", SI_ORDINARY, si_getenv, 1},
{"SI::HASH-SET", SI_ORDINARY, si_hash_set, 3},
......@@ -1032,9 +1033,11 @@ cl_symbols[] = {
{"SI::PROCESS-LAMBDA-LIST", SI_ORDINARY, si_process_lambda_list, 2},
{"SI::PUT-F", SI_ORDINARY, si_put_f, 3},
{"SI::PUT-PROPERTIES", SI_ORDINARY, si_put_properties, -1},
{"SI::PUT-SYSPROP", SI_ORDINARY, si_put_sysprop, 3},
{"SI::PUTPROP", SI_ORDINARY, si_putprop, 3},
{"SI::READ-BYTES", SI_ORDINARY, si_read_bytes, 4},
{"SI::REM-F", SI_ORDINARY, si_rem_f, 2},
{"SI::REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2},
{"SI::REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2},
{"SI::RESET-STACK-LIMITS", SI_ORDINARY, si_reset_stack_limits, 0},
{"SI::ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3},
......
......@@ -249,7 +249,7 @@ strings."
`(,report-function x stream))))))
,@(when documentation
`((EVAL-WHEN (COMPILE LOAD EVAL)
(SETF (GET ',name 'DOCUMENTATION) ',documentation))))
(SETF (DOCUMENTATION ',name) ',documentation))))
',NAME)))
(defun make-condition (type &rest slot-initializations)
......
......@@ -41,7 +41,7 @@
(defun search-make-instance (obj)
(declare (si::c-local))
(let* ((gfun (symbol-function (if (si::tracing-body 'make-instance)
(get 'make-instance 'si::traced)
(get-sysprop 'make-instance 'si::traced)
'make-instance)))
(table (si:gfun-method-ht gfun))
(key (list (class-name (si:instance-class obj))))
......
......@@ -9,7 +9,7 @@
(defpackage "CLOS"
(:use "WALKER" "CL")
(:import-from "SI" "UNBOUND"))
(:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP"))
(in-package "CLOS")
......
......@@ -793,9 +793,9 @@
;;; Force the compiler into optimizing use of gethash inside methods:
(setf (symbol-function 'SLOT-INDEX) (symbol-function 'GETHASH))
(setf (get 'SLOT-INDEX ':INLINE-ALWAYS)
'(((T T) FIXNUM NIL NIL "fix(gethash(#0,#1))")
((T T) T NIL NIL "(gethash(#0,#1))")))
(put-sysprop 'SLOT-INDEX ':INLINE-ALWAYS
'(((T T) FIXNUM NIL NIL "fix(gethash(#0,#1))")
((T T) T NIL NIL "(gethash(#0,#1))")))
(defun reduce-constant (old)
(let ((new (eval old)))
......
......@@ -18,7 +18,7 @@
(defmacro pre-make-templated-function-constructor (name
&rest template-parameters)
(let* ((params (get name 'TEMPLATED-FN-PARAMS))
(let* ((params (get-sysprop name 'TEMPLATED-FN-PARAMS))
(template-params (first params))
(instance-params (second params))
(body (cddr params))
......@@ -27,12 +27,12 @@
template-parameters
`(LET ((ENTRY
(OR (ASSOC ',template-parameters
(GET ',name 'TEMPLATED-FN-CONSTRUCTORS)
(GET-SYSPROP ',name 'TEMPLATED-FN-CONSTRUCTORS)
:test #'equal)
(LET ((NEW-ENTRY
(LIST ',template-parameters () () ())))
(PUSH NEW-ENTRY
(GET ',name 'TEMPLATED-FN-CONSTRUCTORS))
(GET-SYSPROP ',name 'TEMPLATED-FN-CONSTRUCTORS))
NEW-ENTRY))))
(SETF (THIRD ENTRY) 'COMPILED)
(SETF (SECOND ENTRY)
......
......@@ -68,7 +68,8 @@
*variable-declarations*
variable-declaration
macroexpand-all
))
)
(:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP"))
(in-package "WALKER")
(declaim (notinline note-lexical-binding walk-bindings-1 walk-let/let*
......@@ -355,15 +356,14 @@
(eval-when (compile load eval)
(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
`(get ,x 'WALKER-TEMPLATE)) ;Golden Common Lisp doesn't hack
`(get-sysprop ,x 'WALKER-TEMPLATE)) ;Golden Common Lisp doesn't hack
;compile time definition of macros
;right for setf.
(defmacro define-walker-template
(name &optional (template '(NIL REPEAT (EVAL))))
`(eval-when (load eval)
(setf (get-walker-template-internal ',name) ',template)))
)
(put-sysprop ',name 'WALKER-TEMPLATE ',template)))
(defun get-walker-template (x)
(cond ((symbolp x)
......
......@@ -102,4 +102,4 @@
(setf (var-ref-ccb var) t))
(wt-comment (var-name var)))
(setf (get 'BIND 'SET-LOC) 'bind)
(put-sysprop 'BIND 'SET-LOC 'bind)
......@@ -138,8 +138,8 @@
;;; ----------------------------------------------------------------------
(setf (get 'BLOCK 'C1SPECIAL) 'c1block)
(setf (get 'BLOCK 'C2) 'c2block)
(put-sysprop 'BLOCK 'C1SPECIAL 'c1block)
(put-sysprop 'BLOCK 'C2 'c2block)
(setf (get 'RETURN-FROM 'C1SPECIAL) 'c1return-from)
(setf (get 'RETURN-FROM 'C2) 'c2return-from)
(put-sysprop 'RETURN-FROM 'C1SPECIAL 'c1return-from)
(put-sysprop 'RETURN-FROM 'C2 'c2return-from)
......@@ -17,13 +17,13 @@
(and *compile-to-linking-call*
(symbolp fname)
(and (< (the fixnum (length args)) 10)
(or (and (get fname 'FIXED-ARGS)
(or (and (get-sysprop fname 'FIXED-ARGS)
(listp args))
(and
(get fname 'PROCLAIMED-FUNCTION)
(eq (get fname 'PROCLAIMED-RETURN-TYPE) t)
(get-sysprop fname 'PROCLAIMED-FUNCTION)
(eq (get-sysprop fname 'PROCLAIMED-RETURN-TYPE) t)
(every #'(lambda (v) (eq v t))
(get fname 'PROCLAIMED-ARG-TYPES)))))))
(get-sysprop fname 'PROCLAIMED-ARG-TYPES)))))))
;;; Like macro-function except it searches the lexical environment,
;;; to determine if the macro is shadowed by a function or a macro.
......@@ -49,7 +49,7 @@
(or (c1call-local function)
(list 'GLOBAL
(make-info :sp-change
(not (get function 'NO-SP-CHANGE)))
(not (get-sysprop function 'NO-SP-CHANGE)))
function)))
((and (consp function)
(eq (first function) 'LAMBDA)
......@@ -297,7 +297,7 @@
;; Call to a function whose C language function name is known,
;; either because it has been proclaimed so, or because it belongs
;; to the runtime.
((or (setq maxarg -1 fd (get fname 'Lfun))
((or (setq maxarg -1 fd (get-sysprop fname 'Lfun))
(multiple-value-setq (found fd maxarg) (si::mangle-name fname t)))
(multiple-value-bind (val found)
(gethash fd *compiler-declared-globals*)
......@@ -325,7 +325,7 @@
((LAMBDA LOCAL))
(GLOBAL
(unless (and (inline-possible (third funob))
(or (get (third funob) 'Lfun)
(or (get-sysprop (third funob) 'Lfun)
(assoc (third funob) *global-funs*)))
(let ((temp (list 'TEMP (next-temp))))
(if *safe-compile*
......@@ -403,11 +403,11 @@
;;; ----------------------------------------------------------------------
(setf (get 'funcall 'C1) #'c1funcall)
(setf (get 'funcall 'c2) #'c2funcall)
(setf (get 'call-lambda 'c2) #'c2call-lambda)
(setf (get 'call-global 'c2) #'c2call-global)
(put-sysprop 'funcall 'C1 #'c1funcall)
(put-sysprop 'funcall 'c2 #'c2funcall)
(put-sysprop 'call-lambda 'c2 #'c2call-lambda)
(put-sysprop 'call-global 'c2 #'c2call-global)
(setf (get 'CALL 'WT-LOC) #'wt-call)
(setf (get 'CALL-FIX 'WT-LOC) #'wt-call-fix)
(setf (get 'STACK-POINTER 'WT-LOC) #'wt-stack-pointer)
(put-sysprop 'CALL 'WT-LOC #'wt-call)
(put-sysprop 'CALL-FIX 'WT-LOC #'wt-call-fix)
(put-sysprop 'STACK-POINTER 'WT-LOC #'wt-stack-pointer)
......@@ -100,9 +100,9 @@
;;; ----------------------------------------------------------------------
(setf (get 'CATCH 'C1SPECIAL) 'c1catch)
(setf (get 'CATCH 'C2) 'c2catch)
(setf (get 'UNWIND-PROTECT 'C1SPECIAL) 'c1unwind-protect)
(setf (get 'UNWIND-PROTECT 'C2) 'c2unwind-protect)
(setf (get 'THROW 'C1SPECIAL) 'c1throw)
(setf (get 'THROW 'C2) 'c2throw)
(put-sysprop 'CATCH 'C1SPECIAL 'c1catch)
(put-sysprop 'CATCH 'C2 'c2catch)
(put-sysprop 'UNWIND-PROTECT 'C1SPECIAL 'c1unwind-protect)
(put-sysprop 'UNWIND-PROTECT 'C2 'c2unwind-protect)
(put-sysprop 'THROW 'C1SPECIAL 'c1throw)
(put-sysprop 'THROW 'C2 'c2throw)
......@@ -26,7 +26,8 @@
shared-library-pathname
static-library-pathname
*suppress-compiler-warnings*
*suppress-compiler-notes*))
*suppress-compiler-notes*)
(:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP"))
(in-package "COMPILER")
......
......@@ -144,13 +144,13 @@
(cond ((and (symbolp fname)
(listp decl) (listp (cdr decl)))
(cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '*)
(remprop fname 'PROCLAIMED-ARG-TYPES))
(rem-sysprop fname 'PROCLAIMED-ARG-TYPES))
(t (setq arg-types (function-arg-types (car decl)))
(setf (get fname 'PROCLAIMED-ARG-TYPES) arg-types)))
(put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)))
(cond ((or (null (cdr decl))(eq (second decl) '*))
(setq return-types '*))
(t (setq return-types (function-return-type (cdr decl)))))
(setf (get fname 'PROCLAIMED-RETURN-TYPE) return-types)
(put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)
(cond((eql return-types '*))
(t(setq return-types (cdr decl))))
;;; A non-local function may have local entry only if it returns
......@@ -161,8 +161,8 @@
(eq (caar return-types) 'VALUES)
(or (endp (cdar return-types))
(not (endp (cddar return-types)))))))
(setf (get fname 'PROCLAIMED-FUNCTION) t)
(remprop fname 'PROCLAIMED-FUNCTION)))
(put-sysprop fname 'PROCLAIMED-FUNCTION t)
(rem-sysprop fname 'PROCLAIMED-FUNCTION)))
(t (warn "The function procl ~s ~s is not valid." fname decl))))
(defun add-function-declaration (fname arg-types return-types)
......@@ -176,13 +176,13 @@
(defun get-arg-types (fname &aux x)
(if (setq x (assoc fname *function-declarations*))
(second x)
(get fname 'PROCLAIMED-ARG-TYPES)))
(get-sysprop fname 'PROCLAIMED-ARG-TYPES)))
(defun get-return-type (fname)
(let* ((x (assoc fname *function-declarations*))
(type1 (if x (caddr x) (get fname 'PROCLAIMED-RETURN-TYPE))))
(type1 (if x (caddr x) (get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
(cond (type1
(let ((type (get fname 'RETURN-TYPE)))
(let ((type (get-sysprop fname 'RETURN-TYPE)))
(cond (type
(cond ((setq type (type-and type type1)) type)
(t
......@@ -190,7 +190,7 @@
"The return type of ~s was badly declared."
fname))))
(t type1))))
(t (get fname 'RETURN-TYPE)))
(t (get-sysprop fname 'RETURN-TYPE)))
))
(defun get-local-arg-types (fun &aux x)
......@@ -208,7 +208,7 @@
(defun inline-possible (fname)
(not (or ; *compiler-push-events*
(member fname *notinline*)
(get fname 'CMP-NOTINLINE))))
(get-sysprop fname 'CMP-NOTINLINE))))
#-:CCL
(defun proclaim (decl)
......@@ -252,12 +252,12 @@
(INLINE
(dolist (fun (cdr decl))
(if (symbolp fun)
(remprop fun 'CMP-NOTINLINE)
(rem-sysprop fun 'CMP-NOTINLINE)
(warn "The function name ~s is not a symbol." fun))))
(NOTINLINE
(dolist (fun (cdr decl))
(if (symbolp fun)
(setf (get fun 'CMP-NOTINLINE) t)
(put-sysprop fun 'CMP-NOTINLINE t)
(warn "The function name ~s is not a symbol." fun))))
((OBJECT IGNORE)
(dolist (var (cdr decl))
......@@ -275,7 +275,7 @@
(si::mangle-name x t)
(if found
(warn "The function ~s is already in the runtime." x)
(setf (get x 'Lfun) fname)))
(put-sysprop x 'Lfun fname)))
(warn "The function name ~ is not a symbol." x))))
((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION
COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST
......@@ -287,9 +287,9 @@
(otherwise
(unless (member (car decl) *alien-declarations*)
(warn "The declaration specifier ~s is unknown." (car decl)))
(and (functionp (get (car decl) :proclaim))
(and (functionp (get-sysprop (car decl) :proclaim))
(dolist (v (cdr decl))
(funcall (get (car decl) :proclaim) v))))
(funcall (get-sysprop (car decl) :proclaim) v))))
)
nil
)
......@@ -298,7 +298,7 @@
(setq type (type-filter type))
(dolist (var vl)
(if (symbolp var)
(let ((type1 (get var 'CMP-TYPE))
(let ((type1 (get-sysprop var 'CMP-TYPE))
(v (sch-global var)))
(setq type1 (if type1 (type-and type1 type) type))
(when v (setq type1 (type-and type1 (var-type v))))
......@@ -307,7 +307,7 @@
"Inconsistent type declaration was found for the variable ~s."
var)
(setq type1 T))
(setf (get var 'CMP-TYPE) type1)
(put-sysprop var 'CMP-TYPE type1)
(when v (setf (var-type v) type1)))
(warn "The variable name ~s is not a symbol." var))))
......@@ -464,7 +464,7 @@
(setq body (c1progn body))
(list 'DECL-BODY (second body) dl body))))
(setf (get 'decl-body 'c2) 'c2decl-body)
(put-sysprop 'decl-body 'c2 'c2decl-body)
(defun c2decl-body (decls body)
(let ((*compiler-check-args* *compiler-check-args*)
......
......@@ -53,7 +53,7 @@
(defun c1t () *c1t*)
(defun c1call-symbol (fname args &aux fd)
(cond ((setq fd (get fname 'c1special)) (funcall fd args))
(cond ((setq fd (get-sysprop fname 'c1special)) (funcall fd args))
((setq fd (c1call-local fname))
(let* ((info (make-info :sp-change t
:referred-vars
......@@ -78,10 +78,10 @@
(list 'CALL-LOCAL info (third fd) forms)))
((setq fd (sch-local-macro fname))
(c1expr (cmp-expand-macro fd fname args)))
((and (setq fd (get fname 'C1))
((and (setq fd (get-sysprop fname 'C1))
(inline-possible fname))
(funcall fd args))
((and (setq fd (get fname 'C1CONDITIONAL))
((and (setq fd (get-sysprop fname 'C1CONDITIONAL))
(inline-possible fname)
(funcall fd args)))
((setq fd (macro-function fname))
......@@ -92,7 +92,7 @@
(cmp-expand-compiler-macro fd fname args))
success))
(c1expr fd))
((and (setq fd (get fname 'SYS::STRUCTURE-ACCESS))
((and (setq fd (get-sysprop fname 'SYS::STRUCTURE-ACCESS))
(inline-possible fname)
;;; Structure hack.
(consp fd)
......@@ -106,7 +106,7 @@
)
)
(t (let* ((info (make-info
:sp-change (null (get fname 'NO-SP-CHANGE))))
:sp-change (null (get-sysprop fname 'NO-SP-CHANGE))))
(forms (c1args args info)))
(let ((return-type (get-return-type fname)))
(when return-type (setf (info-type info) return-type)))
......@@ -123,7 +123,7 @@
:safe "In a call to ~a" fname)
fl1)
(pop arg-types))))))
(let ((arg-types (get fname 'ARG-TYPES)))
(let ((arg-types (get-sysprop fname 'ARG-TYPES)))
;; Check argument types.
(when arg-types
(do ((fl forms (cdr fl))
......@@ -190,15 +190,15 @@
(last-call-p)
(symbolp fname) ; locally defined function are
; represented as variables
(get fname 'PROCLAIMED-FUNCTION))
(get fname 'PROCLAIMED-RETURN-TYPE)
(get-sysprop fname 'PROCLAIMED-FUNCTION))
(get-sysprop fname 'PROCLAIMED-RETURN-TYPE)
(info-type (second form)))))
(if (or (eq (car form) 'LET)
(eq (car form) 'LET*))
(let ((*volatile* (volatile (second form))))
(declare (special *volatile*))
(apply (get (car form) 'C2) (cddr form)))
(apply (get (car form) 'C2) (cddr form)))))
(apply (get-sysprop (car form) 'C2) (cddr form)))
(apply (get-sysprop (car form) 'C2) (cddr form)))))
(defun c2expr* (form)
(let* ((*exit* (next-label))
......@@ -263,7 +263,7 @@
(defun get-slot-type (name index)
;; default is t
(type-filter
(or (third (nth index (get name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T)))
(or (third (nth index (get-sysprop name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T)))
(defun c2structure-ref (form name-vv index
&aux (*inline-blocks* 0))
......@@ -401,18 +401,18 @@
;;; ----------------------------------------------------------------------
(setf (get 'PROGN 'C1SPECIAL) 'c1progn)
(setf (get 'PROGN 'C2) 'c2progn)
(put-sysprop 'PROGN 'C1SPECIAL 'c1progn)
(put-sysprop 'PROGN 'C2 'c2progn)
(setf (get 'SYS:STRUCTURE-REF 'C1) 'c1structure-ref)
(setf (get 'SYS:STRUCTURE-REF 'C2) 'c2structure-ref)
(setf (get 'SYS:STRUCTURE-REF 'WT-LOC) 'wt-structure-ref)
(setf (get 'SYS:STRUCTURE-SET 'C1) 'c1structure-set)
(setf (get 'SYS:STRUCTURE-SET 'C2) 'c2structure-set)
(put-sysprop 'SYS:STRUCTURE-REF 'C1 'c1structure-ref)
(put-sysprop 'SYS:STRUCTURE-REF 'C2 'c2structure-ref)
(put-sysprop 'SYS:STRUCTURE-REF 'WT-LOC 'wt-structure-ref)
(put-sysprop 'SYS:STRUCTURE-SET 'C1 'c1structure-set)
(put-sysprop 'SYS:STRUCTURE-SET 'C2 'c2structure-set)
#+clos
(setf (get 'SYS:INSTANCE-REF 'C1) 'c1instance-ref)
(put-sysprop 'SYS:INSTANCE-REF 'C1 'c1instance-ref)
#+clos
(setf (get 'SYS:INSTANCE-REF 'C2) 'c2instance-ref)
(put-sysprop 'SYS:INSTANCE-REF 'C2 'c2instance-ref)
#+clos
(setf (get 'SYS:INSTANCE-REF 'WT-LOC) 'wt-instance-ref)
(put-sysprop 'SYS:INSTANCE-REF 'WT-LOC 'wt-instance-ref)
......@@ -362,15 +362,15 @@
;;; ----------------------------------------------------------------------
(setf (get 'FLET 'C1SPECIAL) 'c1flet)
(setf (get 'LABELS 'C1SPECIAL) 'c1labels)
(setf (get 'LOCALLY 'C1SPECIAL) 'c1locally)
(setf (get 'MACROLET 'C1SPECIAL) 'c1macrolet)
(setf (get 'SYMBOL-MACROLET 'C1SPECIAL) 'c1symbol-macrolet)
(put-sysprop 'FLET 'C1SPECIAL 'c1flet)
(put-sysprop 'LABELS 'C1SPECIAL 'c1labels)
(put-sysprop 'LOCALLY 'C1SPECIAL 'c1locally)
(put-sysprop 'MACROLET 'C1SPECIAL 'c1macrolet)
(put-sysprop 'SYMBOL-MACROLET 'C1SPECIAL 'c1symbol-macrolet)
(setf (get 'LOCALS 'c2) 'c2locals) ; replaces both c2flet and c2lables
(put-sysprop 'LOCALS 'c2 'c2locals) ; replaces both c2flet and c2lables
;;; c2macrolet is not defined, because MACROLET is replaced by PROGN
;;; during Pass 1.
(setf (get 'CALL-LOCAL 'C2) 'c2call-local)
(put-sysprop 'CALL-LOCAL 'C2 'c2call-local)
(setf (get 'CALL-LOCAL 'WT-LOC) #'wt-call-local)
(put-sysprop 'CALL-LOCAL 'WT-LOC #'wt-call-local)
......@@ -515,9 +515,9 @@
(subtypep (result-type (second args)) 'FIXNUM)
(c1expr `(the fixnum (ldb1 ,size ,pos ,(second args))))))
(push '((fixnum fixnum fixnum) fixnum nil nil
"((((~(-1 << (#0))) << (#1)) & (#2)) >> (#1))")
(get 'ldb1 ':INLINE-ALWAYS))
(put-sysprop 'ldb1 :INLINE-ALWAYS
'((fixnum fixnum fixnum) fixnum nil nil
"((((~(-1 << (#0))) << (#1)) & (#2)) >> (#1))"))
;----------------------------------------------------------------------
......@@ -545,36 +545,36 @@
;;; ----------------------------------------------------------------------
(setf (get 'princ 'C1) 'c1princ)
(setf (get 'princ 'C2) 'c2princ)
(setf (get 'terpri 'C1) 'c1terpri)
(setf (get 'apply 'C1) 'c1apply)
(setf (get 'apply-lambda/local 'C2) 'c2apply-lambda/local)
(setf (get 'rplaca 'C1) 'c1rplaca)
(setf (get 'rplaca 'C2) 'c2rplaca)
(setf (get 'rplacd 'C1) 'c1rplacd)
(setf (get 'rplacd 'C2) 'c2rplacd)
(setf (get 'member 'C1) 'c1member)
(setf (get 'member!2 'C2) 'c2member!2)
(setf (get 'assoc 'C1) 'c1assoc)
(setf (get 'assoc!2 'C2) 'c2assoc!2)
(setf (get 'nth 'C1CONDITIONAL) 'co1nth)
(setf (get 'nthcdr 'C1CONDITIONAL) 'co1nthcdr)
(setf (get 'sys:rplaca-nthcdr 'C1) 'c1rplaca-nthcdr)
(setf (get 'rplaca-nthcdr-immediate 'C2) 'c2rplaca-nthcdr-immediate)
(setf (get 'sys:list-nth 'C1) 'c1list-nth)
(setf (get 'list-nth-immediate 'C2) 'c2list-nth-immediate)
(setf (get 'ash 'C1CONDITIONAL) 'co1ash)