1 |
|
;;; CMPBIND Variable Binding. |
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 'bds-bind 'set-bds-bind 'set-loc) |
25 |
|
|
26 |
|
;;; Those functions that call the following binding functions should |
27 |
|
;;; rebind the special variables, |
28 |
|
;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*. |
29 |
|
|
30 |
|
(defun c2bind (var) |
31 |
|
(case (var-kind var) |
32 |
|
(LEXICAL |
33 |
|
(when (var-ref-ccb var) |
34 |
|
(wt-nl) |
35 |
|
(wt-vs (var-ref var)) |
36 |
|
(wt "=MMcons(") (wt-vs (var-ref var)) |
37 |
|
(wt ",") (wt-clink) (wt ");") |
38 |
|
(clink (var-ref var)) |
39 |
|
(setf (var-ref-ccb var) (ccb-vs-push)))) |
40 |
|
(SPECIAL |
41 |
|
(wt-nl "bds_bind(VV[" (var-loc var) "],") (wt-vs (var-ref var)) |
42 |
|
(wt ");") |
43 |
|
(push 'bds-bind *unwind-exit*)) |
44 |
|
(DOWN |
45 |
|
(cond ((integerp (var-loc var)) |
46 |
|
(wt-nl "base0[" (var-loc var) "]=") |
47 |
|
(wt-vs (var-ref var)) |
48 |
|
(wt ";")) |
49 |
|
(t (wfs-error)))) |
50 |
|
(INTEGER |
51 |
|
(wt-nl "SETQ_IO(V" (var-loc var)"," |
52 |
|
"V" (var-loc var)"alloc,") |
53 |
|
(wt "(") (wt-vs (var-ref var)) (wt "));")) |
54 |
|
(t |
55 |
|
(wt-nl "V" (var-loc var) "=") |
56 |
|
(case (var-kind var) |
57 |
|
(OBJECT) |
58 |
|
(FIXNUM (wt "fix")) |
59 |
|
(CHARACTER (wt "char_code")) |
60 |
|
(LONG-FLOAT (wt "lf")) |
61 |
|
(SHORT-FLOAT (wt "sf")) |
62 |
|
(t (baboon))) |
63 |
|
(wt "(") (wt-vs (var-ref var)) (wt ");"))) |
64 |
|
) |
65 |
|
|
66 |
|
(defun c2bind-loc (var loc) |
67 |
|
(case (var-kind var) |
68 |
|
(LEXICAL |
69 |
|
(cond ((var-ref-ccb var) |
70 |
|
(wt-nl) |
71 |
|
(wt-vs (var-ref var)) |
72 |
|
(wt "=MMcons(" loc ",") (wt-clink) (wt ");") |
73 |
|
(clink (var-ref var)) |
74 |
|
(setf (var-ref-ccb var) (ccb-vs-push))) |
75 |
|
(t |
76 |
|
(wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";")))) |
77 |
|
(SPECIAL |
78 |
|
(wt-nl "bds_bind(VV[" (var-loc var) "]," loc ");") |
79 |
|
(push 'bds-bind *unwind-exit*)) |
80 |
|
|
81 |
|
(DOWN |
82 |
|
(wt-nl "base0[" (var-loc var) "]=" loc ";")) |
83 |
|
(INTEGER |
84 |
|
(let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) |
85 |
|
(save-avma '(nil integer)) |
86 |
|
(wt-nl "V" (var-loc var) "= ") |
87 |
|
(wt-integer-loc loc var) |
88 |
|
(wt ";") |
89 |
|
(close-inline-blocks))) |
90 |
|
(t |
91 |
|
(wt-nl "V" (var-loc var) "= ") |
92 |
|
(case (var-kind var) |
93 |
|
(OBJECT (wt-loc loc)) |
94 |
|
(FIXNUM (wt-fixnum-loc loc)) |
95 |
|
(CHARACTER (wt-character-loc loc)) |
96 |
|
(LONG-FLOAT (wt-long-float-loc loc)) |
97 |
|
(SHORT-FLOAT (wt-short-float-loc loc)) |
98 |
|
(t (baboon))) |
99 |
|
(wt ";"))) |
100 |
|
) |
101 |
|
|
102 |
|
(defun c2bind-init (var init) |
103 |
|
(case (var-kind var) |
104 |
|
(LEXICAL |
105 |
|
(cond ((var-ref-ccb var) |
106 |
|
(let ((loc (list 'vs (var-ref var)))) |
107 |
|
(let ((*value-to-go* loc)) |
108 |
|
(c2expr* init)) |
109 |
|
(wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*) |
110 |
|
(wt ");")) |
111 |
|
(clink (var-ref var)) |
112 |
|
(setf (var-ref-ccb var) (ccb-vs-push))) |
113 |
|
(t |
114 |
|
(let ((*value-to-go* (list 'vs (var-ref var)))) |
115 |
|
(c2expr* init))))) |
116 |
|
(SPECIAL |
117 |
|
(let ((*value-to-go* (list 'bds-bind (var-loc var)))) |
118 |
|
(c2expr* init)) |
119 |
|
(push 'bds-bind *unwind-exit*)) |
120 |
|
(DOWN |
121 |
|
(let ((*value-to-go* (list 'down (var-loc var)))) |
122 |
|
(c2expr* init))) |
123 |
|
((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) |
124 |
|
(let ((*value-to-go* (list 'var var nil))) |
125 |
|
(c2expr* init))) |
126 |
|
(t (baboon))) |
127 |
|
) |
128 |
|
|
129 |
|
(defun set-bds-bind (loc vv) |
130 |
|
(wt-nl "bds_bind(VV[" vv "]," loc ");")) |