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 / cmpcatch.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  4.0 KB  |  123 lines
  1. ;;; CMPCATCH  Catch, Unwind-protect, and Throw.
  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 'catch 'c1catch 'c1special)
  25. (si:putprop 'catch 'c2catch 'c2)
  26. (si:putprop 'unwind-protect 'c1unwind-protect 'c1special)
  27. (si:putprop 'unwind-protect 'c2unwind-protect 'c2)
  28. (si:putprop 'throw 'c1throw 'c1special)
  29. (si:putprop 'throw 'c2throw 'c2)
  30.  
  31. (defun c1catch (args &aux (info (make-info :sp-change t)) tag)
  32.   (incf *setjmps*)
  33.   (when (endp args) (too-few-args 'catch 1 0))
  34.   (setq tag (c1expr (car args)))
  35.   (add-info info (cadr tag))
  36.   (setq args (c1progn (cdr args)))
  37.   (add-info info (cadr args))
  38.   (list 'catch info tag args))
  39.  
  40. (si:putprop 'push-catch-frame 'set-push-catch-frame 'set-loc)
  41.  
  42. (defun c2catch (tag body &aux (*vs* *vs*))
  43.   (let ((*value-to-go* '(push-catch-frame))) (c2expr* tag))
  44.   (wt-nl "if(nlj_active)")
  45.   (wt-nl "{nlj_active=FALSE;frs_pop();")
  46.   (unwind-exit 'fun-val 'jump)
  47.   (wt "}")
  48.   (wt-nl "else{")
  49.   (let ((*unwind-exit* (cons 'frame *unwind-exit*)))
  50.        (c2expr body))
  51.   (wt "}")
  52.   )
  53.  
  54. (defun set-push-catch-frame (loc)
  55.   (wt-nl "frs_push(FRS_CATCH," loc ");"))
  56.  
  57. (defun c1unwind-protect (args &aux (info (make-info :sp-change t)) form)
  58.   (incf *setjmps*)
  59.   (when (endp args) (too-few-args 'unwind-protect 1 0))
  60.   (setq form (let ((*blocks* (cons 'lb *blocks*))
  61.                    (*tags* (cons 'lb *tags*))
  62.                    (*vars* (cons 'lb *vars*)))
  63.                   (c1expr (car args))))
  64.   (add-info info (cadr form))
  65.   (setq args (c1progn (cdr args)))
  66.   (add-info info (cadr args))
  67.   (list 'unwind-protect info form args)
  68.   )
  69.  
  70. (defun c2unwind-protect (form body
  71.                          &aux (*vs* *vs*) (loc (list 'vs (vs-push)))
  72.              top-data)
  73.   (wt-nl "{object tag;frame_ptr fr;object p;bool active;")
  74.   (wt-nl "frs_push(FRS_PROTECT,Cnil);")
  75.   (wt-nl "if(nlj_active){tag=nlj_tag;fr=nlj_fr;active=TRUE;}")
  76.   (wt-nl "else{")
  77.   (let ((*value-to-go* 'top)
  78.     *top-data* )
  79.     (c2expr* form)
  80.     (setq top-data *top-data*))
  81.   (wt-nl "active=FALSE;}")
  82.   (wt-nl loc "=Cnil;")
  83.   (wt-nl "while(vs_base<vs_top)")
  84.   (wt-nl "{" loc "=MMcons(vs_top[-1]," loc ");vs_top--;}")
  85.   (wt-nl) (reset-top)
  86.   (wt-nl "nlj_active=FALSE;frs_pop();")
  87.   (let ((*value-to-go* 'trash)) (c2expr* body))
  88.   (wt-nl "vs_base=vs_top=base+" *vs* ";")
  89.   (base-used)
  90.   (wt-nl "for(p= " loc ";!endp(p);p=MMcdr(p))vs_push(MMcar(p));")
  91.   (wt-nl "if(active)unwind(fr,tag);else{")
  92.   (unwind-exit 'fun-val nil (if top-data (car top-data)))
  93.   (wt "}}")
  94.   )
  95.  
  96. (defun c1throw (args &aux (info (make-info)) tag)
  97.   (when (or (endp args) (endp (cdr args)))
  98.         (too-few-args 'throw 2 (length args)))
  99.   (unless (endp (cddr args))
  100.           (too-many-args 'throw 2 (length args)))
  101.   (setq tag (c1expr (car args)))
  102.   (add-info info (cadr tag))
  103.   (setq args (c1expr (cadr args)))
  104.   (add-info info (cadr args))
  105.   (list 'throw info tag args)
  106.   )
  107.  
  108. (defun c2throw (tag val &aux (*vs* *vs*) loc)
  109.   (wt-nl "{frame_ptr fr;")
  110.   (case (car tag)
  111.     (LOCATION (setq loc (caddr tag)))
  112.     (VAR  (setq loc (cons 'var (third tag))))    
  113.     (t (setq loc (list 'vs (vs-push)))
  114.        (let ((*value-to-go* loc)) (c2expr* tag))))
  115.  
  116.   (wt-nl "fr=frs_sch_catch(" loc ");")
  117.   (wt-nl "if(fr==NULL) FEerror(\"The tag ~s is undefined.\",1," loc ");")
  118.   (let ((*value-to-go* 'top)) (c2expr* val))
  119.   (wt-nl "unwind(fr," loc ");}")
  120.   )
  121.  
  122.  
  123.