push-all-args inline flag - gcl.git - GNU Common Lisp

diff --git a/gcl/cmpnew/gcl_cmpcall.lsp b/gcl/cmpnew/gcl_cmpcall.lsp
index 60624429f..60f140e16 100755
--- a/gcl/cmpnew/gcl_cmpcall.lsp
+++ b/gcl/cmpnew/gcl_cmpcall.lsp

@@ -466,7 +466,7 @@

(f (if (single-type-p rt) f (flag-or f svt)))

(f (if apnarg (flag-or f aa) f)))

(push (list* fname (format nil "LI~d" n) n tail) *function-links*)

- (car (push (list fname at rt f

+ (car (push (list fname at rt (push-all-args-flag f clp at rt)

(g fname n (list at rt) apnarg clp)

'link-call n)

*inline-functions*))))))

diff --git a/gcl/cmpnew/gcl_cmpeval.lsp b/gcl/cmpnew/gcl_cmpeval.lsp
index dabf9820c..5ad2ff95e 100755
--- a/gcl/cmpnew/gcl_cmpeval.lsp
+++ b/gcl/cmpnew/gcl_cmpeval.lsp

@@ -184,7 +184,8 @@

(inline-types-function itf) ;; car of ii is a function returning match info

(sets-vs-top svt)

(normalized-types nt)

- (apply-arg aa)))

+ (apply-arg aa)

+ (push-all-args paa)))

(cond ((member flag v :test 'eq)

(return-from flags-pos i)))

(setq i (+ i 1)))

diff --git a/gcl/cmpnew/gcl_cmpflet.lsp b/gcl/cmpnew/gcl_cmpflet.lsp
index a896562a3..430898f74 100755
--- a/gcl/cmpnew/gcl_cmpflet.lsp
+++ b/gcl/cmpnew/gcl_cmpflet.lsp

@@ -1050,6 +1050,12 @@

;; (if mv "FUN_VALP=(fixnum)#v," "")

;; (if va "VFUN_NARGS= #n ," "") x ")")))

+(defun push-all-args-flag (flags clp at rt)

+ (logior

+ (if (or clp (member '* at) (not (single-type-p rt)))

+ (flags paa) 0)

+ flags))

+

(defun make-local-inline (fd)

(let* ((fun (pop fd))

(clp (pop fd))

@@ -1062,7 +1068,7 @@

(nm (if clp (ms clp "->fun.fun_self") nm))

(inl (g1 clp nm sig ap clp (if clp -1 (fun-level fun)))))

`(,(car sig) ,(cadr sig)

- ,(if mv (flags rfa svt) (flags rfa))

+ ,(apply 'push-all-args-flag (if mv (flags rfa svt) (flags rfa)) clp sig)

,inl)))

;; (defun make-local-inline (fd)

diff --git a/gcl/cmpnew/gcl_cmpinline.lsp b/gcl/cmpnew/gcl_cmpinline.lsp
index 69b704a87..8672e850e 100755
--- a/gcl/cmpnew/gcl_cmpinline.lsp
+++ b/gcl/cmpnew/gcl_cmpinline.lsp

@@ -853,53 +853,40 @@

;; (let ((tl (cdr (assoc (promoted-c-type type) +coersion-alist+))))

;; (if tl (list tl loc) loc)))))

-(defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs)

- ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*.

- (setq locs (inline-args args (car ii) fun))

- (when (and (stringp fun) (char= (char (the string fun) 0) #\@))

- (let ((i 1) (saves nil))

- (declare (fixnum i))

- (do ((char (char (the string fun) i)

- (char (the string fun) i)))

- ((char= char #\;) (incf i))

- (declare (character char))

- (push (the fixnum (- (char-code char) #.(char-code #0円))) saves)

- (incf i))

- (do ((l locs (cdr l))

- (n 0 (1+ n))

- (locs1 nil))

- ((endp l) (setq locs (reverse locs1)))

- (declare (fixnum n))

- (if (member n saves)

- (let* ((loc (car l)) (loc1 loc)

- (coersion (and (consp loc) (cdr (rassoc (car loc) +coersion-alist+))))

- (loc (if coersion (cadr loc) loc))); remove coersion

- (cond

- ((and (consp loc)

- (rassoc (car loc) +inline-types-alist+)

- (or (member (car loc) '(inline inline-cond))

- (flag-p (cadr loc) allocates-new-storage)

- (flag-p (cadr loc) side-effect-p)))

- (wt-nl "{")

- (inc-inline-blocks) ;;FIXME -- make sure not losing specificity in coersion

- (let* ((ck (or (car (rassoc coersion +coersion-alist+)) 'object))

- (cvar (cs-push ck t)))

- (push (list 'CVAR cvar) locs1)

- (unless ck (baboon))

- (wt (rep-type ck) "V" cvar "= ")

- (funcall (cdr (assoc ck +wt-loc-alist+)) loc))

- (wt ";"))

- (t (push loc1 locs1))))

- (push (car l) locs1)))))

+(defun get-inline-loc (ii args &aux (pa (flag-p (caddr ii) paa)) (fun (car (cdddr ii))) (locs (inline-args args (car ii) fun)) saves)

+ (unless pa

+ (when (when (stringp fun) (char= #\@ (char fun 0)))

+ (let ((i 1))

+ (declare (fixnum i))

+ (do ((char (char fun i) (char fun i)))

+ ((char= #\; char))

+ (push (- (char-code char) #.(char-code #0円)) saves)

+ (incf i)))))

+ (when (or pa saves)

+ (do ((l locs (cdr l))

+ (n 0 (1+ n)) locs1)

+ ((endp l) (setq locs (reverse locs1)))

+ (declare (fixnum n))

+ (if (or pa (member n saves))

+ (let* ((loc (car l)) (loc1 loc)

+ (coersion (and (consp loc) (cdr (rassoc (car loc) +coersion-alist+))))

+ (loc (if coersion (cadr loc) loc))); remove coersion

+ (if (and (consp loc)

+ (rassoc (car loc) +inline-types-alist+)

+ (or pa

+ (member (car loc) '(inline inline-cond))

+ (flag-p (cadr loc) allocates-new-storage)

+ (flag-p (cadr loc) side-effect-p)))

+ (push (wt-push-loc loc (or (car (rassoc coersion +coersion-alist+)) 'object)) locs1)

+ (push loc1 locs1)))

+ (push (car l) locs1))))

(let ((others (and (stringp fun) (not (single-type-p (cadr ii))) (not (type>= (cadr ii) '*))

(mapcar 'inline-type (cddadr ii)))))

(list (inline-type (cadr ii))

(caddr ii)

(if others (cons fun others) fun)

- locs

- ))

- )

+ locs)))

(defun inline-type (type)

(or (cdr (assoc (promoted-c-type type) +inline-types-alist+)) 'inline))