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

Diff of /gcl/cmpnew/gcl_cmpvar.lsp

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

revision 1.9 by camm, Wed Jun 29 04:21:21 2005 UTC revision 1.10 by camm, Fri Jul 8 06:02:47 2005 UTC
# Line 1  Line 1 
1    ;;-*-Lisp-*-
2  ;;; CMPVAR  Variables.  ;;; CMPVAR  Variables.
3  ;;;  ;;;
4  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
# Line 164  Line 165 
165        (if (eq (var-loc var) 'OBJECT)        (if (eq (var-loc var) 'OBJECT)
166            'OBJECT            'OBJECT
167            (let ((type (var-type var)))            (let ((type (var-type var)))
168                 (declare (object type))                 (cond ((car (member type +c-local-var-types+ :test 'type<=)))
                (cond ((type>= 'fixnum type) 'FIXNUM)  
                      ((type>= 'integer type) 'INTEGER)  
                      ((type>= 'CHARACTER type) 'CHARACTER)  
                      ((type>= 'long-float type) 'LONG-FLOAT)  
                      ((type>= 'short-float type) 'SHORT-FLOAT)  
169                       ((and (boundp '*c-gc*) *c-gc* 'OBJECT))                       ((and (boundp '*c-gc*) *c-gc* 'OBJECT))
170                       (t nil))))                       (t nil))))
171        nil)        nil)
# Line 301  Line 297 
297                    (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*))                    (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*))
298                      (save-avma '(nil integer))                      (save-avma '(nil integer))
299                      (wt-nl "SETQ_II(V"n",V" n"alloc,")                      (wt-nl "SETQ_II(V"n",V" n"alloc,")
300                      (wt-integer-loc loc  (cons 'set-var var))                      (wt-integer-loc loc)
301                      (wt "," (bignum-expansion-storage) ");")                      (wt "," (bignum-expansion-storage) ");")
302                      (close-inline-blocks))                      (close-inline-blocks))
303                    (return-from set-var nil))                    (return-from set-var nil))
# Line 309  Line 305 
305                 (wt ");")))                 (wt ");")))
306              (t              (t
307               (wt-nl "V" (var-loc var) "= ")               (wt-nl "V" (var-loc var) "= ")
308               (case (var-kind var)               (funcall (or (cdr (assoc (var-kind var) +wt-loc-alist+)) (baboon)) loc)
309                     (FIXNUM (wt-fixnum-loc loc))               (wt ";")))))
                    (CHARACTER (wt-character-loc loc))  
                    (LONG-FLOAT (wt-long-float-loc loc))  
                    (SHORT-FLOAT (wt-short-float-loc loc))  
                    (OBJECT (wt-loc loc))  
                    (t (baboon)))  
              (wt ";"))  
             )))  
310    
311  (defun sch-global (name)  (defun sch-global (name)
312    (dolist* (var *undefined-vars* nil)    (dolist* (var *undefined-vars* nil)
# Line 446  Line 435 
435          (case (caar forms)          (case (caar forms)
436            (LOCATION (push (cons vref (caddar forms)) saves))            (LOCATION (push (cons vref (caddar forms)) saves))
437            (otherwise            (otherwise
438              (if (member (var-kind (car vref))              (if (assoc (var-kind (car vref)) +return-alist+)
                         '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT))  
439                  (let* ((kind (var-kind (car vref)))                  (let* ((kind (var-kind (car vref)))
440                         (cvar (cs-push (var-type (car vref)) t))                         (cvar (cs-push (var-type (car vref)) t))
441                         (temp (list 'var (make-var :kind kind :type (var-type (car vref)) :loc cvar) nil)))                         (temp (list 'var (make-var :kind kind :type (var-type (car vref)) :loc cvar) nil)))

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

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