mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-08 10:13:36 -08:00
86 lines
No EOL
3 KiB
Common Lisp
86 lines
No EOL
3 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; Copyright (c) 2006, Juan Jose Garcia-Ripoll
|
|
;;;;
|
|
;;;; 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.
|
|
|
|
;;;; CMPSTACK Manipulation of the lisp stack from C code
|
|
;;;;
|
|
;;;; Following special forms are provided:
|
|
;;;;
|
|
;;;; (WITH-STACK {form}*)
|
|
;;;; Executes given forms, restoring the lisp stack on output.
|
|
;;;; (STACK-PUSH form)
|
|
;;;; (STACK-PUSH-VALUES form)
|
|
;;;; (STACK-POP nvalues)
|
|
;;;;
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun c1with-stack (forms)
|
|
(let* ((var (pop forms))
|
|
(body (c1expr `(let ((,var (innermost-stack-frame))) ,@forms))))
|
|
(make-c1form* 'WITH-STACK
|
|
:type (c1form-type body)
|
|
:args body)))
|
|
|
|
(defvar +ecl-stack-frame-variable+ "_ecl_inner_frame")
|
|
|
|
(defun c2with-stack (body)
|
|
(let* ((new-destination (tmp-destination *destination*))
|
|
(*temp* *temp*))
|
|
(wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;")
|
|
(wt-nl *volatile* "cl_object _ecl_inner_frame = (_ecl_inner_frame_aux.narg=0,_ecl_inner_frame_aux.sp=0,_ecl_inner_frame_aux.t=t_frame,(cl_object)&_ecl_inner_frame_aux);")
|
|
(let* ((*destination* new-destination)
|
|
(*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*)))
|
|
(c2expr* body))
|
|
(wt-nl "ecl_stack_frame_close(_ecl_inner_frame);}")
|
|
(unwind-exit new-destination)))
|
|
|
|
(defun c1innermost-stack-frame (args)
|
|
(c1expr `(c-inline () () :object ,+ecl-stack-frame-variable+
|
|
:one-liner t :side-effects nil)))
|
|
|
|
(defun c1stack-push (args)
|
|
(c1expr `(progn
|
|
(c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)"
|
|
:one-liner t :side-effects t)
|
|
1)))
|
|
|
|
(defun c1stack-push-values (args)
|
|
(let ((frame-var (pop args))
|
|
(form (pop args)))
|
|
(make-c1form* 'STACK-PUSH-VALUES :type '(VALUES)
|
|
:args
|
|
(c1expr form)
|
|
(c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)"
|
|
:one-liner t :side-effects t)))))
|
|
|
|
(defun c2stack-push-values (form push-statement)
|
|
(let ((*destination* 'VALUES))
|
|
(c2expr* form))
|
|
(c2expr push-statement))
|
|
|
|
(defun c1stack-pop (args)
|
|
(c1expr `(c-inline ,args (t) (values &rest t)
|
|
"VALUES(0)=ecl_stack_frame_pop_values(#0);"
|
|
:one-liner nil :side-effects t)))
|
|
|
|
(defun c1apply-from-stack-frame (args)
|
|
(c1expr `(c-inline ,args (t t) (values &rest t)
|
|
"VALUES(0)=ecl_apply_from_stack_frame(#0,#1);"
|
|
:one-liner nil :side-effects t)))
|
|
|
|
(put-sysprop 'with-stack 'C1 #'c1with-stack)
|
|
(put-sysprop 'with-stack 'c2 #'c2with-stack)
|
|
(put-sysprop 'innermost-stack-frame 'C1 #'c1innermost-stack-frame)
|
|
(put-sysprop 'stack-push 'C1 #'c1stack-push)
|
|
(put-sysprop 'stack-push-values 'C1 #'c1stack-push-values)
|
|
(put-sysprop 'stack-push-values 'C2 #'c2stack-push-values)
|
|
(put-sysprop 'stack-pop 'C1 #'c1stack-pop)
|
|
(put-sysprop 'si::apply-from-stack-frame 'c1 #'c1apply-from-stack-frame) |