Changeset 11845


Ignore:
Timestamp:
05/08/09 21:52:36 (12 years ago)
Author:
ehuelsmann
Message:

Use WITH-SAVED-COMPILER-POLICY in COMPILE-FILE.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r11843 r11845  
    138138                  (block-name (fdefinition-block-name name))
    139139                  (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
    169153                      (setf form
    170154                            `(fset ',name
    171                                    ,precompiled-function
     155                                   (load-compiled-function ,(file-namestring classfile))
    172156                                   ,*source-position*
    173157                                   ',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))
    178175                 ;; FIXME Need to support SETF functions too!
    179                  (setf (inline-expansion name)
    180                        (jvm::generate-inline-expansion block-name
    181                                                        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))))
    186183             (push name jvm::*functions-defined-in-current-file*)
    187184             (note-name-defined name)
     
    239236          (LOCALLY
    240237           ;; 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
    246239             (multiple-value-bind (forms decls)
    247240                 (parse-body (cdr form) nil)
     
    256249          (t
    257250           (when (and (symbolp operator)
    258                         (macro-function operator *compile-file-environment*))
     251                      (macro-function operator *compile-file-environment*))
    259252             (note-toplevel-form form)
    260253             ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
     
    338331               (eq (%car function-form) 'FUNCTION))
    339332      (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
    344334          (let* ((classfile-name (next-classfile-name))
    345335                 (classfile (report-error
     
    430420          (format t "; Compiling ~A ...~%" namestring))
    431421        (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)
    433424            (let ((*readtable* *readtable*)
    434425                  (*read-default-float-format* *read-default-float-format*)
    435426                  (*read-base* *read-base*)
    436427                  (*package* *package*)
    437                   (*speed* *speed*)
    438                   (*space* *space*)
    439                   (*safety* *safety*)
    440                   (*debug* *debug*)
    441                   (*explain* *explain*)
    442428                  (jvm::*functions-defined-in-current-file* '())
    443429                  (*fbound-names* '())
    444430                  (*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)
    450434                  (%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)))))))
    473462        (rename-file temp-file output-file)
    474463
    475464        (when *compile-file-zip*
    476465          (let* ((type ;; Don't use ".zip", it'll result in an extension
    477                        ;;  with a dot, which is rejected by NAMESTRING
     466                  ;;  with a dot, which is rejected by NAMESTRING
    478467                  (%format nil "~A~A" (pathname-type output-file) "-zip"))
    479468                 (zipfile (namestring
     
    499488        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
    500489        (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))))
    502492    (values (truename output-file) warnings-p failure-p)))
    503493
Note: See TracChangeset for help on using the changeset viewer.