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

The automatic generation of check-type forms for function arguments could not be suppressed when having additional declarations (src/cmp/cmplam.lsp)

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-11-30 12:55:41 +01:00
parent be996c0e89
commit bd7b3fd6d8
1 changed files with 17 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

31
src/cmp/cmplam.lsp
View file

@ -147,6 +147,19 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(handler-case (si::process-lambda-list list 'function)
(error (c) (cmperr "Illegal lambda list ~S" list))))
(defun extract-type-checks (type-checks type-declarations other-decls)
(flet ((required-type-check (name other-decls)
(loop for decl in other-decls
never (and (consp decl)
(eq (first decl) 'si::no-check-type)
(member name (rest decl))))))
(when (policy-automatic-check-type-p)
(loop for var in type-checks
for name = (var-name var)
for type = (cdr (assoc name type-declarations))
when (and type (required-type-check name other-decls))
collect `(optional-check-type ,name ,type)))))
(defun c1lambda-expr (lambda-expr
&optional (block-name nil)
&aux doc body ss is ts
@ -242,21 +255,11 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
;; (type (function (t t) t) foo)) We let OPTIONAL-CHECK-TYPE do the
;; job.
;;
(let* ((pairs (loop for var in type-checks
nconc (let* ((name (var-name var))
(type (assoc name ts)))
(when type
(loop for decl in other-decls
unless (and (consp decl)
(eq (first decl) 'si::no-check-type)
(member name (rest decl)))
do (return (list (list name (cdr type))))))))))
(when (and pairs (policy-automatic-check-type-p))
(let* ((checks (extract-type-checks type-checks ts other-decls)))
(when checks
(cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}."
block-name
(mapcar #'var-name type-checks))
(loop for pair in (nreverse pairs)
do (push `(optional-check-type ,@pair) body))))
block-name (mapcar #'second checks))
(setf body (nconc checks body))))
(setq body
(cond (aux-vars
(let ((let nil))