From 6b76d155eeaf55b138a1dc6fd8044b52a00e118e Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Fri, 21 Mar 2003 14:18:56 +0000 Subject: [PATCH] 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. --- src/CHANGELOG | 6 +++ src/c/assignment.d | 80 +++++++++++++++++++++++------- src/c/eval.d | 10 ++-- src/c/macros.d | 2 +- src/c/print.d | 8 +-- src/c/structure.d | 4 +- src/c/symbol.d | 1 + src/c/symbols_list.h | 3 ++ src/clos/conditions.lsp | 2 +- src/clos/kernel.lsp | 2 +- src/clos/macros.lsp | 2 +- src/clos/method.lsp | 6 +-- src/clos/precomp.lsp | 6 +-- src/clos/walk.lsp | 8 +-- src/cmp/cmpbind.lsp | 2 +- src/cmp/cmpblock.lsp | 8 +-- src/cmp/cmpcall.lsp | 28 +++++------ src/cmp/cmpcatch.lsp | 12 ++--- src/cmp/cmpdefs.lsp | 3 +- src/cmp/cmpenv.lsp | 36 +++++++------- src/cmp/cmpeval.lsp | 42 ++++++++-------- src/cmp/cmpflet.lsp | 16 +++--- src/cmp/cmpfun.lsp | 62 +++++++++++------------ src/cmp/cmpif.lsp | 24 ++++----- src/cmp/cmpinline.lsp | 42 ++++++++-------- src/cmp/cmplam.lsp | 2 +- src/cmp/cmplet.lsp | 8 +-- src/cmp/cmploc.lsp | 38 +++++++------- src/cmp/cmpmain.lsp | 6 +-- src/cmp/cmpmap.lsp | 18 +++---- src/cmp/cmpmulti.lsp | 22 ++++----- src/cmp/cmpspecial.lsp | 22 ++++----- src/cmp/cmptag.lsp | 8 +-- src/cmp/cmptest.lsp | 26 +++++----- src/cmp/cmptop.lsp | 106 ++++++++++++++++++++-------------------- src/cmp/cmptype.lsp | 2 +- src/cmp/cmputil.lsp | 22 ++++----- src/cmp/cmpvar.lsp | 32 ++++++------ src/cmp/cmpwt.lsp | 4 +- src/cmp/sysfun.lsp | 23 +++++---- src/h/external.h | 3 ++ src/lsp/autoload.lsp | 10 ++-- src/lsp/defpackage.lsp | 5 +- src/lsp/defstruct.lsp | 42 ++++++++-------- src/lsp/describe.lsp | 14 +++--- src/lsp/evalmacros.lsp | 11 ++--- src/lsp/iolib.lsp | 6 +-- src/lsp/loop.lsp | 2 +- src/lsp/loop2.lsp | 2 +- src/lsp/predlib.lsp | 37 +++++++------- src/lsp/setf.lsp | 34 ++++++------- src/lsp/trace.lsp | 16 +++--- 52 files changed, 494 insertions(+), 442 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 1bfb25bf7..26c82567a 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -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: ===== diff --git a/src/c/assignment.d b/src/c/assignment.d index 1c6b132ec..c1a66afdc 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -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 */ } diff --git a/src/c/eval.d b/src/c/eval.d index 08c86e227..08f6be260 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -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)); diff --git a/src/c/macros.d b/src/c/macros.d index 2e029e98c..139d5b524 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -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 diff --git a/src/c/print.d b/src/c/print.d index 9103f0648..f7dedb56d 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -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. diff --git a/src/c/structure.d b/src/c/structure.d index d348a3bab..7873e69d2 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -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) && isymbol.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) @) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index d48d2efbf..9c4cfd698 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}, diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index d074e1b28..601828f53 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -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) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 45b3459b0..e05be03d0 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -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)))) diff --git a/src/clos/macros.lsp b/src/clos/macros.lsp index 0e781ba9b..4844d7693 100644 --- a/src/clos/macros.lsp +++ b/src/clos/macros.lsp @@ -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") diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 3a54630de..20199e387 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -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))) diff --git a/src/clos/precomp.lsp b/src/clos/precomp.lsp index 25229bdcf..af9b3ee8a 100644 --- a/src/clos/precomp.lsp +++ b/src/clos/precomp.lsp @@ -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) diff --git a/src/clos/walk.lsp b/src/clos/walk.lsp index 05725c8aa..3ef5a4699 100644 --- a/src/clos/walk.lsp +++ b/src/clos/walk.lsp @@ -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) diff --git a/src/cmp/cmpbind.lsp b/src/cmp/cmpbind.lsp index bc124767b..730687ebd 100644 --- a/src/cmp/cmpbind.lsp +++ b/src/cmp/cmpbind.lsp @@ -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) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index 4d22ec56a..87424aac5 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -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) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 659748bea..9bbd677cb 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -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) diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index 3b4383752..216247e7f 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -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) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 6db98a13a..aaf04fffd 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -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") diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index ed5853857..13152fedf 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -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*) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 874024a3f..766cec73b 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -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) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index a360528df..d8baa6bb6 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -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) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 4741d1464..a17a5bf3b 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -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) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 5cc56a37b..81f6b94e2 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -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) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 5b4310d40..1083f74c5 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -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) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 8bfd90eb1..7f9d6c05f 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -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) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index b1e33279c..6e83aa95c 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -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*) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 5d6705066..15c44e10b 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -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) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 90b4a9301..64d080b9e 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -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*)))) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index 37cf5c402..dd82ce835 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -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)) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 1fdc2dc1b..71b6a7f45 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -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) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index b91d457ee..a634072c2 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -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) diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index 831560601..c62a8120c 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -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) diff --git a/src/cmp/cmptest.lsp b/src/cmp/cmptest.lsp index 8b45ce50b..99733ee0d 100644 --- a/src/cmp/cmptest.lsp +++ b/src/cmp/cmptest.lsp @@ -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)))) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index cbfc346eb..70a2de451 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -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) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 4ddb270f4..dc1549015 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -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 diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 0fed3bda5..88778c105 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -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)) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index cf462608a..4636dd8d7 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -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) diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 21605c3d3..39ecb4afe 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -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)))) \ No newline at end of file + output)))) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 333d1431e..c91c84c0a 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -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) diff --git a/src/h/external.h b/src/h/external.h index 9448f9139..cb4e73662 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -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); diff --git a/src/lsp/autoload.lsp b/src/lsp/autoload.lsp index ccadf83f3..b3192c504 100644 --- a/src/lsp/autoload.lsp +++ b/src/lsp/autoload.lsp @@ -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) diff --git a/src/lsp/defpackage.lsp b/src/lsp/defpackage.lsp index e1f527cc9..10f3253cd 100644 --- a/src/lsp/defpackage.lsp +++ b/src/lsp/defpackage.lsp @@ -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))) diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 240d28be3..e882472ea 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -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 diff --git a/src/lsp/describe.lsp b/src/lsp/describe.lsp index adcfb4687..3e9464094 100644 --- a/src/lsp/describe.lsp +++ b/src/lsp/describe.lsp @@ -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 diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 5166b8ca3..920a9bfc7 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -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) diff --git a/src/lsp/iolib.lsp b/src/lsp/iolib.lsp index 1fd19edda..6e08a9228 100644 --- a/src/lsp/iolib.lsp +++ b/src/lsp/iolib.lsp @@ -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)) \ No newline at end of file + ,@body)) diff --git a/src/lsp/loop.lsp b/src/lsp/loop.lsp index 6b40e3324..fa5986f53 100644 --- a/src/lsp/loop.lsp +++ b/src/lsp/loop.lsp @@ -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))) diff --git a/src/lsp/loop2.lsp b/src/lsp/loop2.lsp index 0e51d2896..3e1ffab12 100755 --- a/src/lsp/loop2.lsp +++ b/src/lsp/loop2.lsp @@ -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)))) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 24f5a1b07..6806cbcfe 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -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)) diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index 2159365bc..9eb8e62a9 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -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) diff --git a/src/lsp/trace.lsp b/src/lsp/trace.lsp index 036542515..45a573aaf 100644 --- a/src/lsp/trace.lsp +++ b/src/lsp/trace.lsp @@ -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))