mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-26 06:22:33 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-various' into 'develop'

Browse source 
restart-case: conformance fix: more precise keyword parsing

Closes #666

See merge request embeddable-common-lisp/ecl!265
This commit is contained in:
Marius Gerbershagen 2022-01-06 14:09:48 +00:00
commit ef94137e3d
1 changed files with 29 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

65
src/clos/conditions.lsp
View file

@ -139,41 +139,35 @@
(defmacro restart-case (expression &body clauses &environment env)
(flet ((transform-keywords (&key report interactive test)
(let ((keywords '()))
(when test
(setq keywords (list :TEST-FUNCTION `#',test)))
(when interactive
(setq keywords (list* :INTERACTIVE-FUNCTION
`#',interactive
keywords)))
(when report
(setq keywords (list* :REPORT-FUNCTION
(if (stringp report)
`#'(lambda (stream)
(write-string ,report stream))
`#',report)
keywords)))
keywords)))
(flet ((process-clause (clause)
(do ((name (pop clause))
(args (pop clause))
(opts '(:test :report :interactive))
(keys '())
(forms clause (cddr forms)))
((or (null forms) (not (member (car forms) opts)))
;; name=0, tag=1, keys=2, bvl=3, body=4
(list name (gensym) keys args forms))
(let ((key (first forms))
(val (second forms)))
(setf opts (remove key opts)
keys (ecase key
(:test
(list* :test-function `(function ,val)
keys))
(:interactive
(list* :interactive-function `(function ,val)
keys))
(:report
(list* :report-function
(if (stringp val)
`(lambda (stream)
(write-string ,val stream))
`(function ,val))
keys))))))))
(let*((block-tag (gensym))
(temp-var (gensym))
(data (mapcar #'(lambda (clause)
(let (keywords (forms (cddr clause)))
(do ()
((null forms))
(if (keywordp (car forms))
(setq keywords (list* (car forms)
(cadr forms)
keywords)
forms (cddr forms))
(return)))
(list (car clause) ;Name=0
(gensym) ;Tag=1
(apply #'transform-keywords ;Keywords=2
keywords)
(cadr clause) ;BVL=3
forms))) ;Body=4
clauses)))
(data (mapcar #'process-clause clauses)))
(let ((expression2 (macroexpand expression env)))
(when (consp expression2)
(let* ((condition-form nil)
@ -187,7 +181,7 @@
(ERROR
(setq condition-form `(coerce-to-condition ,(second expression2)
(list ,@(cddr expression2))
'SIMPLE-ERROR 'ERROR)))
'simple-error 'ERROR)))
(CERROR
(setq condition-form `(coerce-to-condition ,(third expression2)
(list ,@(cdddr expression2))
@ -203,8 +197,7 @@
(first *restart-clusters*)
,(if (eq name 'CERROR)
`(cerror ,(second expression2) ,condition-var)
(list name condition-var)))))
))))
(list name condition-var)))))))))
`(block ,block-tag
(let ((,temp-var nil))
(tagbody