← Back to branch summary

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

« back to all changes in this revision

Viewing changes to lsp/ucall.lisp

  • 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:
lsp/ucall.lisp
 
1
(in-package 'compiler)
 
2
(import 'si::switch)
 
3
(import 'sloop::sloop)
 
4
(provide "UCALL")
 
5
 
 
6
;;ucall is like funcall, except it assumes
 
7
;;1) its first arg has an inline-always property.
 
8
;;2) the order of evaluation of the remaining args is unimportant.
 
9
 
 
10
;;This can be useful when we know that the side effects caused by evaluating
 
11
;;the args do not affect the order of evaluation.
 
12
;;It also returns an indeterminate value.
 
13
 
 
14
(defun c1ucall (args &aux funob (info (compiler::make-info)))
 
15
  (setq funob (compiler::c1funob (car args)))
 
16
  (compiler::add-info info (cadr funob))
 
17
  (list 'ucall info funob (compiler::c1args (cdr args) info))
 
18
  )
 
19
 
 
20
(defun c2ucall (funob args &aux (*inline-blocks* 0)(*vs* *vs*))
 
21
  (let* ((fname (caddr funob))
 
22
        (props (car (get fname 'inline-always)))
 
23
        new-args
 
24
        )
 
25
    (or props (error "no inline-always prop"))
 
26
    (do ((v args (cdr v))
 
27
         (types (car props) (cdr types)))
 
28
        ((null v) (setq new-args (nreverse new-args)))
 
29
        (setq new-args
 
30
              (append (inline-args (list (car v)) (list (car types)))
 
31
                    new-args)))
 
32
    (wt-nl)
 
33
    (wt-inline-loc (nth 4 props) new-args)
 
34
    (wt ";")
 
35
    (unwind-exit "Cnil")
 
36
    (close-inline-blocks)
 
37
    ))
 
38
 
 
39
 
 
40
;;Usage (comment "hi there") ; will insert a comment at that point in
 
41
;;the program.
 
42
(defun c1comment (args)
 
43
  (list 'comment (make-info) args))
 
44
(defun c2comment (args)
 
45
  (let ((string (car args)))
 
46
    (if (find #\/ string) (setq string (remove #\/ string)))
 
47
    (wt "/* "string " */")))
 
48
 
 
49
(defmacro comment (a) a nil)
 
50
 
 
51
;;Usage: (tlet (char *) jack ....)
 
52
;;--> {char * V1; ...V1..
 
53
 
 
54
(defun c1tlet (args &aux  (info (make-info)) (*vars* *vars*))
 
55
  (let ((sym (cadr args))
 
56
        (type (car args))
 
57
        form )
 
58
    (let ((var (c1make-var sym nil nil nil)))
 
59
      (cond ((subtypep type 'fixnum)
 
60
             (setf (var-type var) 'fixnum)))
 
61
      (push var *vars*)
 
62
      (setq form (c1expr* (cons 'progn (cddr args)) info))
 
63
      (list 'tlet (second form) type var form))))
 
64
 
 
65
(defun c2tlet (type var orig &aux (stype type))
 
66
  (setf (var-loc var) (next-cvar))
 
67
  (or (stringp type) (setq stype (format nil "~(~a~)" type)))
 
68
  (setf (var-kind var)
 
69
        (cond ((subtypep type 'fixnum)
 
70
               (setf (var-type var) 'fixnum))
 
71
              (t 'object)))
 
72
  (if (listp type) (setq stype (string-trim "()" stype)))
 
73
  (wt-nl "{"  stype " V" (var-loc var) ";" )
 
74
  (c2expr orig)
 
75
  (wt "}"))
 
76
 
 
77
(si::putprop 'tlet 'c1tlet 'c1special)
 
78
(si::putprop 'tlet 'c2tlet 'c2)
 
79
 
 
80
 
 
81
(defun c1clet (args)
 
82
  (let ((string (car args))
 
83
        (form (c1expr (cons 'progn (cdr args)))))
 
84
    (list 'clet (second form) string form)))
 
85
 
 
86
(defun c2clet (string orig )
 
87
  (wt-nl "{" string)
 
88
  (c2expr orig)
 
89
    (wt "}"))
 
90
 
 
91
;;Usage: Takes a STRING and BODY.  Acts like progn
 
92
;;on the body, but the c code will have {string . c code for body}
 
93
;;Sample (clet "int jack; char *jane;" ....)
 
94
(defmacro clet (string &rest body) string `(progn ,@ body))
 
95
 
 
96
(si::putprop 'clet 'c1clet 'c1special)
 
97
(si::putprop 'clet 'c2clet 'c2)
 
98
 
 
99
 
 
100
(si::putprop 'comment 'c1comment 'c1special)
 
101
(si::putprop 'comment 'c2comment 'c2)
 
102
 
 
103
 
 
104
  
 
105
 
 
106
 
 
107
(si::putprop 'ucall 'c1ucall 'c1)
 
108
(si::putprop 'ucall 'c2ucall 'c2)
 
109
 
 
110
 
 
111
 
 
112
(defmacro def-inline (name args return-type &rest bod)
 
113
  (let* ((side-effect-p (if (member (car bod)
 
114
                                    '(:side-effect nil t))
 
115
                            (prog1  (and (car bod) t) (setq bod (cdr bod)))
 
116
                          nil))
 
117
         (inline (list args return-type side-effect-p nil (car bod))))
 
118
    `(car (push ',inline
 
119
                (get ',name 'inline-always)))))
 
120
 
 
121
 
 
122
 
 
123
 
 
124
(defmacro defun-inline (name args return-type &rest bod)
 
125
  (let* ((sym (gensym))
 
126
         (named-args
 
127
          (nthcdr (- 10 (length args)) '(X9 X8 X7 X6 X5 X4 X3 X2 X1 X0)))
 
128
         (inline (eval `(def-inline ,sym ,args ,return-type ,@ bod))))
 
129
    `(progn
 
130
       (defun ,name  ,named-args
 
131
         (declare ,@ (sloop for v in named-args for w in args
 
132
                            when (not (eq t v))
 
133
                            collect (list w v)))
 
134
         (the ,return-type (,sym ,@ named-args)))
 
135
       (push  ',inline
 
136
              (get ',name 'inline-always)))))
 
137
 
 
138
(defmacro def-ucall (fun args string)
 
139
  (let ((sym (gensym)))
 
140
    `(progn
 
141
    (def-inline ,sym ,args t t ,string)
 
142
    (defmacro ,fun (&rest args) `(ucall ',',sym ,@ args)))))
 
143