;;; CMPBLOCK Block and Return-from. ;;; ;; 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 'block 'c1block 'c1special) (si:putprop 'block 'c2block 'c2) (si:putprop 'return-from 'c1return-from 'c1special) (si:putprop 'return-from 'c2return-from 'c2) (defstruct blk name ;;; Block name. ref ;;; Referenced or not. T or NIL. ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; block id, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the ccb-vs for the ;;; block id, or NIL. exit ;;; Where to return. A label. value-to-go ;;; Where the value of the block to go. var ;;; The block name holder. Used only in ;;; the error message. ) (defvar *blocks* nil) ;;; During Pass 1, *blocks* holds a list of blk objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *blocks* when the compiler begins to process a closure. 'LB' will be ;;; pushed on *blocks* when *level* is incremented. (defun c1block (args) (when (endp args) (too-few-args 'block 1 0)) (cmpck (not (symbolp (car args))) "The block name ~s is not a symbol." (car args)) (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil)) (*blocks* (cons blk *blocks*)) (body (c1progn (cdr args)))) (if (or (blk-ref-ccb blk) (blk-ref-clb blk)) (incf *setjmps*)) (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk)) (list 'block (reset-info-type (cadr body)) blk body) body)) ) (defun c2block (blk body) (cond ((blk-ref-ccb blk) (c2block-ccb blk body)) ((blk-ref-clb blk) (c2block-clb blk body)) (t (c2block-local blk body)))) (defun c2block-local (blk body) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (c2expr body) ) (defun c2block-clb (blk body &aux (*vs* *vs*)) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (setf (blk-ref-clb blk) (vs-push)) (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") (wt-nl "frs_push(FRS_CATCH,") (wt-vs (blk-ref-clb blk)) (wt ");") (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt-nl "}") ) (defun c2block-ccb (blk body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (setf (blk-ref-clb blk) (vs-push)) (setf (blk-var blk) (add-symbol (blk-name blk))) (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=MMcons(") (wt-vs (blk-ref-clb blk)) (wt ",") (wt-clink) (wt ");") (clink (blk-ref-clb blk)) (setf (blk-ref-ccb blk) (ccb-vs-push)) (wt-nl "frs_push(FRS_CATCH,") (wt-vs* (blk-ref-clb blk)) (wt ");") (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt-nl "}") ) (defun c1return-from (args) (cond ((endp args) (too-few-args 'return-from 1 0)) ((and (not (endp (cdr args))) (not (endp (cddr args)))) (too-many-args 'return-from 2 (length args))) ((not (symbolp (car args))) "The block name ~s is not a symbol." (car args))) (do ((blks *blocks* (cdr blks)) (name (car args)) (ccb nil) (clb nil)) ((endp blks) (cmperr "The block ~s is undefined." name)) (declare (object name ccb clb)) (case (car blks) (cb (setq ccb t)) (lb (setq clb t)) (t (when (eq (blk-name (car blks)) name) (let ((val (c1expr (cadr args))) (blk (car blks))) (cond (ccb (setf (blk-ref-ccb blk) t)) (clb (setf (blk-ref-clb blk) t)) (t (setf (blk-ref blk) t))) (return (list 'return-from (reset-info-type (cadr val)) blk clb ccb val))))))) ) (defun c2return-from (blk clb ccb val) (cond (ccb (c2return-ccb blk val)) (clb (c2return-clb blk val)) (t (c2return-local blk val)))) (defun c2return-local (blk val) (let ((*value-to-go* (blk-value-to-go blk)) (*exit* (blk-exit blk))) (c2expr val)) ) (defun c2return-clb (blk val) (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(frs_sch(") (if (blk-ref-ccb blk) (wt-vs* (blk-ref-clb blk)) (wt-vs (blk-ref-clb blk))) (wt "),Cnil);") ) (defun c2return-ccb (blk val) (wt-nl "{frame_ptr fr;") (wt-nl "fr=frs_sch(") (wt-ccb-vs (blk-ref-ccb blk)) (wt ");") (wt-nl "if(fr==NULL) FEerror(\"The block ~s is missing.\",1,VV[" (blk-var blk) "]);") (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(fr,Cnil);}") )