/[gcl]/gcl/cmpnew/gcl_cmpinline.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpinline.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by camm, Tue Dec 14 03:34:06 2004 UTC revision 1.11 by camm, Tue Dec 21 04:49:47 2004 UTC
# Line 369  Line 369 
369                                               (make-var                                               (make-var
370                                                :type type                                                :type type
371                                                :kind                                                :kind
372                                                (if (member type                                                (let ((type (promoted-c-type type)))
373                                                            *special-types*)                                                  (if (member type
374                                                    type 'object)                                                              *special-types*)
375                                                         :loc (cdar *c-vars*))                                                      type 'object))
376                                                  :loc (cdar *c-vars*))
377                                               nil                                               nil
378                                               ))))                                               ))))
379                               (t  (list 'vs (vs-push))))))                               (t  (list 'vs (vs-push))))))
# Line 449  Line 450 
450                    )                    )
451                   (t (push loc1 locs1))))                   (t (push loc1 locs1))))
452                (push (car l) locs1)))))                (push (car l) locs1)))))
453    (list (inline-type (cadr ii))  
454          (caddr ii)    (let ((others (and (stringp fun) (consp (cadr ii)) (eq 'values (caadr ii))
455          fun                       (mapcar #'inline-type (cddadr ii)))))
456          locs)      (list (inline-type (cadr ii))
457              (caddr ii)
458              (if others (cons fun others) fun)
459              locs
460              ))
461    )    )
462  (defvar *inline-types*  (defvar *inline-types*
463    '((boolean . INLINE-COND)    '((boolean . INLINE-COND)
# Line 589  Line 594 
594  (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc)  (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc)
595  (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc)  (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc)
596    
597  (defun wt-inline-loc (fun locs &aux (i 0) (max -1))  (defun wt-inline-loc (fun locs &aux (i 0) (max -1) (maxv 0))
598         (declare (fixnum i max))    (declare (fixnum i max maxv))
599    (cond ((stringp fun)    (let* ((others (and (consp fun) (stringp (car fun)) (cdr fun)))
600             (fun (if (and (consp fun) (stringp (car fun))) (car fun) fun)))
601           (cond ((stringp fun)
602           (when (char= (char (the string fun) 0) #\@)           (when (char= (char (the string fun) 0) #\@)
603             (setq i 1)             (setq i 1)
604             (do ()             (do ()
# Line 629  Line 636 
636                                    (cond ((>= n max) (setq  max n)))                                    (cond ((>= n max) (setq  max n)))
637                                    (wt-loc (nth n locs)))))                                    (wt-loc (nth n locs)))))
638                           (incf i 2))                           (incf i 2))
639                            ((char= char #\$)
640                             (let* ((n (- (char-code (char fun (1+ i))) #.(char-code #\1)))
641                                    (pos (position #\$ fun :start (+ i 2)))
642                                    (new-fun (subseq fun (+ i 2) pos))
643                                    (*value-to-go* (or (nth n *values-to-go*)
644                                                       (and (member *value-to-go* '(top return) :test #'eq)
645                                                           (list 'vs (vs-push)))
646                                                       'trash)))
647                               (set-loc (list (nth n others) (flags) new-fun locs))
648                               (setf maxv (max maxv (1+ n)))
649                               (setf i (1+ pos))))
650                          (t                          (t
651                           (princ char *compiler-output1*)                           (princ char *compiler-output1*)
652                           (incf i)))))                           (incf i)))))
653             (setq *values-to-go* (nthcdr maxv *values-to-go*))
654           )           )
655          (t (apply fun locs))))          (t (apply fun locs)))))
656    
657  (defun wt-inline (side-effectp fun locs)  (defun wt-inline (side-effectp fun locs)
658    (declare (ignore side-effectp))    (declare (ignore side-effectp))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26