home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpmulti.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  9.0 KB  |  265 lines
  1. ;;; CMPMULT  Multiple-value-call and Multiple-value-prog1.
  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 'multiple-value-call 'c1multiple-value-call 'c1special)
  25. (si:putprop 'multiple-value-call 'c2multiple-value-call 'c2)
  26. (si:putprop 'multiple-value-prog1 'c1multiple-value-prog1 'c1special)
  27. (si:putprop 'multiple-value-prog1 'c2multiple-value-prog1 'c2)
  28. (si:putprop 'values 'c1values 'c1)
  29. (si:putprop 'values 'c2values 'c2)
  30. (si:putprop 'multiple-value-setq 'c1multiple-value-setq 'c1)
  31. (si:putprop 'multiple-value-setq 'c2multiple-value-setq 'c2)
  32. (si:putprop 'multiple-value-bind 'c1multiple-value-bind 'c1)
  33. (si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2)
  34.  
  35. (defun c1multiple-value-call (args &aux info funob)
  36.   (when (endp args) (too-few-args 'multiple-value-call 1 0))
  37.   (cond ((endp (cdr args)) (c1funcall args))
  38.         (t (setq funob (c1funob (car args)))
  39.            (setq info (copy-info (cadr funob)))
  40.            (setq args (c1args (cdr args) info))
  41.            (list 'multiple-value-call info funob args)))
  42.   )
  43.  
  44. (defun c2multiple-value-call (funob forms &aux (*vs* *vs*) loc top)
  45.   (cond ((endp (cdr forms))
  46.          (setq loc (save-funob funob))
  47.          (let ((*value-to-go* 'top)) (c2expr* (car forms)))
  48.          (c2funcall funob 'args-pushed loc))
  49.         (t
  50.          (setq top (next-cvar))
  51.          (setq loc (save-funob funob))
  52.          (wt-nl "{object *V" top "=base+" *vs* ";")
  53.          (base-used)
  54.          (dolist** (form forms)
  55.            (let ((*value-to-go* 'top)) (c2expr-top* form top))
  56.            (wt-nl "while(vs_base<vs_top)")
  57.            (wt-nl "{V" top "[0]=vs_base[0];V" top "++;vs_base++;}"))
  58.          (wt-nl "vs_base=base+" *vs* ";vs_top=V" top ";")
  59.          (base-used)
  60.          (c2funcall funob 'args-pushed loc)
  61.          (wt "}")))
  62.   )
  63.  
  64. (defun c1multiple-value-prog1 (args &aux (info (make-info)) form)
  65.   (when (endp args) (too-few-args 'multiple-value-prog1 1 0))
  66.   (setq form (c1expr* (car args) info))
  67.   (setq args (c1args (cdr args) info))
  68.   (list 'multiple-value-prog1 info form args)
  69.   )
  70. ;; We may record information here when *value-to-go* = 'top
  71. (defvar *top-data* nil)
  72.  
  73. (defun c2multiple-value-prog1 (form forms &aux (base (next-cvar))
  74.                                                (top (next-cvar))
  75.                            top-data)
  76.   (let ((*value-to-go* 'top)
  77.     *top-data* )
  78.     (c2expr* form)
  79.     (setq top-data *top-data*)
  80.     )
  81.   (wt-nl "{object *V" top "=vs_top;object *V" base "=vs_base; vs_base=V" top ";")
  82.   
  83.   (dolist** (form forms)
  84.     (let ((*value-to-go* 'trash)) (c2expr-top* form top)))
  85.   (wt-nl "vs_base=V" base ";vs_top=V" top ";}")
  86.   (unwind-exit 'fun-val nil (if top-data (car top-data)))
  87.   )
  88.  
  89. (defun c1values (args &aux (info (make-info)))
  90.       (cond ((and args (not (cdr args))
  91.           (or (not (consp (car args)))
  92.               (and (symbolp (caar args))
  93.                (let ((tem (get-return-type (caar args))))
  94.                  (and tem
  95.                   (or (atom tem)
  96.                       (and (consp tem)
  97.                        (null (cdr tem))
  98.                        (not (eq '* (car tem))))))))))
  99.          ;;the compiler put in unnecessary code
  100.          ;;if we just had say (values nil)
  101.          ;; so if we know there's one value only:
  102.          (c1expr (car args)))
  103.         (t  (setq args (c1args args info))
  104.               (list 'values info args))))
  105.  
  106. (defun c2values (forms &aux (base *vs*) (*vs* *vs*))
  107.      (cond ((and (eq *value-to-go* 'return-object)
  108.          (cdr forms)
  109.          (consp *current-form*)
  110.          (eq 'defun (car *current-form*)))
  111.         (cmpwarn "Trying to return multiple values. ~%;But ~a was proclaimed to have single value.~%;Only first one will assured."
  112.              (cadr *current-form*))))
  113.  
  114.   (cond ((null forms)
  115.          (wt-nl "vs_base=vs_top=base+" base ";")
  116.          (base-used)
  117.          (wt-nl "vs_base[0]=Cnil;"))
  118.         (t
  119.          (dolist** (form forms)
  120.            (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* form)))
  121.          (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
  122.          (base-used)))
  123.   (unwind-exit 'fun-val nil (cons 'values (length forms))))
  124.  
  125. (defun c1multiple-value-setq (args &aux (info (make-info)) (vrefs nil))
  126.   (when (or (endp args) (endp (cdr args)))
  127.         (too-few-args 'multiple-value-setq 2 0))
  128.   (unless (endp (cddr args))
  129.           (too-many-args 'multiple-value-setq 2 (length args)))
  130.   (dolist (var (car args))
  131.           (cmpck (not (symbolp var)) "The variable ~s is not a symbol." var)
  132.           (cmpck (constantp var)
  133.                  "The constant ~s is being assigned a value." var)
  134.           (setq var (c1vref var))
  135.           (push var vrefs)
  136.           (push (car var) (info-changed-vars info))
  137.           )
  138.   (list 'multiple-value-setq info (reverse vrefs) (c1expr* (cadr args) info))
  139.   )
  140.  
  141.  
  142. (defun multiple-value-check (vrefs form)
  143.   (and (cdr vrefs)
  144.        (eq (car form) 'call-global)
  145.        (let ((fname (third form)))
  146.      (cond ((and (symbolp fname)
  147.              (let ((tem (get fname 'proclaimed-return-type)))
  148.                (and tem
  149.                 ;; proclaimed to have 1 arg:
  150.                 (consp tem)
  151.                 (not (equal tem '(*)))
  152.                 (null (cdr tem)))))
  153.         (cmpwarn "~A was proclaimed to have only one return value. ~%;But you appear to want multiple values." fname))))))
  154.         
  155. (defun c2multiple-value-setq (vrefs form &aux top-data)
  156.     (multiple-value-check vrefs form)
  157.   (let ((*value-to-go* 'top)*top-data*)
  158.     (c2expr* form) (setq top-data *top-data*))
  159.   (and *record-call-info* (record-call-info nil (car top-data)))
  160.   (do ((vs vrefs (cdr vs)))
  161.       ((endp vs))
  162.       (declare (object vs))
  163.       (let ((vref (car vs)))
  164.            (declare (object vref))
  165.            (wt-nl "if(vs_base<vs_top){")
  166.            (set-var 'fun-val (car vref) (cadr vref))
  167.            (unless (endp (cdr vs)) (wt-nl "vs_base++;"))
  168.            (wt-nl "}else{") (set-var nil (car vref) (cadr vref))
  169.            (wt "}"))
  170.       )
  171.   (cond ((null vrefs)
  172.          (wt-nl "if(vs_base=vs_top){vs_base[0]=Cnil;vs_top=vs_base+1;}")
  173.          (unwind-exit 'fun-val))
  174.         (t (unless (eq *exit* 'return) (wt-nl) (reset-top))
  175.            (unwind-exit (cons 'var (car vrefs)))))
  176.   )
  177.  
  178. (defun c1multiple-value-bind (args &aux (info (make-info))
  179.                                    (vars nil) (vnames nil) init-form
  180.                                    ss is ts body other-decls
  181.                                    (*vars* *vars*))
  182.   (when (or (endp args) (endp (cdr args)))
  183.     (too-few-args 'multiple-value-bind 2 (length args)))
  184.  
  185.   (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil))
  186.  
  187.   (c1add-globals ss)
  188.  
  189.   (dolist** (s (car args))
  190.     (let ((v (c1make-var s ss is ts)))
  191.       (push s vnames)
  192.       (push v vars)))
  193.  
  194.   (setq init-form (c1expr* (cadr args) info))
  195.  
  196.   (dolist* (v (reverse vars)) (push v *vars*))
  197.  
  198.   (check-vdecl vnames ts is)
  199.  
  200.   (setq body (c1decl-body other-decls body))
  201.  
  202.   (add-info info (cadr body))
  203.   (setf (info-type info) (info-type (cadr body)))
  204.  
  205.   (dolist** (var vars) (check-vref var))
  206.  
  207.   (list 'multiple-value-bind info (reverse vars) init-form body)
  208.   )
  209.  
  210.  
  211. (defun c2multiple-value-bind (vars init-form body
  212.                    &aux (block-p nil) (labels nil)
  213.                         (*unwind-exit* *unwind-exit*)
  214.                         (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)
  215.             top-data)
  216.        (declare (object block-p))
  217.     (multiple-value-check vars init-form)
  218.  
  219.   (dolist** (var vars)
  220.     (let ((kind (c2var-kind var)))
  221.          (declare (object kind))
  222.       (if kind
  223.           (let ((cvar (next-cvar)))
  224.             (setf (var-kind var) kind)
  225.             (setf (var-loc var) cvar)
  226.             (wt-nl)
  227.             (unless block-p (wt "{") (setq block-p t))
  228.         (wt-var-decl var)
  229.         )
  230.           (setf (var-ref var) (vs-push)))))
  231.  
  232.   (let ((*value-to-go* 'top) *top-data*)
  233.     (c2expr* init-form) (setq top-data *top-data*))
  234.   (and *record-call-info* (record-call-info nil (car top-data)))
  235.   (let ((*clink* *clink*)
  236.         (*unwind-exit* *unwind-exit*)
  237.         (*ccb-vs* *ccb-vs*))
  238.     (do ((vs vars (cdr vs)))
  239.         ((endp vs))
  240.         (declare (object vs))
  241.       (push (next-label) labels)
  242.       (wt-nl "if(vs_base>=vs_top){")
  243.       (reset-top)
  244.       (wt-go (car labels)) (wt "}")
  245.       (c2bind-loc (car vs) '(vs-base 0))
  246.       (unless (endp (cdr vs)) (wt-nl "vs_base++;"))))
  247.  
  248.   (wt-nl) (reset-top)
  249.  
  250.   (let ((label (next-label)))
  251.     (wt-nl) (wt-go label)
  252.  
  253.     (setq labels (reverse labels))
  254.  
  255.     (dolist** (v vars)
  256.       (wt-label (car labels))
  257.       (pop labels)
  258.       (c2bind-loc v nil))
  259.  
  260.     (wt-label label))
  261.  
  262.   (c2expr body)
  263.   (when block-p (wt "}"))
  264.   )
  265.