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)))) |
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)) |
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)) |