mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 07:30:55 -08:00
Instead of producing a call to object_to_int, defCbody should call object_to_fixnum
This commit is contained in:
jjgarcia
parent
33263c74c5
commit
af0504410d
1 changed files with 10 additions and 312 deletions
|
|
@ -838,180 +838,6 @@
|
|||
(wt-function-epilogue closure-p)) ; we should declare in CLSR only those used
|
||||
)
|
||||
|
||||
#|
|
||||
(defun t1defcfun (args &aux (body nil))
|
||||
(when (or (endp args) (endp (cdr args)))
|
||||
(too-few-args 'defcfun 2 (length args)))
|
||||
(cmpck (not (stringp (car args)))
|
||||
"The first argument to defCfun ~s is not a string." (car args))
|
||||
(cmpck (not (numberp (second args)))
|
||||
"The second argument to defCfun ~s is not a number." (second args))
|
||||
(dolist (s (cddr args))
|
||||
(cond ((stringp s) (push s body))
|
||||
((consp s)
|
||||
(cond ((symbolp (car s))
|
||||
(cmpck (special-form-p (car s))
|
||||
"Special form ~s is not allowed in defCfun." (car s))
|
||||
(push (list (cons (car s) (parse-cvspecs (cdr s)))) body))
|
||||
((and (consp (car s)) (symbolp (caar s))
|
||||
(not (if (eq (caar s) 'QUOTE)
|
||||
(or (endp (cdar s))
|
||||
(not (endp (cddar s)))
|
||||
(endp (cdr s))
|
||||
(not (endp (cddr s))))
|
||||
(special-form-p (caar s)))))
|
||||
(push (cons (cons (caar s)
|
||||
(if (eq (caar s) 'QUOTE)
|
||||
(list (add-object (cadar s)))
|
||||
(parse-cvspecs (cdar s))))
|
||||
(parse-cvspecs (cdr s)))
|
||||
body))
|
||||
(t (cmperr "The defCfun body ~s is illegal." s))))
|
||||
(t (cmperr "The defCfun body ~s is illegal." s))))
|
||||
(push (list 'DEFCFUN (car args) (second args) (reverse body))
|
||||
*top-level-forms*)
|
||||
)
|
||||
|
||||
(defun t3defcfun (header vs-size body &aux fd narg)
|
||||
(wt-comment "C function defined by " 'defcfun)
|
||||
(wt-nl1 header)
|
||||
(wt-nl1 "{")
|
||||
;;; manca un pezzo, Beppe ???
|
||||
(dolist (s body)
|
||||
(cond ((stringp s) (wt-nl1 s))
|
||||
((eq (caar s) 'QUOTE)
|
||||
(wt-nl1 (cadadr s))
|
||||
(if (eq (caadr s) 'OBJECT)
|
||||
(wt "=" (cadar s) ";")
|
||||
(wt "=object_to_" (string-downcase (symbol-name (caadr s)))
|
||||
"(" (cadar s) ");")))
|
||||
(t
|
||||
(setq narg (length cdar s))
|
||||
(cond ((setq fd (assoc (caar s) *global-funs*))
|
||||
(cond (*compiler-push-events*
|
||||
(wt-nl1 "ihs_push(" (add-symbol (caar s)) ");")
|
||||
(wt-nl1 "L" (cdr fd) "();")
|
||||
(wt-nl1 "ihs_pop();"))
|
||||
(t (wt-nl1 "L" (cdr fd) "(" narg))))
|
||||
(t (wt-nl1 "funcall(" (1+ narg) "," (add-symbol (caar s))
|
||||
"->symbol.gfdef"))
|
||||
)
|
||||
(dolist (arg (cdar s))
|
||||
(wt ",")
|
||||
(case (car arg)
|
||||
(OBJECT (wt (second arg)))
|
||||
(CHAR (wt "CODE_CHAR((int)" (second arg) ")"))
|
||||
(INT (wt "MAKE_FIXNUM((int)" (second arg) ")"))
|
||||
(FLOAT (wt "make_shortfloat((float)" (second arg) ")"))
|
||||
(DOUBLE (wt "make_longfloat((double)" (second arg) ")"))))
|
||||
(wt ");")
|
||||
(unless (endp (cdr s))
|
||||
(wt-nl1 (cadadr s))
|
||||
(case (caadr s)
|
||||
(object (wt "=vs_base[0];"))
|
||||
(otherwise (wt "=object_to_"
|
||||
(string-downcase (symbol-name (caadr s)))
|
||||
"(vs_base[0]);")))
|
||||
(dolist (dest (cddr s))
|
||||
(wt-nl1 "vs_base++;")
|
||||
(wt-nl1 (second dest))
|
||||
(if (eq (car dest) 'OBJECT)
|
||||
(wt "=(vs_base<vs_top?vs_base[0]:Cnil);")
|
||||
(wt "=object_to_"
|
||||
(string-downcase (symbol-name (car dest)))
|
||||
"((vs_base<vs_top?vs_base[0]:Cnil));")))
|
||||
)
|
||||
(wt-nl1 "}")
|
||||
)))
|
||||
(wt-nl1 "}")
|
||||
)
|
||||
|
||||
(defun t1defentry (args &aux type cname (cfun (next-cfun)) cfspec)
|
||||
(when (or (endp args) (endp (cdr args)) (endp (cddr args)))
|
||||
(too-few-args 'defentry 3 (length args)))
|
||||
(cmpck (not (symbolp (car args)))
|
||||
"The function name ~s is not a symbol." (car args))
|
||||
(dolist (x (second args))
|
||||
(cmpck (not (member x '(OBJECT CHAR* CHAR INT FLOAT DOUBLE)))
|
||||
"The C-type ~s is illegal." x))
|
||||
(setq cfspec (third args))
|
||||
(cond ((symbolp cfspec)
|
||||
(setq type 'OBJECT)
|
||||
(setq cname (string-downcase (symbol-name cfspec))))
|
||||
((stringp cfspec)
|
||||
(setq type 'OBJECT)
|
||||
(setq cname cfspec))
|
||||
((and (consp cfspec)
|
||||
(member (car cfspec) '(VOID OBJECT CHAR* CHAR INT FLOAT DOUBLE))
|
||||
(consp (cdr cfspec))
|
||||
(or (symbolp (second cfspec)) (stringp (second cfspec)))
|
||||
(endp (cddr cfspec)))
|
||||
(setq cname (if (symbolp (second cfspec))
|
||||
(string-downcase (symbol-name (second cfspec)))
|
||||
(second cfspec)))
|
||||
(setq type (car cfspec)))
|
||||
(t (cmperr "The C function specification ~s is illegal." cfspec)))
|
||||
(push (list 'DEFENTRY (car args) cfun (second args) type cname)
|
||||
*top-level-forms*)
|
||||
(push (cons (car args) cfun) *global-funs*)
|
||||
)
|
||||
|
||||
(defun t2defentry (fname cfun arg-types type cname
|
||||
&aux (vv (add-symbol fname)))
|
||||
(declare (ignore arg-types type cname))
|
||||
(wt-h "static L" cfun "();")
|
||||
(wt-nl "MF(" vv ",(cl_objectfn)L" cfun ",Cblock);")
|
||||
)
|
||||
|
||||
(defun t3defentry (fname cfun arg-types type cname)
|
||||
(wt-comment "function definition for " fname)
|
||||
(wt-nl1 "static L" cfun "()")
|
||||
(wt-nl1 "{ cl_object *old_base=vs_base;")
|
||||
(unless (eq type 'VOID) (wt-nl (string-downcase (symbol-name type)) " x;"))
|
||||
(when *safe-compile* (wt-nl "check_arg(" (length arg-types) ");"))
|
||||
(unless (eq type 'VOID) (wt-nl "x="))
|
||||
(wt-nl cname "(")
|
||||
(unless (endp arg-types)
|
||||
(do ((types arg-types (cdr types))
|
||||
(i 0 (1+ i)))
|
||||
(nil)
|
||||
(declare (object types) (fixnum i))
|
||||
(case (car types)
|
||||
(object (wt-nl "vs_base[" i "]"))
|
||||
(char*
|
||||
(if *safe-compile*
|
||||
(wt-nl "object_to_string"
|
||||
"(vs_base[" i "])")
|
||||
(wt-nl "(vs_base[" i "]->string.self)")))
|
||||
(int
|
||||
(if *safe-compile*
|
||||
(wt-nl "object_to_int"
|
||||
"(vs_base[" i "])")
|
||||
(wt-nl "fix(vs_base[" i "])")))
|
||||
(otherwise
|
||||
(wt-nl "object_to_"
|
||||
(string-downcase (symbol-name (car types)))
|
||||
"(vs_base[" i "])")))
|
||||
(when (endp (cdr types)) (return))
|
||||
(wt ",")))
|
||||
(wt ");")
|
||||
(wt-nl "vs_top=(vs_base=old_base)+1;")
|
||||
(wt-nl "vs_base[0]=")
|
||||
(case type
|
||||
(VOID (wt "Cnil"))
|
||||
(OBJECT (wt "x"))
|
||||
(CHAR* (wt "make_simple_string(x)"))
|
||||
(CHAR (wt "CODE_CHAR(x)"))
|
||||
(INT (wt "MAKE_FIXNUM(x)"))
|
||||
(FLOAT (wt "make_shortfloat(x)"))
|
||||
(DOUBLE (wt "make_longfloat(x)"))
|
||||
)
|
||||
(wt ";")
|
||||
(wt-nl1 "}")
|
||||
)
|
||||
|
||||
(defun t1defla (args) (declare (ignore args)))
|
||||
|#
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Function definition with in-line body expansion.
|
||||
;;; This is similar to defentry, except that the C body is supplied
|
||||
|
|
@ -1039,33 +865,6 @@
|
|||
(wt-nl "MF(" vv ",(cl_objectfn)L" cfun ",Cblock);")
|
||||
)
|
||||
|
||||
#|
|
||||
;;; Simpler version. Does not perform type checking of args though.
|
||||
|
||||
(defun t3defCbody (fname cfun arg-types type body &aux args)
|
||||
(wt-comment "function definition for " fname)
|
||||
(wt-nl1 "static L" cfun "(int narg")
|
||||
(do ((vl arg-types (cdr vl))
|
||||
(lcl 1 (1+ lcl)))
|
||||
((endp vl))
|
||||
(declare (fixnum lcl))
|
||||
(push (list 'VAR (make-info :type (car vl))
|
||||
(list (make-var :kind 'OBJECT :loc lcl))) args)
|
||||
(wt ", cl_object ") (wt-lcl lcl)
|
||||
)
|
||||
(wt ")")
|
||||
(wt-nl1 "{")
|
||||
(when *safe-compile* (wt-nl "check_arg(" (length arg-types) ");"))
|
||||
(let ((*inline-functions* (push (list fname arg-types type T NIL body)
|
||||
*inline-functions*))
|
||||
(*destination* (if type 'RETURN 'TRASH)))
|
||||
(c2expr* `(CALL-GLOBAL ,(make-info :type type)
|
||||
,fname ,(nreverse args) ,type)))
|
||||
(wt-nl "RETURN(" (if type 1 0) ");")
|
||||
(wt-nl1 "}")
|
||||
)
|
||||
|#
|
||||
|
||||
(eval-when (compile eval) ; also in cmpinline.lsp
|
||||
;; by mds@sepgifbr.sep.de.edf.fr (M.Decugis)
|
||||
(defmacro parse-index (fun i)
|
||||
|
|
@ -1090,10 +889,18 @@
|
|||
(case type
|
||||
((NIL) 'VOID)
|
||||
(CHARACTER 'CHAR)
|
||||
(FIXNUM 'INT)
|
||||
(FIXNUM 'CL_FIXNUM)
|
||||
(LONG-FLOAT 'DOUBLE)
|
||||
(SHORT-FLOAT 'FLOAT)
|
||||
(otherwise 'OBJECT)))
|
||||
(lisp2c-convert (type)
|
||||
(case type
|
||||
((NIL) "(void)(V~d)")
|
||||
(CHARACTER "object_to_char(V~d)")
|
||||
(FIXNUM "object_to_fixnum(V~d)")
|
||||
(LONG-FLOAT "object_to_double(V~d)")
|
||||
(SHORT-FLOAT "object_to_float(V~d)")
|
||||
(otherwise "V~d")))
|
||||
(wt-inline-arg (fun locs &aux (i 0))
|
||||
(declare (fixnum i))
|
||||
(cond ((stringp fun)
|
||||
|
|
@ -1125,12 +932,7 @@
|
|||
(lst))
|
||||
((null types) (nreverse lst))
|
||||
(declare (object types) (fixnum i))
|
||||
(push
|
||||
(if (eq (lisp2c-type (car types)) 'OBJECT)
|
||||
(format nil "V~d" i)
|
||||
(format nil "object_to_~(~a~)(V~d)"
|
||||
(lisp2c-type (car types)) i))
|
||||
lst)))
|
||||
(push (format nil (lisp2c-convert (car types)) i) lst)))
|
||||
(wt ";")
|
||||
(wt-nl "NValues=1;")
|
||||
(wt-nl "return ")
|
||||
|
|
@ -1145,110 +947,6 @@
|
|||
)
|
||||
(wt ";}")
|
||||
))
|
||||
#|
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Lisp function defined in C.
|
||||
;;; Arguments and results are passed on stack.
|
||||
;;;
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(defun t1defunC (args &aux fun lambda-list (cfun (next-cfun)))
|
||||
(when (or (endp args) (endp (cdr args)))
|
||||
(too-few-args 'defunC 2 (length args)))
|
||||
(setq fun (first args))
|
||||
(cmpck (not (symbolp fun))
|
||||
"The function name ~s is not a symbol." fun)
|
||||
(setq lambda-list (second args))
|
||||
(cmpck (not (listp lambda-list))
|
||||
"The lambda list ~s is not a list." lambda-list)
|
||||
(dolist (s (cddr args))
|
||||
(cmpck (not (stringp s)) "The argument to DEFUNC, ~s, is not a string." s))
|
||||
(push (list 'DEFUNC fun cfun lambda-list (cddr args)) *top-level-forms*)
|
||||
(push (cons fun cfun) *global-funs*)
|
||||
)
|
||||
|
||||
(defun t2defunC (fname cfun lambda-list body
|
||||
&aux (vv (add-symbol fname)))
|
||||
(declare (ignore lambda-list body))
|
||||
(wt-h "static L" cfun "();")
|
||||
(wt-nl "MF(" vv ",(cl_objectfn)L" cfun ",Cblock);")
|
||||
)
|
||||
|
||||
(defun t3defunC (fname cfun lambda-list body)
|
||||
(wt-comment "function definition for " fname)
|
||||
(wt-nl1 "static L" cfun "()")
|
||||
(multiple-value-bind
|
||||
(requireds optionals rest key-flag keywords allow-other-keys auxs)
|
||||
(parse-lambda-list lambda-list)
|
||||
(let ((nreq (length requireds))
|
||||
(nopt (length optionals)))
|
||||
(declare (fixnum nreq nopt))
|
||||
;; Emit declarations:
|
||||
(wt-nl1 "{")
|
||||
(dolist (v requireds)
|
||||
(wt-nl "cl_object " (string-downcase v) ";"))
|
||||
(do ((scan optionals (cdr scan))
|
||||
(v))
|
||||
((null scan))
|
||||
(setq v (car scan))
|
||||
(when (consp v)
|
||||
(setq v (car v))
|
||||
(cmpwarn "Discarding default value for optional variable ~s" v))
|
||||
(setq v (string-downcase v))
|
||||
(rplaca scan v)
|
||||
(wt-nl "cl_object " v "=Cnil;"))
|
||||
(when rest
|
||||
(setq rest (string-downcase rest))
|
||||
(wt-nl "cl_object " rest "=Cnil;"))
|
||||
(dolist (v keywords)
|
||||
(wt-nl "cl_object " (string-downcase (second v)) ";"))
|
||||
(when auxs
|
||||
(cmpwarn "&aux variables in defunC discarded"))
|
||||
(if (and (null optionals)
|
||||
(null rest)
|
||||
(null key-flag))
|
||||
(wt-nl "check_arg(" nreq ");")
|
||||
(wt-nl "if (narg < " nreq ") FEtoo_few_arguments(&narg);"))
|
||||
;; Assign requireds:
|
||||
(do ((i 0 (1+ i))
|
||||
(vars requireds (cdr vars)))
|
||||
((null vars))
|
||||
(declare (fixnum i))
|
||||
(wt-nl (string-downcase (car vars)) "=vs_base[" i "];"))
|
||||
;; Assign optionals:
|
||||
(do ((i nreq (1+ i))
|
||||
(vars optionals (cdr vars)))
|
||||
((null vars))
|
||||
(declare (fixnum i))
|
||||
(wt-nl (car vars) "=(narg>" i ") ? vs_base[" i "] : Cnil;"))
|
||||
(when (and (> nopt 0) (not key-flag) (null rest))
|
||||
(wt-nl "if (narg > " (+ nreq nopt) ") FEtoo_many_arguments(fname,narg);"))
|
||||
(when rest
|
||||
(wt-nl "{cl_object *p=vs_top;")
|
||||
(wt-nl " for(;p>vs_base+" (+ nreq nopt) ";p--)"
|
||||
rest "=CONS(p[-1]," rest ");}"))
|
||||
(when key-flag
|
||||
(cmperr "Keywords not allowed in defunC"))
|
||||
#+nil
|
||||
(when key-flag
|
||||
(wt-nl "parse_key(vs_base+" (+ nreq nopt) ",FALSE,"
|
||||
(if allow-other-keys "TRUE," "FALSE,") (length keywords))
|
||||
(dolist (k keywords)
|
||||
(wt-nl "," (add-object (car k))))
|
||||
(wt ");")
|
||||
(do ((ks keywords (cdr ks))
|
||||
(i (+ nreq nopt) (1+ i)))
|
||||
((null ks))
|
||||
(declare (fixnum i))
|
||||
(wt-nl (string-downcase (second (car ks))) "=vs_base[" i "];")))
|
||||
))
|
||||
;; Now the supplied body:
|
||||
(dolist (s body)
|
||||
(wt-nl1 s))
|
||||
(wt-nl1 "}")
|
||||
)
|
||||
|#
|
||||
|
||||
(defun t2function-constant (funob fun)
|
||||
(let ((previous (new-local *level* fun funob)))
|
||||
(if (and previous (fun-var previous))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue