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

Code for directly using the pointers in function objects.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-02-15 00:06:49 +01:00
parent 3eb2c66b9d
commit f35ca512a2
1 changed files with 16 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

27
src/cmp/cmpcall.lsp
View file

@ -226,15 +226,18 @@
;;; NARG is a location containing the number of ARGS-PUSHED
;;;
(defun call-unknown-global-loc (fname loc narg args)
`(CALL-INDIRECT ,(cond (loc loc)
((and (symbolp fname)
(not (eql (symbol-package fname) (find-package "CL"))))
(cmpnote "Emitting FUNCALL for ~S" fname)
(add-symbol fname))
(t
(cmpnote "Emitting FDEFINITION for ~S" fname)
(list 'FDEFINITION fname)))
,(or narg (length args)) ,(coerce-locs args)))
(unless loc
(setf loc (if (and (symbolp fname)
(not (eql (symbol-package fname)
(find-package "CL"))))
(add-symbol fname)
(list 'FDEFINITION fname))))
`(CALL-INDIRECT ,loc ,(or narg (length args)) ,(coerce-locs args) ,fname nil)
#+(or)
(let* ((type (loc-type loc))
(unsafe (or (subtypep type 'function)
(and (subtypep 'function type) (policy-assume-right-type)))))
`(CALL-INDIRECT ,loc ,(or narg (length args)) ,(coerce-locs args) ,fname ,unsafe)))
;;; Functions that use MAYBE-SAVE-VALUE should rebind *temp*.
(defun maybe-save-value (value &optional (other-forms nil other-forms-flag))
@ -279,8 +282,10 @@
(wt ")")))
(when fname (wt-comment fname)))
(defun wt-call-indirect (fun-loc narg args &optional fname)
(wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg)
(defun wt-call-indirect (fun-loc narg args fname unsafe)
(if unsafe
(wt "(value0=" fun-loc ",cl_env_copy->function=value0,value0->cfun.entry)(" narg)
(wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg))
(dolist (arg args)
(wt "," arg))
(wt ")")