mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-20 19:42:30 -08:00
Code Issues Projects Releases Packages Wiki Activity

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

Browse source 
about functions, SETF forms, DEFTYPEs, etc. Property lists are no longer
used for this task.
This commit is contained in:
jjgarcia 2003-03-21 14:18:56 +00:00
parent d8300559a9
commit 6b76d155ee
52 changed files with 494 additions and 442 deletions
Download patch file Download diff file Expand all files Collapse all files

6
src/CHANGELOG
View file

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

80
src/c/assignment.d
View file

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

10
src/c/eval.d
View file

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

2
src/c/macros.d
View file

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

8
src/c/print.d
View file

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

4
src/c/structure.d
View file

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

1
src/c/symbol.d
View file

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

3
src/c/symbols_list.h
View file

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

2
src/clos/conditions.lsp
View file

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

2
src/clos/kernel.lsp
View file

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

2
src/clos/macros.lsp
View file

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

6
src/clos/method.lsp
View file

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

6
src/clos/precomp.lsp
View file

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

8
src/clos/walk.lsp
View file

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

2
src/cmp/cmpbind.lsp
View file

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

8
src/cmp/cmpblock.lsp
View file

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

28
src/cmp/cmpcall.lsp
View file

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

12
src/cmp/cmpcatch.lsp
View file

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

3
src/cmp/cmpdefs.lsp
View file

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

36
src/cmp/cmpenv.lsp
View file

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

42
src/cmp/cmpeval.lsp
View file

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

16
src/cmp/cmpflet.lsp
View file

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

62
src/cmp/cmpfun.lsp
View file

