mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-11 19:53:52 -08:00
94 lines
3.2 KiB
Common Lisp
94 lines
3.2 KiB
Common Lisp
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
|
;;;;
|
|
;;;; This program 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 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
;;;; CMPCATCH Catch, Unwind-protect, and Throw.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun c1catch (args &aux (info (make-info :sp-change t)) tag)
|
|
(incf *setjmps*)
|
|
(when (endp args) (too-few-args 'CATCH 1 0))
|
|
(setq tag (c1expr (car args)))
|
|
(add-info info (second tag))
|
|
(setq args (c1progn (cdr args)))
|
|
(add-info info (second args))
|
|
(list 'CATCH info tag args))
|
|
|
|
(defun c2catch (tag body)
|
|
(let* ((*lcl* *lcl*)
|
|
(tag-lcl (list 'LCL (next-lcl))))
|
|
(wt-nl "{ cl_object " tag-lcl ";")
|
|
(let* ((*destination* tag-lcl))
|
|
(c2expr* tag))
|
|
(let* ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
|
|
(wt-nl "if (frs_push(FRS_CATCH," tag-lcl ")!=0){")
|
|
(unwind-exit 'VALUES)
|
|
(wt-nl "} else {")
|
|
(c2expr body)
|
|
(wt-nl "}}"))))
|
|
|
|
(defun c1unwind-protect (args &aux (info (make-info :sp-change t)) form)
|
|
(incf *setjmps*)
|
|
(when (endp args) (too-few-args 'UNWIND-PROTECT 1 0))
|
|
(setq form (let ((*blocks* (cons 'UNWIND-PROTECT *blocks*))
|
|
(*tags* (cons 'UNWIND-PROTECT *tags*))
|
|
;(*vars* (cons 'LB *vars*))
|
|
)
|
|
(c1expr (car args))))
|
|
(add-info info (second form))
|
|
(setq args (c1progn (cdr args)))
|
|
(add-info info (second args))
|
|
(list 'UNWIND-PROTECT info form args)
|
|
)
|
|
|
|
(defun c2unwind-protect (form body &aux (nr (list 'LCL (next-lcl))))
|
|
(wt-nl "{ volatile bool unwinding = FALSE;")
|
|
(wt-nl "if (frs_push(FRS_PROTECT,Cnil)) {")
|
|
(wt-nl "unwinding = TRUE;} else {")
|
|
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
|
|
(let ((*destination* 'VALUES)) (c2expr* form))
|
|
(wt-nl "}")
|
|
(wt-nl "MV_SAVE(" nr ");")
|
|
(let ((*destination* 'TRASH)) (c2expr* body))
|
|
(wt-nl "MV_RESTORE(" nr ");")
|
|
(wt-nl "if (unwinding) unwind(nlj_fr,nlj_tag);")
|
|
(wt-nl "else {")
|
|
(unwind-exit 'VALUES)
|
|
(wt "}}")))
|
|
|
|
(defun c1throw (args &aux (info (make-info)) tag)
|
|
(when (or (endp args) (endp (cdr args)))
|
|
(too-few-args 'THROW 2 (length args)))
|
|
(unless (endp (cddr args))
|
|
(too-many-args 'THROW 2 (length args)))
|
|
(setq tag (c1expr (car args)))
|
|
(add-info info (second tag))
|
|
(setq args (c1expr (second args)))
|
|
(add-info info (second args))
|
|
(list 'THROW info tag args)
|
|
)
|
|
|
|
(defun c2throw (tag val &aux loc)
|
|
(case (car tag)
|
|
(LOCATION (setq loc (third tag)))
|
|
(VAR (setq loc (cons 'VAR (third tag))))
|
|
(t (setq loc (list 'TEMP (next-temp)))
|
|
(let ((*destination* loc)) (c2expr* tag))))
|
|
(let ((*destination* 'VALUES)) (c2expr* val))
|
|
(wt-nl "cl_throw(" loc ");"))
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
|
|
(setf (get 'CATCH 'C1SPECIAL) 'c1catch)
|
|
(setf (get 'CATCH 'C2) 'c2catch)
|
|
(setf (get 'UNWIND-PROTECT 'C1SPECIAL) 'c1unwind-protect)
|
|
(setf (get 'UNWIND-PROTECT 'C2) 'c2unwind-protect)
|
|
(setf (get 'THROW 'C1SPECIAL) 'c1throw)
|
|
(setf (get 'THROW 'C2) 'c2throw)
|