/[gcl]/gcl/cmpnew/gcl_cmplet.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmplet.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by camm, Sat Dec 11 00:34:35 2004 UTC revision 1.5 by camm, Tue Dec 14 03:34:06 2004 UTC
# Line 37  Line 37 
37                          (caddr (si:defmacro* (car def) (cadr def) (cddr def))))                          (caddr (si:defmacro* (car def) (cadr def) (cddr def))))
38                    *funs*)))                    *funs*)))
39    
40    (defun cmp-macroexp-with-compiler-macros (form)
41      (let ((form (cmp-macroexpand form)))
42        (if (and (consp form) (symbolp (car form)))
43            (let ((cmf (get (car form) 'compiler-macro)))
44              (if cmf
45                  (cmp-eval `(funcall ',cmf ',form nil))
46                form))
47          form)))
48    
49  (defun recursively-cmp-macroexpand (form &optional bf &aux (*funs* *funs*))  (defun recursively-cmp-macroexpand (form &optional bf &aux (*funs* *funs*))
50    (if (atom form)    (if (atom form)
51        form        form
52      (let ((cf (car form)))      (let ((cf (car form)))
53        (let ((new-cdr-bf (or (and (consp bf) (if (atom (car bf)) bf        (let ((new-cdr-bf (or (and (consp bf)
54                                                (and (member (caar bf) '(flet labels macrolet) :test #'eq) 'lambda)))                                   (if (atom (car bf)) bf
55                                       (and (member (caar bf) '(flet labels macrolet) :test #'eq) 'lambda)))
56                              (car (member cf '(let let* lambda flet labels macrolet quote)))))                              (car (member cf '(let let* lambda flet labels macrolet quote)))))
57              (new-car-bf (and (consp cf) bf (list bf)))              (new-car-bf (and (consp cf) bf (list bf)))
58              (new-cf (if (or bf (atom cf) (eq (car cf) 'lambda))              (new-cf (if (or bf (atom cf) (eq (car cf) 'lambda))
59                          cf (cmp-macroexpand cf))))                          cf (cmp-macroexp-with-compiler-macros cf))))
60          (cons (recursively-cmp-macroexpand new-cf new-car-bf)          (cons (recursively-cmp-macroexpand new-cf new-car-bf)
61                (progn                (progn
62                  (when (eq bf 'macrolet)                  (when (eq bf 'macrolet)
# Line 88  Line 98 
98  (defun t-to-nil (x)  (defun t-to-nil (x)
99    (if (eq x t) nil x))    (if (eq x t) nil x))
100    
101    (defun nil-to-t (x)
102      (if x x t))
103    
104    (defun fun-ret-type (form)
105      (cond ((symbolp form) (nil-to-t (cdr (assoc form *decls*))))
106            ((integerp form) (list 'integer form form))
107            ((atom form) (type-of form))
108            ((eq (car form) 'quote) (type-of (cadr form)))
109            ((symbolp (car form))
110             (nil-to-t (or (result-type-from-args (car form) (mapcar #'fun-ret-type (cdr form)))
111                           (let ((proc (get (car form) 'proclaimed-return-type)))
112                             (and (symbolp proc) proc)))))
113            (t t)))
114    
115  (defun binding-decls (bindings body star)  (defun binding-decls (bindings body star)
116    (cond ((atom bindings) nil)    (cond ((atom bindings) nil)
117          ((atom (car bindings)) (binding-decls (cdr bindings) body star))          ((atom (car bindings)) (binding-decls (cdr bindings) body star))
# Line 97  Line 121 
121             (let ((outer (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*))))             (let ((outer (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*))))
122                   (inf (t-to-nil (var-is-inferred var body)))                   (inf (t-to-nil (var-is-inferred var body)))
123                   (exp (and (consp (cadr bf)) (eq (caadr bf) 'the) (cadadr bf)))                   (exp (and (consp (cadr bf)) (eq (caadr bf) 'the) (cadadr bf)))
124                   (proc (and (consp (cadr bf))                   (frt (and (consp (cadr bf))
125                              (symbolp (caadr bf))                             (symbolp (caadr bf))
126                              (t-to-nil (get (caadr bf) 'compiler::proclaimed-return-type))))                             (t-to-nil (fun-ret-type (cadr bf)))))
127                   (dec (var-is-declared var body))                   (dec (var-is-declared var body))
128                   (chb (var-is-changed var body))                   (chb (var-is-changed var body))
129                   (chc (and star (var-is-changed var (cdr bindings)))))                   (chc (and star (var-is-changed var (cdr bindings)))))
130               (let ((type (or exp (and (symbolp proc) proc) inf outer))               (let ((type (or exp frt inf outer))
131                     (ublk (not (or dec chb chc))))                     (ublk (not (or dec chb chc))))
132                 (if type                 (if type
133                     (progn                     (progn
134                       (cmpnote "var ~S is type ~S from ~a, ~a~%"                       (cmpnote "var ~S is type ~S from ~a, ~a~%"
135                                var type (cond (exp "explicit declaration")                                var type (cond (exp "explicit declaration")
136                                               ((and (symbolp proc) proc) "proclamation")                                               (frt "deduced function return type")
137                                               (inf "argument inference")                                               (inf "argument inference")
138                                               (outer "outer scope"))                                               (outer "outer scope"))
139                                (cond (dec "but is already declared")                                (cond (dec "but is already declared")

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26