@ -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)
(put-sysprop 'princ 'C1 'c1princ)
(put-sysprop 'princ 'C2 'c2princ)
(put-sysprop 'terpri 'C1 'c1terpri)
(setf (get 'apply 'C1) 'c1apply)
(setf (get 'apply-lambda/local 'C2) 'c2apply-lambda/local)
(put-sysprop 'apply 'C1 'c1apply)
(put-sysprop '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)
(put-sysprop 'rplaca 'C1 'c1rplaca)
(put-sysprop 'rplaca 'C2 'c2rplaca)
(put-sysprop 'rplacd 'C1 'c1rplacd)
(put-sysprop '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)
(put-sysprop 'member 'C1 'c1member)
(put-sysprop 'member!2 'C2 'c2member!2)
(put-sysprop 'assoc 'C1 'c1assoc)
(put-sysprop '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)
(put-sysprop 'nth 'C1CONDITIONAL 'co1nth)
(put-sysprop 'nthcdr 'C1CONDITIONAL 'co1nthcdr)
(put-sysprop 'sys:rplaca-nthcdr 'C1 'c1rplaca-nthcdr)
(put-sysprop 'rplaca-nthcdr-immediate 'C2 'c2rplaca-nthcdr-immediate)
(put-sysprop 'sys:list-nth 'C1 'c1list-nth)
(put-sysprop 'list-nth-immediate 'C2 'c2list-nth-immediate)
(setf (get 'ash 'C1CONDITIONAL) 'co1ash)
(setf (get 'boole 'C2) 'c2boole)
(setf (get 'boole 'C1CONDITIONAL) 'co1boole)
(setf (get 'coerce 'C1CONDITIONAL) 'co1coerce)
(setf (get 'cons 'C1CONDITIONAL) 'co1cons)
(setf (get 'eql 'C1CONDITIONAL) 'co1eql)
(setf (get 'ldb 'C1CONDITIONAL) 'co1ldb)
(setf (get 'vector-push 'C1CONDITIONAL) 'co1vector-push)
(setf (get 'vector-push-extend 'C1CONDITIONAL) 'co1vector-push-extend)
(put-sysprop 'ash 'C1CONDITIONAL 'co1ash)
(put-sysprop 'boole 'C2 'c2boole)
(put-sysprop 'boole 'C1CONDITIONAL 'co1boole)
(put-sysprop 'coerce 'C1CONDITIONAL 'co1coerce)
(put-sysprop 'cons 'C1CONDITIONAL 'co1cons)
(put-sysprop 'eql 'C1CONDITIONAL 'co1eql)
(put-sysprop 'ldb 'C1CONDITIONAL 'co1ldb)
(put-sysprop 'vector-push 'C1CONDITIONAL 'co1vector-push)
(put-sysprop 'vector-push-extend 'C1CONDITIONAL 'co1vector-push-extend)

24
src/cmp/cmpif.lsp
View file

@ -228,7 +228,7 @@
(wt "!=Cnil){")
(unwind-exit (cons 'VAR (third form)) 'JUMP) (wt "}"))
((and (eq (car form) 'CALL-GLOBAL)
(get (third form) 'PREDICATE))
(get-sysprop (third form) 'PREDICATE))
(let* ((label (next-label))
(*unwind-exit* (cons label *unwind-exit*)))
(let ((*destination* (list 'JUMP-FALSE label)))
@ -347,16 +347,16 @@
;;; ----------------------------------------------------------------------
(setf (get 'if 'c1special) #'c1if)
(setf (get 'if 'c2) #'c2if)
(setf (get 'and 'c1) #'c1and)
(setf (get 'and 'c2) #'c2and)
(setf (get 'or 'c1) #'c1or)
(setf (get 'or 'c2) #'c2or)
(put-sysprop 'if 'c1special #'c1if)
(put-sysprop 'if 'c2 #'c2if)
(put-sysprop 'and 'c1 #'c1and)
(put-sysprop 'and 'c2 #'c2and)
(put-sysprop 'or 'c1 #'c1or)
(put-sysprop 'or 'c2 #'c2or)
(setf (get 'jump-true 'set-loc) #'set-jump-true)
(setf (get 'jump-false 'set-loc) #'set-jump-false)
(put-sysprop 'jump-true 'set-loc #'set-jump-true)
(put-sysprop 'jump-false 'set-loc #'set-jump-false)
(setf (get 'case 'c1) #'c1case)
(setf (get 'ecase 'c1) #'c1ecase)
(setf (get 'case 'c2) #'c2case)
(put-sysprop 'case 'c1 #'c1case)
(put-sysprop 'ecase 'c1 #'c1ecase)
(put-sysprop 'case 'c2 #'c2case)

42
src/cmp/cmpinline.lsp
View file

@ -130,7 +130,7 @@
(arg-locs (inline-args args))
loc)
(if (and (inline-possible fname)
(not (get fname 'C2)) ; no special treatment
(not (get-sysprop fname 'C2)) ; no special treatment
(setq loc (inline-function fname arg-locs return-type)))
(let* ((arg-type (first loc))
(and-type (type-and arg-type return-type))
@ -358,12 +358,12 @@
(when (and (eq (car x) fname)
(setq ii (inline-type-matches (cdr x) types return-type)))
(return-from get-inline-info ii)))
(dolist (x (get fname (if *safe-compile*
(dolist (x (get-sysprop fname (if *safe-compile*
':INLINE-SAFE
':INLINE-UNSAFE)))
(when (setq ii (inline-type-matches x types return-type))
(return)))
(dolist (x (get fname ':INLINE-ALWAYS))
(dolist (x (get-sysprop fname ':INLINE-ALWAYS))
(when (setq iia (inline-type-matches x types return-type))
(return)))
(if (and ii iia)
@ -528,22 +528,22 @@
;;; ----------------------------------------------------------------------
(setf (get 'INLINE 'WT-LOC) 'wt-inline)
(setf (get 'INLINE-COND 'WT-LOC) 'wt-inline-cond)
(setf (get 'INLINE-FIXNUM 'WT-LOC) 'wt-inline-fixnum)
(setf (get 'INLINE-CHARACTER 'WT-LOC) 'wt-inline-character)
(setf (get 'INLINE-LONG-FLOAT 'WT-LOC) 'wt-inline-long-float)
(setf (get 'INLINE-SHORT-FLOAT 'WT-LOC) 'wt-inline-short-float)
(put-sysprop 'INLINE 'WT-LOC 'wt-inline)
(put-sysprop 'INLINE-COND 'WT-LOC 'wt-inline-cond)
(put-sysprop 'INLINE-FIXNUM 'WT-LOC 'wt-inline-fixnum)
(put-sysprop 'INLINE-CHARACTER 'WT-LOC 'wt-inline-character)
(put-sysprop 'INLINE-LONG-FLOAT 'WT-LOC 'wt-inline-long-float)
(put-sysprop 'INLINE-SHORT-FLOAT 'WT-LOC 'wt-inline-short-float)
(setf (get 'FIXNUM 'WT-LOC) 'wt-fixnum-loc)
(setf (get 'CHARACTER 'WT-LOC) 'wt-character-loc)
(setf (get 'LONG-FLOAT 'WT-LOC) 'wt-long-float-loc)
(setf (get 'SHORT-FLOAT 'WT-LOC) 'wt-short-float-loc)
(setf (get 'BOOLEAN 'WT-LOC) 'wt-loc)
(setf (get 'T 'WT-LOC) 'wt-loc)
(put-sysprop 'FIXNUM 'WT-LOC 'wt-fixnum-loc)
(put-sysprop 'CHARACTER 'WT-LOC 'wt-character-loc)
(put-sysprop 'LONG-FLOAT 'WT-LOC 'wt-long-float-loc)
(put-sysprop 'SHORT-FLOAT 'WT-LOC 'wt-short-float-loc)
(put-sysprop 'BOOLEAN 'WT-LOC 'wt-loc)
(put-sysprop 'T 'WT-LOC 'wt-loc)
;;; Since they are possible locations, we must add:
(setf (get 'STRING 'WT-LOC) 'wt-loc)
(setf (get 'BIT-VECTOR 'WT-LOC) 'wt-loc)
(put-sysprop 'STRING 'WT-LOC 'wt-loc)
(put-sysprop 'BIT-VECTOR 'WT-LOC 'wt-loc)
(defun wt-fixnum->object (loc)
(wt "MAKE_FIXNUM(" loc ")"))
@ -554,7 +554,7 @@
(defun wt-long-float->object (loc)
(wt "make_longfloat(" loc ")"))
(setf (get 'FIXNUM->OBJECT 'WT-LOC) 'wt-fixnum->object)
(setf (get 'CHARACTER->OBJECT 'WT-LOC) 'wt-character->object)
(setf (get 'LONG-FLOAT->OBJECT 'WT-LOC) 'wt-long-float->object)
(setf (get 'SHORT-FLOAT->OBJECT 'WT-LOC) 'wt-short-float->object)
(put-sysprop 'FIXNUM->OBJECT 'WT-LOC 'wt-fixnum->object)
(put-sysprop 'CHARACTER->OBJECT 'WT-LOC 'wt-character->object)
(put-sysprop 'LONG-FLOAT->OBJECT 'WT-LOC 'wt-long-float->object)
(put-sysprop 'SHORT-FLOAT->OBJECT 'WT-LOC 'wt-short-float->object)

2
src/cmp/cmplam.lsp
View file

@ -643,7 +643,7 @@
(add-info dm-info (second body))
(unless (eql setjmps *setjmps*)
(setf (info-volatile dm-info) t)
(setf (get macro-name 'CONTAINS-SETJMP) t))
(put-sysprop macro-name 'CONTAINS-SETJMP t))
(dolist (v dm-vars) (check-vref v))
(list doc ppn whole env vl body)

8
src/cmp/cmplet.lsp
View file

@ -426,7 +426,7 @@
;;; ----------------------------------------------------------------------
(setf (get 'LET 'C1SPECIAL) #'c1let)
(setf (get 'LET 'C2) 'c2let)
(setf (get 'LET* 'C1SPECIAL) #'c1let*)
(setf (get 'LET* 'C2) 'c2let*)
(put-sysprop 'LET 'C1SPECIAL #'c1let)
(put-sysprop 'LET 'C2 'c2let)
(put-sysprop 'LET* 'C1SPECIAL #'c1let*)
(put-sysprop 'LET* 'C2 'c2let*)

38
src/cmp/cmploc.lsp
View file

@ -92,9 +92,9 @@
((or (not (consp *destination*))
(not (symbolp (car *destination*))))
(baboon))
((setq fd (get (car *destination*) 'SET-LOC))
((setq fd (get-sysprop (car *destination*) 'SET-LOC))
(apply fd loc (cdr *destination*)))
((setq fd (get (car *destination*) 'WT-LOC))
((setq fd (get-sysprop (car *destination*) 'WT-LOC))
(wt-nl) (apply fd (cdr *destination*)) (wt "= " loc ";"))
(t (baboon)))))
)
@ -111,7 +111,7 @@
((or (not (consp loc))
(not (symbolp (car loc))))
(baboon))
((setq fd (get (car loc) 'WT-LOC))
((setq fd (get-sysprop (car loc) 'WT-LOC))
(apply fd (cdr loc)))
(t (baboon)))
)
@ -214,19 +214,19 @@
;;; -----------------------------------------------------------------
(setf (get 'TEMP 'WT-LOC) #'wt-temp)
(setf (get 'LCL 'WT-LOC) #'wt-lcl-loc)
(setf (get 'VV 'WT-LOC) #'wt-vv)
(setf (get 'CAR 'WT-LOC) #'wt-car)
(setf (get 'CDR 'WT-LOC) #'wt-cdr)
(setf (get 'CADR 'WT-LOC) #'wt-cadr)
(setf (get 'FIXNUM-VALUE 'WT-LOC) #'wt-number)
(setf (get 'FIXNUM-LOC 'WT-LOC) #'wt-fixnum-loc) ; used in cmpfun.lsp
(setf (get 'CHARACTER-VALUE 'WT-LOC) #'wt-character)
;(setf (get 'CHARACTER-LOC 'WT-LOC) #'wt-character-loc)
(setf (get 'LONG-FLOAT-VALUE 'WT-LOC) #'wt-number)
;(setf (get 'LONG-FLOAT-LOC 'WT-LOC) #'wt-long-float-loc)
(setf (get 'SHORT-FLOAT-VALUE 'WT-LOC) #'wt-number)
;(setf (get 'SHORT-FLOAT-LOC 'WT-LOC) #'wt-short-float-loc)
(setf (get 'VALUE 'WT-LOC) #'wt-value)
(setf (get 'KEYVARS 'WT-LOC) #'wt-keyvars)
(put-sysprop 'TEMP 'WT-LOC #'wt-temp)
(put-sysprop 'LCL 'WT-LOC #'wt-lcl-loc)
(put-sysprop 'VV 'WT-LOC #'wt-vv)
(put-sysprop 'CAR 'WT-LOC #'wt-car)
(put-sysprop 'CDR 'WT-LOC #'wt-cdr)
(put-sysprop 'CADR 'WT-LOC #'wt-cadr)
(put-sysprop 'FIXNUM-VALUE 'WT-LOC #'wt-number)
(put-sysprop 'FIXNUM-LOC 'WT-LOC #'wt-fixnum-loc) ; used in cmpfun.lsp
(put-sysprop 'CHARACTER-VALUE 'WT-LOC #'wt-character)
;(put-sysprop 'CHARACTER-LOC 'WT-LOC #'wt-character-loc)
(put-sysprop 'LONG-FLOAT-VALUE 'WT-LOC #'wt-number)
;(put-sysprop 'LONG-FLOAT-LOC 'WT-LOC #'wt-long-float-loc)
(put-sysprop 'SHORT-FLOAT-VALUE 'WT-LOC #'wt-number)
;(put-sysprop 'SHORT-FLOAT-LOC 'WT-LOC #'wt-short-float-loc)
(put-sysprop 'VALUE 'WT-LOC #'wt-value)
(put-sysprop 'KEYVARS 'WT-LOC #'wt-keyvars)

6
src/cmp/cmpmain.lsp
View file

@ -518,10 +518,10 @@ Cannot compile ~a."
null-stream))
(*error-count* 0)
(t3local-fun (symbol-function 'T3LOCAL-FUN))
(t3fun (get 'DEFUN 'T3)))
(t3fun (get-sysprop 'DEFUN 'T3)))
(unwind-protect
(progn
(setf (get 'DEFUN 'T3)
(put-sysprop 'DEFUN 'T3
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3fun args))))
@ -539,7 +539,7 @@ Cannot compile ~a."
(setq *error-p* t))
(when data-file (wt-data-end))
)
(setf (get 'DEFUN 'T3) t3fun)
(put-sysprop 'DEFUN 'T3 t3fun)
(setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
(when h-file (close *compiler-output2*))
(when data-file (close *compiler-output-data*))))

18
src/cmp/cmpmap.lsp
View file

@ -213,15 +213,15 @@
;;; ----------------------------------------------------------------------
(setf (get 'mapcar 'c1) 'c1mapcar)
(setf (get 'maplist 'c1) 'c1maplist)
(setf (get 'mapcar 'c2) 'c2mapcar)
(setf (get 'mapc 'c1) 'c1mapc)
(setf (get 'mapl 'c1) 'c1mapl)
(setf (get 'mapc 'c2) 'c2mapc)
(setf (get 'mapcan 'c1) 'c1mapcan)
(setf (get 'mapcon 'c1) 'c1mapcon)
(setf (get 'mapcan 'c2) 'c2mapcan)
(put-sysprop 'mapcar 'c1 'c1mapcar)
(put-sysprop 'maplist 'c1 'c1maplist)
(put-sysprop 'mapcar 'c2 'c2mapcar)
(put-sysprop 'mapc 'c1 'c1mapc)
(put-sysprop 'mapl 'c1 'c1mapl)
(put-sysprop 'mapc 'c2 'c2mapc)
(put-sysprop 'mapcan 'c1 'c1mapcan)
(put-sysprop 'mapcon 'c1 'c1mapcon)
(put-sysprop 'mapcan 'c2 'c2mapcan)
(defun c1mapcar (args) (c1map-functions 'mapcar t args))
(defun c1maplist (args) (c1map-functions 'mapcar nil args))

22
src/cmp/cmpmulti.lsp
View file

@ -131,7 +131,7 @@
(eq (first form) 'CALL-GLOBAL)
(let ((fname (third form)))
(when (and (symbolp fname)
(get fname 'PROCLAIMED-RETURN-TYPE))
(get-sysprop fname 'PROCLAIMED-RETURN-TYPE))
(cmpwarn "~A was proclaimed to have only one return value. ~
~%;;; But you appear to want multiple values." fname)))))
@ -251,13 +251,13 @@
;;; ----------------------------------------------------------------------
(setf (get 'multiple-value-call 'c1special) #'c1multiple-value-call)
(setf (get 'multiple-value-call 'c2) #'c2multiple-value-call)
(setf (get 'multiple-value-prog1 'c1special) #'c1multiple-value-prog1)
(setf (get 'multiple-value-prog1 'c2) #'c2multiple-value-prog1)
(setf (get 'values 'c1) #'c1values)
(setf (get 'values 'c2) #'c2values)
(setf (get 'multiple-value-setq 'c1) #'c1multiple-value-setq)
(setf (get 'multiple-value-setq 'c2) #'c2multiple-value-setq)
(setf (get 'multiple-value-bind 'c1) #'c1multiple-value-bind)
(setf (get 'multiple-value-bind 'c2) #'c2multiple-value-bind)
(put-sysprop 'multiple-value-call 'c1special #'c1multiple-value-call)
(put-sysprop 'multiple-value-call 'c2 #'c2multiple-value-call)
(put-sysprop 'multiple-value-prog1 'c1special #'c1multiple-value-prog1)
(put-sysprop 'multiple-value-prog1 'c2 #'c2multiple-value-prog1)
(put-sysprop 'values 'c1 #'c1values)
(put-sysprop 'values 'c2 #'c2values)
(put-sysprop 'multiple-value-setq 'c1 #'c1multiple-value-setq)
(put-sysprop 'multiple-value-setq 'c2 #'c2multiple-value-setq)
(put-sysprop 'multiple-value-bind 'c1 #'c1multiple-value-bind)
(put-sysprop 'multiple-value-bind 'c2 #'c2multiple-value-bind)

22
src/cmp/cmpspecial.lsp
View file

@ -85,7 +85,7 @@
:local-referred vars)
vars))
`(FUNCTION ,(make-info :sp-change
(not (get fun 'NO-SP-CHANGE)))
(not (get-sysprop fun 'NO-SP-CHANGE)))
GLOBAL nil ,fun))))
((and (consp fun) (eq (car fun) 'LAMBDA))
(cmpck (endp (cdr fun))
@ -176,14 +176,14 @@
;;; ----------------------------------------------------------------------
(setf (get 'quote 'c1special) 'c1quote)
(setf (get 'function 'c1special) 'c1function)
(setf (get 'function 'c2) 'c2function)
(setf (get 'the 'c1special) 'c1the)
(setf (get 'eval-when 'c1special) 'c1eval-when)
(setf (get 'declare 'c1special) 'c1declare)
(setf (get 'compiler-let 'c1special) 'c1compiler-let)
(setf (get 'compiler-let 'c2) 'c2compiler-let)
(put-sysprop 'quote 'c1special 'c1quote)
(put-sysprop 'function 'c1special 'c1function)
(put-sysprop 'function 'c2 'c2function)
(put-sysprop 'the 'c1special 'c1the)
(put-sysprop 'eval-when 'c1special 'c1eval-when)
(put-sysprop 'declare 'c1special 'c1declare)
(put-sysprop 'compiler-let 'c1special 'c1compiler-let)
(put-sysprop 'compiler-let 'c2 'c2compiler-let)
(setf (get 'symbol-function 'wt-loc) 'wt-symbol-function)
(setf (get 'make-cclosure 'wt-loc) 'wt-make-closure)
(put-sysprop 'symbol-function 'wt-loc 'wt-symbol-function)
(put-sysprop 'make-cclosure 'wt-loc 'wt-make-closure)

8
src/cmp/cmptag.lsp
View file

@ -225,8 +225,8 @@
;;; ------------------------------------------------------------
(setf (get 'tagbody 'c1special) 'c1tagbody)
(setf (get 'tagbody 'c2) 'c2tagbody)
(put-sysprop 'tagbody 'c1special 'c1tagbody)
(put-sysprop 'tagbody 'c2 'c2tagbody)
(setf (get 'go 'c1special) 'c1go)
(setf (get 'go 'c2) 'c2go)
(put-sysprop 'go 'c1special 'c1go)
(put-sysprop 'go 'c2 'c2go)

26
src/cmp/cmptest.lsp
View file

@ -198,23 +198,23 @@
(defun remrem ()
(do-symbols (x (find-package 'lisp))
(remprop x ':inline-always)
(remprop x ':inline-safe)
(remprop x ':inline-unsafe))
(rem-sysprop x ':inline-always)
(rem-sysprop x ':inline-safe)
(rem-sysprop x ':inline-unsafe))
(do-symbols (x (find-package 'system))
(remprop x ':inline-always)
(remprop x ':inline-safe)
(remprop x ':inline-unsafe)))
(rem-sysprop x ':inline-always)
(rem-sysprop x ':inline-safe)
(rem-sysprop x ':inline-unsafe)))
(defun ckck ()
(do-symbols (x (find-package 'lisp))
(when (or (get x ':inline-always)
(get x ':inline-safe)
(get x ':inline-unsafe))
(when (or (get-sysprop x ':inline-always)
(get-sysprop x ':inline-safe)
(get-sysprop x ':inline-unsafe))
(print x)))
(do-symbols (x (find-package 'si))
(when (or (get x ':inline-always)
(get x ':inline-safe)
(get x ':inline-unsafe))
(when (or (get-sysprop x ':inline-always)
(get-sysprop x ':inline-safe)
(get-sysprop x ':inline-unsafe))
(print x))))
(defun make-cmpopt (&aux (eof (cons nil nil)))
@ -246,7 +246,7 @@
(print
`(push '(,arg-types ,return-type ,side-effectp
,new-object-p ,body)
(get ',name ',property))
(get-sysprop ',name ',property))
out))
(cdr x)))
(terpri out))))

106
src/cmp/cmptop.lsp
View file

@ -29,13 +29,13 @@
(let ((fun (car form)) (args (cdr form)) fd setf-symbol) ; #+cltl2
(cond
((symbolp fun)
(cond ((get fun 'PACKAGE-OPERATION)
(cond ((get-sysprop fun 'PACKAGE-OPERATION)
(cmp-eval form)
(wt-data-package-operation form))
((setq fd (get fun 'T1))
((setq fd (get-sysprop fun 'T1))
(when *compile-print* (print-current-form))
(funcall fd args))
((get fun 'C1) (t1ordinary form))
((get-sysprop fun 'C1) (t1ordinary form))
((setq fd (macro-function fun))
(t1expr* (cmp-expand-macro fd fun (cdr form))))
((and (setq fd (assoc fun *funs*))
@ -53,7 +53,7 @@
(defun t2expr (form)
;(pprint (cons 'T2 form))
(when form
(let ((def (get (car form) 'T2)))
(let ((def (get-sysprop (car form) 'T2)))
(when def (apply def (cdr form))))))
(defvar *emitted-local-funs* nil)
@ -78,7 +78,7 @@
(when form
(emit-local-funs)
(setq *funarg-vars* nil)
(let ((def (get (car form) 'T3)))
(let ((def (get-sysprop (car form) 'T3)))
(when def
;; new local functions get pushed into *local-funs*
(when (and *compile-print*
@ -221,7 +221,7 @@
(mapcar #'t3expr args))
(defun exported-fname (name)
(or (get name 'Lfun)
(or (get-sysprop name 'Lfun)
(next-cfun)))
(defun t1defun (args &aux (setjmps *setjmps*))
@ -250,7 +250,7 @@
(setq output (new-defun fname cfun lambda-expr *special-binding* no-entry))
(when
(and
(get fname 'PROCLAIMED-FUNCTION)
(get-sysprop fname 'PROCLAIMED-FUNCTION)
(let ((lambda-list (third lambda-expr)))
(declare (list lambda-list))
(and (null (second lambda-list)) ; no optional
@ -271,8 +271,8 @@
(declare (fixnum n))
(format o "#~d," n))
o))))
(let ((pat (get fname 'PROCLAIMED-ARG-TYPES))
(prt (get fname 'PROCLAIMED-RETURN-TYPE)))
(let ((pat (get-sysprop fname 'PROCLAIMED-ARG-TYPES))
(prt (get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))
(push (list fname pat prt t
(not (member prt
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT)
@ -314,7 +314,7 @@
(defun wt-if-proclaimed (fname cfun vv lambda-expr)
(when (fast-link-proclaimed-type-p fname)
(let ((arg-c (length (car (third lambda-expr))))
(arg-p (length (get fname 'PROCLAIMED-ARG-TYPES))))
(arg-p (length (get-sysprop fname 'PROCLAIMED-ARG-TYPES))))
(if (= arg-c arg-p)
(cmpwarn
" ~a is proclaimed but not in *inline-functions* ~
@ -340,7 +340,7 @@
(if (numberp cfun)
(wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)L" cfun ");")
(wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)" cfun ");"))
(when (get fname 'PROCLAIMED-FUNCTION)
(when (get-sysprop fname 'PROCLAIMED-FUNCTION)
(wt-if-proclaimed fname cfun vv lambda-expr))))
(defun t3defun (fname cfun lambda-expr sp funarg-vars no-entry
@ -518,7 +518,7 @@
(analyze-regs1 data *free-data-registers*))))
(defun wt-global-entry (fname cfun arg-types return-type)
(when (get fname 'NO-GLOBAL-ENTRY) (return-from wt-global-entry nil))
(when (get-sysprop fname 'NO-GLOBAL-ENTRY) (return-from wt-global-entry nil))
(wt-comment "global entry for the function " fname)
(wt-nl1 "static cl_object L" cfun "(int narg")
(wt-h "static cl_object L" cfun "(int")
@ -583,7 +583,7 @@
(declare (ignore macro-lambda sp))
(when (< *space* 3)
(when ppn
(wt-nl "si_putprop(" vv "," ppn "," (add-symbol 'si::pretty-print-format) ");")
(wt-nl "si_put_sysprop(" vv "," (add-symbol 'si::pretty-print-format) "," ppn ");")
(wt-nl)))
(wt-h "static cl_object L" cfun "();")
(wt-nl "cl_def_c_macro_va(" vv ",(cl_objectfn)L" cfun ");"))
@ -594,7 +594,7 @@
(*next-unboxed* 0) *unboxed*
(*env* *env*) (*max-env* 0) (*level* *level*)
(*volatile*
(if (get fname 'CONTAINS-SETJMP) " volatile " ""))
(if (get-sysprop fname 'CONTAINS-SETJMP) " volatile " ""))
(*exit* 'RETURN) (*unwind-exit* '(RETURN))
(*destination* 'RETURN)
(*reservation-cmacro* (next-cmacro)))
@ -955,52 +955,52 @@
;;; Pass 1 top-levels.
(setf (get 'COMPILER-LET 'T1) #'t1compiler-let)
(setf (get 'EVAL-WHEN 'T1) #'t1eval-when)
(setf (get 'PROGN 'T1) #'t1progn)
(setf (get 'DEFUN 'T1) #'t1defun)
(setf (get 'DEFMACRO 'T1) #'t1defmacro)
(setf (get 'DEFVAR 'T1) #'t1defvar)
(setf (get 'MACROLET 'T1) #'t1macrolet)
(setf (get 'LOCALLY 'T1) #'t1locally)
(setf (get 'SYMBOL-MACROLET 'T1) #'t1symbol-macrolet)
(setf (get 'CLINES 'T1) 't1clines)
(setf (get 'DEFCFUN 'T1) 't1defcfun)
;(setf (get 'DEFENTRY 'T1) 't1defentry)
(setf (get 'DEFLA 'T1) 't1defla)
(setf (get 'DEFCBODY 'T1) 't1defCbody) ; Beppe
;(setf (get 'DEFUNC 'T1) 't1defunC) ; Beppe
(setf (get 'LOAD-TIME-VALUE 'C1) 'c1load-time-value)
(put-sysprop 'COMPILER-LET 'T1 #'t1compiler-let)
(put-sysprop 'EVAL-WHEN 'T1 #'t1eval-when)
(put-sysprop 'PROGN 'T1 #'t1progn)
(put-sysprop 'DEFUN 'T1 #'t1defun)
(put-sysprop 'DEFMACRO 'T1 #'t1defmacro)
(put-sysprop 'DEFVAR 'T1 #'t1defvar)
(put-sysprop 'MACROLET 'T1 #'t1macrolet)
(put-sysprop 'LOCALLY 'T1 #'t1locally)
(put-sysprop 'SYMBOL-MACROLET 'T1 #'t1symbol-macrolet)
(put-sysprop 'CLINES 'T1 't1clines)
(put-sysprop 'DEFCFUN 'T1 't1defcfun)
;(put-sysprop 'DEFENTRY 'T1 't1defentry)
(put-sysprop 'DEFLA 'T1 't1defla)
(put-sysprop 'DEFCBODY 'T1 't1defCbody) ; Beppe
;(put-sysprop 'DEFUNC 'T1 't1defunC) ; Beppe
(put-sysprop 'LOAD-TIME-VALUE 'C1 'c1load-time-value)
;;; Pass 2 initializers.
(setf (get 'DECL-BODY 't2) #'t2decl-body)
(setf (get 'PROGN 'T2) #'t2progn)
(setf (get 'DEFUN 'T2) #'t2defun)
(setf (get 'DEFMACRO 'T2) #'t2defmacro)
(setf (get 'ORDINARY 'T2) #'t2ordinary)
(setf (get 'DECLARE 'T2) #'t2declare)
(setf (get 'DEFVAR 'T2) #'t2defvar)
;(setf (get 'DEFENTRY 'T2) 't2defentry)
(setf (get 'DEFCBODY 'T2) 't2defCbody) ; Beppe
;(setf (get 'DEFUNC 'T2) 't2defunC); Beppe
(setf (get 'FUNCTION-CONSTANT 'T2) 't2function-constant); Beppe
(setf (get 'LOAD-TIME-VALUE 'T2) 't2load-time-value)
(put-sysprop 'DECL-BODY 't2 #'t2decl-body)
(put-sysprop 'PROGN 'T2 #'t2progn)
(put-sysprop 'DEFUN 'T2 #'t2defun)
(put-sysprop 'DEFMACRO 'T2 #'t2defmacro)
(put-sysprop 'ORDINARY 'T2 #'t2ordinary)
(put-sysprop 'DECLARE 'T2 #'t2declare)
(put-sysprop 'DEFVAR 'T2 #'t2defvar)
;(put-sysprop 'DEFENTRY 'T2 't2defentry)
(put-sysprop 'DEFCBODY 'T2 't2defCbody) ; Beppe
;(put-sysprop 'DEFUNC 'T2 't2defunC); Beppe
(put-sysprop 'FUNCTION-CONSTANT 'T2 't2function-constant); Beppe
(put-sysprop 'LOAD-TIME-VALUE 'T2 't2load-time-value)
;;; Pass 2 C function generators.
(setf (get 'DECL-BODY 't3) #'t3decl-body)
(setf (get 'PROGN 'T3) #'t3progn)
(setf (get 'DEFUN 'T3) #'t3defun)
(setf (get 'DEFMACRO 'T3) #'t3defmacro)
(setf (get 'CLINES 'T3) 't3clines)
(setf (get 'DEFCFUN 'T3) 't3defcfun)
;(setf (get 'DEFENTRY 'T3) 't3defentry)
(setf (get 'DEFCBODY 'T3) 't3defCbody) ; Beppe
;(setf (get 'DEFUNC 'T3) 't3defunC) ; Beppe
(put-sysprop 'DECL-BODY 't3 #'t3decl-body)
(put-sysprop 'PROGN 'T3 #'t3progn)
(put-sysprop 'DEFUN 'T3 #'t3defun)
(put-sysprop 'DEFMACRO 'T3 #'t3defmacro)
(put-sysprop 'CLINES 'T3 't3clines)
(put-sysprop 'DEFCFUN 'T3 't3defcfun)
;(put-sysprop 'DEFENTRY 'T3 't3defentry)
(put-sysprop 'DEFCBODY 'T3 't3defCbody) ; Beppe
;(put-sysprop 'DEFUNC 'T3 't3defunC) ; Beppe
;;; Package operations.
(setf (get 'si::select-package 'PACKAGE-OPERATION) t)
(setf (get 'si::%defpackage 'PACKAGE-OPERATION) t)
(put-sysprop 'si::select-package 'PACKAGE-OPERATION t)
(put-sysprop 'si::%defpackage 'PACKAGE-OPERATION t)

2
src/cmp/cmptype.lsp
View file

@ -103,7 +103,7 @@
t))
((and (eq type-name 'SATISFIES) ; Beppe
(symbolp (car type-args))
(get (car type-args) 'TYPE-FILTER)))
(get-sysprop (car type-args) 'TYPE-FILTER)))
(t t))))))
;;; The algebra of types should be more complete. Beppe

22
src/cmp/cmputil.lsp
View file

@ -164,15 +164,15 @@
(defun si::compiler-clear-compiler-properties (symbol)
#-:CCL
;(sys::unlink-symbol symbol)
(remprop symbol 'package-operation)
(remprop symbol 't1)
(remprop symbol 't2)
(remprop symbol 't3)
(remprop symbol 'c1)
(remprop symbol 'c2)
(remprop symbol 'c1conditional)
(remprop symbol ':inline-always)
(remprop symbol ':inline-unsafe)
(remprop symbol ':inline-safe)
(remprop symbol 'lfun))
(rem-sysprop symbol 'package-operation)
(rem-sysprop symbol 't1)
(rem-sysprop symbol 't2)
(rem-sysprop symbol 't3)
(rem-sysprop symbol 'c1)
(rem-sysprop symbol 'c2)
(rem-sysprop symbol 'c1conditional)
(rem-sysprop symbol ':inline-always)
(rem-sysprop symbol ':inline-unsafe)
(rem-sysprop symbol ':inline-safe)
(rem-sysprop symbol 'lfun))

32
src/cmp/cmpvar.lsp
View file

@ -69,7 +69,7 @@
((not (symbolp form)) form)
(dolist (v *vars*
;; At the end, loof for a DEFINE-SYMBOL-MACRO definition
(let ((expansion (get form 'si::symbol-macro)))
(let ((expansion (get-sysprop form 'si::symbol-macro)))
(if expansion
(setq form expansion)
(return-from chk-symbol-macrolet form))))
@ -104,7 +104,7 @@
(setf (var-loc var) (add-symbol name))
(cond ((setq x (assoc name types))
(setf (var-type var) (cdr x)))
((setq x (get name 'CMP-TYPE))
((setq x (get-sysprop name 'CMP-TYPE))
(setf (var-type var) x)))
(setq *special-binding* t))
(t
@ -181,7 +181,7 @@
(setq var (make-var :name name
:kind 'GLOBAL
:loc (add-symbol name)
:type (or (get name 'CMP-TYPE) t)))
:type (or (get-sysprop name 'CMP-TYPE) t)))
(push var *undefined-vars*))
(list var)) ; ccb
)
@ -277,7 +277,7 @@
(push (make-var :name name
:kind 'GLOBAL
:loc (add-symbol name)
:type (let ((x (get name 'CMP-TYPE))) (if x x t))
:type (let ((x (get-sysprop name 'CMP-TYPE))) (if x x t))
)
*vars*))
)
@ -447,17 +447,17 @@
;;; ----------------------------------------------------------------------
(setf (get 'VAR 'C2) 'c2var)
(setf (get 'LOCATION 'C2) 'c2location)
(setf (get 'SETQ 'c1special) 'c1setq)
(setf (get 'SETQ 'C2) 'c2setq)
(setf (get 'PROGV 'c1special) 'c1progv)
(setf (get 'PROGV 'C2) 'c2progv)
(setf (get 'PSETQ 'c1) 'c1psetq)
(setf (get 'PSETQ 'C2) 'c2psetq)
(put-sysprop 'VAR 'C2 'c2var)
(put-sysprop 'LOCATION 'C2 'c2location)
(put-sysprop 'SETQ 'c1special 'c1setq)
(put-sysprop 'SETQ 'C2 'c2setq)
(put-sysprop 'PROGV 'c1special 'c1progv)
(put-sysprop 'PROGV 'C2 'c2progv)
(put-sysprop 'PSETQ 'c1 'c1psetq)
(put-sysprop 'PSETQ 'C2 'c2psetq)
(setf (get 'VAR 'SET-LOC) 'set-var)
(setf (get 'VAR 'WT-LOC) 'wt-var)
(put-sysprop 'VAR 'SET-LOC 'set-var)
(put-sysprop 'VAR 'WT-LOC 'wt-var)
(setf (get 'LEX 'SET-LOC) 'set-lex)
(setf (get 'LEX 'WT-LOC) 'wt-lex)
(put-sysprop 'LEX 'SET-LOC 'set-lex)
(put-sysprop 'LEX 'WT-LOC 'wt-lex)

4
src/cmp/cmpwt.lsp
View file

@ -58,7 +58,7 @@
(defun wt-h1 (form)
(if (consp form)
(let ((fun (get (car form) 'wt)))
(let ((fun (get-sysprop (car form) 'wt)))
(if fun
(apply fun (cdr form))
(cmperr "The location ~s is undefined." form)))
@ -153,4 +153,4 @@
(let ((output (t1ordinary `(eval ',form))))
(wt-filtered-data (format nil "#!1 ~s" (second form)))
(cmp-eval form)
output))))
output))))

23
src/cmp/sysfun.lsp
View file

@ -45,22 +45,22 @@
;; The value NIL for each parameter except for fname means "not known".
;; optimizers is a list of alternating {safety inline-info}* as above.
(when arg-types
(setf (get fname 'arg-types)
(mapcar #'(lambda (x) (if (eql x '*) '* (type-filter x)))
arg-types)))
(put-sysprop fname 'arg-types
(mapcar #'(lambda (x) (if (eql x '*) '* (type-filter x)))
arg-types)))
(when (and return-type (not (eq 'T return-type)))
(setf (get fname 'return-type) (type-filter return-type)))
(when never-change-special-var-p (setf (get fname 'no-sp-change) t))
(when predicate (setf (get fname 'predicate) t))
(remprop fname ':inline-always)
(remprop fname ':inline-safe)
(remprop fname ':inline-unsafe)
(put-sysprop fname 'return-type (type-filter return-type)))
(when never-change-special-var-p (put-sysprop fname 'no-sp-change t))
(when predicate (put-sysprop fname 'predicate t))
(rem-sysprop fname ':inline-always)
(rem-sysprop fname ':inline-safe)
(rem-sysprop fname ':inline-unsafe)
(do ((scan optimizers (cddr scan))
(safety) (inline-info))
((null scan))
(setq safety (first scan)
inline-info (second scan))
(push inline-info (get fname safety)))
(put-sysprop fname safety (cons inline-info (get-sysprop fname safety))))
)
; file alloc.c
@ -977,6 +977,9 @@ type_of(#0)==t_bitvector"))
(SI::REM-F NIL (T T))
(si::SET-SYMBOL-PLIST (symbol t) T)
(SI::PUTPROP (T T T) T NIL NIL)
(SI::PUT-SYSPROP (T T T) T NIL NIL)
(SI::GET-SYSPROP (T T T) T NIL NIL)
(SI::REM-SYSPROP (T T) T NIL NIL)
; file tcp.c
(si::OPEN-TCP-STREAM (T T) T)

3
src/h/external.h
View file

@ -122,6 +122,9 @@ extern cl_object si_setf_namep(cl_object arg);
extern cl_object cl_makunbound(cl_object sym);
extern cl_object cl_fmakunbound(cl_object sym);
extern cl_object si_fset _ARGS((int narg, cl_object fun, cl_object def, ...));
extern cl_object si_get_sysprop(cl_object sym, cl_object prop);
extern cl_object si_put_sysprop(cl_object sym, cl_object prop, cl_object value);
extern cl_object si_rem_sysprop(cl_object sym, cl_object prop);
extern cl_object setf_namep(cl_object fun_spec);
extern void clear_compiler_properties(cl_object sym);

10
src/lsp/autoload.lsp
View file

@ -23,10 +23,10 @@
(when (and *record-source-pathname-p*
*source-pathname*)
(when (sys::setf-namep symbol)
(setq symbol (get (second symbol) 'setf-symbol)))
(setq symbol (get-sysprop (second symbol) 'setf-symbol)))
(if (symbolp type)
(putprop symbol *source-pathname* type)
(let* ((alist (get symbol (car type)))
(put-sysprop symbol *source-pathname* type)
(let* ((alist (get-sysprop symbol (car type)))
(spec (cdr type)))
(if alist
(let ((entry (assoc spec alist :test #'equal)))
@ -34,7 +34,7 @@
(setf (cdr entry) *source-pathname*)
(push (cons spec *source-pathname*) alist)))
(setq alist (list (cons spec *source-pathname*))))
(putprop symbol alist (car type))))))
(put-sysprop symbol alist (car type))))))
)
;;; Go into LISP.
@ -265,7 +265,7 @@ NIL, then all packages are searched."
(in-package "SYSTEM")
(mapc #'(lambda (x) (sys::putprop (first x) (second x) 'sys::pretty-print-format))
(mapc #'(lambda (x) (put-sysprop (first x) 'sys::pretty-print-format (second x)))
'((block 1)
(case 1)
(catch 1)

5
src/lsp/defpackage.lsp
View file

@ -195,9 +195,8 @@
(unuse-package (package-use-list (find-package name)) name)))
(make-package name :use nil :nicknames nicknames))
#+nil
(when documentation ((setf (get (intern name :keyword)
:package-documentation)
documentation)))
(when documentation ((put-sysprop (intern name :keyword) :package-documentation
documentation)))
(let ((*package* (find-package name)))
(when shadowed-symbol-names
(shadow (mapcar #'intern shadowed-symbol-names)))

42
src/lsp/defstruct.lsp
View file

@ -39,15 +39,15 @@
(t (error "~S is an illegal structure type." type)))
(if read-only
(progn
(remprop access-function 'SETF-UPDATE-FN)
(remprop access-function 'SETF-LAMBDA)
(remprop access-function 'SETF-SYMBOL)
(sys::set-documentation access-function 'SETF nil))
(rem-sysprop access-function 'SETF-UPDATE-FN)
(rem-sysprop access-function 'SETF-LAMBDA)
(rem-sysprop access-function 'SETF-SYMBOL)
(set-documentation access-function 'SETF nil))
(progn
;; The following is used by the compiler to expand inline
;; the accessor
(sys:putprop access-function (cons (or type name) offset)
'STRUCTURE-ACCESS))))
(put-sysprop access-function 'STRUCTURE-ACCESS (cons (or type name) offset)))
))
)
(defun make-constructor (name constructor type named slot-descriptions)
@ -322,16 +322,15 @@
(defun define-structure (name conc-name type named slots slot-descriptions
copier include print-function constructors
offset documentation)
(sys:put-properties name
'DEFSTRUCT-FORM `(defstruct ,name ,@slots)
'IS-A-STRUCTURE t
'STRUCTURE-SLOT-DESCRIPTIONS slot-descriptions
'STRUCTURE-INCLUDE include
'STRUCTURE-PRINT-FUNCTION print-function
'STRUCTURE-TYPE type
'STRUCTURE-NAMED named
'STRUCTURE-OFFSET offset
'STRUCTURE-CONSTRUCTORS constructors)
(put-sysprop name 'DEFSTRUCT-FORM `(defstruct ,name ,@slots))
(put-sysprop name 'IS-A-STRUCTURE t)
(put-sysprop name 'STRUCTURE-SLOT-DESCRIPTIONS slot-descriptions)
(put-sysprop name 'STRUCTURE-INCLUDE include)
(put-sysprop name 'STRUCTURE-PRINT-FUNCTION print-function)
(put-sysprop name 'STRUCTURE-TYPE type)
(put-sysprop name 'STRUCTURE-NAMED named)
(put-sysprop name 'STRUCTURE-OFFSET offset)
(put-sysprop name 'STRUCTURE-CONSTRUCTORS constructors)
(when *keep-documentation*
(sys:set-documentation name 'STRUCTURE documentation))
(and (consp type) (eq (car type) 'VECTOR)
@ -419,7 +418,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(setq predicate-specified t))
(:INCLUDE
(setq include (cdar os))
(unless (get v 'IS-A-STRUCTURE)
(unless (get-sysprop v 'IS-A-STRUCTURE)
(error "~S is an illegal included structure." v)))
(:PRINT-FUNCTION (setq print-function v))
(:TYPE (setq type v))
@ -447,13 +446,13 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
;; Check the include option.
(when include
(unless (equal type (get (car include) 'STRUCTURE-TYPE))
(unless (equal type (get-sysprop (car include) 'STRUCTURE-TYPE))
(error "~S is an illegal structure include."
(car include))))
;; Set OFFSET.
(setq offset (if include
(get (car include) 'STRUCTURE-OFFSET)
(get-sysprop (car include) 'STRUCTURE-OFFSET)
0))
;; Increment OFFSET.
@ -490,7 +489,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(cond ((null include))
((endp (cdr include))
(setq slot-descriptions
(append (get (car include) 'STRUCTURE-SLOT-DESCRIPTIONS)
(append (get-sysprop (car include) 'STRUCTURE-SLOT-DESCRIPTIONS)
slot-descriptions)))
(t
(setq slot-descriptions
@ -498,8 +497,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(mapcar #'(lambda (sd)
(parse-slot-description sd 0))
(cdr include))
(get (car include)
'STRUCTURE-SLOT-DESCRIPTIONS))
(get-sysprop (car include) 'STRUCTURE-SLOT-DESCRIPTIONS))
slot-descriptions))))
(cond (no-constructor

14
src/lsp/describe.lsp
View file

@ -489,30 +489,30 @@ inspect commands, or type '?' to the inspector."
(cond ((setq x (si::get-documentation symbol 'TYPE))
(doc1 x "[Type]"))
((setq x (get symbol 'DEFTYPE-FORM))
((setq x (get-sysprop symbol 'DEFTYPE-FORM))
(let ((*package* (good-package)))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x)
"[Type]"))))
(cond ((setq x (si::get-documentation symbol 'STRUCTURE))
(doc1 x "[Structure]"))
((setq x (get symbol 'DEFSTRUCT-FORM))
((setq x (get-sysprop symbol 'DEFSTRUCT-FORM))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x)
"[Structure]")))
(cond ((setq x (si::get-documentation symbol 'SETF))
(doc1 x "[Setf]"))
((setq x (get symbol 'SETF-UPDATE-FN))
((setq x (get-sysprop symbol 'SETF-UPDATE-FN))
(let ((*package* (good-package)))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
`(defsetf ,symbol ,(get symbol 'SETF-UPDATE-FN)))
`(defsetf ,symbol ,(get-sysprop symbol 'SETF-UPDATE-FN)))
"[Setf]")))
((setq x (get symbol 'SETF-LAMBDA))
((setq x (get-sysprop symbol 'SETF-LAMBDA))
(let ((*package* (good-package)))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
`(defsetf ,symbol ,@(get symbol 'SETF-LAMBDA)))
`(defsetf ,symbol ,@(get-sysprop symbol 'SETF-LAMBDA)))
"[Setf]")))
((setq x (get symbol 'SETF-METHOD))
((setq x (get-sysprop symbol 'SETF-METHOD))
(let ((*package* (good-package)))
(doc1
(format nil

11
src/lsp/evalmacros.lsp
View file

@ -113,17 +113,17 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)."
(print function)
(setq function `(si::bc-disassemble ,function)))
`(progn
(setf (get ',name 'sys::compiler-macro)
(compiler-macro-function-wrapper ,function))
(put-sysprop ',name 'sys::compiler-macro
(compiler-macro-function-wrapper ,function))
,@(si::expand-set-documentation name 'function doc-string)
',name))))
(defun compiler-macro-function (name &optional env)
(declare (ignore env))
(get name 'sys::compiler-macro))
(get-sysprop name 'sys::compiler-macro))
(defun sys::undef-compiler-macro (name)
(remprop name 'sys::compiler-macro))
(rem-sysprop name 'sys::compiler-macro))
;;; Each of the following macros is also defined as a special form,
@ -402,8 +402,7 @@ SECOND-FORM."
symbol))
(t
`(progn
(setf (get ',symbol 'si::symbol-macro)
(lambda (form env) ',expansion))
(put-sysprop ',symbol 'si::symbol-macro (lambda (form env) ',expansion))
',symbol))))
(defmacro nth-value (n expr)

6
src/lsp/iolib.lsp
View file

@ -166,13 +166,13 @@ printed. If FORMAT-STRING is NIL, however, no prompt will appear."
(let ((l (read stream)))
(when *read-suppress*
(return-from sharp-s-reader nil))
(unless (get (car l) 'is-a-structure)
(unless (get-sysprop (car l) 'is-a-structure)
(error "~S is not a structure." (car l)))
;; Intern keywords in the keyword package.
(do ((ll (cdr l) (cddr ll)))
((endp ll)
;; Find an appropriate construtor.
(do ((cs (get (car l) 'structure-constructors) (cdr cs)))
(do ((cs (get-sysprop (car l) 'structure-constructors) (cdr cs)))
((endp cs)
(error "The structure ~S has no structure constructor."
(car l)))
@ -248,4 +248,4 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t,
(*read-eval* t)
(*read-suppress* nil)
(*readtable* (copy-readtable (si::standard-readtable))))
,@body))
,@body))

2
src/lsp/loop.lsp
View file

@ -928,7 +928,7 @@ The offending clause"
z)
((symbolp (car x))
(let ((fn (car x)) (tem nil))
(cond ((setq tem (get fn 'loop-simplep))
(cond ((setq tem (get-sysprop fn 'loop-simplep))
(if (typep tem 'fixnum) (setq z tem)
(setq z (funcall tem x) x nil)))
((member fn '(null not eq go return progn)))

2
src/lsp/loop2.lsp
View file

@ -934,7 +934,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
(macrolet ((f (overhead &optional (args nil args-p))
`(the fixnum (+ (the fixnum ,overhead)
(the fixnum (list-size ,(if args-p args '(cdr x))))))))
(cond ((setq tem (get fn 'estimate-code-size))
(cond ((setq tem (get-sysprop fn 'estimate-code-size))
(typecase tem
(fixnum (f tem))
(t (funcall tem x env))))

37
src/lsp/predlib.lsp
View file

@ -33,10 +33,8 @@ by (documentation 'NAME 'type)."
(multiple-value-bind (body doc)
(remove-documentation body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name 'DEFTYPE-FORM)
'(DEFTYPE ,name ,lambda-list ,@body))
(setf (get ',name 'DEFTYPE-DEFINITION)
#'(LAMBDA ,lambda-list ,@body))
(put-sysprop ',name 'DEFTYPE-FORM '(DEFTYPE ,name ,lambda-list ,@body))
(put-sysprop ',name 'DEFTYPE-DEFINITION #'(LAMBDA ,lambda-list ,@body))
,@(si::expand-set-documentation name 'type doc)
',name)))
@ -174,7 +172,7 @@ has no fill-pointer, and is not adjustable."
(COMMON . COMMONP)
(REAL . REALP)
))
(setf (get (car l) 'TYPE-PREDICATE) (cdr l)))
(put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
(defun type-for-array (element-type)
@ -192,7 +190,7 @@ has no fill-pointer, and is not adjustable."
"Args: (object type)
Returns T if X belongs to TYPE; NIL otherwise."
(cond ((symbolp type)
(let ((f (get type 'TYPE-PREDICATE)))
(let ((f (get-sysprop type 'TYPE-PREDICATE)))
(cond (f (return-from typep (funcall f object)))
((eq (type-of object) type) (return-from typep t))
(t (setq tp type i nil)))))
@ -273,21 +271,20 @@ Returns T if X belongs to TYPE; NIL otherwise."
(match-dimensions (array-dimensions object) (second i)))))
(t
(cond
((get tp 'DEFTYPE-DEFINITION)
(typep object
(apply (get tp 'DEFTYPE-DEFINITION) i)))
((get-sysprop tp 'DEFTYPE-DEFINITION)
(typep object (apply (get-sysprop tp 'DEFTYPE-DEFINITION) i)))
#+clos
((setq c (find-class type nil))
;; Follow the inheritance chain
(subclassp (class-of object) c))
#-clos
((get tp 'IS-A-STRUCTURE)
((get-sysprop tp 'IS-A-STRUCTURE)
(when (sys:structurep object)
;; Follow the chain of structure-include.
(do ((stp (sys:structure-name object)
(get stp 'STRUCTURE-INCLUDE)))
(get-sysprop stp 'STRUCTURE-INCLUDE)))
((eq tp stp) t)
(when (null (get stp 'STRUCTURE-INCLUDE))
(when (null (get-sysprop stp 'STRUCTURE-INCLUDE))
(return nil)))))
(t (error "typep: not a valid type specifier ~A for ~A" type object))))))
@ -308,7 +305,7 @@ Returns T if X belongs to TYPE; NIL otherwise."
(defun normalize-type (type &aux tp i fd)
;; Loops until the car of type has no DEFTYPE definition.
(cond ((symbolp type)
(if (setq fd (get type 'DEFTYPE-DEFINITION))
(if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION))
(normalize-type (funcall fd))
(values type nil)))
#+clos
@ -317,7 +314,7 @@ Returns T if X belongs to TYPE; NIL otherwise."
(error "normalize-type: bogus type specifier ~A" type))
((progn
(setq tp (car type) i (cdr type))
(setq fd (get tp 'DEFTYPE-DEFINITION)))
(setq fd (get-sysprop tp 'DEFTYPE-DEFINITION)))
(normalize-type (apply fd i)))
((and (eq tp 'INTEGER) (consp (cadr i)))
(values tp (list (car i) (1- (caadr i)))))
@ -341,7 +338,7 @@ Returns T if X belongs to TYPE; NIL otherwise."
#+clos
(find-class type nil)
#-clos
(get type 'IS-A-STRUCTURE))
(get-sysprop type 'IS-A-STRUCTURE))
t)
(t nil)))
@ -420,20 +417,20 @@ second value is T."
#-clos
((eq t2 'STRUCTURE)
(if (or (eq t1 'STRUCTURE)
(get t1 'IS-A-STRUCTURE))
(get-sysprop t1 'IS-A-STRUCTURE))
(values t t)
(values nil ntp1)))
#-clos
((eq t1 'STRUCTURE) (values nil ntp2))
#-clos
((get t1 'IS-A-STRUCTURE)
(if (get t2 'IS-A-STRUCTURE)
(do ((tp1 t1 (get tp1 'STRUCTURE-INCLUDE)) (tp2 t2))
((get-sysprop t1 'IS-A-STRUCTURE)
(if (get-sysprop t2 'IS-A-STRUCTURE)
(do ((tp1 t1 (get-sysprop tp1 'STRUCTURE-INCLUDE)) (tp2 t2))
((null tp1) (values nil t))
(when (eq tp1 tp2) (return (values t t))))
(values nil ntp2)))
#-clos
((get t2 'IS-A-STRUCTURE) (values nil ntp1))
((get-sysprop t2 'IS-A-STRUCTURE) (values nil ntp1))
#+clos
((setq c1 (find-the-class t1))
(if (setq c2 (find-the-class t2))

34
src/lsp/setf.lsp
View file

@ -28,10 +28,10 @@ The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved
by (documentation 'SYMBOL 'setf)."
(cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
`(eval-when (compile load eval)
(sys:putprop ',access-fn ',(car rest) 'SETF-UPDATE-FN)
(remprop ',access-fn 'SETF-LAMBDA)
(remprop ',access-fn 'SETF-METHOD)
(remprop ',access-fn 'SETF-SYMBOL)
(put-sysprop ',access-fn 'SETF-UPDATE-FN ',(car rest))
(rem-sysprop ',access-fn 'SETF-LAMBDA)
(rem-sysprop ',access-fn 'SETF-METHOD)
(rem-sysprop ',access-fn 'SETF-SYMBOL)
,@(si::expand-set-documentation access-fn 'setf (cadr rest))
',access-fn))
(t
@ -43,11 +43,10 @@ by (documentation 'SYMBOL 'setf)."
(error "Single store-variable expected."))
(setq rest `(lambda ,args #'(lambda ,store ,@body)))
`(eval-when (compile load eval)
(sys:putprop ',access-fn #'(lambda (,@store ,@args) ,@body)
'SETF-LAMBDA)
(remprop ',access-fn 'SETF-UPDATE-FN)
(remprop ',access-fn 'SETF-METHOD)
(remprop ',access-fn 'SETF-SYMBOL)
(put-sysprop ',access-fn 'SETF-LAMBDA #'(lambda (,@store ,@args) ,@body))
(rem-sysprop ',access-fn 'SETF-UPDATE-FN)
(rem-sysprop ',access-fn 'SETF-METHOD)
(rem-sysprop ',access-fn 'SETF-SYMBOL)
,@(si::expand-set-documentation access-fn 'setf doc)
',access-fn)))))
@ -83,10 +82,10 @@ by (DOCUMENTATION 'SYMBOL 'SETF)."
(setq args (cons env args))
(push `(declare (ignore ,env)) body))))
`(eval-when (compile load eval)
(sys:putprop ',access-fn #'(lambda ,args ,@body) 'SETF-METHOD)
(remprop ',access-fn 'SETF-LAMBDA)
(remprop ',access-fn 'SETF-UPDATE-FN)
(remprop ',access-fn 'SETF-SYMBOL)
(put-sysprop ',access-fn 'SETF-METHOD #'(lambda ,args ,@body))
(rem-sysprop ',access-fn 'SETF-LAMBDA)
(rem-sysprop ',access-fn 'SETF-UPDATE-FN)
(rem-sysprop ',access-fn 'SETF-SYMBOL)
,@(si::expand-set-documentation access-fn 'setf
(find-documentation body))
',access-fn))
@ -128,18 +127,18 @@ Does not check if the third gang is a single-element list."
(values nil nil (list store) `(setq ,form ,store) form)))
((or (not (consp form)) (not (symbolp (car form))))
(error "Cannot get the setf-method of ~S." form))
((setq f (get (car form) 'SETF-METHOD))
((setq f (get-sysprop (car form) 'SETF-METHOD))
(apply f env (cdr form)))
(t
(let* ((name (car form)) writer)
(multiple-value-bind (store vars inits all)
(rename-arguments (cdr form))
(setq writer
(cond ((setq f (get name 'SETF-UPDATE-FN))
(cond ((setq f (get-sysprop name 'SETF-UPDATE-FN))
`(,f ,@all ,store))
((setq f (get name 'STRUCTURE-ACCESS))
((setq f (get-sysprop name 'STRUCTURE-ACCESS))
(setf-structure-access (car all) (car f) (cdr f) store))
((setq f (get (car form) 'SETF-LAMBDA))
((setq f (get-sysprop (car form) 'SETF-LAMBDA))
(apply f store all))
(t
`(,(si::setf-namep (list 'SETF name)) ,store ,@all))))
@ -198,6 +197,7 @@ Does not check if the third gang is a single-element list."
(defsetf row-major-aref (a i) (v) `(sys:row-major-aset ,a ,i ,v))
(defsetf get (s p &optional d) (v)
(if d `(progn ,d (sys:putprop ,s ,v ,p)) `(sys:putprop ,s ,v ,p)))
(defsetf get-sysprop put-sysprop)
(defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v))
(defsetf char sys:char-set)
(defsetf schar sys:schar-set)

16
src/lsp/trace.lsp
View file

@ -61,7 +61,7 @@ SI::ARGS."
(cond ((atom spec)
(setq fname spec))
((eq 'SETF (car spec))
(setq fname (get (cadr spec) 'SETF-SYMBOL)))
(setq fname (get-sysprop (cadr spec) 'SETF-SYMBOL)))
((atom (car spec))
(setq fname (car spec))
(do ((specs (cdr spec) (cdr specs)))
@ -80,7 +80,7 @@ SI::ARGS."
(unless barfp (error "Parameter missing"))))
((eq 'SETF (caar spec))
(return-from trace-one
(trace-one `(,(get (cadar spec) 'SETF-SYMBOL) . ,(cdr spec)))))
(trace-one `(,(get-sysprop (cadar spec) 'SETF-SYMBOL) . ,(cdr spec)))))
(t
(let (results)
(dolist (fname (car spec))
@ -95,14 +95,14 @@ SI::ARGS."
(when (macro-function fname)
(format *trace-output* "~S is a macro.~%" fname)
(return-from trace-one nil))
(when (get fname 'TRACED)
(when (get-sysprop fname 'TRACED)
(cond ((tracing-body fname)
(format *trace-output*
"The function ~S is already traced.~%" fname)
(return-from trace-one nil))
(t (untrace-one fname))))
(sys:fset (setq oldf (gensym)) (symbol-function fname))
(sys:putprop fname oldf 'TRACED)
(put-sysprop fname 'TRACED oldf)
(eval
`(defun ,fname (&rest args)
(block ,+tracing-block+ ; used to recognize traced functions
@ -172,13 +172,13 @@ SI::ARGS."
extras))))
(defun untrace-one (fname)
(cond ((get fname 'TRACED)
(cond ((get-sysprop fname 'TRACED)
(if (tracing-body fname)
(sys:fset fname (symbol-function (get fname 'TRACED)))
(sys:fset fname (symbol-function (get-sysprop fname 'TRACED)))
(format *trace-output*
"The function ~S was traced, but redefined.~%"
fname))
(remprop fname 'TRACED)
(rem-sysprop fname 'TRACED)
(setq *trace-list* (delete fname *trace-list* :test #'eq))
(list fname))
(t
@ -272,7 +272,7 @@ for Stepper mode commands."
;; skip the encapsulation of traced functions:
(when (and (consp form)
(symbolp (car form))
(get (car form) 'TRACED)
(get-sysprop (car form) 'TRACED)
(tracing-body (car form)))
(do ((args (cdr form) (cdr args))
(values))