home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / cmpnew / cmpbind.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-03  |  3.1 KB  |  93 lines
  1. ;;; CMPBIND  Variable Binding.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'bds-bind 'set-bds-bind 'set-loc)
  10.  
  11. ;;; Those functions that call the following binding functions should
  12. ;;; rebind the special variables,
  13. ;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*.
  14.  
  15. (defun c2bind (var)
  16.   (case (var-kind var)
  17.         (LEXICAL
  18.          (when (var-ref-ccb var)
  19.                (wt-nl)
  20.                (wt-vs (var-ref var))
  21.                (wt "=MMcons(") (wt-vs (var-ref var))
  22.                (wt ",") (wt-clink) (wt ");")
  23.                (clink (var-ref var))
  24.                (setf (var-ref-ccb var) (ccb-vs-push))))
  25.         (SPECIAL
  26.          (wt-nl "bds_bind(VV[" (var-loc var) "],") (wt-vs (var-ref var))
  27.          (wt ");")
  28.          (push 'bds-bind *unwind-exit*))
  29.         (t
  30.          (wt-nl "V" (var-loc var) "=")
  31.          (case (var-kind var)
  32.                (OBJECT)
  33.                (FIXNUM (wt "fix"))
  34.                (CHARACTER (wt "char_code"))
  35.                (LONG-FLOAT (wt "lf"))
  36.                (SHORT-FLOAT (wt "sf"))
  37.                (t (baboon)))
  38.          (wt "(") (wt-vs (var-ref var)) (wt ");")))
  39.   )
  40.  
  41. (defun c2bind-loc (var loc)
  42.   (case (var-kind var)
  43.         (LEXICAL
  44.          (cond ((var-ref-ccb var)
  45.                 (wt-nl)
  46.                 (wt-vs (var-ref var))
  47.                 (wt "=MMcons(" loc ",") (wt-clink) (wt ");")
  48.                 (clink (var-ref var))
  49.                 (setf (var-ref-ccb var) (ccb-vs-push)))
  50.                (t
  51.                 (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";"))))
  52.         (SPECIAL
  53.          (wt-nl "bds_bind(VV[" (var-loc var) "]," loc ");")
  54.          (push 'bds-bind *unwind-exit*))
  55.         (t
  56.          (wt-nl "V" (var-loc var) "= ")
  57.          (case (var-kind var)
  58.                (OBJECT (wt-loc loc))
  59.                (FIXNUM (wt-fixnum-loc loc))
  60.                (CHARACTER (wt-character-loc loc))
  61.                (LONG-FLOAT (wt-long-float-loc loc))
  62.                (SHORT-FLOAT (wt-short-float-loc loc))
  63.                (t (baboon)))
  64.          (wt ";")))
  65.   )
  66.  
  67. (defun c2bind-init (var init)
  68.   (case (var-kind var)
  69.         (LEXICAL
  70.          (cond ((var-ref-ccb var)
  71.                 (let ((loc (list 'vs (var-ref var))))
  72.                      (let ((*value-to-go* loc))
  73.                           (c2expr* init))
  74.                      (wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*)
  75.                      (wt ");"))
  76.                 (clink (var-ref var))
  77.                 (setf (var-ref-ccb var) (ccb-vs-push)))
  78.                (t
  79.                 (let ((*value-to-go* (list 'vs (var-ref var))))
  80.                      (c2expr* init)))))
  81.         (SPECIAL
  82.          (let ((*value-to-go* (list 'bds-bind (var-loc var))))
  83.               (c2expr* init))
  84.          (push 'bds-bind *unwind-exit*))
  85.         ((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT)
  86.          (let ((*value-to-go* (list 'var var nil)))
  87.               (c2expr* init)))
  88.         (t (baboon)))
  89.   )
  90.  
  91. (defun set-bds-bind (loc vv)
  92.        (wt-nl "bds_bind(VV[" vv "]," loc ");"))
  93.