← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/cmp/cmpstack.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Albin Tonnerre
  • Date: 2008-06-20 18:00:19 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20080620180019-7fbz1ln5444vtkkr
Tags: 0.9j-20080306-2ubuntu1
* Enabled unicode support. (Closes: LP #123530)
* Modify Maintainer value to match the DebianMaintainerField specification.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/cmp/cmpstack.lsp
 
1
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 
2
;;;;
1
3
;;;;  Copyright (c) 2006, Juan Jose Garcia-Ripoll
2
4
;;;;
3
5
;;;;    This program is free software; you can redistribute it and/or
21
23
(in-package "COMPILER")
22
24
 
23
25
(defun c1with-stack (forms)
24
 
  (let ((body (c1expr `(progn ,@forms))))
25
 
    (make-c1form* 'WITH-STACK :type (c1form-type body)
26
 
                  :args body)))
 
26
  (let* ((var (pop forms))
 
27
         (body (c1expr `(let ((,var (innermost-stack-frame))) ,@forms))))
 
28
      (make-c1form* 'WITH-STACK
 
29
                    :type (c1form-type body)
 
30
                    :args body)))
 
31
 
 
32
(defvar +ecl-stack-frame-variable+ "_ecl_inner_frame")
27
33
 
28
34
(defun c2with-stack (body)
29
35
  (let* ((new-destination (tmp-destination *destination*))
30
 
         (*temp* *temp*)
31
 
         (sp (make-lcl-var :rep-type :cl-index)))
32
 
    (wt-nl "{cl_index " sp "=cl_stack_index();")
 
36
         (*temp* *temp*))
 
37
    (wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;")
 
38
    (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);")
33
39
    (let* ((*destination* new-destination)
34
 
           (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*)))
 
40
           (*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*)))
35
41
      (c2expr* body))
36
 
    (wt-nl "cl_stack_set_index(" sp ");}")
 
42
    (wt-nl "ecl_stack_frame_close(_ecl_inner_frame);}")
37
43
    (unwind-exit new-destination)))
38
44
 
 
45
(defun c1innermost-stack-frame (args)
 
46
  (c1expr `(c-inline () () :object ,+ecl-stack-frame-variable+
 
47
            :one-liner t :side-effects nil)))
 
48
 
39
49
(defun c1stack-push (args)
40
50
  (c1expr `(progn
41
 
             (c-inline ,args (t) :void "cl_stack_push(#0)"
 
51
             (c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)"
42
52
                       :one-liner t :side-effects t)
43
53
             1)))
44
54
 
45
55
(defun c1stack-push-values (args)
46
 
  (make-c1form* 'STACK-PUSH-VALUES :type 'fixnum
47
 
                :args (c1expr (first args))
48
 
                (c1expr `(c-inline () () fixnum "cl_stack_push_values()"
49
 
                                   :one-liner t :side-effects t))))
 
56
  (let ((frame-var (pop args))
 
57
        (form (pop args)))
 
58
    (make-c1form* 'STACK-PUSH-VALUES :type '(VALUES)
 
59
                  :args
 
60
                  (c1expr form)
 
61
                  (c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)"
 
62
                                     :one-liner t :side-effects t)))))
50
63
 
51
64
(defun c2stack-push-values (form push-statement)
52
65
  (let ((*destination* 'VALUES))
54
67
  (c2expr push-statement))
55
68
 
56
69
(defun c1stack-pop (args)
57
 
  (let ((action (c1expr `(c-inline ,args (fixnum) :void
58
 
                                  "cl_stack_pop_values(#0)"
59
 
                                  :one-liner t
60
 
                                  :side-effects t))))
61
 
    (make-c1form* 'STACK-POP :type t :args action)))
62
 
 
63
 
(defun c2stack-pop (action)
64
 
  (let ((*destination* 'TRASH))
65
 
    (c2expr* action))
66
 
  (unwind-exit 'VALUES))
67
 
 
68
 
(defun c1apply-from-stack (args)
69
 
  (c1expr `(c-inline ,args (fixnum t) (values &rest t) "cl_apply_from_stack(#0,#1);"
 
70
  (c1expr `(c-inline ,args (t) (values &rest t)
 
71
                     "VALUES(0)=ecl_stack_frame_pop_values(#0);"
 
72
                     :one-liner nil :side-effects t)))
 
73
 
 
74
(defun c1apply-from-stack-frame (args)
 
75
  (c1expr `(c-inline ,args (t t) (values &rest t)
 
76
                     "VALUES(0)=ecl_apply_from_stack_frame(#0,#1);"
70
77
                     :one-liner nil :side-effects t)))
71
78
 
72
79
(put-sysprop 'with-stack 'C1 #'c1with-stack)
73
80
(put-sysprop 'with-stack 'c2 #'c2with-stack)
 
81
(put-sysprop 'innermost-stack-frame 'C1 #'c1innermost-stack-frame)
74
82
(put-sysprop 'stack-push 'C1 #'c1stack-push)
75
83
(put-sysprop 'stack-push-values 'C1 #'c1stack-push-values)
76
84
(put-sysprop 'stack-push-values 'C2 #'c2stack-push-values)
77
85
(put-sysprop 'stack-pop 'C1 #'c1stack-pop)
78
 
(put-sysprop 'stack-pop 'C2 #'c2stack-pop)
79
 
(put-sysprop 'apply-from-stack 'c1 #'c1apply-from-stack)
 
 
b'\\ No newline at end of file'
 
86
(put-sysprop 'si::apply-from-stack-frame 'c1 #'c1apply-from-stack-frame)
 
 
b'\\ No newline at end of file'