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

Diff of /gcl/cmpnew/gcl_cmpvs.lsp

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

revision 1.1 by camm, Sun Sep 14 02:30:34 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:02 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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