/[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.8 by camm, Tue Dec 21 04:50:36 2004 UTC revision 1.9 by camm, Mon Dec 27 22:15:45 2004 UTC
# Line 53  Line 53 
53        (let ((new-cdr-bf (or (and (consp bf)        (let ((new-cdr-bf (or (and (consp bf)
54                                   (if (atom (car bf)) bf                                   (if (atom (car bf)) bf
55                                     (and (member (caar bf) '(flet labels macrolet) :test #'eq) 'lambda)))                                     (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 function)))))
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-macroexp-with-compiler-macros cf))))                          cf (cmp-macroexp-with-compiler-macros cf))))
# Line 101  Line 101 
101  (defun nil-to-t (x)  (defun nil-to-t (x)
102    (if x x t))    (if x x t))
103    
104  (defun fun-ret-type (form)  ;(defun fun-ret-type (form)
105    (cond ((symbolp form) (nil-to-t (cdr (assoc form *decls*))))  ;  (cond ((symbolp form) (nil-to-t (cdr (assoc form *decls*))))
106          ((integerp form) (list 'integer form form))  ;       ((integerp form) (list 'integer form form))
107          ((atom form) (type-of form))  ;       ((atom form) (type-of form))
108          ((eq (car form) 'quote) (type-of (cadr form)))  ;       ((eq (car form) 'quote) (type-of (cadr form)))
109          ((and (cdr form) (atom (cdr form))) (error "Dotted list in fun-ret-type~"))  ;       ((and (cdr form) (atom (cdr form))) (error "Dotted list in fun-ret-type~"))
110          ((symbolp (car form))  ;       ((symbolp (car form))
111           (nil-to-t (or (result-type-from-args (car form) (mapcar #'fun-ret-type (cdr form)))  ;        (nil-to-t (or (result-type-from-args (car form) (mapcar #'fun-ret-type (cdr form)))
112                         (let ((proc (get (car form) 'proclaimed-return-type)))  ;                      (let ((proc (get (car form) 'proclaimed-return-type)))
113                           (and (symbolp proc) proc)))))  ;                        (and (symbolp proc) proc)))))
114          (t t)))  ;       (t t)))
115    
116  (defun coerce-to-one-value (type)  (defun coerce-to-one-value (type)
117    (if (and (consp type) (eq (car type) 'values))    (if (and (consp type) (eq (car type) 'values))
# Line 129  Line 129 
129                   (exp (and (consp (cadr bf)) (eq (caadr bf) 'the) (cadadr bf)))                   (exp (and (consp (cadr bf)) (eq (caadr bf) 'the) (cadadr bf)))
130                   (frt (and (consp (cadr bf))                   (frt (and (consp (cadr bf))
131                             (symbolp (caadr bf))                             (symbolp (caadr bf))
132                             (t-to-nil (coerce-to-one-value (fun-ret-type (cadr bf))))))                             (t-to-nil
133                                (coerce-to-one-value
134                                 (info-type
135                                  (cadr
136                                   (c1symbol-fun (caadr bf) (cdadr bf))))))))
137                   (dec (var-is-declared var body))                   (dec (var-is-declared var body))
138                   (chb (var-is-changed var body))                   (chb (var-is-changed var body))
139                   (chc (and star (var-is-changed var (cdr bindings)))))                   (chc (and star (var-is-changed var (cdr bindings)))))
140               (let ((type (or exp frt inf outer))               (let ((type (or exp frt inf outer))
141                     (ublk (not (or dec chb chc))))                     (ublk (not (or dec chb chc))))
142                 (if type                 (let ((*vars* (if (not star) *vars*
143                     (progn                                   (cons (c1make-var var nil nil (list (cons var (nil-to-t type)))) *vars*))))
144                       (cmpnote "var ~S is type ~S from ~a, ~a~%"                   (if type
145                                var type (cond (exp "explicit declaration")                       (progn
146                                               (frt "deduced function return type")                         (cmpnote "var ~S is type ~S from ~a, ~a~%"
147                                               (inf "argument inference")                                  var type (cond (exp "explicit declaration")
148                                               (outer "outer scope"))                                                 (frt "deduced function return type")
149                                (cond (dec "but is already declared")                                                 (inf "argument inference")
150                                      (chb "but is changed in body")                                                 (outer "outer scope"))
151                                      (chc "but is changed in other bindings")                                  (cond (dec "but is already declared")
152                                      (t "declaring")))                                        (chb "but is changed in body")
153                       (if ublk                                        (chc "but is changed in other bindings")
154                           (cons (list type var) (binding-decls (cdr bindings) body star))                                        (t "declaring")))
155                         (binding-decls (cdr bindings) body star)))                         (if ublk
156                   (binding-decls (cdr bindings) body star))))))))                             (cons (list type var) (binding-decls (cdr bindings) body star))
157                             (binding-decls (cdr bindings) body star)))
158                       (binding-decls (cdr bindings) body star)))))))))
159    
160  ;(type (or (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*)))  ;(type (or (and (symbolp (cadr bf)) (cdr (assoc (cadr bf) *decls*)))
161  ;                         (t-to-nil (var-is-inferred var body))  ;                         (t-to-nil (var-is-inferred var body))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

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