mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-18 23:32:17 -08:00
Code Issues Projects Releases Packages Wiki Activity

SI:ECASE-ERROR and ETYPECASE-ERROR are now exported.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2011-12-23 15:38:06 +01:00
parent 24c658e918
commit 169d2997df
5 changed files with 18 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/c/symbols_list.h
View file

@ -2014,6 +2014,8 @@ cl_symbols[] = {
{EXT_ "COMPILER-TYPECASE", EXT_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "ASSERT-FAILURE", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "ECASE-ERROR", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "ETYPECASE-ERROR", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "SERIALIZE", SI_ORDINARY, si_serialize, 1, OBJNULL},
{SYS_ "DESERIALIZE", SI_ORDINARY, si_deserialize, 1, OBJNULL},
@ -2075,7 +2077,7 @@ cl_symbols[] = {
{SYS_ "PROPER-LIST-P", SI_ORDINARY, si_proper_list_p, 1, OBJNULL},
{SYS_ "TRACED-OLD-DEFINITION", SI_ORDINARY, ECL_NAME(si_traced_old_definition), 1, OBJNULL},
{SYS_ "*TRACE-LIST*", SI_ORDINARY, NULL, -1, Cnil},
{SYS_ "*TRACE-LIST*", SI_SPECIAL, NULL, -1, Cnil},
{SYS_ "FUNCTION-BOUNDARY", SI_ORDINARY, NULL, -1, OBJNULL},

2
src/c/symbols_list2.h
View file

@ -2014,6 +2014,8 @@ cl_symbols[] = {
{EXT_ "COMPILER-TYPECASE",NULL},
{SYS_ "ASSERT-FAILURE",NULL},
{SYS_ "ECASE-ERROR",NULL},
{SYS_ "ETYPECASE-ERROR",NULL},
{SYS_ "SERIALIZE","si_serialize"},
{SYS_ "DESERIALIZE","si_deserialize"},

6
src/cmp/proclamations.lsp
View file

@ -256,6 +256,10 @@
(proclamation si:bds-val (si::index) t)
(proclamation si:sch-frs-base (si::index si::index) (or null si::index))
(proclamation si::ecase-error (t t) t)
(proclamation si::etypecase-error (t t) t)
(proclamation si::do-check-type (t t t t) t)
;;;
;;; 7. OBJECTS
;;;
@ -1327,7 +1331,7 @@
(proclamation associate-methods-to-gfun (generic-function *)
generic-function)
#+clos
(proclamation clos::need-to-make-load-form-p (t) gen-bool :pure)
(proclamation clos::need-to-make-load-form-p (t t) gen-bool :pure)
#+clos
(proclamation clos::load-defclass (t t t t) t)

1
src/cmp/sysfun.lsp
View file

@ -972,6 +972,7 @@
si::coerce-to-list si::coerce-to-vector
si::fill-array-with-seq
si::assert-failure
si::ecase-error si::etypecase-error
si::traced-old-definition
#+formatter

15
src/lsp/assert.lsp
View file

@ -87,7 +87,7 @@ for the error message and ARGs are arguments to the format string."
`(while (not ,test-form)
,repl)))
(defun accumulate-cases (macro-name cases list-is-atom-p)
(defun accumulate-cases (cases list-is-atom-p)
(declare (si::c-local))
(do ((c cases (cdr c))
(l '()))
@ -97,7 +97,7 @@ for the error message and ARGs are arguments to the format string."
(list-is-atom-p (push keys l))
(t (setq l (append keys l)))))))
(defun ecase-error (keyform value values)
(defun ecase-error (value values)
(error 'CASE-FAILURE :name 'ECASE
:datum value
:expected-type (cons 'MEMBER values)
@ -113,7 +113,7 @@ signals an error."
(let ((key (gensym)))
`(let ((,key ,keyform))
(case ,key ,@clauses
(t (si::ecase-error ',keyform ,key ',(accumulate-cases 'ECASE clauses nil)))))))
(t (si::ecase-error ,key ',(accumulate-cases clauses nil)))))))
(defun ccase-error (keyform key values)
(restart-case (error 'CASE-FAILURE
@ -155,7 +155,7 @@ becomes EQL to one of the KEYs."
(case ,key ,@clauses
(t (setf ,keyplace
(si::ccase-error ',keyplace ,key
',(accumulate-cases 'CCASE clauses nil)))
',(accumulate-cases clauses nil)))
(go ,repeat)))))))))
(defmacro typecase (keyform &rest clauses)
@ -175,7 +175,7 @@ be used as a TYPE to specify the default case."
,form))))
)
(defun etypecase-error (keyform value types)
(defun etypecase-error (value types)
(error 'CASE-FAILURE :name 'ETYPECASE
:datum value
:expected-type (cons 'OR types)
@ -188,8 +188,7 @@ If found, then evaluates FORMs that follow the TYPE and returns all values of
the last FORM. If not, signals an error."
(setq clauses (remove-otherwise-from-clauses clauses))
(do ((l (reverse clauses) (cdr l)) ; Beppe
(form `(etypecase-error ',keyform ,key
',(accumulate-cases 'ETYPECASE clauses t))))
(form `(etypecase-error ,key ',(accumulate-cases clauses t))))
((endp l) `(let ((,key ,keyform)) ,form))
(setq form `(if (typep ,key ',(caar l))
(progn ,@(cdar l))
@ -224,4 +223,4 @@ Repeats this process until the value of PLACE becomes of one of the TYPEs."
(return (progn ,@(cdr l)))))
clauses)
(setf ,keyplace (ctypecase-error ',keyplace ,key
',(accumulate-cases 'CTYPECASE clauses t))))))
',(accumulate-cases clauses t))))))