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