← Back to branch summary

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

« back to all changes in this revision

Viewing changes to comp/c-pass1.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/c-pass1.lsp
 
1
(in-package "BCOMP")
 
2
(setf (get 'call-set-mv 'b1) 'b1-call-set-mv)
 
3
(defun b1-call-set-mv (x where &aux form) where
 
4
  (desetq (nil  form) x)
 
5
  `(call-set-mv #.(make-desk t) 
 
6
                 ,(b1-walk form 'call-set-mv)))
 
7
 
 
8
 
 
9
(setf (get 'multiple-value-bind 'b1) 'b1-multiple-value-bind)
 
10
(defun b1-multiple-value-bind(x where &aux vars form body )
 
11
  (desetq (nil vars form . body) x)
 
12
  (b1-walk
 
13
        `(progn
 
14
           (call-set-mv , form)
 
15
           (let ,
 
16
               (sloop for v in vars
 
17
                  for i from 0
 
18
                  collect `(,v (nth-mv ,i )))
 
19
                  ,@ body))
 
20
        where))
 
21
 
 
22
(setf (get 'multiple-value-setq 'b1) 'b1-multiple-value-setq)
 
23
(defun b1-multiple-value-setq(x where &aux vars form body  gens)
 
24
  (desetq (nil vars form . body) x)
 
25
  (setq gens (sloop for v in-list vars collect (gensym)))
 
26
  (b1-walk
 
27
        `(multiple-value-bind ,gens ,form
 
28
           (setq ,@ (sloop for v in vars for w in gens collect v collect w))
 
29
           ,@ body) where ))
 
30
 
 
31
(setf (get 'multiple-value-list 'b1) 'b1-multiple-value-list)
 
32
(defun b1-multiple-value-list(x where &aux  form )
 
33
  (desetq (nil form ) x)
 
34
  (b1-walk `(progn (call-set-mv ,form)
 
35
                   (list-mv))
 
36
           where))
 
37
 
 
38
 
 
39
;; replace this by storage allocation in c stack of n*multiple-value-limit
 
40
;; and then copy into this storage at each stage.   Then c_apply_n
 
41
;; which funcalls a vector.
 
42
(setf (get 'multiple-value-call 'b1) 'b1-multiple-value-call)
 
43
(defun b1-multiple-value-call(x where &aux   bod fun )
 
44
  (desetq (nil fun . bod) x)
 
45
  (b1-walk
 
46
    `(apply ,fun
 
47
            (nconc  ,@ (sloop for v in-list bod
 
48
                 collect `(the dynamic-extent (multiple-value-list ,v)))))
 
49
 
 
50
  where
 
51
  ))
 
52
 
 
53
(setf (get 'multiple-value-prog1 'b1) 'b1-multiple-value-prog1)
 
54
(defun b1-multiple-value-prog1(x where &aux  form  bod (sym (gensym )))
 
55
  (desetq (nil form . bod) x)
 
56
  (b1-walk
 
57
   `(let ((,sym  (multiple-value-list ,form)))
 
58
      (declare (dynamic-extent ,sym))
 
59
      ,@ bod
 
60
      (apply #'values ,sym))
 
61
   where))
 
62
 
 
63
 
 
64
 
 
65
 
 
66
 
 
67
 
 
68
 
 
69
 
 
70