Changeset 11845
- Timestamp:
- 05/08/09 21:52:36 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
r11843 r11845 138 138 (block-name (fdefinition-block-name name)) 139 139 (lambda-list (third form)) 140 (body (nthcdr 3 form)) 141 (*speed* *speed*) 142 (*space* *space*) 143 (*safety* *safety*) 144 (*debug* *debug*)) 145 (multiple-value-bind (body decls doc) 146 (parse-body body) 147 (let* ((expr `(lambda ,lambda-list 148 ,@decls (block ,block-name ,@body))) 149 (classfile-name (next-classfile-name)) 150 (classfile (report-error 151 (jvm:compile-defun name expr nil 152 classfile-name))) 153 (compiled-function (verify-load classfile))) 154 (cond 155 (compiled-function 156 (setf form 157 `(fset ',name 158 (load-compiled-function ,(file-namestring classfile)) 159 ,*source-position* 160 ',lambda-list 161 ,doc)) 162 (when compile-time-too 163 (fset name compiled-function))) 164 (t 165 ;; FIXME Should be a warning or error of some sort... 166 (format *error-output* 167 "; Unable to compile function ~A~%" name) 168 (let ((precompiled-function (precompile-form expr nil))) 140 (body (nthcdr 3 form))) 141 (jvm::with-saved-compiler-policy 142 (multiple-value-bind (body decls doc) 143 (parse-body body) 144 (let* ((expr `(lambda ,lambda-list 145 ,@decls (block ,block-name ,@body))) 146 (classfile-name (next-classfile-name)) 147 (classfile (report-error 148 (jvm:compile-defun name expr nil 149 classfile-name))) 150 (compiled-function (verify-load classfile))) 151 (cond 152 (compiled-function 169 153 (setf form 170 154 `(fset ',name 171 ,precompiled-function155 (load-compiled-function ,(file-namestring classfile)) 172 156 ,*source-position* 173 157 ',lambda-list 174 ,doc))) 175 (when compile-time-too 176 (eval form))))) 177 (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) 158 ,doc)) 159 (when compile-time-too 160 (fset name compiled-function))) 161 (t 162 ;; FIXME Should be a warning or error of some sort... 163 (format *error-output* 164 "; Unable to compile function ~A~%" name) 165 (let ((precompiled-function (precompile-form expr nil))) 166 (setf form 167 `(fset ',name 168 ,precompiled-function 169 ,*source-position* 170 ',lambda-list 171 ,doc))) 172 (when compile-time-too 173 (eval form))))) 174 (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) 178 175 ;; FIXME Need to support SETF functions too! 179 (setf (inline-expansion name)180 (jvm::generate-inline-expansion block-name181 lambda-list body))182 (dump-form `(setf (inline-expansion ',name)183 ',(inline-expansion name))184 stream)185 (%stream-terpri stream)))176 (setf (inline-expansion name) 177 (jvm::generate-inline-expansion block-name 178 lambda-list body)) 179 (dump-form `(setf (inline-expansion ',name) 180 ',(inline-expansion name)) 181 stream) 182 (%stream-terpri stream)))) 186 183 (push name jvm::*functions-defined-in-current-file*) 187 184 (note-name-defined name) … … 239 236 (LOCALLY 240 237 ;; FIXME Need to handle special declarations too! 241 (let ((*speed* *speed*) 242 (*safety* *safety*) 243 (*debug* *debug*) 244 (*space* *space*) 245 (*inline-declarations* *inline-declarations*)) 238 (jvm::with-saved-compiler-policy 246 239 (multiple-value-bind (forms decls) 247 240 (parse-body (cdr form) nil) … … 256 249 (t 257 250 (when (and (symbolp operator) 258 251 (macro-function operator *compile-file-environment*)) 259 252 (note-toplevel-form form) 260 253 ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in … … 338 331 (eq (%car function-form) 'FUNCTION)) 339 332 (let ((lambda-expression (cadr function-form))) 340 (let* ((*speed* *speed*) 341 (*space* *space*) 342 (*safety* *safety*) 343 (*debug* *debug*)) 333 (jvm::with-saved-compiler-policy 344 334 (let* ((classfile-name (next-classfile-name)) 345 335 (classfile (report-error … … 430 420 (format t "; Compiling ~A ...~%" namestring)) 431 421 (with-compilation-unit () 432 (with-open-file (out temp-file :direction :output :if-exists :supersede) 422 (with-open-file (out temp-file 423 :direction :output :if-exists :supersede) 433 424 (let ((*readtable* *readtable*) 434 425 (*read-default-float-format* *read-default-float-format*) 435 426 (*read-base* *read-base*) 436 427 (*package* *package*) 437 (*speed* *speed*)438 (*space* *space*)439 (*safety* *safety*)440 (*debug* *debug*)441 (*explain* *explain*)442 428 (jvm::*functions-defined-in-current-file* '()) 443 429 (*fbound-names* '()) 444 430 (*fasl-anonymous-package* (%make-package))) 445 (jvm::with-file-compilation 446 (write "; -*- Mode: Lisp -*-" :escape nil :stream out) 447 (%stream-terpri out) 448 (let ((*package* (find-package '#:cl))) 449 (write (list 'init-fasl :version *fasl-version*) :stream out) 431 (jvm::with-saved-compiler-policy 432 (jvm::with-file-compilation 433 (write "; -*- Mode: Lisp -*-" :escape nil :stream out) 450 434 (%stream-terpri out) 451 (write (list 'setq '*source* *compile-file-truename*) :stream out) 452 (%stream-terpri out)) 453 (handler-bind ((style-warning #'(lambda (c) 454 (declare (ignore c)) 455 (setf warnings-p t) 456 nil)) 457 ((or warning 458 compiler-error) #'(lambda (c) 459 (declare (ignore c)) 460 (setf warnings-p t 461 failure-p t) 462 nil))) 463 (loop 464 (let* ((*source-position* (file-position in)) 465 (jvm::*source-line-number* (stream-line-number in)) 466 (form (read in nil in)) 467 (*compiler-error-context* form)) 468 (when (eq form in) 469 (return)) 470 (process-toplevel-form form out nil)))) 471 (dolist (name *fbound-names*) 472 (fmakunbound name)))))) 435 (let ((*package* (find-package '#:cl))) 436 (write (list 'init-fasl :version *fasl-version*) 437 :stream out) 438 (%stream-terpri out) 439 (write (list 'setq '*source* *compile-file-truename*) 440 :stream out) 441 (%stream-terpri out)) 442 (handler-bind ((style-warning #'(lambda (c) 443 (declare (ignore c)) 444 (setf warnings-p t) 445 nil)) 446 ((or warning 447 compiler-error) #'(lambda (c) 448 (declare (ignore c)) 449 (setf warnings-p t 450 failure-p t) 451 nil))) 452 (loop 453 (let* ((*source-position* (file-position in)) 454 (jvm::*source-line-number* (stream-line-number in)) 455 (form (read in nil in)) 456 (*compiler-error-context* form)) 457 (when (eq form in) 458 (return)) 459 (process-toplevel-form form out nil)))) 460 (dolist (name *fbound-names*) 461 (fmakunbound name))))))) 473 462 (rename-file temp-file output-file) 474 463 475 464 (when *compile-file-zip* 476 465 (let* ((type ;; Don't use ".zip", it'll result in an extension 477 466 ;; with a dot, which is rejected by NAMESTRING 478 467 (%format nil "~A~A" (pathname-type output-file) "-zip")) 479 468 (zipfile (namestring … … 499 488 (setf elapsed (/ (- (get-internal-real-time) start) 1000.0)) 500 489 (when *compile-verbose* 501 (format t "~&; Wrote ~A (~A seconds)~%" (namestring output-file) elapsed)))) 490 (format t "~&; Wrote ~A (~A seconds)~%" 491 (namestring output-file) elapsed)))) 502 492 (values (truename output-file) warnings-p failure-p))) 503 493
Note: See TracChangeset
for help on using the changeset viewer.
