diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index d1a301caa..6dcf1c44a 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -463,8 +463,6 @@ strings." :FORMAT-ARGUMENTS format-arguments))) nil) -(define-condition warning () ()) - (defun warn (datum &rest arguments) "Args: (format-string &rest args) Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message. Enters @@ -484,24 +482,34 @@ returns with NIL." nil)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ALL CONDITIONS +;;; +;;; Instead of compiling each condition definition, we store them in a +;;; list and evaluate them at run time. Besides, there are multiple +;;; SIMPLE-* conditions which inherit from SIMPLE-ERROR and which are +;;; only created when the error is signaled. +;;; + +#+ecl-min +(defconstant +all-conditions+ (mapcar #'cdr '( +(define-condition warning () ()) (define-condition serious-condition () ()) (define-condition error (serious-condition) ()) -(defun simple-condition-printer (condition stream) - (format stream "~?" (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) - (define-condition simple-condition () ((format-control :INITARG :FORMAT-CONTROL :INITFORM "" :ACCESSOR simple-condition-format-control) (format-arguments :INITARG :FORMAT-ARGUMENTS :INITFORM NIL :ACCESSOR simple-condition-format-arguments)) - (:REPORT simple-condition-printer)) + (:REPORT + (lambda (condition stream) + (format stream "~?" (simple-condition-format-control condition) + (simple-condition-format-arguments condition))))) -(define-condition simple-warning (simple-condition warning) - () (:REPORT simple-condition-printer)) +(define-condition simple-warning (simple-condition warning) ()) (define-condition style-warning (warning) ()) @@ -609,25 +617,6 @@ returns with NIL." (define-condition reader-error (parse-error stream-error) ()) -#+nil -(defun simple-condition-class-p (type) - (typep type 'SIMPLE-CONDITION-CLASS)) - -;;; -;;; Additions by ECL -;;; -(defun signal-simple-error (base-condition continue-message format-control format-args - &rest args) - (let ((simple-error-name (intern (concatenate 'string "SIMPLE-" (string base-condition)) - (find-package "SI")))) - (unless (find-class simple-error-name nil) - (eval `(defclass ,simple-error-name (simple-error ,base-condition) ()))) - (if continue-message - (apply #'cerror continue-message simple-error-name :format-control format-control - :format-arguments format-args args) - (apply #'error simple-error-name :format-control format-control - :format-arguments format-args args)))) - (define-condition format-error (simple-error) ((format-control :initarg :complaint) @@ -650,6 +639,24 @@ returns with NIL." (simple-condition-format-arguments condition) (format-error-control-string condition) (format-error-offset condition))))) +))) + +(dolist (expression '#.+all-conditions+) + (eval (list* 'define-condition expression))) + + +(defun signal-simple-error (base-condition continue-message format-control format-args + &rest args) + (let ((simple-error-name (intern (concatenate 'string "SIMPLE-" (string base-condition)) + (find-package "SI")))) + (unless (find-class simple-error-name nil) + (eval `(defclass ,simple-error-name (simple-error ,base-condition) ()))) + (if continue-message + (apply #'cerror continue-message simple-error-name :format-control format-control + :format-arguments format-args args) + (apply #'error simple-error-name :format-control format-control + :format-arguments format-args args)))) + (defmacro handler-case (form &rest cases) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 084035d52..c85bce48d 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -7,6 +7,11 @@ ;;;; ;;;; See file '../Copyright' for full details. +(defpackage "CLOS" + (:use "CL") + (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" + "COMPUTE-EFFECTIVE-METHOD" "SIMPLE-PROGRAM-ERROR")) + (in-package "CLOS") (defconstant *default-method-cache-size* 64 "Size of hash tables for methods") @@ -129,10 +134,44 @@ #.(create-accessors +standard-method-slots+ 'standard-method) ;;; ---------------------------------------------------------------------- +;;; +;;; FIND-CLASS naming classes. +;;; +;;; +;;; (FIND-CLASS ) returns the class named . setf can be used +;;; with find-class to set the class named . These are "extrinsic" +;;; names. Neither find-class nor setf of find-class do anything with the +;;; name slot of the class, they only lookup and change the association from +;;; name to class. +;;; +;;; This is only used during boot. The real one is in built-in. +(eval-when (compile) + (defun setf-find-class (new-value class &optional errorp env) + (warn "Ignoring class definition for ~S" class))) + +(defun setf-find-class (new-value name &optional errorp env) + (let ((old-class (find-class name nil))) + (cond + ((and old-class + (or (typep old-class 'built-in-class) + (member name '(class built-in-class) :test #'eq))) + (error "The class associated to the CL specifier ~S cannot be changed." + name)) + ((classp new-value) + (setf (gethash name si:*class-name-hash-table*) new-value)) + ((null new-value) (remhash name si:*class-name-hash-table*)) + (t (error "~A is not a class." new-value)))) + new-value) + +(defsetf find-class (&rest x) (v) `(setf-find-class ,v ,@x)) (defun classp (obj) (and (si:instancep obj) - (si::subclassp (si::instance-class obj) (find-class 'CLASS)) + (let ((topmost (find-class 'CLASS nil))) + ;; All instances can be classes until the class CLASS has + ;; been installed. Otherwise, we check the parents. + (or (null topmost) + (si::subclassp (si::instance-class obj) topmost))) t)) ;;; ---------------------------------------------------------------------- diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in index 6bb97d6f7..2f159356d 100644 --- a/src/clos/load.lsp.in +++ b/src/clos/load.lsp.in @@ -1,8 +1,8 @@ ;;; @configure_input@ -(defconstant +clos-module-files+ -'("src:clos;macros.lsp" - "src:clos;kernel.lsp" +(defvar +clos-module-files+ +'("src:clos;kernel.lsp" + "src:clos;macros.lsp" "src:clos;method.lsp" "src:clos;slot.lsp" "src:clos;combin.lsp" @@ -24,3 +24,5 @@ )) (mapc #'(lambda (x) (load x :verbose nil)) +clos-module-files+) + +(setf +clos-module-files+ (remove "src:clos;macros.lsp" +clos-module-files+ :test #'equalp)) diff --git a/src/clos/macros.lsp b/src/clos/macros.lsp index 4337988d9..3f5d70621 100644 --- a/src/clos/macros.lsp +++ b/src/clos/macros.lsp @@ -7,63 +7,15 @@ ;;;; ;;;; See file '../Copyright' for full details. -(defpackage "CLOS" - (:use "CL") - (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" - "COMPUTE-EFFECTIVE-METHOD" "SIMPLE-PROGRAM-ERROR")) - (in-package "CLOS") -;;; ---------------------------------------------------------------------- - -;(proclaim '(DECLARATION VARIABLE-REBINDING)) -;;; Make this stable: -(declaim (DECLARATION VARIABLE-REBINDING)) -(eval-when (compile eval) -(defmacro doplist ((key val) plist &body body) - `(let* ((.plist-tail. ,plist) ,key ,val) - (loop (when (null .plist-tail.) (return nil)) - (setq ,key (pop .plist-tail.)) - (when (null .plist-tail.) - (error "Malformed plist in doplist, odd number of elements.")) - (setq ,val (pop .plist-tail.)) - (progn ,@body)))) -) - -;;; -;;;;;; FIND-CLASS naming classes. -;;; -;;; -;;; (FIND-CLASS ) returns the class named . setf can be used -;;; with find-class to set the class named . These are "extrinsic" -;;; names. Neither find-class nor setf of find-class do anything with the -;;; name slot of the class, they only lookup and change the association from -;;; name to class. -;;; - -;(defvar *class-name-hash-table* (make-hash-table :test #'eq) -; "The hash table containing all classes") - -;;; This is only used during boot. The real one is in built-in. -(eval-when (compile) - (defun setf-find-class (new-value class &optional errorp env) - (warn "Ignoring class definition for ~S" class))) - -(defun setf-find-class (new-value name &optional errorp env) - (if (si:instancep new-value) - (progn - (setf (gethash name si:*class-name-hash-table*) new-value)) - (error "~A is not a class." new-value))) - -(defsetf find-class (&rest x) (v) `(setf-find-class ,v ,@x)) - -;;; ---------------------------------------------------------------------- - -(defun mapappend (fun &rest args) - (reduce #'append (apply #'mapcar fun args))) +(defmacro mapappend (fun &rest args) + `(reduce #'append (mapcar ,fun ,@args))) (defmacro ensure-up-to-date-instance (instance) `(let ((i ,instance)) (unless (or (si::structurep i) (eq (si::instance-sig i) (class-slots (si::instance-class i)))) (update-instance i)))) + +