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