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

cmp: enforce valid shape of si:function-block-name delcaration

Browse source 
Also fix a declaration in clos::make-raw-lambda function.
This commit is contained in:
Daniel Kochmański 2023-06-29 19:55:08 +02:00
parent 33df93da14
commit faebc7b266
3 changed files with 36 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

57
src/clos/method.lsp
View file

@ -143,38 +143,39 @@
(not (member '&allow-other-keys lambda-list)))
(let ((x (position '&aux lambda-list)))
(setf lambda-list
(append (subseq lambda-list 0 x)
'(&allow-other-keys)
(and x (subseq lambda-list x))
nil))))
(append (subseq lambda-list 0 x)
'(&allow-other-keys)
(and x (subseq lambda-list x))
nil))))
(let* ((copied-variables '())
(ignorable `(declare (ignorable ,@required-parameters)))
(block-name (si:function-block-name name))
(class-declarations
(nconc (when *add-method-argument-declarations*
(loop for name in required-parameters
for type in specializers
when (and (not (eq type t)) (symbolp type))
do (push `(,name ,name) copied-variables) and
nconc `((type ,type ,name)
(si::no-check-type ,name))))
(list (list 'si::function-block-name name))
(cdar declarations)))
(block `(block ,(si::function-block-name name) ,@real-body))
(nconc (when *add-method-argument-declarations*
(loop for name in required-parameters
for type in specializers
when (and (not (eq type t)) (symbolp type))
do (push `(,name ,name) copied-variables) and
nconc `((type ,type ,name)
(si::no-check-type ,name))))
(list (list 'si:function-block-name block-name))
(cdar declarations)))
(block `(block ,block-name ,@real-body))
(method-lambda
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
;; string is removed to make it easy for us to insert
;; new declarations later, they will just go after the
;; second of the method lambda. The class declarations
;; are inserted to communicate the class of the method's
;; arguments to the code walk.
`(lambda ,lambda-list
,@(and class-declarations `((declare ,@class-declarations)))
,ignorable
,(if copied-variables
`(let* ,copied-variables
,ignorable
,block)
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
;; string is removed to make it easy for us to insert
;; new declarations later, they will just go after the
;; second of the method lambda. The class declarations
;; are inserted to communicate the class of the method's
;; arguments to the code walk.
`(lambda ,lambda-list
,@(and class-declarations `((declare ,@class-declarations)))
,ignorable
,(if copied-variables
`(let* ,copied-variables
,ignorable
,block)
block))))
(values method-lambda declarations documentation))))

2
src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
View file

@ -159,7 +159,7 @@
;;; FDEFINITION, MAKE-CLOSURE
;;;
(defun wt-fdefinition (fun-name)
(let* ((name (si::function-block-name fun-name))
(let* ((name (si:function-block-name fun-name))
(package (symbol-package name))
(safe (or (not (safe-compile))
(and (or (eq package (find-package "CL"))

10
src/cmp/cmpfun.lsp
View file

@ -166,10 +166,12 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
;;; searches for a (FUNCTION-BLOCK-NAME ...) declaration
(defun function-block-name-declaration (declarations)
(loop for i in declarations
if (and (consp i) (eql (car i) 'si::function-block-name)
(consp (cdr i)))
return (cadr i)
finally (return nil)))
do (when (and (consp i) (eql (car i) 'si:function-block-name))
(let ((name (second i))
(rest (cddr i)))
(unless (and (symbolp name) (null rest))
(cmperr "Invalid ~s declaration:~%~s" 'si:function-block-name i))
(return name)))))
(defun exported-fname (name)
(let (cname)