mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 07:30:55 -08:00
Do not compile the DEFINE-CONDITION statements, but rather keep them as lists for later evaluation.
This commit is contained in:
jjgarcia
parent
8846ac62b2
commit
562b7b5cf4
4 changed files with 84 additions and 84 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 <name>) returns the class named <name>. setf can be used
|
||||
;;; with find-class to set the class named <name>. 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))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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 <name>) returns the class named <name>. setf can be used
|
||||
;;; with find-class to set the class named <name>. 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))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue