← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to comp/exit.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
comp/exit.lsp
 
1
(in-package "BCOMP")
 
2
 
 
3
(setf (get 'let-control-stack 'b2) 'b2-let-control-stack)
 
4
(defun b2-let-control-stack (x)
 
5
  (let ((*control-stack* *control-stack*)(*blocks* 0))
 
6
    (open-block)
 
7
    (wr "object *VOL SaveVs = VsTop;")
 
8
    (expr-b2 (cadr x))
 
9
    (close-blocks)
 
10
    ))
 
11
 
 
12
(defopt control-jumped-back
 
13
  ((t) boolean #.(flags set safe) control-jumped-back-aux))
 
14
 
 
15
(defun control-jumped-back-aux(x)
 
16
    (push 'ctl-push *control-stack*)
 
17
  (wr-inline-call1 x "@0;CtlJumpedBack(ctl_TAGGED_CATCH,$0)"))
 
18
 
 
19
(defopt push-unwind-protect
 
20
  ;; The second argument is a function to call to do unwinding   
 
21
  ((t) t #.(flags  safe set) push-unwind-protect-aux))
 
22
 
 
23
(defun push-unwind-protect-aux (x)
 
24
;; we use this function call to push something on control stack  
 
25
  (push (list 'unwind-protect (car x)) *control-stack*)
 
26
  (or (and (eq (car *exit*) 'next)
 
27
           (or (and  (eq (cadr *control-stack*) 'avma-bind)
 
28
                     (eq (cdr *exit*) (cddr *control-stack*)))
 
29
               (eq (cdr *exit*) (cdr *control-stack*))))
 
30
      (wfs-error))
 
31
  (setq *exit* (cons 'next *control-stack*))
 
32
  (wr-inline-call1 x "CtlUnwindPush($0)"))
 
33
 
 
34
 
 
35
 
 
36
 
 
37
 
 
38
 
 
39
 
 
40
 
 
41
 
 
42
 
 
43
 
 
44