From 7e5cacd38e06bc65a7b0711db84b59dbf458b0a3 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Fri, 17 May 2002 16:37:21 +0000 Subject: [PATCH] * Variable *EVAL-WHEN-COMPILE* is no longer used. * FIND-CLASS belongs to the C library -- it can now be directly called. * Class BUILT-IN renamed to BUILT-IN-CLASS * Macro PROG1 slightly optimized --- src/c/all_functions.d | 3 +++ src/c/all_symbols.d | 2 +- src/c/alloc_2.d | 2 +- src/c/clos.d | 27 +++++++++++++++++++-------- src/clos/boot.lsp | 14 +++++++------- src/clos/builtin.lsp | 6 +++--- src/clos/macros.lsp | 24 ------------------------ src/doc/user.txi | 15 --------------- src/h/lisp_external.h | 3 ++- src/lsp/evalmacros.lsp | 3 ++- src/lsp/export.lsp | 5 +---- src/lsp/predlib.lsp | 5 ----- 12 files changed, 39 insertions(+), 70 deletions(-) diff --git a/src/c/all_functions.d b/src/c/all_functions.d index 999b3ac66..dcbc6fc70 100644 --- a/src/c/all_functions.d +++ b/src/c/all_functions.d @@ -127,6 +127,9 @@ const struct function_info all_functions[] = { {"CHAR-NAME", clLchar_name, cl}, {"NAME-CHAR", clLname_char, cl}, + /* clos.c */ + {"FIND-CLASS", clLfind_class, cl}, + /* cmpaux.c */ {"SPECIALP", siLspecialp, si}, diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index e5ef777b2..020c3cfd9 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -47,7 +47,7 @@ const struct symbol_info all_symbols[] = { #ifdef CLOS {&siVclass_name_hash_table, "*CLASS-NAME-HASH-TABLE*", SI_SPECIAL}, {&clSclass, "CLASS", CL_ORDINARY}, -{&clSbuilt_in, "BUILT-IN", CL_ORDINARY}, +{&clSbuilt_in_class, "BUILT-IN-CLASS", CL_ORDINARY}, #endif /* compiler.c */ diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index dd05c7afa..5c433cfb6 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -112,7 +112,7 @@ cl_alloc_atomic(cl_index n) void cl_dealloc(void *p, cl_index s) { - GC_free(p); + /* GC_free(p); */ } /* diff --git a/src/c/clos.d b/src/c/clos.d index cd3311a69..a8024ee1f 100644 --- a/src/c/clos.d +++ b/src/c/clos.d @@ -20,7 +20,7 @@ cl_object class_class, class_object, class_built_in; cl_object @'si::*class-name-hash-table*'; cl_object @'class'; -cl_object @'built-in'; +cl_object @'built-in-class'; /******************************* ------- ******************************/ @@ -56,11 +56,22 @@ make_our_hash_table(cl_object test, int size) return(h); } +@(defun find-class (name &optional (errorp Ct) env) + cl_object class; +@ + class = gethash_safe(name, SYM_VAL(@'si::*class-name-hash-table*'), Cnil); + if (class == Cnil) { + if (!Null(errorp)) + FEerror("No class named ~S.", 1, name); + } + @(return class) +@) + static void clos_boot(void) { - SYM_VAL(siVclass_name_hash_table) = make_our_hash_table(@'eq', 1024); + SYM_VAL(@'si::*class-name-hash-table*') = make_our_hash_table(@'eq', 1024); /* booting Class CLASS */ @@ -72,19 +83,19 @@ clos_boot(void) CLASS_INFERIORS(class_class) = Cnil; CLASS_SLOTS(class_class) = OBJNULL; /* filled later */ - sethash(@'class', SYM_VAL(siVclass_name_hash_table), class_class); + sethash(@'class', SYM_VAL(@'si::*class-name-hash-table*'), class_class); - /* booting Class BUILT-IN */ + /* booting Class BUILT-IN-CLASS */ class_built_in = cl_alloc_instance(4); register_root(&class_built_in); CLASS_OF(class_built_in) = class_class; - CLASS_NAME(class_built_in) = @'built-in'; + CLASS_NAME(class_built_in) = @'built-in-class'; CLASS_SUPERIORS(class_built_in) = CONS(class_class, Cnil); CLASS_INFERIORS(class_built_in) = Cnil; CLASS_SLOTS(class_built_in) = OBJNULL; /* filled later */ - sethash(@'built-in', SYM_VAL(siVclass_name_hash_table), class_built_in); + sethash(@'built-in-class', SYM_VAL(@'si::*class-name-hash-table*'), class_built_in); /* booting Class T (= OBJECT) */ @@ -96,7 +107,7 @@ clos_boot(void) CLASS_INFERIORS(class_object) = CONS(class_class, Cnil); CLASS_SLOTS(class_object) = Cnil; - sethash(Ct, SYM_VAL(siVclass_name_hash_table), class_object); + sethash(Ct, SYM_VAL(@'si::*class-name-hash-table*'), class_object); /* complete now Class CLASS */ CLASS_SUPERIORS(class_class) = CONS(class_object, Cnil); @@ -106,7 +117,7 @@ clos_boot(void) void init_clos(void) { - SYM_VAL(siVclass_name_hash_table) = OBJNULL; + SYM_VAL(@'si::*class-name-hash-table*') = OBJNULL; clos_boot(); } diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 8280d0956..a0ca60796 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -14,7 +14,7 @@ (defun boot () (let ((class (find-class 'class)) - (built-in (find-class 'built-in))) + (built-in-class (find-class 'built-in-class))) ;; class CLASS -------- (setf (class-slots class) @@ -56,25 +56,25 @@ (or supplied-superclasses (list (find-class 't)))) - ;; class BUILT-IN -------- - (setf (class-slots built-in) + ;; class BUILT-IN-CLASS -------- + (setf (class-slots built-in-class) (parse-slots '((NAME :INITARG :NAME :INITFORM NIL) (SUPERIORS :INITARG :DIRECT-SUPERCLASSES) (INFERIORS :INITFORM NIL) (SLOTS :INITARG :SLOTS)))) - (defmethod slot-value ((self built-in) slot) + (defmethod slot-value ((self built-in-class) slot) (let ((position (position slot (class-slots (si:instance-class self)) :key #'slotd-name))) (if position (si:instance-ref self position) (slot-missing (si:instance-class self) self slot 'slot-value)))) - (defmethod make-instance ((class built-in) &rest initargs) + (defmethod make-instance ((class built-in-class) &rest initargs) (declare (ignore initargs)) (error "The built-in class (~A) cannot be instantiated" class)) - (defmethod initialize-instance ((class built-in) + (defmethod initialize-instance ((class built-in-class) &rest initargs &key &allow-other-keys) (call-next-method) ; from class T @@ -87,7 +87,7 @@ (push class (class-inferiors s))) class) - (defmethod print-object ((class built-in) stream) + (defmethod print-object ((class built-in-class) stream) (print-unreadable-object (class stream) (format stream "The ~A ~A" (class-name (si:instance-class class)) diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp index 7cc8ffd52..77d03f546 100644 --- a/src/clos/builtin.lsp +++ b/src/clos/builtin.lsp @@ -57,7 +57,7 @@ (eval-when (compile load eval) (mapcar #'(lambda (args &aux (class (first args)) (super (cdr args))) - (eval `(defclass ,class ,super () (:metaclass built-in)))) + (eval `(defclass ,class ,super () (:metaclass built-in-class)))) '(;(t object) (sequence t) (list sequence) @@ -96,10 +96,10 @@ ;;; Now we protect classes from redefinition: (defun setf-find-class (name new-value) (cond - ((typep (find-class name nil) 'built-in) + ((typep (find-class name nil) 'built-in-class) (error "The class associated to the CL specifier ~S cannot be changed." name)) - ((member name '(CLASS BUILT-IN) :test #'eq) + ((member name '(CLASS BUILT-IN-CLASS) :test #'eq) (error "The kernel CLOS class ~S cannot be changed." name)) ((classp new-value) (setf (gethash name si:*class-name-hash-table*) new-value)) diff --git a/src/clos/macros.lsp b/src/clos/macros.lsp index 40e6110cf..9e3535a0d 100644 --- a/src/clos/macros.lsp +++ b/src/clos/macros.lsp @@ -45,13 +45,6 @@ ;(defvar *class-name-hash-table* (make-hash-table :test #'eq) ; "The hash table containing all classes") -(defun find-class (name &optional (errorp t) environment) - (declare (ignore environment)) - (let ((class (gethash name si:*class-name-hash-table*))) - (cond (class class) - (errorp (error "No class named ~S." name)) - (t nil)))) - ;;; This is only used during boot. The real one is in built-in. (defun setf-find-class (name new-value) (if (classp new-value) @@ -109,20 +102,3 @@ ;;; a variable declared of type standard-class. (defmacro slot-index-table (a-standard-class) `(the hash-table (si:instance-ref ,a-standard-class 5))) - -;;; ---------------------------------------------------------------------- -;;; Low level printing -;;; - -(defun set-function-name (fn new-name) - (cond ((compiled-function-p fn) - (si::set-compiled-function-name fn new-name)) - ((and (listp fn) - (eq (car fn) 'LAMBDA-BLOCK)) - (setf (cadr fn) new-name)) - ((and (listp fn) - (eq (car fn) 'LAMBDA)) - (setf (car fn) 'LAMBDA-BLOCK - (cdr fn) (cons new-name (cdr fn))))) - fn) - diff --git a/src/doc/user.txi b/src/doc/user.txi index 1935cf854..c4d5ba7a1 100644 --- a/src/doc/user.txi +++ b/src/doc/user.txi @@ -2453,12 +2453,6 @@ open-coded in-line. To control runtime error checking, supply appropriate The @ecl{} compiler processes the @code{eval-when} special form exactly as specified in @bibcite{Steele:84} (see Section 5.3.3 of @bibcite{Steele:84}). -Notice that KCL and AKCL instead behave differently from the @clisp{} -specification, since they normally process all top-level forms in -@emph{compile-time-too} mode. If it is desired that each top-level form be -processed in @emph{compile-time-too} mode, set the value of the @ecl{} -specific variable @code{*eval-when-compiler*} to @true{}. - The @ecl{} compiler is invoked by the functions @code{compile-file}, @code{compile}, and @code{disassemble} described below. In addition, the @ecl{} compiler may be invoked directly by the Shell commands @code{ecl}. @@ -2590,13 +2584,6 @@ intermediate data-file is specified by the keyword parameter @kwd{data-file}. @end defun -@defvar {*eval-when-compile*} -The compiler processes each top-level form in @dfn{not-compile-time} mode if -the value of this variable is @nil{}, and in @dfn{compile-time-too} mode, -otherwise. See Section 5.3.3 of @bibcite{Steele:84} for these two modes. The -initial value of this variable is @nil{}. -@end defvar - @node Declarations, OS interface, The compiler, Top @chapter Declarations @@ -3973,8 +3960,6 @@ that case @code{suspend} will return the values specified by @code{resume}. @end defvar @defvar {*error-output*} @end defvar -@defvar {*eval-when-compile*} -@end defvar @defvar {*evalhook*} @end defvar @defvar {*features*} diff --git a/src/h/lisp_external.h b/src/h/lisp_external.h index eee75e0bf..d3aab9964 100644 --- a/src/h/lisp_external.h +++ b/src/h/lisp_external.h @@ -132,7 +132,8 @@ extern cl_object clLname_char _ARGS((int narg, cl_object s)); #ifdef CLOS extern cl_object siVclass_name_hash_table; extern cl_object clSclass; -extern cl_object clSbuilt_in; +extern cl_object clSbuilt_in_class; +extern cl_object clLfind_class _ARGS((int narg, cl_object name, ...)); #endif /* cmpaux.c */ diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 2eb3f9a47..1c8395554 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -258,9 +258,10 @@ to NIL) sequentially, and executes STATEMENTs. Returns NIL." (defmacro prog1 (first &rest body &aux (sym (gensym))) "Syntax: (prog1 first-form {form}*) Evaluates FIRST-FORM and FORMs in order. Returns the value of FIRST-FORM." + (if (null body) first `(LET ((,sym ,first)) ; (DECLARE (:READ-ONLY ,sym)) ; Beppe - ,@body ,sym)) + ,@body ,sym))) (defmacro prog2 (first second &rest body &aux (sym (gensym))) "Syntax: (prog2 first-form second-form {forms}*) diff --git a/src/lsp/export.lsp b/src/lsp/export.lsp index e064f1d0b..4d973e45b 100644 --- a/src/lsp/export.lsp +++ b/src/lsp/export.lsp @@ -299,8 +299,6 @@ space safety compilation-speed - - *eval-when-compile* )) (si::select-package "SI") @@ -391,7 +389,6 @@ define-method-combination defmethod ensure-generic-function - find-class find-method generic-flet generic-function @@ -427,7 +424,7 @@ with-slots class - built-in + built-in-class standard-class standard-generic-function standard-method diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 1f8b5db96..4f0ab4da8 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -340,11 +340,6 @@ Returns T if X belongs to TYPE; NIL otherwise." t) (t nil))) -;;; Dummy version before CLOS is loaded -#+(and clos ecl-min) -(unless (fboundp 'sys::fpp) - (defun find-class (n &optional err env) (declare (ignore n err env)) nil)) - ;;; SUBTYPEP predicate. (defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 c1 c2) "Args: (type1 type2)