| 1 | ;;; compiler-pass1.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003-2008 Peter Graves |
|---|
| 4 | ;;; $Id: compiler-pass1.lisp 14558 2013-06-22 19:57:58Z ehuelsmann $ |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; This program is free software; you can redistribute it and/or |
|---|
| 7 | ;;; modify it under the terms of the GNU General Public License |
|---|
| 8 | ;;; as published by the Free Software Foundation; either version 2 |
|---|
| 9 | ;;; of the License, or (at your option) any later version. |
|---|
| 10 | ;;; |
|---|
| 11 | ;;; This program is distributed in the hope that it will be useful, |
|---|
| 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|---|
| 14 | ;;; GNU General Public License for more details. |
|---|
| 15 | ;;; |
|---|
| 16 | ;;; You should have received a copy of the GNU General Public License |
|---|
| 17 | ;;; along with this program; if not, write to the Free Software |
|---|
| 18 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. |
|---|
| 19 | ;;; |
|---|
| 20 | ;;; As a special exception, the copyright holders of this library give you |
|---|
| 21 | ;;; permission to link this library with independent modules to produce an |
|---|
| 22 | ;;; executable, regardless of the license terms of these independent |
|---|
| 23 | ;;; modules, and to copy and distribute the resulting executable under |
|---|
| 24 | ;;; terms of your choice, provided that you also meet, for each linked |
|---|
| 25 | ;;; independent module, the terms and conditions of the license of that |
|---|
| 26 | ;;; module. An independent module is a module which is not derived from |
|---|
| 27 | ;;; or based on this library. If you modify this library, you may extend |
|---|
| 28 | ;;; this exception to your version of the library, but you are not |
|---|
| 29 | ;;; obligated to do so. If you do not wish to do so, delete this |
|---|
| 30 | ;;; exception statement from your version. |
|---|
| 31 | |
|---|
| 32 | (in-package "JVM") |
|---|
| 33 | |
|---|
| 34 | (require "LOOP") |
|---|
| 35 | (require "FORMAT") |
|---|
| 36 | (require "CLOS") |
|---|
| 37 | (require "PRINT-OBJECT") |
|---|
| 38 | (require "COMPILER-TYPES") |
|---|
| 39 | (require "KNOWN-FUNCTIONS") |
|---|
| 40 | (require "KNOWN-SYMBOLS") |
|---|
| 41 | (require "DUMP-FORM") |
|---|
| 42 | (require "JAVA") |
|---|
| 43 | |
|---|
| 44 | (proclaim '(optimize speed)) |
|---|
| 45 | |
|---|
| 46 | (defun generate-inline-expansion (name lambda-list body |
|---|
| 47 | &optional (args nil args-p)) |
|---|
| 48 | "Generates code that can be used to expand a named local function inline. |
|---|
| 49 | It can work either per-function (no args provided) or per-call." |
|---|
| 50 | (if args-p |
|---|
| 51 | (multiple-value-bind |
|---|
| 52 | (body decls) |
|---|
| 53 | (parse-body body) |
|---|
| 54 | (expand-function-call-inline nil lambda-list |
|---|
| 55 | ;; the forms below get wrapped |
|---|
| 56 | ;; in a LET, making the decls |
|---|
| 57 | ;; part of the decls of the LET. |
|---|
| 58 | (copy-tree `(,@decls (block ,name ,@body))) |
|---|
| 59 | args)) |
|---|
| 60 | (cond ((intersection lambda-list |
|---|
| 61 | '(&optional &rest &key &allow-other-keys &aux) |
|---|
| 62 | :test #'eq) |
|---|
| 63 | nil) |
|---|
| 64 | (t |
|---|
| 65 | (multiple-value-bind |
|---|
| 66 | (body decls) |
|---|
| 67 | (parse-body body) |
|---|
| 68 | (setf body (copy-tree body)) |
|---|
| 69 | `(lambda ,lambda-list ,@decls |
|---|
| 70 | (block ,name ,@body))))))) |
|---|
| 71 | |
|---|
| 72 | |
|---|
| 73 | ;;; Pass 1. |
|---|
| 74 | |
|---|
| 75 | (defun parse-lambda-list (lambda-list) |
|---|
| 76 | "Breaks the lambda list into the different elements, returning the values |
|---|
| 77 | |
|---|
| 78 | required-vars |
|---|
| 79 | optional-vars |
|---|
| 80 | key-vars |
|---|
| 81 | key-p |
|---|
| 82 | rest-var |
|---|
| 83 | allow-other-keys-p |
|---|
| 84 | aux-vars |
|---|
| 85 | whole-var |
|---|
| 86 | env-var |
|---|
| 87 | |
|---|
| 88 | where each of the vars returned is a list with these elements: |
|---|
| 89 | |
|---|
| 90 | var - the actual variable name |
|---|
| 91 | initform - the init form if applicable; optional, keyword and aux vars |
|---|
| 92 | p-var - variable indicating presence |
|---|
| 93 | keyword - the keyword argument to match against |
|---|
| 94 | |
|---|
| 95 | " |
|---|
| 96 | (let ((remaining lambda-list) |
|---|
| 97 | (state :req) |
|---|
| 98 | keyword-required |
|---|
| 99 | req opt key rest whole env aux key-p allow-others-p) |
|---|
| 100 | (when (eq (car lambda-list) '&WHOLE) |
|---|
| 101 | (let ((var (second lambda-list))) |
|---|
| 102 | (when (memq var lambda-list-keywords) |
|---|
| 103 | (error 'program-error |
|---|
| 104 | :format-control "Lambda list keyword ~A found where &WHOLE ~ |
|---|
| 105 | variable expected in lambda list ~A." |
|---|
| 106 | :format-arguments (list var lambda-list))) |
|---|
| 107 | (setf whole (list var)) |
|---|
| 108 | (setf remaining (nthcdr 2 lambda-list)))) |
|---|
| 109 | |
|---|
| 110 | (do* ((arg (pop remaining) (pop tail)) |
|---|
| 111 | (tail remaining tail)) |
|---|
| 112 | ((and (null arg) |
|---|
| 113 | (endp tail))) |
|---|
| 114 | (let* ((allowable-previous-states |
|---|
| 115 | ;; even if the arglist could theoretically contain the |
|---|
| 116 | ;; keyword :req, this still works, because the cdr will |
|---|
| 117 | ;; be NIL, meaning that the code below thinks we DIDN'T |
|---|
| 118 | ;; find a new state. Which happens to be true. |
|---|
| 119 | (cdr (member arg '(&whole &environment &aux &allow-other-keys |
|---|
| 120 | &key &rest &optional :req))))) |
|---|
| 121 | (cond |
|---|
| 122 | (allowable-previous-states |
|---|
| 123 | (setf keyword-required nil) ;; we have a keyword... |
|---|
| 124 | (case arg |
|---|
| 125 | (&key |
|---|
| 126 | (setf key-p t)) |
|---|
| 127 | (&rest |
|---|
| 128 | (when (endp tail) |
|---|
| 129 | (error 'program-error |
|---|
| 130 | :format-control "&REST without variable in lambda list ~A." |
|---|
| 131 | :format-arguments (list lambda-list))) |
|---|
| 132 | (setf rest (list (pop tail)) |
|---|
| 133 | keyword-required t)) |
|---|
| 134 | (&allow-other-keys |
|---|
| 135 | (unless (eq state '&KEY) |
|---|
| 136 | (error 'program-error |
|---|
| 137 | :format-control "&ALLOW-OTHER-KEYS outside of &KEY ~ |
|---|
| 138 | section in lambda list ~A" |
|---|
| 139 | :format-arguments (list lambda-list))) |
|---|
| 140 | (setf allow-others-p t |
|---|
| 141 | keyword-required t |
|---|
| 142 | arg nil)) |
|---|
| 143 | (&environment |
|---|
| 144 | (setf env (list (pop tail)) |
|---|
| 145 | keyword-required t |
|---|
| 146 | ;; &ENVIRONMENT can appear anywhere; retain our last |
|---|
| 147 | ;; state so we know what next keywords are valid |
|---|
| 148 | arg state)) |
|---|
| 149 | (&whole |
|---|
| 150 | (error 'program-error |
|---|
| 151 | :format-control "&WHOLE must appear first in lambda list ~A." |
|---|
| 152 | :format-arguments (list lambda-list)))) |
|---|
| 153 | (when arg |
|---|
| 154 | ;; ### verify that the next state is valid |
|---|
| 155 | (unless (or (null state) |
|---|
| 156 | (member state allowable-previous-states)) |
|---|
| 157 | (error 'program-error |
|---|
| 158 | :format-control "~A not allowed after ~A ~ |
|---|
| 159 | in lambda-list ~S" |
|---|
| 160 | :format-arguments (list arg state lambda-list))) |
|---|
| 161 | (setf state arg))) |
|---|
| 162 | (keyword-required |
|---|
| 163 | ;; a keyword was required, but none was found... |
|---|
| 164 | (error 'program-error |
|---|
| 165 | :format-control "Lambda list keyword expected, but found ~ |
|---|
| 166 | ~A in lambda list ~A" |
|---|
| 167 | :format-arguments (list arg lambda-list))) |
|---|
| 168 | (t ;; a variable specification |
|---|
| 169 | (case state |
|---|
| 170 | (:req (push (list arg) req)) |
|---|
| 171 | (&optional |
|---|
| 172 | (cond ((symbolp arg) |
|---|
| 173 | (push (list arg) opt)) |
|---|
| 174 | ((consp arg) |
|---|
| 175 | (push (list (car arg) (cadr arg) |
|---|
| 176 | (caddr arg)) opt)) |
|---|
| 177 | (t |
|---|
| 178 | (error "Invalid &OPTIONAL variable.")))) |
|---|
| 179 | (&key |
|---|
| 180 | (cond ((symbolp arg) |
|---|
| 181 | (push (list arg nil nil (sys::keywordify arg)) key)) |
|---|
| 182 | ((consp arg) |
|---|
| 183 | (push (list (if (consp (car arg)) |
|---|
| 184 | (cadar arg) (car arg)) |
|---|
| 185 | (cadr arg) (caddr arg) |
|---|
| 186 | (if (consp (car arg)) |
|---|
| 187 | (caar arg) |
|---|
| 188 | (sys::keywordify (car arg)))) key)) |
|---|
| 189 | (t |
|---|
| 190 | (error "Invalid &KEY variable.")))) |
|---|
| 191 | (&aux |
|---|
| 192 | (cond ((symbolp arg) |
|---|
| 193 | (push (list arg nil nil nil) aux)) |
|---|
| 194 | ((consp arg) |
|---|
| 195 | (push (list (car arg) (cadr arg) nil nil) aux)) |
|---|
| 196 | (t |
|---|
| 197 | (error "Invalid &aux state.")))) |
|---|
| 198 | (t |
|---|
| 199 | (error 'program-error |
|---|
| 200 | :format-control "Invalid state found: ~A." |
|---|
| 201 | :format-arguments (list state)))))))) |
|---|
| 202 | (values |
|---|
| 203 | (nreverse req) |
|---|
| 204 | (nreverse opt) |
|---|
| 205 | (nreverse key) |
|---|
| 206 | key-p |
|---|
| 207 | rest allow-others-p |
|---|
| 208 | (nreverse aux) whole env))) |
|---|
| 209 | |
|---|
| 210 | (define-condition lambda-list-mismatch (error) |
|---|
| 211 | ((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type))) |
|---|
| 212 | |
|---|
| 213 | (defmacro push-argument-binding (var form temp-bindings bindings) |
|---|
| 214 | (let ((g (gensym))) |
|---|
| 215 | `(let ((,g (gensym (symbol-name '#:temp)))) |
|---|
| 216 | (push (list ,g ,form) ,temp-bindings) |
|---|
| 217 | (push (list ,var ,g) ,bindings)))) |
|---|
| 218 | |
|---|
| 219 | (defun match-lambda-list (parsed-lambda-list arguments) |
|---|
| 220 | (flet ((pop-required-argument () |
|---|
| 221 | (if (null arguments) |
|---|
| 222 | (error 'lambda-list-mismatch :mismatch-type :too-few-arguments) |
|---|
| 223 | (pop arguments))) |
|---|
| 224 | (var (var-info) (car var-info)) |
|---|
| 225 | (initform (var-info) (cadr var-info)) |
|---|
| 226 | (p-var (var-info) (caddr var-info))) |
|---|
| 227 | (destructuring-bind (req opt key key-p rest allow-others-p aux whole env) |
|---|
| 228 | parsed-lambda-list |
|---|
| 229 | (declare (ignore whole env)) |
|---|
| 230 | (let (req-bindings temp-bindings bindings ignorables) |
|---|
| 231 | ;;Required arguments. |
|---|
| 232 | (setf req-bindings |
|---|
| 233 | (loop :for (var) :in req |
|---|
| 234 | :collect `(,var ,(pop-required-argument)))) |
|---|
| 235 | |
|---|
| 236 | ;;Optional arguments. |
|---|
| 237 | (when opt |
|---|
| 238 | (dolist (var-info opt) |
|---|
| 239 | (if arguments |
|---|
| 240 | (progn |
|---|
| 241 | (push-argument-binding (var var-info) (pop arguments) |
|---|
| 242 | temp-bindings bindings) |
|---|
| 243 | (when (p-var var-info) |
|---|
| 244 | (push `(,(p-var var-info) t) bindings))) |
|---|
| 245 | (progn |
|---|
| 246 | (push `(,(var var-info) ,(initform var-info)) bindings) |
|---|
| 247 | (when (p-var var-info) |
|---|
| 248 | (push `(,(p-var var-info) nil) bindings))))) |
|---|
| 249 | (setf bindings (nreverse bindings))) |
|---|
| 250 | |
|---|
| 251 | (unless (or key-p rest (null arguments)) |
|---|
| 252 | (error 'lambda-list-mismatch :mismatch-type :too-many-arguments)) |
|---|
| 253 | |
|---|
| 254 | ;;Keyword and rest arguments. |
|---|
| 255 | (if key-p |
|---|
| 256 | (multiple-value-bind (kbindings ktemps kignor) |
|---|
| 257 | (match-keyword-and-rest-args |
|---|
| 258 | key allow-others-p rest arguments) |
|---|
| 259 | (setf bindings (append bindings kbindings) |
|---|
| 260 | temp-bindings (append temp-bindings ktemps) |
|---|
| 261 | ignorables (append kignor ignorables))) |
|---|
| 262 | (when rest |
|---|
| 263 | (let (rest-binding) |
|---|
| 264 | (push-argument-binding (var rest) `(list ,@arguments) |
|---|
| 265 | temp-bindings rest-binding) |
|---|
| 266 | (setf bindings (append bindings rest-binding))))) |
|---|
| 267 | ;;Aux parameters. |
|---|
| 268 | (when aux |
|---|
| 269 | (setf bindings |
|---|
| 270 | `(,@bindings |
|---|
| 271 | ,@(loop |
|---|
| 272 | :for var-info :in aux |
|---|
| 273 | :collect `(,(var var-info) ,(initform var-info)))))) |
|---|
| 274 | (values (append req-bindings temp-bindings bindings) |
|---|
| 275 | ignorables))))) |
|---|
| 276 | |
|---|
| 277 | (defun match-keyword-and-rest-args (key allow-others-p rest arguments) |
|---|
| 278 | (flet ((var (var-info) (car var-info)) |
|---|
| 279 | (initform (var-info) (cadr var-info)) |
|---|
| 280 | (p-var (var-info) (caddr var-info)) |
|---|
| 281 | (keyword (var-info) (cadddr var-info))) |
|---|
| 282 | (when (oddp (list-length arguments)) |
|---|
| 283 | (error 'lambda-list-mismatch |
|---|
| 284 | :mismatch-type :odd-number-of-keyword-arguments)) |
|---|
| 285 | |
|---|
| 286 | (let (temp-bindings bindings other-keys-found-p ignorables already-seen |
|---|
| 287 | args) |
|---|
| 288 | ;;If necessary, make up a fake argument to hold :allow-other-keys, |
|---|
| 289 | ;;needed later. This also handles nicely: |
|---|
| 290 | ;; 3.4.1.4.1 Suppressing Keyword Argument Checking |
|---|
| 291 | ;;third statement. |
|---|
| 292 | (unless (find :allow-other-keys key :key #'keyword) |
|---|
| 293 | (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys)))) |
|---|
| 294 | (push allow-other-keys-temp ignorables) |
|---|
| 295 | (push (list allow-other-keys-temp nil nil :allow-other-keys) key))) |
|---|
| 296 | |
|---|
| 297 | ;;First, let's bind the keyword arguments that have been passed by |
|---|
| 298 | ;;the caller. If we encounter an unknown keyword, remember it. |
|---|
| 299 | ;;As per the above, :allow-other-keys will never be considered |
|---|
| 300 | ;;an unknown keyword. |
|---|
| 301 | (loop |
|---|
| 302 | :for var :in arguments :by #'cddr |
|---|
| 303 | :for value :in (cdr arguments) :by #'cddr |
|---|
| 304 | :do (let ((var-info (find var key :key #'keyword))) |
|---|
| 305 | (if (and var-info (not (member var already-seen))) |
|---|
| 306 | ;;var is one of the declared keyword arguments |
|---|
| 307 | (progn |
|---|
| 308 | (push-argument-binding (var var-info) value |
|---|
| 309 | temp-bindings bindings) |
|---|
| 310 | (when (p-var var-info) |
|---|
| 311 | (push `(,(p-var var-info) t) bindings)) |
|---|
| 312 | (push var args) |
|---|
| 313 | (push (var var-info) args) |
|---|
| 314 | (push var already-seen)) |
|---|
| 315 | (let ((g (gensym))) |
|---|
| 316 | (push `(,g ,value) temp-bindings) |
|---|
| 317 | (push var args) |
|---|
| 318 | (push g args) |
|---|
| 319 | (push g ignorables) |
|---|
| 320 | (unless var-info |
|---|
| 321 | (setf other-keys-found-p t)))))) |
|---|
| 322 | |
|---|
| 323 | ;;Then, let's bind those arguments that haven't been passed in |
|---|
| 324 | ;;to their default value, in declaration order. |
|---|
| 325 | (let (defaults) |
|---|
| 326 | (loop |
|---|
| 327 | :for var-info :in key |
|---|
| 328 | :do (unless (find (var var-info) bindings :key #'car) |
|---|
| 329 | (push `(,(var var-info) ,(initform var-info)) defaults) |
|---|
| 330 | (when (p-var var-info) |
|---|
| 331 | (push `(,(p-var var-info) nil) defaults)))) |
|---|
| 332 | (setf bindings (append (nreverse defaults) bindings))) |
|---|
| 333 | |
|---|
| 334 | ;;If necessary, check for unrecognized keyword arguments. |
|---|
| 335 | (when (and other-keys-found-p (not allow-others-p)) |
|---|
| 336 | (if (loop |
|---|
| 337 | :for var :in arguments :by #'cddr |
|---|
| 338 | :if (eq var :allow-other-keys) |
|---|
| 339 | :do (return t)) |
|---|
| 340 | ;;We know that :allow-other-keys has been passed, so we |
|---|
| 341 | ;;can access the binding for it and be sure to get the |
|---|
| 342 | ;;value passed by the user and not an initform. |
|---|
| 343 | (let* ((arg (var (find :allow-other-keys key :key #'keyword))) |
|---|
| 344 | (binding (find arg bindings :key #'car)) |
|---|
| 345 | (form (cadr binding))) |
|---|
| 346 | (if (constantp form) |
|---|
| 347 | (unless (eval form) |
|---|
| 348 | (error 'lambda-list-mismatch |
|---|
| 349 | :mismatch-type :unknown-keyword)) |
|---|
| 350 | (setf (cadr binding) |
|---|
| 351 | `(or ,(cadr binding) |
|---|
| 352 | (error 'program-error |
|---|
| 353 | "Unrecognized keyword argument"))))) |
|---|
| 354 | ;;TODO: it would be nice to report *which* keyword |
|---|
| 355 | ;;is unknown |
|---|
| 356 | (error 'lambda-list-mismatch :mismatch-type :unknown-keyword))) |
|---|
| 357 | (when rest |
|---|
| 358 | (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args))))))) |
|---|
| 359 | (values bindings temp-bindings ignorables)))) |
|---|
| 360 | |
|---|
| 361 | #||test for the above |
|---|
| 362 | (handler-case |
|---|
| 363 | (let ((lambda-list |
|---|
| 364 | (multiple-value-list |
|---|
| 365 | (jvm::parse-lambda-list |
|---|
| 366 | '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar)))))) |
|---|
| 367 | (jvm::match-lambda-list |
|---|
| 368 | lambda-list |
|---|
| 369 | '((print 1) 3 (print 32) :bar 2))) |
|---|
| 370 | (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x))) |
|---|
| 371 | ||# |
|---|
| 372 | |
|---|
| 373 | (defun expand-function-call-inline (form lambda-list body args) |
|---|
| 374 | (handler-case |
|---|
| 375 | (multiple-value-bind (bindings ignorables) |
|---|
| 376 | (match-lambda-list (multiple-value-list |
|---|
| 377 | (parse-lambda-list lambda-list)) |
|---|
| 378 | args) |
|---|
| 379 | `(let* ,bindings |
|---|
| 380 | ,@(when ignorables |
|---|
| 381 | `((declare (ignorable ,@ignorables)))) |
|---|
| 382 | ,@body)) |
|---|
| 383 | (lambda-list-mismatch (x) |
|---|
| 384 | (compiler-warn "Invalid function call: ~S (mismatch type: ~A)" |
|---|
| 385 | form (lambda-list-mismatch-type x)) |
|---|
| 386 | form))) |
|---|
| 387 | |
|---|
| 388 | ;; Returns a list of declared free specials, if any are found. |
|---|
| 389 | (declaim (ftype (function (list list block-node) list) |
|---|
| 390 | process-declarations-for-vars)) |
|---|
| 391 | (defun process-declarations-for-vars (body variables block) |
|---|
| 392 | (let ((free-specials '())) |
|---|
| 393 | (dolist (subform body) |
|---|
| 394 | (unless (and (consp subform) (eq (%car subform) 'DECLARE)) |
|---|
| 395 | (return)) |
|---|
| 396 | (let ((decls (%cdr subform))) |
|---|
| 397 | (dolist (decl decls) |
|---|
| 398 | (case (car decl) |
|---|
| 399 | ((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE) |
|---|
| 400 | ;; Nothing to do here. |
|---|
| 401 | ) |
|---|
| 402 | ((IGNORE IGNORABLE) |
|---|
| 403 | (process-ignore/ignorable (%car decl) (%cdr decl) variables)) |
|---|
| 404 | (SPECIAL |
|---|
| 405 | (dolist (name (%cdr decl)) |
|---|
| 406 | (let ((variable (find-variable name variables))) |
|---|
| 407 | (cond ((and variable |
|---|
| 408 | ;; see comment below (and DO-ALL-SYMBOLS.11) |
|---|
| 409 | (eq (variable-compiland variable) |
|---|
| 410 | *current-compiland*)) |
|---|
| 411 | (setf (variable-special-p variable) t)) |
|---|
| 412 | (t |
|---|
| 413 | (dformat t "adding free special ~S~%" name) |
|---|
| 414 | (push (make-variable :name name :special-p t |
|---|
| 415 | :block block) |
|---|
| 416 | free-specials)))))) |
|---|
| 417 | (TYPE |
|---|
| 418 | (dolist (name (cddr decl)) |
|---|
| 419 | (let ((variable (find-variable name variables))) |
|---|
| 420 | (when (and variable |
|---|
| 421 | ;; Don't apply a declaration in a local function to |
|---|
| 422 | ;; a variable defined in its parent. For an example, |
|---|
| 423 | ;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre. |
|---|
| 424 | ;; FIXME suboptimal, since we ignore the declaration |
|---|
| 425 | (eq (variable-compiland variable) |
|---|
| 426 | *current-compiland*)) |
|---|
| 427 | (setf (variable-declared-type variable) |
|---|
| 428 | (make-compiler-type (cadr decl))))))) |
|---|
| 429 | (t |
|---|
| 430 | (dolist (name (cdr decl)) |
|---|
| 431 | (let ((variable (find-variable name variables))) |
|---|
| 432 | (when variable |
|---|
| 433 | (setf (variable-declared-type variable) |
|---|
| 434 | (make-compiler-type (%car decl))))))))))) |
|---|
| 435 | free-specials)) |
|---|
| 436 | |
|---|
| 437 | (defun check-name (name) |
|---|
| 438 | ;; FIXME Currently this error is signalled by the precompiler. |
|---|
| 439 | (unless (symbolp name) |
|---|
| 440 | (compiler-error "The variable ~S is not a symbol." name)) |
|---|
| 441 | (when (constantp name) |
|---|
| 442 | (compiler-error "The name of the variable ~S is already in use to name a constant." name)) |
|---|
| 443 | name) |
|---|
| 444 | |
|---|
| 445 | (declaim (ftype (function (t) t) p1-body)) |
|---|
| 446 | (defun p1-body (body) |
|---|
| 447 | (declare (optimize speed)) |
|---|
| 448 | (loop |
|---|
| 449 | for form in body |
|---|
| 450 | for processed-form = (p1 form) |
|---|
| 451 | collect processed-form |
|---|
| 452 | while (not (and (consp processed-form) |
|---|
| 453 | (memq (car processed-form) '(GO RETURN-FROM THROW)))))) |
|---|
| 454 | |
|---|
| 455 | (defknown p1-default (t) t) |
|---|
| 456 | (declaim (inline p1-default)) |
|---|
| 457 | (defun p1-default (form) |
|---|
| 458 | (declare (optimize speed)) |
|---|
| 459 | (cons (car form) (loop for f in (cdr form) collect (p1 f)))) |
|---|
| 460 | |
|---|
| 461 | (defun let/let*-variables (block bindings) |
|---|
| 462 | (loop for binding in bindings |
|---|
| 463 | if (consp binding) |
|---|
| 464 | collect (make-variable :name (check-name (car binding)) |
|---|
| 465 | :initform (cadr binding) |
|---|
| 466 | :block block) |
|---|
| 467 | else |
|---|
| 468 | collect (make-variable :name (check-name binding) |
|---|
| 469 | :block block))) |
|---|
| 470 | |
|---|
| 471 | (defun valid-let/let*-binding-p (varspec) |
|---|
| 472 | (when (consp varspec) |
|---|
| 473 | (unless (<= 1 (length varspec) 2) |
|---|
| 474 | (compiler-error "The LET/LET* binding specification ~ |
|---|
| 475 | ~S is invalid." varspec))) |
|---|
| 476 | T) |
|---|
| 477 | |
|---|
| 478 | (defun check-let/let*-bindings (bindings) |
|---|
| 479 | (every #'valid-let/let*-binding-p bindings)) |
|---|
| 480 | |
|---|
| 481 | (defknown p1-let-vars (t) t) |
|---|
| 482 | (defun p1-let-vars (block varlist) |
|---|
| 483 | (check-let/let*-bindings varlist) |
|---|
| 484 | (let ((vars (let/let*-variables block varlist))) |
|---|
| 485 | (dolist (variable vars) |
|---|
| 486 | (setf (variable-initform variable) |
|---|
| 487 | (p1 (variable-initform variable)))) |
|---|
| 488 | (dolist (variable vars) |
|---|
| 489 | (push variable *visible-variables*) |
|---|
| 490 | (push variable *all-variables*)) |
|---|
| 491 | vars)) |
|---|
| 492 | |
|---|
| 493 | (defknown p1-let*-vars (t) t) |
|---|
| 494 | (defun p1-let*-vars (block varlist) |
|---|
| 495 | (check-let/let*-bindings varlist) |
|---|
| 496 | (let ((vars (let/let*-variables block varlist))) |
|---|
| 497 | (dolist (variable vars) |
|---|
| 498 | (setf (variable-initform variable) |
|---|
| 499 | (p1 (variable-initform variable))) |
|---|
| 500 | (push variable *visible-variables*) |
|---|
| 501 | (push variable *all-variables*)) |
|---|
| 502 | vars)) |
|---|
| 503 | |
|---|
| 504 | (defun p1-let/let* (form) |
|---|
| 505 | (declare (type cons form)) |
|---|
| 506 | (let* ((*visible-variables* *visible-variables*) |
|---|
| 507 | (block (make-let/let*-node)) |
|---|
| 508 | (*block* block) |
|---|
| 509 | (op (%car form)) |
|---|
| 510 | (varlist (cadr form)) |
|---|
| 511 | (body (cddr form))) |
|---|
| 512 | (aver (or (eq op 'LET) (eq op 'LET*))) |
|---|
| 513 | (when (eq op 'LET) |
|---|
| 514 | ;; Convert to LET* if possible. |
|---|
| 515 | (if (null (cdr varlist)) |
|---|
| 516 | (setf op 'LET*) |
|---|
| 517 | (dolist (varspec varlist (setf op 'LET*)) |
|---|
| 518 | (or (atom varspec) |
|---|
| 519 | (constantp (cadr varspec)) |
|---|
| 520 | (eq (car varspec) (cadr varspec)) |
|---|
| 521 | (return))))) |
|---|
| 522 | (let ((vars (if (eq op 'LET) |
|---|
| 523 | (p1-let-vars block varlist) |
|---|
| 524 | (p1-let*-vars block varlist)))) |
|---|
| 525 | ;; Check for globally declared specials. |
|---|
| 526 | (dolist (variable vars) |
|---|
| 527 | (when (special-variable-p (variable-name variable)) |
|---|
| 528 | (setf (variable-special-p variable) t |
|---|
| 529 | (let-environment-register block) t))) |
|---|
| 530 | ;; For processing declarations, we want to walk the variable list from |
|---|
| 531 | ;; last to first, since declarations apply to the last-defined variable |
|---|
| 532 | ;; with the specified name. |
|---|
| 533 | (setf (let-free-specials block) |
|---|
| 534 | (process-declarations-for-vars body (reverse vars) block)) |
|---|
| 535 | (setf (let-vars block) vars) |
|---|
| 536 | ;; Make free specials visible. |
|---|
| 537 | (dolist (variable (let-free-specials block)) |
|---|
| 538 | (push variable *visible-variables*))) |
|---|
| 539 | (with-saved-compiler-policy |
|---|
| 540 | (process-optimization-declarations body) |
|---|
| 541 | (let ((*blocks* (cons block *blocks*))) |
|---|
| 542 | (setf body (p1-body body))) |
|---|
| 543 | (setf (let-form block) (list* op varlist body)) |
|---|
| 544 | block))) |
|---|
| 545 | |
|---|
| 546 | (defun p1-locally (form) |
|---|
| 547 | (let* ((*visible-variables* *visible-variables*) |
|---|
| 548 | (block (make-locally-node)) |
|---|
| 549 | (*block* block) |
|---|
| 550 | (free-specials (process-declarations-for-vars (cdr form) nil block))) |
|---|
| 551 | (setf (locally-free-specials block) free-specials) |
|---|
| 552 | (dolist (special free-specials) |
|---|
| 553 | ;; (format t "p1-locally ~S is special~%" name) |
|---|
| 554 | (push special *visible-variables*)) |
|---|
| 555 | (let ((*blocks* (cons block *blocks*))) |
|---|
| 556 | (with-saved-compiler-policy |
|---|
| 557 | (process-optimization-declarations (cdr form)) |
|---|
| 558 | (setf (locally-form block) |
|---|
| 559 | (list* 'LOCALLY (p1-body (cdr form)))) |
|---|
| 560 | block)))) |
|---|
| 561 | |
|---|
| 562 | (defknown p1-m-v-b (t) t) |
|---|
| 563 | (defun p1-m-v-b (form) |
|---|
| 564 | (when (= (length (cadr form)) 1) |
|---|
| 565 | (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form)))) |
|---|
| 566 | (return-from p1-m-v-b (p1-let/let* new-form)))) |
|---|
| 567 | (let* ((*visible-variables* *visible-variables*) |
|---|
| 568 | (block (make-m-v-b-node)) |
|---|
| 569 | (*block* block) |
|---|
| 570 | (varlist (cadr form)) |
|---|
| 571 | ;; Process the values-form first. ("The scopes of the name binding and |
|---|
| 572 | ;; declarations do not include the values-form.") |
|---|
| 573 | (values-form (p1 (caddr form))) |
|---|
| 574 | (*blocks* (cons block *blocks*)) |
|---|
| 575 | (body (cdddr form))) |
|---|
| 576 | (let ((vars ())) |
|---|
| 577 | (dolist (symbol varlist) |
|---|
| 578 | (let ((var (make-variable :name symbol :block block))) |
|---|
| 579 | (push var vars) |
|---|
| 580 | (push var *visible-variables*) |
|---|
| 581 | (push var *all-variables*))) |
|---|
| 582 | ;; Check for globally declared specials. |
|---|
| 583 | (dolist (variable vars) |
|---|
| 584 | (when (special-variable-p (variable-name variable)) |
|---|
| 585 | (setf (variable-special-p variable) t |
|---|
| 586 | (m-v-b-environment-register block) t))) |
|---|
| 587 | (setf (m-v-b-free-specials block) |
|---|
| 588 | (process-declarations-for-vars body vars block)) |
|---|
| 589 | (dolist (special (m-v-b-free-specials block)) |
|---|
| 590 | (push special *visible-variables*)) |
|---|
| 591 | (setf (m-v-b-vars block) (nreverse vars))) |
|---|
| 592 | (with-saved-compiler-policy |
|---|
| 593 | (process-optimization-declarations body) |
|---|
| 594 | (setf body (p1-body body)) |
|---|
| 595 | (setf (m-v-b-form block) |
|---|
| 596 | (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) |
|---|
| 597 | block))) |
|---|
| 598 | |
|---|
| 599 | (defun p1-block (form) |
|---|
| 600 | (let* ((block (make-block-node (cadr form))) |
|---|
| 601 | (*block* block) |
|---|
| 602 | (*blocks* (cons block *blocks*)) |
|---|
| 603 | (form (list* (car form) (cadr form) (p1-body (cddr form))))) |
|---|
| 604 | (setf (block-form block) form) |
|---|
| 605 | (when (block-non-local-return-p block) |
|---|
| 606 | ;; Add a closure variable for RETURN-FROM to use |
|---|
| 607 | (push (setf (block-id-variable block) |
|---|
| 608 | (make-variable :name (gensym) |
|---|
| 609 | :block block |
|---|
| 610 | :used-non-locally-p t)) |
|---|
| 611 | *all-variables*)) |
|---|
| 612 | block)) |
|---|
| 613 | |
|---|
| 614 | (defun p1-catch (form) |
|---|
| 615 | (let* ((tag (p1 (cadr form))) |
|---|
| 616 | (body (cddr form)) |
|---|
| 617 | (block (make-catch-node)) |
|---|
| 618 | (*block* block) |
|---|
| 619 | ;; our subform processors need to know |
|---|
| 620 | ;; they're enclosed in a CATCH block |
|---|
| 621 | (*blocks* (cons block *blocks*)) |
|---|
| 622 | (result '())) |
|---|
| 623 | (dolist (subform body) |
|---|
| 624 | (let ((op (and (consp subform) (%car subform)))) |
|---|
| 625 | (push (p1 subform) result) |
|---|
| 626 | (when (memq op '(GO RETURN-FROM THROW)) |
|---|
| 627 | (return)))) |
|---|
| 628 | (setf result (nreverse result)) |
|---|
| 629 | (when (and (null (cdr result)) |
|---|
| 630 | (consp (car result)) |
|---|
| 631 | (eq (caar result) 'GO)) |
|---|
| 632 | (return-from p1-catch (car result))) |
|---|
| 633 | (push tag result) |
|---|
| 634 | (push 'CATCH result) |
|---|
| 635 | (setf (catch-form block) result) |
|---|
| 636 | block)) |
|---|
| 637 | |
|---|
| 638 | (defun p1-threads-synchronized-on (form) |
|---|
| 639 | (let* ((synchronized-object (p1 (cadr form))) |
|---|
| 640 | (body (cddr form)) |
|---|
| 641 | (block (make-synchronized-node)) |
|---|
| 642 | (*block* block) |
|---|
| 643 | (*blocks* (cons block *blocks*))) |
|---|
| 644 | (setf (synchronized-form block) |
|---|
| 645 | (list* 'threads:synchronized-on synchronized-object |
|---|
| 646 | (p1-body body))) |
|---|
| 647 | block)) |
|---|
| 648 | |
|---|
| 649 | (defun p1-java-jrun-exception-protected (form) |
|---|
| 650 | (assert (eq (first form) 'java:jrun-exception-protected)) |
|---|
| 651 | (assert (or (eq (car (second form)) 'lambda) |
|---|
| 652 | (and (eq (car (second form)) 'function) |
|---|
| 653 | (eq (car (second (second form))) 'lambda)))) |
|---|
| 654 | (let* ((body (if (eq (car (second form)) 'lambda) |
|---|
| 655 | (cddr (second form)) |
|---|
| 656 | (cddr (second (second form))))) |
|---|
| 657 | (block (make-exception-protected-node)) |
|---|
| 658 | (*block* block) |
|---|
| 659 | (*blocks* (cons block *blocks*))) |
|---|
| 660 | (setf (exception-protected-form block) |
|---|
| 661 | (p1-body body)) |
|---|
| 662 | block)) |
|---|
| 663 | |
|---|
| 664 | (defun p1-unwind-protect (form) |
|---|
| 665 | (if (= (length form) 2) |
|---|
| 666 | (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...) |
|---|
| 667 | |
|---|
| 668 | ;; in order to compile the cleanup forms twice (see |
|---|
| 669 | ;; p2-unwind-protect-node), we need to p1 them twice; p1 outcomes |
|---|
| 670 | ;; can be compiled (in the same compiland?) only once. |
|---|
| 671 | ;; |
|---|
| 672 | ;; However, p1 transforms the forms being processed, so, we |
|---|
| 673 | ;; need to copy the forms to create a second copy. |
|---|
| 674 | (let* ((block (make-unwind-protect-node)) |
|---|
| 675 | (*block* block) |
|---|
| 676 | ;; a bit of jumping through hoops... |
|---|
| 677 | (unwinding-forms (p1-body (copy-tree (cddr form)))) |
|---|
| 678 | (unprotected-forms (p1-body (cddr form))) |
|---|
| 679 | ;; ... because only the protected form is |
|---|
| 680 | ;; protected by the UNWIND-PROTECT block |
|---|
| 681 | (*blocks* (cons block *blocks*)) |
|---|
| 682 | (protected-form (p1 (cadr form)))) |
|---|
| 683 | (setf (unwind-protect-form block) |
|---|
| 684 | `(unwind-protect ,protected-form |
|---|
| 685 | (progn ,@unwinding-forms) |
|---|
| 686 | ,@unprotected-forms)) |
|---|
| 687 | block))) |
|---|
| 688 | |
|---|
| 689 | (defknown p1-return-from (t) t) |
|---|
| 690 | (defun p1-return-from (form) |
|---|
| 691 | (let* ((name (second form)) |
|---|
| 692 | (block (find-block name)) |
|---|
| 693 | non-local-p) |
|---|
| 694 | (when (null block) |
|---|
| 695 | (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible." |
|---|
| 696 | name name)) |
|---|
| 697 | (dformat t "p1-return-from block = ~S~%" (block-name block)) |
|---|
| 698 | (cond ((eq (block-compiland block) *current-compiland*) |
|---|
| 699 | ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT |
|---|
| 700 | ;; which is inside the block we're returning from, we'll do a non- |
|---|
| 701 | ;; local return anyway so that UNWIND-PROTECT can catch it and run |
|---|
| 702 | ;; its cleanup forms. |
|---|
| 703 | ;;(dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*)) |
|---|
| 704 | (let ((protected (enclosed-by-protected-block-p block))) |
|---|
| 705 | (dformat t "p1-return-from protected = ~S~%" protected) |
|---|
| 706 | (if protected |
|---|
| 707 | (setf (block-non-local-return-p block) t |
|---|
| 708 | non-local-p t) |
|---|
| 709 | ;; non-local GO's ensure environment restoration |
|---|
| 710 | ;; find out about this local GO |
|---|
| 711 | (when (null (block-needs-environment-restoration block)) |
|---|
| 712 | (setf (block-needs-environment-restoration block) |
|---|
| 713 | (enclosed-by-environment-setting-block-p block)))))) |
|---|
| 714 | (t |
|---|
| 715 | (setf (block-non-local-return-p block) t |
|---|
| 716 | non-local-p t))) |
|---|
| 717 | (when (block-non-local-return-p block) |
|---|
| 718 | (dformat t "non-local return from block ~S~%" (block-name block))) |
|---|
| 719 | (let ((value-form (p1 (caddr form)))) |
|---|
| 720 | (push value-form (block-return-value-forms block)) |
|---|
| 721 | (make-jump-node (list 'RETURN-FROM name value-form) |
|---|
| 722 | non-local-p block)))) |
|---|
| 723 | |
|---|
| 724 | (defun p1-tagbody (form) |
|---|
| 725 | (let* ((block (make-tagbody-node)) |
|---|
| 726 | (*block* block) |
|---|
| 727 | (*blocks* (cons block *blocks*)) |
|---|
| 728 | (*visible-tags* *visible-tags*) |
|---|
| 729 | (local-tags '()) |
|---|
| 730 | (body (cdr form))) |
|---|
| 731 | ;; Make all the tags visible before processing the body forms. |
|---|
| 732 | (dolist (subform body) |
|---|
| 733 | (when (or (symbolp subform) (integerp subform)) |
|---|
| 734 | (let* ((tag (make-tag :name subform :label (gensym) :block block))) |
|---|
| 735 | (push tag local-tags) |
|---|
| 736 | (push tag *visible-tags*)))) |
|---|
| 737 | (let ((new-body '()) |
|---|
| 738 | (live t)) |
|---|
| 739 | (dolist (subform body) |
|---|
| 740 | (cond ((or (symbolp subform) (integerp subform)) |
|---|
| 741 | (push subform new-body) |
|---|
| 742 | (push (find subform local-tags :key #'tag-name :test #'eql) |
|---|
| 743 | (tagbody-tags block)) |
|---|
| 744 | (setf live t)) |
|---|
| 745 | ((not live) |
|---|
| 746 | ;; Nothing to do. |
|---|
| 747 | ) |
|---|
| 748 | (t |
|---|
| 749 | (when (and (consp subform) |
|---|
| 750 | (memq (%car subform) '(GO RETURN-FROM THROW))) |
|---|
| 751 | ;; Subsequent subforms are unreachable until we see another |
|---|
| 752 | ;; tag. |
|---|
| 753 | (setf live nil)) |
|---|
| 754 | (push (p1 subform) new-body)))) |
|---|
| 755 | (setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body)))) |
|---|
| 756 | (when (some #'tag-used-non-locally (tagbody-tags block)) |
|---|
| 757 | (push (setf (tagbody-id-variable block) |
|---|
| 758 | (make-variable :name (gensym) |
|---|
| 759 | :block block |
|---|
| 760 | :used-non-locally-p t)) |
|---|
| 761 | *all-variables*)) |
|---|
| 762 | block)) |
|---|
| 763 | |
|---|
| 764 | (defknown p1-go (t) t) |
|---|
| 765 | (defun p1-go (form) |
|---|
| 766 | (let* ((name (cadr form)) |
|---|
| 767 | (tag (find-tag name))) |
|---|
| 768 | (unless tag |
|---|
| 769 | (error "p1-go: tag not found: ~S" name)) |
|---|
| 770 | (setf (tag-used tag) t) |
|---|
| 771 | (let ((tag-block (tag-block tag)) |
|---|
| 772 | non-local-p) |
|---|
| 773 | (cond ((eq (tag-compiland tag) *current-compiland*) |
|---|
| 774 | ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH? |
|---|
| 775 | (if (enclosed-by-protected-block-p tag-block) |
|---|
| 776 | (setf (tagbody-non-local-go-p tag-block) t |
|---|
| 777 | (tag-used-non-locally tag) t |
|---|
| 778 | non-local-p t) |
|---|
| 779 | ;; non-local GO's ensure environment restoration |
|---|
| 780 | ;; find out about this local GO |
|---|
| 781 | (when (null (tagbody-needs-environment-restoration tag-block)) |
|---|
| 782 | (setf (tagbody-needs-environment-restoration tag-block) |
|---|
| 783 | (enclosed-by-environment-setting-block-p tag-block))))) |
|---|
| 784 | (t |
|---|
| 785 | (setf (tagbody-non-local-go-p tag-block) t |
|---|
| 786 | (tag-used-non-locally tag) t |
|---|
| 787 | non-local-p t))) |
|---|
| 788 | (make-jump-node form non-local-p tag-block tag)))) |
|---|
| 789 | |
|---|
| 790 | (defun split-decls (forms specific-vars) |
|---|
| 791 | (let ((other-decls nil) |
|---|
| 792 | (specific-decls nil)) |
|---|
| 793 | (dolist (form forms) |
|---|
| 794 | (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen |
|---|
| 795 | (return)) |
|---|
| 796 | (dolist (decl (cdr form)) |
|---|
| 797 | (case (car decl) |
|---|
| 798 | ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE) |
|---|
| 799 | (push (list 'DECLARE decl) other-decls)) |
|---|
| 800 | (SPECIAL |
|---|
| 801 | (dolist (name (cdr decl)) |
|---|
| 802 | (if (memq name specific-vars) |
|---|
| 803 | (push `(DECLARE (SPECIAL ,name)) specific-decls) |
|---|
| 804 | (push `(DECLARE (SPECIAL ,name)) other-decls)))) |
|---|
| 805 | (TYPE |
|---|
| 806 | (dolist (name (cddr decl)) |
|---|
| 807 | (if (memq name specific-vars) |
|---|
| 808 | (push `(DECLARE (TYPE ,(cadr decl) ,name)) specific-decls) |
|---|
| 809 | (push `(DECLARE (TYPE ,(cadr decl) ,name)) other-decls)))) |
|---|
| 810 | (t |
|---|
| 811 | (dolist (name (cdr decl)) |
|---|
| 812 | (if (memq name specific-vars) |
|---|
| 813 | (push `(DECLARE (,(car decl) ,name)) specific-decls) |
|---|
| 814 | (push `(DECLARE (,(car decl) ,name)) other-decls))))))) |
|---|
| 815 | (values (nreverse other-decls) |
|---|
| 816 | (nreverse specific-decls)))) |
|---|
| 817 | |
|---|
| 818 | (defun lambda-list-names (lambda-list) |
|---|
| 819 | "Returns a list of variable names extracted from `lambda-list'." |
|---|
| 820 | (multiple-value-bind |
|---|
| 821 | (req opt key key-p rest allow-key-p aux whole env) |
|---|
| 822 | (parse-lambda-list lambda-list) |
|---|
| 823 | (declare (ignore key-p allow-key-p)) |
|---|
| 824 | (mapcan (lambda (x) |
|---|
| 825 | (mapcar #'first x)) |
|---|
| 826 | (list req opt key aux (list rest) (list whole) (list env))))) |
|---|
| 827 | |
|---|
| 828 | (defun lambda-list-keyword-p (x) |
|---|
| 829 | (memq x lambda-list-keywords)) |
|---|
| 830 | |
|---|
| 831 | (defun rewrite-aux-vars (form) |
|---|
| 832 | (let* ((lambda-list (cadr form)) |
|---|
| 833 | (aux-p (memq '&AUX lambda-list)) |
|---|
| 834 | (post-aux-&environment (memq '&ENVIRONMENT aux-p)) |
|---|
| 835 | (lets (ldiff (cdr aux-p) post-aux-&environment)) ; strip trailing &environment |
|---|
| 836 | aux-vars) |
|---|
| 837 | (unless aux-p |
|---|
| 838 | ;; no rewriting required |
|---|
| 839 | (return-from rewrite-aux-vars form)) |
|---|
| 840 | (dolist (var lets) |
|---|
| 841 | (when (lambda-list-keyword-p var) |
|---|
| 842 | (error 'program-error |
|---|
| 843 | :format-control "Lambda list keyword ~A not allowed after &AUX in ~A." |
|---|
| 844 | :format-arguments (list var lambda-list)))) |
|---|
| 845 | (multiple-value-bind (body decls) |
|---|
| 846 | (parse-body (cddr form)) |
|---|
| 847 | (dolist (form lets) |
|---|
| 848 | (cond ((consp form) |
|---|
| 849 | (push (car form) aux-vars)) |
|---|
| 850 | (t |
|---|
| 851 | (push form aux-vars)))) |
|---|
| 852 | (setf lambda-list |
|---|
| 853 | (append (subseq lambda-list 0 (position '&AUX lambda-list)) |
|---|
| 854 | post-aux-&environment)) |
|---|
| 855 | (multiple-value-bind (let-decls lambda-decls) |
|---|
| 856 | (split-decls decls (lambda-list-names lambda-list)) |
|---|
| 857 | `(lambda ,lambda-list |
|---|
| 858 | ,@lambda-decls |
|---|
| 859 | (let* ,lets |
|---|
| 860 | ,@let-decls |
|---|
| 861 | ,@body)))))) |
|---|
| 862 | |
|---|
| 863 | (defun rewrite-lambda (form) |
|---|
| 864 | (setf form (rewrite-aux-vars form)) |
|---|
| 865 | (let* ((lambda-list (cadr form))) |
|---|
| 866 | (if (not (or (memq '&optional lambda-list) |
|---|
| 867 | (memq '&key lambda-list))) |
|---|
| 868 | ;; no need to rewrite: no arguments with possible initforms anyway |
|---|
| 869 | form |
|---|
| 870 | (multiple-value-bind (body decls doc) |
|---|
| 871 | (parse-body (cddr form)) |
|---|
| 872 | (let (state let-bindings new-lambda-list |
|---|
| 873 | (non-constants 0)) |
|---|
| 874 | (do* ((vars lambda-list (cdr vars)) |
|---|
| 875 | (var (car vars) (car vars))) |
|---|
| 876 | ((endp vars)) |
|---|
| 877 | (push (car vars) new-lambda-list) |
|---|
| 878 | (let ((replacement (gensym))) |
|---|
| 879 | (flet ((parse-compound-argument (arg) |
|---|
| 880 | "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, |
|---|
| 881 | SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." |
|---|
| 882 | (destructuring-bind |
|---|
| 883 | (name &optional (initform nil initform-supplied-p) |
|---|
| 884 | (supplied-p nil supplied-p-supplied-p)) |
|---|
| 885 | (if (listp arg) arg (list arg)) |
|---|
| 886 | (if (listp name) |
|---|
| 887 | (values (cadr name) (car name) |
|---|
| 888 | initform initform-supplied-p |
|---|
| 889 | supplied-p supplied-p-supplied-p) |
|---|
| 890 | (values name (make-keyword name) |
|---|
| 891 | initform initform-supplied-p |
|---|
| 892 | supplied-p supplied-p-supplied-p))))) |
|---|
| 893 | (case var |
|---|
| 894 | (&optional (setf state :optional)) |
|---|
| 895 | (&key (setf state :key)) |
|---|
| 896 | ((&whole &environment &rest &body &allow-other-keys) |
|---|
| 897 | ;; do nothing special |
|---|
| 898 | ) |
|---|
| 899 | (t |
|---|
| 900 | (cond |
|---|
| 901 | ((atom var) |
|---|
| 902 | (setf (car new-lambda-list) |
|---|
| 903 | (if (eq state :key) |
|---|
| 904 | (list (list (make-keyword var) replacement)) |
|---|
| 905 | replacement)) |
|---|
| 906 | (push (list var replacement) let-bindings)) |
|---|
| 907 | ((constantp (second var)) |
|---|
| 908 | ;; so, we must have a consp-type var we're looking at |
|---|
| 909 | ;; and it has a constantp initform |
|---|
| 910 | (multiple-value-bind |
|---|
| 911 | (name keyword initform initform-supplied-p |
|---|
| 912 | supplied-p supplied-p-supplied-p) |
|---|
| 913 | (parse-compound-argument var) |
|---|
| 914 | (let ((var-form (if (eq state :key) |
|---|
| 915 | (list keyword replacement) |
|---|
| 916 | replacement)) |
|---|
| 917 | (supplied-p-replacement (gensym))) |
|---|
| 918 | (setf (car new-lambda-list) |
|---|
| 919 | (cond |
|---|
| 920 | ((not initform-supplied-p) |
|---|
| 921 | (list var-form)) |
|---|
| 922 | ((not supplied-p-supplied-p) |
|---|
| 923 | (list var-form initform)) |
|---|
| 924 | (t |
|---|
| 925 | (list var-form initform |
|---|
| 926 | supplied-p-replacement)))) |
|---|
| 927 | (push (list name replacement) let-bindings) |
|---|
| 928 | ;; if there was a 'supplied-p' variable, it might |
|---|
| 929 | ;; be used in the declarations. Since those will be |
|---|
| 930 | ;; moved below the LET* block, we need to move the |
|---|
| 931 | ;; supplied-p parameter too. |
|---|
| 932 | (when supplied-p-supplied-p |
|---|
| 933 | (push (list supplied-p supplied-p-replacement) |
|---|
| 934 | let-bindings))))) |
|---|
| 935 | (t |
|---|
| 936 | (incf non-constants) |
|---|
| 937 | ;; this is either a keyword or an optional argument |
|---|
| 938 | ;; with a non-constantp initform |
|---|
| 939 | (multiple-value-bind |
|---|
| 940 | (name keyword initform initform-supplied-p |
|---|
| 941 | supplied-p supplied-p-supplied-p) |
|---|
| 942 | (parse-compound-argument var) |
|---|
| 943 | (declare (ignore initform-supplied-p)) |
|---|
| 944 | (let ((var-form (if (eq state :key) |
|---|
| 945 | (list keyword replacement) |
|---|
| 946 | replacement)) |
|---|
| 947 | (supplied-p-replacement (gensym))) |
|---|
| 948 | (setf (car new-lambda-list) |
|---|
| 949 | (list var-form nil supplied-p-replacement)) |
|---|
| 950 | (push (list name `(if ,supplied-p-replacement |
|---|
| 951 | ,replacement ,initform)) |
|---|
| 952 | let-bindings) |
|---|
| 953 | (when supplied-p-supplied-p |
|---|
| 954 | (push (list supplied-p supplied-p-replacement) |
|---|
| 955 | let-bindings))))))))))) |
|---|
| 956 | (if (zerop non-constants) |
|---|
| 957 | ;; there was no reason to rewrite... |
|---|
| 958 | form |
|---|
| 959 | (let ((rv |
|---|
| 960 | `(lambda ,(nreverse new-lambda-list) |
|---|
| 961 | ,@(when doc (list doc)) |
|---|
| 962 | (let* ,(nreverse let-bindings) |
|---|
| 963 | ,@decls ,@body)))) |
|---|
| 964 | rv))))))) |
|---|
| 965 | |
|---|
| 966 | (defun validate-function-name (name) |
|---|
| 967 | (unless (or (symbolp name) (setf-function-name-p name)) |
|---|
| 968 | (compiler-error "~S is not a valid function name." name)) |
|---|
| 969 | name) |
|---|
| 970 | |
|---|
| 971 | (defun construct-flet/labels-function (definition) |
|---|
| 972 | (let* ((name (car definition)) |
|---|
| 973 | (block-name (fdefinition-block-name (validate-function-name name))) |
|---|
| 974 | (lambda-list (cadr definition)) |
|---|
| 975 | (compiland (make-compiland :name name :parent *current-compiland*)) |
|---|
| 976 | (local-function (make-local-function :name name :compiland compiland))) |
|---|
| 977 | (push local-function (compiland-children *current-compiland*)) |
|---|
| 978 | (multiple-value-bind |
|---|
| 979 | (body decls) |
|---|
| 980 | (parse-body (cddr definition)) |
|---|
| 981 | (setf (local-function-definition local-function) |
|---|
| 982 | (copy-tree (cdr definition))) |
|---|
| 983 | (setf (compiland-lambda-expression compiland) |
|---|
| 984 | (rewrite-lambda `(lambda ,lambda-list |
|---|
| 985 | ,@decls |
|---|
| 986 | (block ,block-name |
|---|
| 987 | ,@body))))) |
|---|
| 988 | local-function)) |
|---|
| 989 | |
|---|
| 990 | (defun p1-flet (form) |
|---|
| 991 | (let* ((local-functions |
|---|
| 992 | (mapcar #'(lambda (definition) |
|---|
| 993 | (construct-flet/labels-function definition)) |
|---|
| 994 | (cadr form))) |
|---|
| 995 | (*local-functions* *local-functions*)) |
|---|
| 996 | (dolist (local-function local-functions) |
|---|
| 997 | (p1-compiland (local-function-compiland local-function))) |
|---|
| 998 | (dolist (local-function local-functions) |
|---|
| 999 | (push local-function *local-functions*)) |
|---|
| 1000 | (with-saved-compiler-policy |
|---|
| 1001 | (process-optimization-declarations (cddr form)) |
|---|
| 1002 | (let* ((block (make-flet-node)) |
|---|
| 1003 | (*block* block) |
|---|
| 1004 | (*blocks* (cons block *blocks*)) |
|---|
| 1005 | (body (cddr form)) |
|---|
| 1006 | (*visible-variables* *visible-variables*)) |
|---|
| 1007 | (setf (flet-free-specials block) |
|---|
| 1008 | (process-declarations-for-vars body nil block)) |
|---|
| 1009 | (dolist (special (flet-free-specials block)) |
|---|
| 1010 | (push special *visible-variables*)) |
|---|
| 1011 | (setf body (p1-body body) ;; affects the outcome of references-needed-p |
|---|
| 1012 | (flet-form block) |
|---|
| 1013 | (list* (car form) |
|---|
| 1014 | (remove-if #'(lambda (fn) |
|---|
| 1015 | (and (inline-p (local-function-name fn)) |
|---|
| 1016 | (not (local-function-references-needed-p fn)))) |
|---|
| 1017 | local-functions) |
|---|
| 1018 | body)) |
|---|
| 1019 | block)))) |
|---|
| 1020 | |
|---|
| 1021 | |
|---|
| 1022 | (defun p1-labels (form) |
|---|
| 1023 | (let* ((local-functions |
|---|
| 1024 | (mapcar #'(lambda (definition) |
|---|
| 1025 | (construct-flet/labels-function definition)) |
|---|
| 1026 | (cadr form))) |
|---|
| 1027 | (*local-functions* *local-functions*) |
|---|
| 1028 | (*visible-variables* *visible-variables*)) |
|---|
| 1029 | (dolist (local-function local-functions) |
|---|
| 1030 | (push local-function *local-functions*)) |
|---|
| 1031 | (dolist (local-function local-functions) |
|---|
| 1032 | (p1-compiland (local-function-compiland local-function))) |
|---|
| 1033 | (let* ((block (make-labels-node)) |
|---|
| 1034 | (*block* block) |
|---|
| 1035 | (*blocks* (cons block *blocks*)) |
|---|
| 1036 | (body (cddr form)) |
|---|
| 1037 | (*visible-variables* *visible-variables*)) |
|---|
| 1038 | (setf (labels-free-specials block) |
|---|
| 1039 | (process-declarations-for-vars body nil block)) |
|---|
| 1040 | (dolist (special (labels-free-specials block)) |
|---|
| 1041 | (push special *visible-variables*)) |
|---|
| 1042 | (with-saved-compiler-policy |
|---|
| 1043 | (process-optimization-declarations (cddr form)) |
|---|
| 1044 | (setf (labels-form block) |
|---|
| 1045 | (list* (car form) local-functions (p1-body (cddr form)))) |
|---|
| 1046 | block)))) |
|---|
| 1047 | |
|---|
| 1048 | (defknown p1-funcall (t) t) |
|---|
| 1049 | (defun p1-funcall (form) |
|---|
| 1050 | (unless (> (length form) 1) |
|---|
| 1051 | (compiler-warn "Wrong number of arguments for ~A." (car form)) |
|---|
| 1052 | (return-from p1-funcall form)) |
|---|
| 1053 | (let ((function-form (%cadr form))) |
|---|
| 1054 | (when (and (consp function-form) |
|---|
| 1055 | (eq (%car function-form) 'FUNCTION)) |
|---|
| 1056 | (let ((name (%cadr function-form))) |
|---|
| 1057 | (let ((source-transform (source-transform name))) |
|---|
| 1058 | (when source-transform |
|---|
| 1059 | (let ((new-form (expand-source-transform (list* name (cddr form))))) |
|---|
| 1060 | (return-from p1-funcall (p1 new-form))) |
|---|
| 1061 | ))))) |
|---|
| 1062 | ;; Otherwise... |
|---|
| 1063 | (p1-function-call form)) |
|---|
| 1064 | |
|---|
| 1065 | (defun p1-function (form) |
|---|
| 1066 | (let ((form (copy-tree form)) |
|---|
| 1067 | local-function) |
|---|
| 1068 | (cond ((and (consp (cadr form)) |
|---|
| 1069 | (or (eq (caadr form) 'LAMBDA) |
|---|
| 1070 | (eq (caadr form) 'NAMED-LAMBDA))) |
|---|
| 1071 | (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA)) |
|---|
| 1072 | (named-lambda-form (when named-lambda-p |
|---|
| 1073 | (cadr form))) |
|---|
| 1074 | (name (when named-lambda-p |
|---|
| 1075 | (cadr named-lambda-form))) |
|---|
| 1076 | (lambda-form (if named-lambda-p |
|---|
| 1077 | (cons 'LAMBDA (cddr named-lambda-form)) |
|---|
| 1078 | (cadr form))) |
|---|
| 1079 | (lambda-list (cadr lambda-form)) |
|---|
| 1080 | (body (cddr lambda-form)) |
|---|
| 1081 | (compiland (make-compiland :name (if named-lambda-p |
|---|
| 1082 | name (gensym "ANONYMOUS-LAMBDA-")) |
|---|
| 1083 | :lambda-expression lambda-form |
|---|
| 1084 | :parent *current-compiland*)) |
|---|
| 1085 | (local-function (make-local-function :compiland compiland))) |
|---|
| 1086 | (push local-function (compiland-children *current-compiland*)) |
|---|
| 1087 | (multiple-value-bind (body decls) |
|---|
| 1088 | (parse-body body) |
|---|
| 1089 | (setf (compiland-lambda-expression compiland) |
|---|
| 1090 | ;; if there still was a doc-string present, remove it |
|---|
| 1091 | (rewrite-lambda |
|---|
| 1092 | `(lambda ,lambda-list ,@decls ,@body))) |
|---|
| 1093 | (let ((*visible-variables* *visible-variables*) |
|---|
| 1094 | (*current-compiland* compiland)) |
|---|
| 1095 | (p1-compiland compiland))) |
|---|
| 1096 | (list 'FUNCTION local-function))) |
|---|
| 1097 | ((setf local-function (find-local-function (cadr form))) |
|---|
| 1098 | (dformat "p1-function local function ~S~%" (cadr form)) |
|---|
| 1099 | ;;we found out that the function needs a reference |
|---|
| 1100 | (setf (local-function-references-needed-p local-function) t) |
|---|
| 1101 | form) |
|---|
| 1102 | (t |
|---|
| 1103 | form)))) |
|---|
| 1104 | |
|---|
| 1105 | (defun p1-lambda (form) |
|---|
| 1106 | (setf form (rewrite-lambda form)) |
|---|
| 1107 | (let* ((lambda-list (cadr form))) |
|---|
| 1108 | (when (or (memq '&optional lambda-list) |
|---|
| 1109 | (memq '&key lambda-list)) |
|---|
| 1110 | (let ((state nil)) |
|---|
| 1111 | (dolist (arg lambda-list) |
|---|
| 1112 | (cond ((memq arg lambda-list-keywords) |
|---|
| 1113 | (setf state arg)) |
|---|
| 1114 | ((memq state '(&optional &key)) |
|---|
| 1115 | (when (and (consp arg) |
|---|
| 1116 | (not (constantp (second arg)))) |
|---|
| 1117 | (compiler-unsupported |
|---|
| 1118 | "P1-LAMBDA: can't handle optional argument with non-constant initform."))))))) |
|---|
| 1119 | (p1-function (list 'FUNCTION form)))) |
|---|
| 1120 | |
|---|
| 1121 | (defun p1-eval-when (form) |
|---|
| 1122 | (list* (car form) (cadr form) (mapcar #'p1 (cddr form)))) |
|---|
| 1123 | |
|---|
| 1124 | (defknown p1-progv (t) t) |
|---|
| 1125 | (defun p1-progv (form) |
|---|
| 1126 | ;; We've already checked argument count in PRECOMPILE-PROGV. |
|---|
| 1127 | (let* ((symbols-form (p1 (cadr form))) |
|---|
| 1128 | (values-form (p1 (caddr form))) |
|---|
| 1129 | (block (make-progv-node)) |
|---|
| 1130 | (*block* block) |
|---|
| 1131 | (*blocks* (cons block *blocks*)) |
|---|
| 1132 | (body (cdddr form))) |
|---|
| 1133 | ;; The (commented out) block below means to detect compile-time |
|---|
| 1134 | ;; enumeration of bindings to be created (a quoted form in the symbols |
|---|
| 1135 | ;; position). |
|---|
| 1136 | ;; (when (and (quoted-form-p symbols-form) |
|---|
| 1137 | ;; (listp (second symbols-form))) |
|---|
| 1138 | ;; (dolist (name (second symbols-form)) |
|---|
| 1139 | ;; (let ((variable (make-variable :name name :special-p t))) |
|---|
| 1140 | ;; (push |
|---|
| 1141 | (setf (progv-environment-register block) t |
|---|
| 1142 | (progv-form block) |
|---|
| 1143 | `(progv ,symbols-form ,values-form ,@(p1-body body))) |
|---|
| 1144 | block)) |
|---|
| 1145 | |
|---|
| 1146 | (defun p1-quote (form) |
|---|
| 1147 | (unless (= (length form) 2) |
|---|
| 1148 | (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)." |
|---|
| 1149 | 'QUOTE |
|---|
| 1150 | (1- (length form)))) |
|---|
| 1151 | (let ((arg (%cadr form))) |
|---|
| 1152 | (if (or (numberp arg) (characterp arg)) |
|---|
| 1153 | arg |
|---|
| 1154 | form))) |
|---|
| 1155 | |
|---|
| 1156 | (defun p1-setq (form) |
|---|
| 1157 | (unless (= (length form) 3) |
|---|
| 1158 | (error "Too many arguments for SETQ.")) |
|---|
| 1159 | (let ((arg1 (%cadr form)) |
|---|
| 1160 | (arg2 (%caddr form))) |
|---|
| 1161 | (let ((variable (find-visible-variable arg1))) |
|---|
| 1162 | (if variable |
|---|
| 1163 | (progn |
|---|
| 1164 | (when (variable-ignore-p variable) |
|---|
| 1165 | (compiler-style-warn |
|---|
| 1166 | "Variable ~S is assigned even though it was declared to be ignored." |
|---|
| 1167 | (variable-name variable))) |
|---|
| 1168 | (incf (variable-writes variable)) |
|---|
| 1169 | (cond ((eq (variable-compiland variable) *current-compiland*) |
|---|
| 1170 | (dformat t "p1-setq: write ~S~%" arg1)) |
|---|
| 1171 | (t |
|---|
| 1172 | (dformat t "p1-setq: non-local write ~S~%" arg1) |
|---|
| 1173 | (setf (variable-used-non-locally-p variable) t)))) |
|---|
| 1174 | (dformat t "p1-setq: unknown variable ~S~%" arg1))) |
|---|
| 1175 | (list 'SETQ arg1 (p1 arg2)))) |
|---|
| 1176 | |
|---|
| 1177 | (defun p1-the (form) |
|---|
| 1178 | (unless (= (length form) 3) |
|---|
| 1179 | (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)." |
|---|
| 1180 | 'THE |
|---|
| 1181 | (1- (length form)))) |
|---|
| 1182 | (let ((type (%cadr form)) |
|---|
| 1183 | (expr (%caddr form))) |
|---|
| 1184 | (cond ((and (listp type) (eq (car type) 'VALUES)) |
|---|
| 1185 | ;; FIXME |
|---|
| 1186 | (p1 expr)) |
|---|
| 1187 | ((= *safety* 3) |
|---|
| 1188 | (let* ((sym (gensym)) |
|---|
| 1189 | (new-expr `(let ((,sym ,expr)) |
|---|
| 1190 | (require-type ,sym ',type) |
|---|
| 1191 | ,sym))) |
|---|
| 1192 | (p1 new-expr))) |
|---|
| 1193 | ((and (<= 1 *safety* 2) ;; at safety 1 or 2 check relatively |
|---|
| 1194 | (symbolp type)) ;; simple types (those specified by a single symbol) |
|---|
| 1195 | (let* ((sym (gensym)) |
|---|
| 1196 | (new-expr `(let ((,sym ,expr)) |
|---|
| 1197 | (require-type ,sym ',type) |
|---|
| 1198 | ,sym))) |
|---|
| 1199 | (p1 new-expr))) |
|---|
| 1200 | (t |
|---|
| 1201 | (list 'THE type (p1 expr)))))) |
|---|
| 1202 | |
|---|
| 1203 | (defun p1-truly-the (form) |
|---|
| 1204 | (unless (= (length form) 3) |
|---|
| 1205 | (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)." |
|---|
| 1206 | 'TRULY-THE |
|---|
| 1207 | (1- (length form)))) |
|---|
| 1208 | (list 'TRULY-THE (%cadr form) (p1 (%caddr form)))) |
|---|
| 1209 | |
|---|
| 1210 | (defknown p1-throw (t) t) |
|---|
| 1211 | (defun p1-throw (form) |
|---|
| 1212 | (list* 'THROW (mapcar #'p1 (cdr form)))) |
|---|
| 1213 | |
|---|
| 1214 | (defknown rewrite-function-call (t) t) |
|---|
| 1215 | (defun rewrite-function-call (form) |
|---|
| 1216 | (let ((op (car form)) (args (cdr form))) |
|---|
| 1217 | (cond |
|---|
| 1218 | ((and (eq op 'funcall) (listp (car args)) (eq (caar args) 'lambda)) |
|---|
| 1219 | ;;(funcall (lambda (...) ...) ...) |
|---|
| 1220 | (let ((op (car args)) (args (cdr args))) |
|---|
| 1221 | (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) |
|---|
| 1222 | args))) |
|---|
| 1223 | ((and (listp op) (eq (car op) 'lambda)) |
|---|
| 1224 | ;;((lambda (...) ...) ...) |
|---|
| 1225 | (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args)) |
|---|
| 1226 | (t form)))) |
|---|
| 1227 | |
|---|
| 1228 | (defknown p1-function-call (t) t) |
|---|
| 1229 | (defun p1-function-call (form) |
|---|
| 1230 | (let ((new-form (rewrite-function-call form))) |
|---|
| 1231 | (when (neq new-form form) |
|---|
| 1232 | (return-from p1-function-call (p1 new-form)))) |
|---|
| 1233 | (let* ((op (car form)) |
|---|
| 1234 | (local-function (find-local-function op))) |
|---|
| 1235 | (when local-function |
|---|
| 1236 | (when (and *enable-inline-expansion* (inline-p op) |
|---|
| 1237 | (local-function-definition local-function)) |
|---|
| 1238 | (let* ((definition (local-function-definition local-function)) |
|---|
| 1239 | (lambda-list (car definition)) |
|---|
| 1240 | (body (cdr definition)) |
|---|
| 1241 | (expansion (generate-inline-expansion op lambda-list body |
|---|
| 1242 | (cdr form)))) |
|---|
| 1243 | (when expansion |
|---|
| 1244 | (let ((explain *explain*)) |
|---|
| 1245 | (when (and explain (memq :calls explain)) |
|---|
| 1246 | (format t "; inlining call to local function ~S~%" op))) |
|---|
| 1247 | (return-from p1-function-call |
|---|
| 1248 | (let ((*inline-declarations* |
|---|
| 1249 | (remove op *inline-declarations* :key #'car :test #'equal))) |
|---|
| 1250 | (p1 expansion)))))))) |
|---|
| 1251 | (p1-default form)) |
|---|
| 1252 | |
|---|
| 1253 | (defun %funcall (fn &rest args) |
|---|
| 1254 | "Dummy FUNCALL wrapper to force p1 not to optimize the call." |
|---|
| 1255 | (apply fn args)) |
|---|
| 1256 | |
|---|
| 1257 | (defun p1-variable-reference (var) |
|---|
| 1258 | (let ((variable (find-visible-variable var))) |
|---|
| 1259 | (when (null variable) |
|---|
| 1260 | (unless (or (special-variable-p var) |
|---|
| 1261 | (memq var *undefined-variables*)) |
|---|
| 1262 | (compiler-style-warn |
|---|
| 1263 | "Undefined variable ~S assumed special" var) |
|---|
| 1264 | (push var *undefined-variables*)) |
|---|
| 1265 | (setf variable (make-variable :name var :special-p t)) |
|---|
| 1266 | (push variable *visible-variables*)) |
|---|
| 1267 | (let ((ref (make-var-ref variable))) |
|---|
| 1268 | (unless (variable-special-p variable) |
|---|
| 1269 | (when (variable-ignore-p variable) |
|---|
| 1270 | (compiler-style-warn |
|---|
| 1271 | "Variable ~S is read even though it was declared to be ignored." |
|---|
| 1272 | (variable-name variable))) |
|---|
| 1273 | (push ref (variable-references variable)) |
|---|
| 1274 | (incf (variable-reads variable)) |
|---|
| 1275 | (cond |
|---|
| 1276 | ((eq (variable-compiland variable) *current-compiland*) |
|---|
| 1277 | (dformat t "p1: read ~S~%" var)) |
|---|
| 1278 | (t |
|---|
| 1279 | (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" |
|---|
| 1280 | var |
|---|
| 1281 | (compiland-name (variable-compiland variable)) |
|---|
| 1282 | (compiland-name *current-compiland*)) |
|---|
| 1283 | (setf (variable-used-non-locally-p variable) t)))) |
|---|
| 1284 | ref))) |
|---|
| 1285 | |
|---|
| 1286 | (defknown p1 (t) t) |
|---|
| 1287 | (defun p1 (form) |
|---|
| 1288 | (cond |
|---|
| 1289 | ((symbolp form) |
|---|
| 1290 | (let (value) |
|---|
| 1291 | (cond |
|---|
| 1292 | ((null form) |
|---|
| 1293 | form) |
|---|
| 1294 | ((eq form t) |
|---|
| 1295 | form) |
|---|
| 1296 | ((keywordp form) |
|---|
| 1297 | form) |
|---|
| 1298 | ((and (constantp form) |
|---|
| 1299 | (progn |
|---|
| 1300 | (setf value (symbol-value form)) |
|---|
| 1301 | (or (numberp value) |
|---|
| 1302 | (stringp value) |
|---|
| 1303 | (pathnamep value)))) |
|---|
| 1304 | (setf form value)) |
|---|
| 1305 | (t |
|---|
| 1306 | (p1-variable-reference form))))) |
|---|
| 1307 | ((atom form) |
|---|
| 1308 | form) |
|---|
| 1309 | (t |
|---|
| 1310 | (let ((op (%car form)) |
|---|
| 1311 | handler) |
|---|
| 1312 | (cond |
|---|
| 1313 | ((symbolp op) |
|---|
| 1314 | (when (find-local-function op) |
|---|
| 1315 | ;; local functions shadow macros and functions in |
|---|
| 1316 | ;; the global environment as well as compiler macros |
|---|
| 1317 | (return-from p1 |
|---|
| 1318 | (p1-function-call form))) |
|---|
| 1319 | (when (compiler-macro-function op) |
|---|
| 1320 | (unless (notinline-p op) |
|---|
| 1321 | (multiple-value-bind (expansion expanded-p) |
|---|
| 1322 | (compiler-macroexpand form) |
|---|
| 1323 | ;; Fall through if no change... |
|---|
| 1324 | (when expanded-p |
|---|
| 1325 | (return-from p1 (p1 expansion)))))) |
|---|
| 1326 | (cond |
|---|
| 1327 | ((setf handler (get op 'p1-handler)) |
|---|
| 1328 | (funcall handler form)) |
|---|
| 1329 | ((macro-function op *compile-file-environment*) |
|---|
| 1330 | (p1 (macroexpand form *compile-file-environment*))) |
|---|
| 1331 | ((special-operator-p op) |
|---|
| 1332 | (compiler-unsupported "P1: unsupported special operator ~S" op)) |
|---|
| 1333 | (t |
|---|
| 1334 | (p1-function-call form)))) |
|---|
| 1335 | ((and (consp op) (eq (%car op) 'LAMBDA)) |
|---|
| 1336 | (let ((maybe-optimized-call (rewrite-function-call form))) |
|---|
| 1337 | (if (eq maybe-optimized-call form) |
|---|
| 1338 | (p1 `(%funcall (function ,op) ,@(cdr form))) |
|---|
| 1339 | (p1 maybe-optimized-call)))) |
|---|
| 1340 | (t |
|---|
| 1341 | (compiler-unsupported "P1 unhandled case ~S" form))))))) |
|---|
| 1342 | |
|---|
| 1343 | (defun install-p1-handler (symbol handler) |
|---|
| 1344 | (setf (get symbol 'p1-handler) handler)) |
|---|
| 1345 | |
|---|
| 1346 | (defun initialize-p1-handlers () |
|---|
| 1347 | (dolist (pair '((AND p1-default) |
|---|
| 1348 | (BLOCK p1-block) |
|---|
| 1349 | (CATCH p1-catch) |
|---|
| 1350 | (DECLARE identity) |
|---|
| 1351 | (EVAL-WHEN p1-eval-when) |
|---|
| 1352 | (FLET p1-flet) |
|---|
| 1353 | (FUNCALL p1-funcall) |
|---|
| 1354 | (FUNCTION p1-function) |
|---|
| 1355 | (GO p1-go) |
|---|
| 1356 | (IF p1-default) |
|---|
| 1357 | ;; used to be p1-if, which was used to rewrite the test |
|---|
| 1358 | ;; form to a LET-binding; that's not necessary, because |
|---|
| 1359 | ;; the test form doesn't lead to multiple operands on the |
|---|
| 1360 | ;; operand stack |
|---|
| 1361 | (LABELS p1-labels) |
|---|
| 1362 | (LAMBDA p1-lambda) |
|---|
| 1363 | (LET p1-let/let*) |
|---|
| 1364 | (LET* p1-let/let*) |
|---|
| 1365 | (LOAD-TIME-VALUE identity) |
|---|
| 1366 | (LOCALLY p1-locally) |
|---|
| 1367 | (MULTIPLE-VALUE-BIND p1-m-v-b) |
|---|
| 1368 | (MULTIPLE-VALUE-CALL p1-default) |
|---|
| 1369 | (MULTIPLE-VALUE-LIST p1-default) |
|---|
| 1370 | (MULTIPLE-VALUE-PROG1 p1-default) |
|---|
| 1371 | (OR p1-default) |
|---|
| 1372 | (PROGN p1-default) |
|---|
| 1373 | (PROGV p1-progv) |
|---|
| 1374 | (QUOTE p1-quote) |
|---|
| 1375 | (RETURN-FROM p1-return-from) |
|---|
| 1376 | (SETQ p1-setq) |
|---|
| 1377 | (SYMBOL-MACROLET identity) |
|---|
| 1378 | (TAGBODY p1-tagbody) |
|---|
| 1379 | (THE p1-the) |
|---|
| 1380 | (THROW p1-throw) |
|---|
| 1381 | (TRULY-THE p1-truly-the) |
|---|
| 1382 | (UNWIND-PROTECT p1-unwind-protect) |
|---|
| 1383 | (THREADS:SYNCHRONIZED-ON |
|---|
| 1384 | p1-threads-synchronized-on) |
|---|
| 1385 | (JAVA:JRUN-EXCEPTION-PROTECTED |
|---|
| 1386 | p1-java-jrun-exception-protected) |
|---|
| 1387 | (JVM::WITH-INLINE-CODE identity))) |
|---|
| 1388 | (install-p1-handler (%car pair) (%cadr pair)))) |
|---|
| 1389 | |
|---|
| 1390 | (initialize-p1-handlers) |
|---|
| 1391 | |
|---|
| 1392 | (defun p1-compiland (compiland) |
|---|
| 1393 | (let ((*current-compiland* compiland) |
|---|
| 1394 | (*local-functions* *local-functions*) |
|---|
| 1395 | (*visible-variables* *visible-variables*) |
|---|
| 1396 | (form (compiland-lambda-expression compiland))) |
|---|
| 1397 | (aver (eq (car form) 'LAMBDA)) |
|---|
| 1398 | (setf form (rewrite-lambda form)) |
|---|
| 1399 | (with-saved-compiler-policy |
|---|
| 1400 | (process-optimization-declarations (cddr form)) |
|---|
| 1401 | |
|---|
| 1402 | (let* ((lambda-list (cadr form)) |
|---|
| 1403 | (body (cddr form)) |
|---|
| 1404 | (closure (make-closure `(lambda ,lambda-list nil) nil)) |
|---|
| 1405 | (syms (sys::varlist closure)) |
|---|
| 1406 | (vars nil) |
|---|
| 1407 | compiland-result) |
|---|
| 1408 | (dolist (sym syms) |
|---|
| 1409 | (let ((var (make-variable :name sym |
|---|
| 1410 | :special-p (special-variable-p sym)))) |
|---|
| 1411 | (push var vars) |
|---|
| 1412 | (push var *all-variables*) |
|---|
| 1413 | (push var *visible-variables*))) |
|---|
| 1414 | (setf (compiland-arg-vars compiland) (nreverse vars)) |
|---|
| 1415 | (let ((free-specials (process-declarations-for-vars body vars nil))) |
|---|
| 1416 | (setf (compiland-free-specials compiland) free-specials) |
|---|
| 1417 | (dolist (var free-specials) |
|---|
| 1418 | (push var *visible-variables*))) |
|---|
| 1419 | (setf compiland-result |
|---|
| 1420 | (list* 'LAMBDA lambda-list (p1-body body))) |
|---|
| 1421 | (setf (compiland-%single-valued-p compiland) |
|---|
| 1422 | (single-valued-p compiland-result)) |
|---|
| 1423 | (setf (compiland-p1-result compiland) |
|---|
| 1424 | compiland-result))))) |
|---|
| 1425 | |
|---|
| 1426 | (provide "COMPILER-PASS1") |
|---|
