Changeset 15581


Ignore:
Timestamp:
05/23/22 06:23:39 (9 months ago)
Author:
Mark Evenson
Message:

whitespace: normalize to SLIME conventions

File:
1 edited

Legend:

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

    r15580 r15581  
    5757(declaim (ftype (function (t) t) compute-classfile))
    5858(defun compute-classfile (n &optional (output-file-pathname
    59                                             *output-file-pathname*))
     59                                       *output-file-pathname*))
    6060  "Computes the pathname of the class file associated with number `n'."
    6161  (let ((name
    62          (sanitize-class-name
    63           (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
     62          (sanitize-class-name
     63           (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
    6464    (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*)
    65                                  output-file-pathname)))
     65                     output-file-pathname)))
    6666
    6767(defun sanitize-class-name (name)
     
    189189         (classfile (next-classfile))
    190190         (result
    191           (with-open-file
    192               (f classfile
    193                  :direction :output
    194                  :element-type '(unsigned-byte 8)
    195                  :if-exists :supersede)
    196             (report-error (jvm:compile-defun nil
    197                                              expr *compile-file-environment*
    198                                              classfile f
    199                                              declare-inline))))
     191           (with-open-file
     192               (f classfile
     193                  :direction :output
     194                  :element-type '(unsigned-byte 8)
     195                  :if-exists :supersede)
     196             (report-error (jvm:compile-defun nil
     197                                              expr *compile-file-environment*
     198                                              classfile f
     199                                              declare-inline))))
    200200         (compiled-function (verify-load classfile)))
    201201    (declare (ignore toplevel-form result))
     
    203203      #+nil
    204204      (when (> *debug* 0)
    205 ;; TODO        (annotate form toplevel-form classfile compiled-function fasl-class-number)
     205        ;; TODO        (annotate form toplevel-form classfile compiled-function fasl-class-number)
    206206        ;;; ??? define an API by perhaps exporting these symbols?
    207207        (setf (getf form 'form-source)
     
    240240(defun process-toplevel-macrolet (form stream compile-time-too)
    241241  (let ((*compile-file-environment*
    242          (make-environment *compile-file-environment*)))
     242          (make-environment *compile-file-environment*)))
    243243    (dolist (definition (cadr form))
    244244      (environment-add-macro-definition *compile-file-environment*
     
    331331                  (function-form (getf tail key)))
    332332             (when (and function-form (consp function-form)
    333                (eq (%car function-form) 'FUNCTION))
     333                        (eq (%car function-form) 'FUNCTION))
    334334               (let ((lambda-expression (cadr function-form)))
    335335                 (jvm::with-saved-compiler-policy
    336                      (let* ((saved-class-number *class-number*)
    337                             (classfile (next-classfile))
    338                             (result
    339                              (with-open-file
    340                                  (f classfile
    341                                     :direction :output
    342                                     :element-type '(unsigned-byte 8)
    343                                     :if-exists :supersede)
    344                                (report-error
    345                                 (jvm:compile-defun nil lambda-expression
    346                                                    *compile-file-environment*
    347                                                    classfile f nil))))
    348                             (compiled-function (verify-load classfile)))
    349                        (declare (ignore result))
    350                        (cond
    351                          (compiled-function
    352                           (setf (getf tail key)
    353                                 `(sys::get-fasl-function *fasl-loader*
    354                                                          ,saved-class-number)))
    355                          (t
    356                           ;; FIXME This should be a warning or error of some sort...
    357                           (format *error-output* "; Unable to compile method~%"))))))))))
     336                   (let* ((saved-class-number *class-number*)
     337                          (classfile (next-classfile))
     338                          (result
     339                            (with-open-file
     340                                (f classfile
     341                                   :direction :output
     342                                   :element-type '(unsigned-byte 8)
     343                                   :if-exists :supersede)
     344                              (report-error
     345                               (jvm:compile-defun nil lambda-expression
     346                                                  *compile-file-environment*
     347                                                  classfile f nil))))
     348                          (compiled-function (verify-load classfile)))
     349                     (declare (ignore result))
     350                     (cond
     351                       (compiled-function
     352                        (setf (getf tail key)
     353                              `(sys::get-fasl-function *fasl-loader*
     354                                                       ,saved-class-number)))
     355                       (t
     356                        ;; FIXME This should be a warning or error of some sort...
     357                        (format *error-output* "; Unable to compile method~%"))))))))))
    358358    (when compile-time-too
    359359      (let* ((copy-form (copy-tree form))
     
    451451            (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
    452452            the types of situations present in the list."
    453             ; Adapted from SBCL.
     453                                        ; Adapted from SBCL.
    454454           (when (or (not (listp situations))
    455455                     (set-difference situations
     
    509509(defun process-toplevel-locally (form stream compile-time-too)
    510510  (jvm::with-saved-compiler-policy
    511       (multiple-value-bind (forms decls)
    512           (parse-body (cdr form) nil)
    513         (process-optimization-declarations decls)
    514         (let* ((jvm::*visible-variables* jvm::*visible-variables*)
    515                (specials (jvm::process-declarations-for-vars (cdr form)
    516                                                              nil nil)))
    517           (dolist (special specials)
    518             (push special jvm::*visible-variables*))
    519           (process-progn forms stream compile-time-too))))
     511    (multiple-value-bind (forms decls)
     512        (parse-body (cdr form) nil)
     513      (process-optimization-declarations decls)
     514      (let* ((jvm::*visible-variables* jvm::*visible-variables*)
     515             (specials (jvm::process-declarations-for-vars (cdr form)
     516                                                           nil nil)))
     517        (dolist (special specials)
     518          (push special jvm::*visible-variables*))
     519        (process-progn forms stream compile-time-too))))
    520520  nil)
    521521
     
    536536             :if-exists :supersede)
    537537        (ignore-errors
    538           (jvm:compile-defun nil expr *compile-file-environment*
    539                              classfile f nil)))
     538         (jvm:compile-defun nil expr *compile-file-environment*
     539                            classfile f nil)))
    540540      (when (null (verify-load classfile))
    541541        ;; FIXME error or warning
     
    545545      (if (special-operator-p name)
    546546          `(sys:put ',name 'macroexpand-macro
    547                 (sys:make-macro ',name
    548                                 (sys::get-fasl-function *fasl-loader*
    549                                                         ,saved-class-number)))
     547                    (sys:make-macro ',name
     548                                    (sys::get-fasl-function *fasl-loader*
     549                                                            ,saved-class-number)))
    550550          `(progn
    551551             (sys:put ',name 'sys::source
     
    569569         (body (nthcdr 3 form)))
    570570    (jvm::with-saved-compiler-policy
    571         (multiple-value-bind (body decls doc)
    572             (parse-body body)
    573           (let* ((expr `(lambda ,lambda-list
    574                           ,@decls (block ,block-name ,@body)))
    575                  (saved-class-number *class-number*)
    576                  (classfile (next-classfile))
    577                  (internal-compiler-errors nil)
    578                  (result (with-open-file
    579                              (f classfile
    580                                 :direction :output
    581                                 :element-type '(unsigned-byte 8)
    582                                 :if-exists :supersede)
    583                            (handler-bind
    584                                ((internal-compiler-error
    585                                  #'(lambda (e)
    586                                      (push e internal-compiler-errors)
    587                                      (continue))))
    588                              (report-error
    589                               (jvm:compile-defun name expr *compile-file-environment*
    590                                                  classfile f nil)))))
    591                  (compiled-function (if (not internal-compiler-errors)
    592                                         (verify-load classfile)
    593                                         nil)))
    594             (declare (ignore result))
    595             (cond
    596               ((and (not internal-compiler-errors)
    597                     compiled-function)
    598                (when compile-time-too
    599                  (eval form))
    600                (let ((sym (if (consp name) (second name) name)))
    601                  (setf form
    602                        `(progn
    603                           (sys:put ',sym 'sys::source
    604                                    (cl:cons '((:function ,name)
    605                                               ,(namestring *source*) ,*source-position*)
    606                                             (cl:get ',sym  'sys::source nil)))
    607                           (sys:fset ',name
    608                                     (sys::get-fasl-function *fasl-loader*
    609                                                             ,saved-class-number)
    610                                     ,*source-position*
    611                                     ',lambda-list
    612                                     ,doc)))))
    613               (t
    614                (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
    615                (when internal-compiler-errors
    616                  (dolist (e internal-compiler-errors)
    617                    (format *error-output*
    618                            "; ~A~%" e)))
    619                (let ((precompiled-function
    620                       (precompiler:precompile-form expr nil
    621                                                    *compile-file-environment*)))
    622                  (setf form
    623                        `(sys:fset ',name
    624                                   ,precompiled-function
     571      (multiple-value-bind (body decls doc)
     572          (parse-body body)
     573        (let* ((expr `(lambda ,lambda-list
     574                        ,@decls (block ,block-name ,@body)))
     575               (saved-class-number *class-number*)
     576               (classfile (next-classfile))
     577               (internal-compiler-errors nil)
     578               (result (with-open-file
     579                           (f classfile
     580                              :direction :output
     581                              :element-type '(unsigned-byte 8)
     582                              :if-exists :supersede)
     583                         (handler-bind
     584                             ((internal-compiler-error
     585                                #'(lambda (e)
     586                                    (push e internal-compiler-errors)
     587                                    (continue))))
     588                           (report-error
     589                            (jvm:compile-defun name expr *compile-file-environment*
     590                                               classfile f nil)))))
     591               (compiled-function (if (not internal-compiler-errors)
     592                                      (verify-load classfile)
     593                                      nil)))
     594          (declare (ignore result))
     595          (cond
     596            ((and (not internal-compiler-errors)
     597                  compiled-function)
     598             (when compile-time-too
     599               (eval form))
     600             (let ((sym (if (consp name) (second name) name)))
     601               (setf form
     602                     `(progn
     603                        (sys:put ',sym 'sys::source
     604                                 (cl:cons '((:function ,name)
     605                                            ,(namestring *source*) ,*source-position*)
     606                                          (cl:get ',sym  'sys::source nil)))
     607                        (sys:fset ',name
     608                                  (sys::get-fasl-function *fasl-loader*
     609                                                          ,saved-class-number)
    625610                                  ,*source-position*
    626611                                  ',lambda-list
    627                                   ,doc)))
    628                (when compile-time-too
    629                  (eval form)))))
    630           (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
    631             ;; FIXME Need to support SETF functions too!
    632             (setf (inline-expansion name)
    633                   (jvm::generate-inline-expansion block-name
    634                                                   lambda-list
    635                                                   (append decls body)))
    636             (output-form `(cl:setf (inline-expansion ',name)
    637                                    ',(inline-expansion name))))))
     612                                  ,doc)))))
     613            (t
     614             (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
     615             (when internal-compiler-errors
     616               (dolist (e internal-compiler-errors)
     617                 (format *error-output*
     618                         "; ~A~%" e)))
     619             (let ((precompiled-function
     620                     (precompiler:precompile-form expr nil
     621                                                  *compile-file-environment*)))
     622               (setf form
     623                     `(sys:fset ',name
     624                                ,precompiled-function
     625                                ,*source-position*
     626                                ',lambda-list
     627                                ,doc)))
     628             (when compile-time-too
     629               (eval form)))))
     630        (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
     631          ;; FIXME Need to support SETF functions too!
     632          (setf (inline-expansion name)
     633                (jvm::generate-inline-expansion block-name
     634                                                lambda-list
     635                                                (append decls body)))
     636          (output-form `(cl:setf (inline-expansion ',name)
     637                                 ',(inline-expansion name))))))
    638638    (push name jvm::*functions-defined-in-current-file*)
    639639    (note-name-defined name)
     
    737737(defun populate-zip-fasl (output-file)
    738738  (let* ((type ;; Don't use ".zip", it'll result in an extension with
    739                ;; a dot, which is rejected by NAMESTRING
    740           (%format nil "~A~A" (pathname-type output-file) "-zip"))
     739           ;; a dot, which is rejected by NAMESTRING
     740           (%format nil "~A~A" (pathname-type output-file) "-zip"))
    741741         (output-file (if (logical-pathname-p output-file)
    742742                          (translate-logical-pathname output-file)
    743743                          output-file))
    744744         (zipfile
    745           (if (find :windows *features*)
    746               (make-pathname :defaults output-file :type type)
    747               (make-pathname :defaults output-file :type type
    748                              :device :unspecific)))
     745           (if (find :windows *features*)
     746               (make-pathname :defaults output-file :type type)
     747               (make-pathname :defaults output-file :type type
     748                              :device :unspecific)))
    749749         (pathnames nil)
    750750         (fasl-loader (make-pathname :defaults output-file
     
    856856              (handler-bind
    857857                  ((style-warning
    858                     #'(lambda (c)
    859                         (setf warnings-p t)
    860                         ;; let outer handlers do their thing
    861                         (signal c)
    862                         ;; prevent the next handler
    863                         ;; from running: we're a
    864                         ;; WARNING subclass
    865                         (continue)))
     858                     #'(lambda (c)
     859                         (setf warnings-p t)
     860                         ;; let outer handlers do their thing
     861                         (signal c)
     862                         ;; prevent the next handler
     863                         ;; from running: we're a
     864                         ;; WARNING subclass
     865                         (continue)))
    866866                   ((or warning compiler-error)
    867                     #'(lambda (c)
    868                         (declare (ignore c))
    869                         (setf warnings-p t
    870                               failure-p t))))
     867                     #'(lambda (c)
     868                         (declare (ignore c))
     869                         (setf warnings-p t
     870                               failure-p t))))
    871871                (loop
    872                    (let* ((*source-position* (file-position in))
    873                           (jvm::*source-line-number* (stream-line-number in))
    874                           (form (read in nil in))
    875                           (*compiler-error-context* form))
    876                      (when (eq form in)
    877                        (return))
    878                      (if (>= (length (format nil "~a" form)) 65536)
    879                          ;; Following the solution propose here:
    880                          ;; see https://github.com/armedbear/abcl/issues/246#issuecomment-698854437
    881                          ;; just include the offending interpreted form in the loader
    882                          ;; using it instead of the compiled representation
    883                          (write (ext:macroexpand-all form *compile-file-environment*)
    884                                 :stream out)
    885                          (process-toplevel-form form out nil))
    886                      )))
    887                     (finalize-fasl-output)
    888                     (dolist (name *fbound-names*)
    889                       (fmakunbound name)))))))
    890         (when extract-toplevel-funcs-and-macros
    891           (setf *toplevel-functions*
    892                 (remove-if-not (lambda (func-name)
    893                                  (if (symbolp func-name)
    894                                      (symbol-package func-name)
    895                                      T))
    896                                (remove-duplicates
     872                  (let* ((*source-position* (file-position in))
     873                         (jvm::*source-line-number* (stream-line-number in))
     874                         (form (read in nil in))
     875                         (*compiler-error-context* form))
     876                    (when (eq form in)
     877                      (return))
     878                    (if (>= (length (format nil "~a" form)) 65536)
     879                        ;; Following the solution propose here:
     880                        ;; see https://github.com/armedbear/abcl/issues/246#issuecomment-698854437
     881                        ;; just include the offending interpreted form in the loader
     882                        ;; using it instead of the compiled representation
     883                        (write (ext:macroexpand-all form *compile-file-environment*)
     884                               :stream out)
     885                        (process-toplevel-form form out nil))
     886                    )))
     887              (finalize-fasl-output)
     888              (dolist (name *fbound-names*)
     889                (fmakunbound name)))))))
     890    (when extract-toplevel-funcs-and-macros
     891      (setf *toplevel-functions*
     892            (remove-if-not (lambda (func-name)
     893                             (if (symbolp func-name)
     894                                 (symbol-package func-name)
     895                                 T))
     896                           (remove-duplicates
    897897                            *toplevel-functions*)))
    898           (when *toplevel-functions*
    899             (with-open-file (f-out functions-file
    900                                    :direction :output
    901                                    :if-does-not-exist :create
    902                                    :if-exists :supersede)
    903 
    904               (let ((*package* (find-package :keyword)))
    905                 (write *toplevel-functions* :stream f-out))))
    906           (setf *toplevel-macros*
    907                 (remove-if-not (lambda (mac-name)
    908                                  (if (symbolp mac-name)
    909                                      (symbol-package mac-name)
    910                                      T))
    911                                (remove-duplicates *toplevel-macros*)))
    912           (when *toplevel-macros*
    913             (with-open-file (m-out macros-file
    914                                    :direction :output
    915                                    :if-does-not-exist :create
    916                                    :if-exists :supersede)
    917               (let ((*package* (find-package :keyword)))
    918                 (write *toplevel-macros* :stream m-out))))
    919           (setf *toplevel-exports*
    920                 (remove-if-not (lambda (sym)
    921                                  (if (symbolp sym)
    922                                      (symbol-package sym)
    923                                      T))
    924                                (remove-duplicates *toplevel-exports*)))
    925           (when *toplevel-exports*
    926             (with-open-file (e-out exports-file
    927                                    :direction :output
    928                                    :if-does-not-exist :create
    929                                    :if-exists :supersede)
    930               (let ((*package* (find-package :keyword)))
    931                 (write *toplevel-exports* :stream e-out))))
    932           (setf *toplevel-setf-functions*
    933                 (remove-if-not (lambda (sym)
    934                                  (if (symbolp sym)
    935                                      (symbol-package sym)
    936                                      T))
    937                                (remove-duplicates *toplevel-setf-functions*)))
    938           (when *toplevel-setf-functions*
    939             (with-open-file (e-out setf-functions-file
    940                                    :direction :output
    941                                    :if-does-not-exist :create
    942                                    :if-exists :supersede)
    943               (let ((*package* (find-package :keyword)))
    944                 (write *toplevel-setf-functions* :stream e-out))))
    945           (setf *toplevel-setf-expanders*
    946                 (remove-if-not (lambda (sym)
    947                                  (if (symbolp sym)
    948                                      (symbol-package sym)
    949                                      T))
    950                                (remove-duplicates *toplevel-setf-expanders*)))
    951           (when *toplevel-setf-expanders*
    952             (with-open-file (e-out setf-expanders-file
    953                                    :direction :output
    954                                    :if-does-not-exist :create
    955                                    :if-exists :supersede)
    956               (let ((*package* (find-package :keyword)))
    957                 (write *toplevel-setf-expanders* :stream e-out)))))
    958         (with-open-file (in temp-file :direction :input :external-format *fasl-external-format*)
    959           (with-open-file (out temp-file2 :direction :output
     898      (when *toplevel-functions*
     899        (with-open-file (f-out functions-file
     900                               :direction :output
    960901                               :if-does-not-exist :create
    961                                :if-exists :supersede
    962                                :external-format *fasl-external-format*)
    963             (let ((*package* (find-package :keyword))
    964                   (*print-fasl* t)
    965                   (*print-array* t)
    966                   (*print-base* 10)
    967                   (*print-case* :upcase)
    968                   (*print-circle* nil)
    969                   (*print-escape* t)
    970                   (*print-gensym* t)
    971                   (*print-length* nil)
    972                   (*print-level* nil)
    973                   (*print-lines* nil)
    974                   (*print-pretty* nil)
    975                   (*print-radix* nil)
    976                   (*print-readably* t)
    977                   (*print-right-margin* nil)
    978                   (*print-structure* t)
    979 
    980                   ;; make sure to write all floats with their exponent marker:
    981                   ;; the dump-time default may not be the same at load-time
    982 
    983                   (*read-default-float-format* nil))
    984 
    985               ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
    986               ;; but not used by our reader/printer, so don't bind them,
    987               ;; for efficiency reasons.
    988               ;;        (*read-eval* t)
    989               ;;        (*read-suppress* nil)
    990               ;;        (*print-miser-width* nil)
    991               ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
    992               ;;        (*read-base* 10)
    993               ;;        (*read-default-float-format* 'single-float)
    994               ;;        (*readtable* (copy-readtable nil))
    995 
    996               (write-fasl-prologue out in-package)
    997               ;; copy remaining content
    998               (loop for line = (read-line in nil :eof)
    999                  while (not (eq line :eof))
    1000                     do (write-line line out)))))
    1001         (delete-file temp-file)
    1002         (when (subtypep (type-of output-file) 'jar-pathname)
    1003           (remove-zip-cache-entry output-file))
    1004         (rename-file temp-file2 output-file)
    1005 
    1006         (when *compile-file-zip*
    1007           (populate-zip-fasl output-file))
    1008 
    1009         (when *compile-verbose*
    1010           (format t "~&; Wrote ~A (~A seconds)~%"
    1011                   (namestring output-file)
    1012                   (/ (- (get-internal-real-time) start) 1000.0)))
    1013         (values (truename output-file) warnings-p failure-p)))
     902                               :if-exists :supersede)
     903
     904          (let ((*package* (find-package :keyword)))
     905            (write *toplevel-functions* :stream f-out))))
     906      (setf *toplevel-macros*
     907            (remove-if-not (lambda (mac-name)
     908                             (if (symbolp mac-name)
     909                                 (symbol-package mac-name)
     910                                 T))
     911                           (remove-duplicates *toplevel-macros*)))
     912      (when *toplevel-macros*
     913        (with-open-file (m-out macros-file
     914                               :direction :output
     915                               :if-does-not-exist :create
     916                               :if-exists :supersede)
     917          (let ((*package* (find-package :keyword)))
     918            (write *toplevel-macros* :stream m-out))))
     919      (setf *toplevel-exports*
     920            (remove-if-not (lambda (sym)
     921                             (if (symbolp sym)
     922                                 (symbol-package sym)
     923                                 T))
     924                           (remove-duplicates *toplevel-exports*)))
     925      (when *toplevel-exports*
     926        (with-open-file (e-out exports-file
     927                               :direction :output
     928                               :if-does-not-exist :create
     929                               :if-exists :supersede)
     930          (let ((*package* (find-package :keyword)))
     931            (write *toplevel-exports* :stream e-out))))
     932      (setf *toplevel-setf-functions*
     933            (remove-if-not (lambda (sym)
     934                             (if (symbolp sym)
     935                                 (symbol-package sym)
     936                                 T))
     937                           (remove-duplicates *toplevel-setf-functions*)))
     938      (when *toplevel-setf-functions*
     939        (with-open-file (e-out setf-functions-file
     940                               :direction :output
     941                               :if-does-not-exist :create
     942                               :if-exists :supersede)
     943          (let ((*package* (find-package :keyword)))
     944            (write *toplevel-setf-functions* :stream e-out))))
     945      (setf *toplevel-setf-expanders*
     946            (remove-if-not (lambda (sym)
     947                             (if (symbolp sym)
     948                                 (symbol-package sym)
     949                                 T))
     950                           (remove-duplicates *toplevel-setf-expanders*)))
     951      (when *toplevel-setf-expanders*
     952        (with-open-file (e-out setf-expanders-file
     953                               :direction :output
     954                               :if-does-not-exist :create
     955                               :if-exists :supersede)
     956          (let ((*package* (find-package :keyword)))
     957            (write *toplevel-setf-expanders* :stream e-out)))))
     958    (with-open-file (in temp-file :direction :input :external-format *fasl-external-format*)
     959      (with-open-file (out temp-file2 :direction :output
     960                                      :if-does-not-exist :create
     961                                      :if-exists :supersede
     962                                      :external-format *fasl-external-format*)
     963        (let ((*package* (find-package :keyword))
     964              (*print-fasl* t)
     965              (*print-array* t)
     966              (*print-base* 10)
     967              (*print-case* :upcase)
     968              (*print-circle* nil)
     969              (*print-escape* t)
     970              (*print-gensym* t)
     971              (*print-length* nil)
     972              (*print-level* nil)
     973              (*print-lines* nil)
     974              (*print-pretty* nil)
     975              (*print-radix* nil)
     976              (*print-readably* t)
     977              (*print-right-margin* nil)
     978              (*print-structure* t)
     979
     980              ;; make sure to write all floats with their exponent marker:
     981              ;; the dump-time default may not be the same at load-time
     982
     983              (*read-default-float-format* nil))
     984
     985          ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
     986          ;; but not used by our reader/printer, so don't bind them,
     987          ;; for efficiency reasons.
     988          ;;        (*read-eval* t)
     989          ;;        (*read-suppress* nil)
     990          ;;        (*print-miser-width* nil)
     991          ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
     992          ;;        (*read-base* 10)
     993          ;;        (*read-default-float-format* 'single-float)
     994          ;;        (*readtable* (copy-readtable nil))
     995
     996          (write-fasl-prologue out in-package)
     997          ;; copy remaining content
     998          (loop for line = (read-line in nil :eof)
     999                while (not (eq line :eof))
     1000                do (write-line line out)))))
     1001    (delete-file temp-file)
     1002    (when (subtypep (type-of output-file) 'jar-pathname)
     1003      (remove-zip-cache-entry output-file))
     1004    (rename-file temp-file2 output-file)
     1005
     1006    (when *compile-file-zip*
     1007      (populate-zip-fasl output-file))
     1008
     1009    (when *compile-verbose*
     1010      (format t "~&; Wrote ~A (~A seconds)~%"
     1011              (namestring output-file)
     1012              (/ (- (get-internal-real-time) start) 1000.0)))
     1013    (values (truename output-file) warnings-p failure-p)))
    10141014
    10151015(defun compile-file (input-file
    10161016                     &key
    1017                      output-file
    1018                      ((:verbose *compile-verbose*) *compile-verbose*)
    1019                      ((:print *compile-print*) *compile-print*)
    1020                      (extract-toplevel-funcs-and-macros nil)
    1021                      (external-format :utf-8))
     1017                       output-file
     1018                       ((:verbose *compile-verbose*) *compile-verbose*)
     1019                       ((:print *compile-print*) *compile-print*)
     1020                       (extract-toplevel-funcs-and-macros nil)
     1021                       (external-format :utf-8))
    10221022  (flet ((pathname-with-type (pathname type &optional suffix)
    10231023           (when suffix
Note: See TracChangeset for help on using the changeset viewer.