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

Diff of /gcl/cmpnew/gcl_cmpbind.lsp

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

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

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