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/cmpflet.lsp

Lisp/Scheme | 1994-05-07 | 11.2 KB | 323 lines

;;; CMPFLET  Flet, Labels, and Macrolet.
;;;
;; 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 'flet 'c1flet 'c1special)
(si:putprop 'flet 'c2flet 'c2)
(si:putprop 'labels 'c1labels 'c1special)
(si:putprop 'labels 'c2labels 'c2)
(si:putprop 'macrolet 'c1macrolet 'c1special)
;;; c2macrolet is not defined, because MACROLET is replaced by PROGN
;;; during Pass 1.
(si:putprop 'call-local 'c2call-local 'c2)

(defstruct fun
           name            ;;; Function name.
           ref            ;;; Referenced or not.
                       ;;; During Pass1, T or NIL.
                       ;;; During Pass2, the vs-address for the
                       ;;; function closure, or NIL.
           ref-ccb        ;;; Cross closure reference.
                       ;;; During Pass1, T or NIL.
                       ;;; During Pass2, the vs-address for the
                       ;;; function closure, or NIL.
           cfun            ;;; The cfun for the function.
           level        ;;; The level of the function.
           )

(defvar *funs* nil)

;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions
;;; and the symbol 'CB' (Closure Boundary).  'CB' will be pushed on *funs*
;;; when the compiler begins to process a closure.  A local macro definition
;;; is a list ( macro-name expansion-function).

(defun c1flet (args &aux body ss ts is other-decl info
                         (defs1 nil) (local-funs nil) (closures nil))
  (when (endp args) (too-few-args 'flet 1 0))
  (let ((*funs* *funs*))
       (dolist** (def (car args))
         (cmpck (or (endp def)
                    (not (symbolp (car def)))
                    (endp (cdr def)))
                "The function definition ~s is illegal." def)
         (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
              (push fun *funs*)
              (push (list fun (cdr def)) defs1)))

       (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))

       (let ((*vars* *vars*))
            (c1add-globals ss)
            (check-vdecl nil ts is)
            (setq body (c1decl-body other-decl body)))
       (setq info (copy-info (cadr body))))

  (dolist* (def (reverse defs1))
    (when (fun-ref-ccb (car def))
          (let ((*vars* (cons 'cb *vars*))
                (*funs* (cons 'cb *funs*))
                (*blocks* (cons 'cb *blocks*))
                (*tags* (cons 'cb *tags*)))
               (let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
                    (add-info info (cadr lam))
                    (push (list (car def) lam) closures))))

    (when (fun-ref (car def))
          (let ((*blocks* (cons 'lb *blocks*))
                (*tags* (cons 'lb *tags*))
                (*vars* (cons 'lb *vars*)))
               (let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
                    (add-info info (cadr lam))
                    (push (list (car def) lam) local-funs))))

    (when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
          (setf (fun-cfun (car def)) (next-cfun)))
    )
  (if (or local-funs closures)
      (list 'flet info (reverse local-funs) (reverse closures) body)
      body)
  )

(defun c2flet (local-funs closures body
               &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))

  (dolist** (def local-funs)
    (setf (fun-level (car def)) *level*)
    (push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))

  ;;; Setup closures.
  (dolist** (def closures)
    (push (list 'closure
                (if (null *clink*) nil (cons 0 0))
                *ccb-vs* (car def) (cadr def))
          *local-funs*)
    (push (car def) *closures*)
    (let ((fun (car def)))
         (declare (object fun))
         (setf (fun-ref fun) (vs-push))
         (wt-nl)
         (wt-vs (fun-ref fun))
         (wt "=make_cclosure_new(LC" (fun-cfun fun) ",Cnil,") (wt-clink)
         (wt ",Cdata);")
         (wt-nl)
         (wt-vs (fun-ref fun))
         (wt "=MMcons(") (wt-vs (fun-ref fun)) (wt ",") (wt-clink) (wt ");")
         (clink (fun-ref fun))
         (setf (fun-ref-ccb fun) (ccb-vs-push))
         ))

  (c2expr body)
  )

(defun c1labels (args &aux body ss ts is other-decl info
                      (defs1 nil) (local-funs nil) (closures nil)
                      (fnames nil) (processed-flag nil) (*funs* *funs*))
  (when (endp args) (too-few-args 'labels 1 0))

  ;;; bind local-functions
  (dolist** (def (car args))
    (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
           "The local function definition ~s is illegal." def)
    (cmpck (member (car def) fnames)
           "The function ~s was already defined." (car def))
    (push (car def) fnames)
    (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
         (push fun *funs*)
         (push (list fun nil nil (cdr def)) defs1)))

  (setq defs1 (reverse defs1))

  ;;; Now DEFS1 holds ( { ( fun-object NIL NIL body ) }* ).

  (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
  (let ((*vars* *vars*))
       (c1add-globals ss)
       (check-vdecl nil ts is)
       (setq body (c1decl-body other-decl body)))
  (setq info (copy-info (cadr body)))

  (block local-process
    (loop
     (setq processed-flag nil)
     (dolist** (def defs1)
       (when (and (fun-ref (car def))        ;;; referred locally and
                  (null (cadr def)))        ;;; not processed yet
         (setq processed-flag t)
         (setf (cadr def) t)
         (let ((*blocks* (cons 'lb *blocks*))
               (*tags* (cons 'lb *tags*))
               (*vars* (cons 'lb *vars*)))
              (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
                   (add-info info (cadr lam))
                   (push (list (car def) lam) local-funs)))))
     (unless processed-flag (return-from local-process))
     )) ;;; end local process

  (block closure-process
    (loop
     (setq processed-flag nil)
     (dolist** (def defs1)
       (when (and (fun-ref-ccb (car def))    ; referred across closure
                  (null (caddr def)))        ; and not processed
         (setq processed-flag t)
         (setf (caddr def) t)
         (let ((*vars* (cons 'cb *vars*))
               (*funs* (cons 'cb *funs*))
               (*blocks* (cons 'cb *blocks*))
               (*tags* (cons 'cb *tags*)))
              (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
                   (add-info info (cadr lam))
                   (push (list (car def) lam) closures))))
       )
     (unless processed-flag (return-from closure-process))
     )) ;;; end closure process

  (dolist** (def defs1)
    (when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
          (setf (fun-cfun (car def)) (next-cfun))))

  (if (or local-funs closures)
      (list 'labels info (reverse local-funs) (reverse closures) body)
      body)
  )

(defun c2labels (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*))

  ;;; Prepare for cross-referencing closures.
  (dolist** (def closures)
    (let ((fun (car def)))
         (declare (object fun))
         (setf (fun-ref fun) (vs-push))
         (wt-nl)
         (wt-vs (fun-ref fun))
         (wt "=MMcons(Cnil,") (wt-clink) (wt ");")
         (clink (fun-ref fun))
         (setf (fun-ref-ccb fun) (ccb-vs-push))
    ))

  (dolist** (def local-funs)
    (setf (fun-level (car def)) *level*)
    (push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))

  ;;; Then make closures.
  (dolist** (def closures)
    (push (list 'closure (if (null *clink*) nil (cons 0 0))
                *ccb-vs* (car def) (cadr def))
          *local-funs*)
    (push (car def) *closures*)
    (wt-nl)
    (wt-vs* (fun-ref (car def)))
    (wt "=make_cclosure_new(LC" (fun-cfun (car def)) ",Cnil,") (wt-clink)
    (wt ",Cdata);")
    )

  ;;; now the body of flet

  (c2expr body)
  )

(defun c1macrolet (args &aux body ss ts is other-decl
                        (*funs* *funs*) (*vars* *vars*))
  (when (endp args) (too-few-args 'macrolet 1 0))
  (dolist** (def (car args))
    (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
           "The macro definition ~s is illegal." def)
    (push (list (car def)
                (caddr (si:defmacro* (car def) (cadr def) (cddr def))))
          *funs*))
  (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
  (c1add-globals ss)
  (check-vdecl nil ts is)
  (c1decl-body other-decl body)
  )

(defun c1local-fun (fname &aux (ccb nil))
  (declare (object ccb))
  (dolist* (fun *funs* nil)
    (cond ((eq fun 'CB) (setq ccb t))
          ((consp fun)
           (when (eq (car fun) fname) (return (cadr fun))))
          ((eq (fun-name fun) fname)
           (if ccb
               (setf (fun-ref-ccb fun) t)
               (setf (fun-ref fun) t))
           (return (list 'call-local *info* fun ccb)))))
  )

(defun sch-local-fun (fname)
  ;;; Returns fun-ob for the local function (not locat macro) named FNAME,
  ;;; if any.  Otherwise, returns FNAME itself.
  (dolist* (fun *funs* fname)
    (when (and (not (eq fun 'CB))
               (not (consp fun))
               (eq (fun-name fun) fname))
          (return fun)))
  )

(defun c1local-closure (fname &aux (ccb nil))
  (declare (object ccb))
  ;;; Called only from C1FUNCTION.
  (dolist* (fun *funs* nil)
    (cond ((eq fun 'CB) (setq ccb t))
          ((consp fun)
           (when (eq (car fun) fname) (return (cadr fun))))
          ((eq (fun-name fun) fname)
           (setf (fun-ref-ccb fun) t)
           (return (list 'call-local *info* fun ccb)))))
  )

(defun c2call-local (fd args &aux (*vs* *vs*))
  ;;; FD is a list ( fun-object ccb ).
  (cond
   ((cadr fd)
    (push-args args)
    (wt-nl "cclosure_call(") (wt-ccb-vs (fun-ref-ccb (car fd))) (wt ");"))
   ((and (listp args)
         *do-tail-recursion*
         *tail-recursion-info*
         (eq (car *tail-recursion-info*) (car fd))
         (eq *exit* 'RETURN)
         (tail-recursion-possible)
         (= (length args) (length (cdr *tail-recursion-info*))))
    (let* ((*value-to-go* 'trash)
           (*exit* (next-label))
           (*unwind-exit* (cons *exit* *unwind-exit*)))
          (c2psetq (mapcar #'(lambda (v) (list v nil))
                           (cdr *tail-recursion-info*))
                   args)
          (wt-label *exit*))
    (unwind-no-exit 'tail-recursion-mark)
    (wt-nl "goto TTL;")
    (cmpnote "Tail-recursive call of ~s was replaced by iteration."
             (fun-name (car fd))))
   (t (push-args args)
      (wt-nl "L" (fun-cfun (car fd)) "(")
      (dotimes** (n (fun-level (car fd))) (wt "base" n ","))
      (wt "base")
      (unless (= (fun-level (car fd)) *level*) (wt (fun-level (car fd))))
      (wt ");")
      (base-used)))
  (unwind-exit 'fun-val)
  )