;;; CMPBIND Variable Binding. ;;; ;; 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 'bds-bind 'set-bds-bind 'set-loc) ;;; Those functions that call the following binding functions should ;;; rebind the special variables, ;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*. (defun c2bind (var) (case (var-kind var) (LEXICAL (when (var-ref-ccb var) (wt-nl) (wt-vs (var-ref var)) (wt "=MMcons(") (wt-vs (var-ref var)) (wt ",") (wt-clink) (wt ");") (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push)))) (SPECIAL (wt-nl "bds_bind(VV[" (var-loc var) "],") (wt-vs (var-ref var)) (wt ");") (push 'bds-bind *unwind-exit*)) (DOWN (cond ((integerp (var-loc var)) (wt-nl "base0[" (var-loc var) "]=") (wt-vs (var-ref var)) (wt ";")) (t (wfs-error)))) (INTEGER (wt-nl "SETQ_IO(V" (var-loc var)"," "V" (var-loc var)"alloc,") (wt "(") (wt-vs (var-ref var)) (wt "));")) (t (wt-nl "V" (var-loc var) "=") (case (var-kind var) (OBJECT) (FIXNUM (wt "fix")) (CHARACTER (wt "char_code")) (LONG-FLOAT (wt "lf")) (SHORT-FLOAT (wt "sf")) (t (baboon))) (wt "(") (wt-vs (var-ref var)) (wt ");"))) ) (defun c2bind-loc (var loc) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (wt-nl) (wt-vs (var-ref var)) (wt "=MMcons(" loc ",") (wt-clink) (wt ");") (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) (t (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";")))) (SPECIAL (wt-nl "bds_bind(VV[" (var-loc var) "]," loc ");") (push 'bds-bind *unwind-exit*)) (DOWN (wt-nl "base0[" (var-loc var) "]=" loc ";")) (INTEGER (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma '(nil integer)) (wt-nl "V" (var-loc var) "= ") (wt-integer-loc loc var) (wt ";") (close-inline-blocks))) (t (wt-nl "V" (var-loc var) "= ") (case (var-kind var) (OBJECT (wt-loc loc)) (FIXNUM (wt-fixnum-loc loc)) (CHARACTER (wt-character-loc loc)) (LONG-FLOAT (wt-long-float-loc loc)) (SHORT-FLOAT (wt-short-float-loc loc)) (t (baboon))) (wt ";"))) ) (defun c2bind-init (var init) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (let ((loc (list 'vs (var-ref var)))) (let ((*value-to-go* loc)) (c2expr* init)) (wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*) (wt ");")) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) (t (let ((*value-to-go* (list 'vs (var-ref var)))) (c2expr* init))))) (SPECIAL (let ((*value-to-go* (list 'bds-bind (var-loc var)))) (c2expr* init)) (push 'bds-bind *unwind-exit*)) (DOWN (let ((*value-to-go* (list 'down (var-loc var)))) (c2expr* init))) ((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) (let ((*value-to-go* (list 'var var nil))) (c2expr* init))) (t (baboon))) ) (defun set-bds-bind (loc vv) (wt-nl "bds_bind(VV[" vv "]," loc ");"))