From af0504410d8f7c672bd6f84db85a8d01ae96faa6 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Tue, 12 Feb 2002 16:05:35 +0000
Subject: [PATCH] Instead of producing a call to object_to_int, defCbody should
 call object_to_fixnum

---
 src/cmp/cmptop.lsp | 322 ++-------------------------------------------
 1 file changed, 10 insertions(+), 312 deletions(-)

diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp
index fd5c92db3..85b5d4199 100644
--- a/src/cmp/cmptop.lsp
+++ b/src/cmp/cmptop.lsp
@@ -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))