;;; CMPVS  Value stack manager.
;;;
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

;; This file is part of GNU Common Lisp, herein referred to as GCL
;;
;; GCL is free software; you can redistribute it and/or modify it under
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; GCL is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
;; License for more details.
;; 
;; You should have received a copy of the GNU Library General Public License 
;; along with GCL; see the file COPYING.  If not, write to the Free Software
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


(in-package 'compiler)

(si:putprop 'vs 'set-vs 'set-loc)
(si:putprop 'vs 'wt-vs 'wt-loc)
(si:putprop 'vs* 'wt-vs* 'wt-loc)
(si:putprop 'ccb-vs 'wt-ccb-vs 'wt-loc)

(defvar *vs* 0)
(defvar *max-vs* 0)
(defvar *clink* nil)
(defvar *ccb-vs* 0)
(defvar *initial-ccb-vs*)
(defvar *level* 0)

;;; *vs* holds the offset of the current vs-top.
;;; *max-vs* holds the maximum offset so far.
;;; *clink* holds NIL or the vs-address of the last ccb object.
;;; *ccb-vs* holds the top of the level 0 vs.
;;; *initial-ccb-vs* holds the value of *ccb-vs* when Pass 2 began to process
;;; a local (possibly closure) function.
;;; *level* holds the current function level.  *level* is 0 for a top-level
;;; function.

(defun vs-push ()
  (prog1 (cons *level* *vs*)
         (incf *vs*)
         (setq *max-vs* (max *vs* *max-vs*))))

(defun set-vs (loc vs)
  (unless (and (consp loc)
               (eq (car loc) 'vs)
               (equal (cadr loc) vs))
          (wt-nl)
          (wt-vs vs)
          (wt "= " loc ";")))

(defun wt-vs (vs)
  (cond ((eq (car vs) 'cvar)
	 (wt "V" (second vs)))
	((eq (car vs) 'cs)
	 (wt "Vcs[" (cdr vs) "]"))
	(t
	 (if (= (car vs) *level*)
	     (wt "base[" (cdr vs) "]")
	   (wt "base" (car vs) "[" (cdr vs) "]")))))

(defun wt-vs* (vs)
  (wt "(" )(wt-vs vs) (wt "->c.c_car)"))

(defun wt-ccb-vs (ccb-vs)
  (wt "(base0[" (- *initial-ccb-vs* ccb-vs) "]->c.c_car)"))

(defun clink (vs) (setq *clink* vs))

(defun wt-clink (&optional (clink *clink*))
  (if (null clink) (wt "Cnil") (wt-vs clink)))

(defun ccb-vs-push () (incf *ccb-vs*))


(defun cvs-push ()
  (prog1 (cons 'cs *cs*)
    (incf *cs*)
    ))


(defun wt-list (l)
  (do ((v l (cdr v)))
      ((null v))
      (wt (car v))
      (or (null (cdr v)) (wt ","))))