home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / cmpnew / cmplet.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-03  |  9.4 KB  |  244 lines
  1. ;;; CMPLET  Let and Let*.
  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 'let 'c1let 'c1special)
  10. (si:putprop 'let 'c2let 'c2)
  11. (si:putprop 'let* 'c1let* 'c1special)
  12. (si:putprop 'let* 'c2let* 'c2)
  13.  
  14. (defun c1let (args &aux (info (make-info))
  15.                         (forms nil) (vars nil) (vnames nil)
  16.                         ss is ts body other-decls
  17.                         (*vars* *vars*))
  18.   (when (endp args) (too-few-args 'let 1 0))
  19.  
  20.   (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil))
  21.  
  22.   (c1add-globals ss)
  23.  
  24.   (dolist** (x (car args))
  25.     (cond ((symbolp x)
  26.            (let ((v (c1make-var x ss is ts)))
  27.                 (push x vnames)
  28.                 (push v vars)
  29.                 (push (default-init (var-type v)) forms)))
  30.           (t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
  31.                     "The variable binding ~s is illegal." x)
  32.              (let ((v (c1make-var (car x) ss is ts)))
  33.                   (push (car x) vnames)
  34.                   (push v vars)
  35.                   (push (if (endp (cdr x))
  36.                             (default-init (var-type v))
  37.                             (and-form-type (var-type v)
  38.                                            (c1expr* (cadr x) info)
  39.                                            (cadr x)))
  40.                         forms)))))
  41.  
  42.   (dolist* (v (reverse vars)) (push v *vars*))
  43.  
  44.   (check-vdecl vnames ts is)
  45.  
  46.   (setq body (c1decl-body other-decls body))
  47.  
  48.   (add-info info (cadr body))
  49.   (setf (info-type info) (info-type (cadr body)))
  50.  
  51.   (dolist** (var vars) (check-vref var))
  52.  
  53.   (list 'let info (reverse vars) (reverse forms) body)
  54.   )
  55.  
  56. (defun c2let (vars forms body
  57.                    &aux (block-p nil) (bindings nil)
  58.                         (*unwind-exit* *unwind-exit*)
  59.                         (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
  60.        (declare (object block-p))
  61.  
  62.   (dolist** (var vars)
  63.     (let ((kind (c2var-kind var)))
  64.          (declare (object kind))
  65.          (if kind
  66.              (let ((cvar (next-cvar)))
  67.                   (setf (var-kind var) kind)
  68.                   (setf (var-loc var) cvar)
  69.                   (wt-nl)
  70.                   (unless block-p (wt "{") (setq block-p t))
  71.                   (wt (rep-type kind) "V" cvar ";"))
  72.             (setf (var-ref var) (vs-push)))))
  73.  
  74.   (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil))
  75.       ((endp vl))
  76.       (declare (object vl fl))
  77.       (let ((form (car fl)) (var (car vl)))
  78.            (declare (object form var))
  79.         (case (var-kind var)
  80.           ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
  81.            (let ((*value-to-go* (list 'var var nil))) (c2expr* form)))
  82.           (otherwise
  83.             (case (car form)
  84.               (LOCATION
  85.                (if (can-be-replaced var body)
  86.                    (progn (setf (var-kind var) 'REPLACED)
  87.                           (setf (var-loc var) (caddr form)))
  88.                    (push (list var (caddr form)) bindings)))
  89.               (VAR
  90.                (let ((var1 (caaddr form)))
  91.                     (declare (object var1))
  92.                     (cond ((or (args-info-changed-vars var1 (cdr fl))
  93.                                (and (member (var-kind var1) '(SPECIAL GLOBAL))
  94.                                     (member (var-name var1) prev-ss)))
  95.                            (let ((*value-to-go* (list 'vs (var-ref var))))
  96.                                 (c2expr* form))
  97.                            (push (list var) bindings))
  98.                           ((and (can-be-replaced var body)
  99.                                 (member (var-kind var1)
  100.                                         '(LEXICAL REPLACED OBJECT))
  101.                                 (null (var-ref-ccb var1))
  102.                                 (not (member var1 (info-changed-vars
  103.                                                    (cadr body)))))
  104.                            (setf (var-kind var) 'REPLACED)
  105.                            (setf (var-loc var)
  106.                                  (case (var-kind var1)
  107.                                    (LEXICAL (list 'vs (var-ref var1)))
  108.                                    (REPLACED (var-loc var1))
  109.                                    (OBJECT (list 'cvar (var-loc var1)))
  110.                                    (otherwise (baboon)))))
  111.                           (t (push (list var
  112.                                          (list 'var var1 (cadr (caddr form))))
  113.                                    bindings)))))
  114.               (t (let ((*value-to-go* (list 'vs (var-ref var))))
  115.                       (c2expr* form))
  116.                  (push (list var) bindings))
  117.               )))
  118.         (when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss))
  119.         ))
  120.  
  121.  
  122.   (dolist* (binding (reverse bindings))
  123.     (if (cdr binding)
  124.         (c2bind-loc (car binding) (cadr binding))
  125.         (c2bind (car binding))))
  126.  
  127.   (c2expr body)
  128.   (when block-p (wt "}"))
  129.   )
  130.  
  131. (defun c1let* (args &aux (forms nil) (vars nil) (vnames nil)
  132.                     ss is ts body other-decls
  133.                     (info (make-info)) (*vars* *vars*))
  134.   (when (endp args) (too-few-args 'let* 1 0))
  135.  
  136.   (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil))
  137.   (c1add-globals ss)
  138.  
  139.   (dolist** (x (car args))
  140.     (cond ((symbolp x)
  141.            (let ((v (c1make-var x ss is ts)))
  142.                 (push x vnames)
  143.                 (push (default-init (var-type v)) forms)
  144.                 (push v vars)
  145.                 (push v *vars*)))
  146.           ((not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
  147.            (cmperr "The variable binding ~s is illegal." x))
  148.           (t (let ((v (c1make-var (car x) ss is ts)))
  149.                   (push (car x) vnames)
  150.                   (push (if (endp (cdr x))
  151.                             (default-init (var-type v))
  152.                             (and-form-type (var-type v)
  153.                                            (c1expr* (cadr x) info)
  154.                                            (cadr x)))
  155.                         forms)
  156.                   (push v vars)
  157.                   (push v *vars*)))))
  158.  
  159.   (check-vdecl vnames ts is)
  160.   (setq body (c1decl-body other-decls body))
  161.   (add-info info (cadr body))
  162.   (setf (info-type info) (info-type (cadr body)))
  163.   (dolist** (var vars) (check-vref var))
  164.   (list 'let* info (reverse vars) (reverse forms) body)
  165.   )
  166.  
  167. (defun c2let* (vars forms body
  168.                     &aux (block-p nil)
  169.                     (*unwind-exit* *unwind-exit*)
  170.                     (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
  171.        (declare (object block-p))
  172.  
  173.   (dolist** (var vars)
  174.     (let ((kind (c2var-kind var)))
  175.          (declare (object kind))
  176.          (when kind
  177.                (let ((cvar (next-cvar)))
  178.                     (setf (var-kind var) kind)
  179.                     (setf (var-loc var) cvar)
  180.                     (wt-nl)
  181.                     (unless block-p (wt "{") (setq block-p t))
  182.                     (wt (rep-type kind) "V" cvar ";")))))
  183.  
  184.   (do ((vl vars (cdr vl))
  185.        (fl forms (cdr fl)))
  186.       ((endp vl))
  187.       (declare (object vl fl))
  188.       (let ((form (car fl)) (var (car vl)))
  189.            (declare (object form var))
  190.         (if (member (var-kind var)
  191.                     '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT))
  192.             (let ((*value-to-go* (list 'var var nil)))
  193.                  (c2expr* form))
  194.             (case (car form)
  195.               (LOCATION
  196.                (cond ((can-be-replaced* var body (cdr fl))
  197.                       (setf (var-kind var) 'REPLACED)
  198.                       (setf (var-loc var) (caddr form)))
  199.                      (t (setf (var-ref var) (vs-push))
  200.                         (c2bind-loc var (caddr form)))))
  201.               (VAR
  202.                (let ((var1 (caaddr form)))
  203.                     (declare (object var1))
  204.                     (cond ((and (can-be-replaced* var body (cdr fl))
  205.                                 (member (var-kind var1)
  206.                                         '(LEXICAL REPLACED OBJECT))
  207.                                 (null (var-ref-ccb var1))
  208.                                 (not (args-info-changed-vars var1 (cdr fl)))
  209.                                 (not (member var1 (info-changed-vars
  210.                                                    (cadr body)))))
  211.                            (setf (var-kind var) 'REPLACED)
  212.                            (setf (var-loc var)
  213.                                  (case (var-kind var1)
  214.                                    (LEXICAL (list 'vs (var-ref var1)))
  215.                                    (REPLACED (var-loc var1))
  216.                                    (OBJECT (list 'cvar (var-loc var1)))
  217.                                    (otherwise (baboon)))))
  218.                           (t (setf (var-ref var) (vs-push))
  219.                              (c2bind-loc var
  220.                                (list 'var var1 (cadr (caddr form)))))))
  221.            )
  222.           (t (setf (var-ref var) (vs-push))
  223.              (c2bind-init var form))))
  224.         ))
  225.  
  226.   (c2expr body)
  227.  
  228.   (when block-p (wt "}"))
  229.   )
  230.  
  231. (defun can-be-replaced (var body)
  232.   (and (eq (var-kind var) 'LEXICAL)
  233.        (null (var-ref-ccb var))
  234.        (not (member var (info-changed-vars (cadr body))))))
  235.  
  236. (defun can-be-replaced* (var body forms)
  237.   (and (eq (var-kind var) 'LEXICAL)
  238.        (null (var-ref-ccb var))
  239.        (not (member var (info-changed-vars (cadr body))))
  240.        (dolist** (form forms t)
  241.          (when (member var (info-changed-vars (cadr form)))
  242.                (return nil)))
  243.        ))
  244.