1 |
|
;;; CMPVS Value stack manager. |
2 |
|
;;; |
3 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
4 |
|
|
5 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
6 |
|
;; |
7 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
8 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
9 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
10 |
|
;; any later version. |
11 |
|
;; |
12 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
13 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
15 |
|
;; License for more details. |
16 |
|
;; |
17 |
|
;; You should have received a copy of the GNU Library General Public License |
18 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
19 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
20 |
|
|
21 |
|
|
22 |
|
(in-package 'compiler) |
23 |
|
|
24 |
|
(si:putprop 'vs 'set-vs 'set-loc) |
25 |
|
(si:putprop 'vs 'wt-vs 'wt-loc) |
26 |
|
(si:putprop 'vs* 'wt-vs* 'wt-loc) |
27 |
|
(si:putprop 'ccb-vs 'wt-ccb-vs 'wt-loc) |
28 |
|
|
29 |
|
(defvar *vs* 0) |
30 |
|
(defvar *max-vs* 0) |
31 |
|
(defvar *clink* nil) |
32 |
|
(defvar *ccb-vs* 0) |
33 |
|
(defvar *initial-ccb-vs*) |
34 |
|
(defvar *level* 0) |
35 |
|
|
36 |
|
;;; *vs* holds the offset of the current vs-top. |
37 |
|
;;; *max-vs* holds the maximum offset so far. |
38 |
|
;;; *clink* holds NIL or the vs-address of the last ccb object. |
39 |
|
;;; *ccb-vs* holds the top of the level 0 vs. |
40 |
|
;;; *initial-ccb-vs* holds the value of *ccb-vs* when Pass 2 began to process |
41 |
|
;;; a local (possibly closure) function. |
42 |
|
;;; *level* holds the current function level. *level* is 0 for a top-level |
43 |
|
;;; function. |
44 |
|
|
45 |
|
(defun vs-push () |
46 |
|
(prog1 (cons *level* *vs*) |
47 |
|
(incf *vs*) |
48 |
|
(setq *max-vs* (max *vs* *max-vs*)))) |
49 |
|
|
50 |
|
(defun set-vs (loc vs) |
51 |
|
(unless (and (consp loc) |
52 |
|
(eq (car loc) 'vs) |
53 |
|
(equal (cadr loc) vs)) |
54 |
|
(wt-nl) |
55 |
|
(wt-vs vs) |
56 |
|
(wt "= " loc ";"))) |
57 |
|
|
58 |
|
(defun wt-vs (vs) |
59 |
|
(cond ((eq (car vs) 'cvar) |
60 |
|
(wt "V" (second vs))) |
61 |
|
((eq (car vs) 'cs) |
62 |
|
(setq *vcs-used* t) |
63 |
|
(wt "Vcs[" (cdr vs) "]")) |
64 |
|
(t |
65 |
|
(if (= (car vs) *level*) |
66 |
|
(wt "base[" (cdr vs) "]") |
67 |
|
(wt "base" (car vs) "[" (cdr vs) "]"))))) |
68 |
|
|
69 |
|
(defun wt-vs* (vs) |
70 |
|
(wt "(" )(wt-vs vs) (wt "->c.c_car)")) |
71 |
|
|
72 |
|
(defun wt-ccb-vs (ccb-vs) |
73 |
|
(wt "(base0[" (- *initial-ccb-vs* ccb-vs) "]->c.c_car)")) |
74 |
|
|
75 |
|
(defun clink (vs) (setq *clink* vs)) |
76 |
|
|
77 |
|
(defun wt-clink (&optional (clink *clink*)) |
78 |
|
(if (null clink) (wt "Cnil") (wt-vs clink))) |
79 |
|
|
80 |
|
(defun ccb-vs-push () (incf *ccb-vs*)) |
81 |
|
|
82 |
|
|
83 |
|
(defun cvs-push () |
84 |
|
(prog1 (cons 'cs *cs*) |
85 |
|
(incf *cs*) |
86 |
|
)) |
87 |
|
|
88 |
|
|
89 |
|
(defun wt-list (l) |
90 |
|
(do ((v l (cdr v))) |
91 |
|
((null v)) |
92 |
|
(wt (car v)) |
93 |
|
(or (null (cdr v)) (wt ",")))) |
94 |
|
|