mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 15:22:03 -08:00
6a91d3b45a
* Use the new proclamations/sysfun.lsp files from the new compiler.
* We split src/cmp/cmpdefs.lsp into cmpdefs, cmppackage, cmptypes and cmpglobals
* Split cmpform.lsp out of cmpmac.lsp
* Merged in {cmp,new-cmp}/cmpc-wt.lsp some of the cmpmac wt routines
* Use functions instead of macros for the WT-* operations
* Split out from *cmp/cmpenv.lsp a file cmppolicy.lsp
* A single file, cmpenv-api.lsp for the manipulation of environments.
* The type comparison functions go into cmptype-arith.lsp and are cached.
* The code that propagates types in function calls goes into cmptype-prop.lsp.
* The remainings of cmpenv go into cmpenv-{declare,proclaim,declaim}.
Associated fixes:
* Fixed typo and wrong proclamation for SI:GET-SYSPROP.
* Fixed typo in SIMPLIFY-ARITHMETIC.
* Explicitely set the debug level when building ECL
* All declarations are stored in the compiler environment.
* Each function and form stores the compilation environment.
* Declaration POLICY-DEBUG-IHS-FRAME is acts only on the function environment.
* Make the definition if ihs_env only happen when it is used.
* Eliminated *notinline*, *inline-functions* and *function-declarations*
* Slightly more efficient creation of accessors in kernel.lsp
* Remove the proxy C2DECL-BODY
* Fix the order of declarations in SI:PROCESS-DECLARATIONS
* Reimplemented C1BODY using SI:PROCESS-DECLARATIONS
* DECLAIM's proclamation do not propagate beyond the compiled file.
108 lines
4 KiB
Common Lisp
108 lines
4 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; 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)
|
|
(check-args-number 'CATCH args 1)
|
|
(incf *setjmps*)
|
|
(make-c1form* 'CATCH :sp-change t :type t :args (c1expr (first args))
|
|
(c1progn (rest args))))
|
|
|
|
(defun c2catch (tag body)
|
|
(let* ((new-destination (tmp-destination *destination*)))
|
|
(let* ((*destination* 'VALUE0))
|
|
(c2expr* tag))
|
|
(let* ((*destination* new-destination)
|
|
(code (incf *last-label*))
|
|
(*exit* (next-label))
|
|
(*unwind-exit* (list* *exit* 'FRAME *unwind-exit*)))
|
|
(if (member new-destination '(TRASH VALUES))
|
|
(progn
|
|
(wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")==0) {")
|
|
(wt-comment "BEGIN CATCH ~A" code)
|
|
(c2expr body)
|
|
(wt-nl "}"))
|
|
(progn
|
|
(wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")) {")
|
|
(wt-comment "BEGIN CATCH ~A" code)
|
|
(unwind-exit 'VALUES t)
|
|
(wt-nl "}")
|
|
(c2expr body)))
|
|
(wt-label *exit*)
|
|
(wt-nl "ecl_frs_pop(cl_env_copy);")
|
|
(wt-comment "END CATCH ~A" code)
|
|
)
|
|
(unwind-exit new-destination)))
|
|
|
|
(defun c1unwind-protect (args)
|
|
(check-args-number 'UNWIND-PROTECT args 1)
|
|
(incf *setjmps*)
|
|
(let ((form (let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT)))
|
|
(c1expr (first args)))))
|
|
(make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t
|
|
:args form (c1progn (rest args)))))
|
|
|
|
(defun c2unwind-protect (form body)
|
|
(let* ((sp (make-lcl-var :rep-type :cl-index))
|
|
(nargs (make-lcl-var :rep-type :cl-index))
|
|
(*unwind-exit* `((STACK ,sp) ,@*unwind-exit*)))
|
|
(wt-nl "{")
|
|
(wt-nl "volatile bool unwinding = FALSE;")
|
|
(wt-nl "cl_index " sp "=ECL_STACK_INDEX(cl_env_copy)," nargs ";")
|
|
(wt-nl "ecl_frame_ptr next_fr;")
|
|
;; Here we compile the form which is protected. When this form
|
|
;; is aborted, it continues at the ecl_frs_pop() with unwinding=TRUE.
|
|
(wt-nl "if (ecl_frs_push(cl_env_copy,ECL_PROTECT_TAG)) {")
|
|
(wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;")
|
|
(wt-nl "} else {")
|
|
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
|
|
(*destination* 'VALUES))
|
|
(c2expr* form))
|
|
(wt-nl "}")
|
|
(wt-nl "ecl_frs_pop(cl_env_copy);")
|
|
;; Here we save the values of the form which might have been
|
|
;; aborted, and execute some cleanup code. This code may also
|
|
;; be aborted by some control structure, but is not protected.
|
|
(wt-nl nargs "=ecl_stack_push_values(cl_env_copy);")
|
|
(let ((*destination* 'TRASH))
|
|
(c2expr* body))
|
|
(wt-nl "ecl_stack_pop_values(cl_env_copy," nargs ");")
|
|
;; Finally, if the protected form was aborted, jump to the
|
|
;; next catch point...
|
|
(wt-nl "if (unwinding) ecl_unwind(cl_env_copy,next_fr);")
|
|
;; ... or simply return the values of the protected form.
|
|
(unwind-exit 'VALUES)
|
|
(wt "}")))
|
|
|
|
(defun c1throw (args)
|
|
(check-args-number 'THROW args 2 2)
|
|
(make-c1form* 'THROW :args (c1expr (first args)) (c1expr (second args))))
|
|
|
|
(defun c2throw (tag val &aux loc)
|
|
(case (c1form-name tag)
|
|
((VAR LOCATION) (setq loc (c1form-arg 0 tag)))
|
|
(t (setq loc (make-temp-var))
|
|
(let ((*destination* loc)) (c2expr* tag))))
|
|
(let ((*destination* 'VALUES)) (c2expr* val))
|
|
(wt-nl "cl_throw(" loc ");"))
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
|
|
(put-sysprop 'CATCH 'C1SPECIAL 'c1catch)
|
|
(put-sysprop 'CATCH 'C2 'c2catch)
|
|
(put-sysprop 'UNWIND-PROTECT 'C1SPECIAL 'c1unwind-protect)
|
|
(put-sysprop 'UNWIND-PROTECT 'C2 'c2unwind-protect)
|
|
(put-sysprop 'THROW 'C1SPECIAL 'c1throw)
|
|
(put-sysprop 'THROW 'C2 'c2throw)
|