Changeset 8442


Ignore:
Timestamp:
02/01/05 14:21:31 (16 years ago)
Author:
piso
Message:

WITH-COMPILATION-UNIT

Location:
trunk/j/src/org/armedbear/lisp
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/autoloads.lisp

    r8425 r8442  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: autoloads.lisp,v 1.174 2005-01-31 17:20:31 piso Exp $
     4;;; $Id: autoloads.lisp,v 1.175 2005-02-01 14:21:31 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    276276(in-package "JVM")
    277277(export '(jvm-compile jvm-compile-package))
     278(autoload '%with-compilation-unit "jvm")
  • trunk/j/src/org/armedbear/lisp/compile-file.lisp

    r8416 r8442  
    22;;;
    33;;; Copyright (C) 2004-2005 Peter Graves
    4 ;;; $Id: compile-file.lisp,v 1.52 2005-01-31 05:54:14 piso Exp $
     4;;; $Id: compile-file.lisp,v 1.53 2005-02-01 14:21:03 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    246246             elapsed)
    247247        (%format t "; Compiling ~A ...~%" namestring)
    248         (jvm::with-compilation-unit
    249          (with-open-file (out temp-file :direction :output :if-exists :supersede)
    250            (let ((*readtable* *readtable*)
    251                  (*package* *package*)
    252                  (jvm:*speed* jvm:*speed*)
    253                  (jvm:*safety* jvm:*safety*)
    254                  (jvm:*debug* jvm:*debug*)
    255                  (jvm::*toplevel-defuns* ())
    256                  (*fbound-names* ()))
    257              (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    258              (terpri out)
    259              (let ((*package* (find-package '#:cl)))
    260                (write (list 'init-fasl :version *fasl-version*) :stream out)
    261                (terpri out)
    262                (write (list 'setq '*fasl-source* *compile-file-truename*) :stream out)
    263                (terpri out))
    264              (loop
    265                (let* ((*source-position* (file-position in))
    266                       (form (read in nil in)))
    267                  (when (eq form in)
    268                    (return))
    269                  (process-toplevel-form form out nil)))
    270              (dolist (name *fbound-names*)
    271                (fmakunbound name))))
    272          (cond
    273           ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
    274            (setf warnings-p nil failure-p nil))
    275           ((zerop (+ jvm::*errors* jvm::*warnings*))
    276            (setf failure-p nil))))
     248        (with-compilation-unit ()
     249          (with-open-file (out temp-file :direction :output :if-exists :supersede)
     250            (let ((*readtable* *readtable*)
     251                  (*package* *package*)
     252                  (jvm:*speed* jvm:*speed*)
     253                  (jvm:*safety* jvm:*safety*)
     254                  (jvm:*debug* jvm:*debug*)
     255                  (jvm::*toplevel-defuns* ())
     256                  (*fbound-names* ()))
     257              (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
     258              (terpri out)
     259              (let ((*package* (find-package '#:cl)))
     260                (write (list 'init-fasl :version *fasl-version*) :stream out)
     261                (terpri out)
     262                (write (list 'setq '*fasl-source* *compile-file-truename*) :stream out)
     263                (terpri out))
     264              (loop
     265                (let* ((*source-position* (file-position in))
     266                       (form (read in nil in)))
     267                  (when (eq form in)
     268                    (return))
     269                  (process-toplevel-form form out nil)))
     270              (dolist (name *fbound-names*)
     271                (fmakunbound name))))
     272          (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
     273                 (setf warnings-p nil failure-p nil))
     274                ((zerop (+ jvm::*errors* jvm::*warnings*))
     275                 (setf failure-p nil))))
    277276        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
    278277        (rename-file temp-file output-file)
  • trunk/j/src/org/armedbear/lisp/compile-system.lisp

    r8431 r8442  
    22;;;
    33;;; Copyright (C) 2004-2005 Peter Graves
    4 ;;; $Id: compile-system.lisp,v 1.38 2005-01-31 17:28:17 piso Exp $
     4;;; $Id: compile-system.lisp,v 1.39 2005-02-01 14:20:49 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7575            target-file))))
    7676
    77 (defun compile-system ()
    78   (check-lisp-home)
    79   (time
    80    (let ((*default-pathname-defaults* (pathname *lisp-home*))
     77(defun %compile-system ()
     78  (let ((*default-pathname-defaults* (pathname *lisp-home*))
    8179         (*warn-on-redefinition* nil))
    8280     (load (maybe-compile-file "precompiler.lisp"))
     
    255253                                  "swank-abcl.lisp"
    256254                                  "swank.lisp"))
    257      t)))
     255     t))
     256
     257(defun compile-system ()
     258  (check-lisp-home)
     259  (time
     260   (with-compilation-unit ()
     261     (%compile-system))))
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8441 r8442  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.381 2005-02-01 05:20:45 piso Exp $
     4;;; $Id: jvm.lisp,v 1.382 2005-02-01 14:20:29 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    54255425(defvar *catch-errors* t)
    54265426
    5427 (defmacro with-compilation-unit (&body body)
    5428   `(let ((*style-warnings* 0)
    5429          (*warnings* 0)
    5430          (*errors* 0))
    5431      (unwind-protect
    5432       (progn ,@body)
    5433       (unless (and (zerop *warnings*) (zerop *style-warnings*))
    5434         (format t "~%; Compilation unit finished~%")
    5435         (unless (zerop *warnings*)
    5436           (format t ";   Caught ~D WARNING condition~P~%"
    5437                   *warnings* *warnings*))
    5438         (unless (zerop *style-warnings*)
    5439           (format t ";   Caught ~D STYLE-WARNING condition~P~%"
    5440                   *style-warnings* *style-warnings*))
    5441         (terpri)))))
     5427(defvar *in-compilation-unit* nil)
     5428
     5429(defmacro with-compilation-unit (options &body body)
     5430  `(%with-compilation-unit (lambda () ,@body) ,@options))
     5431
     5432(defun %with-compilation-unit (fn &key override)
     5433  (if (and *in-compilation-unit* (not override))
     5434      (funcall fn)
     5435      (let ((*style-warnings* 0)
     5436            (*warnings* 0)
     5437            (*errors* 0))
     5438        (unwind-protect
     5439            (funcall fn)
     5440          (unless (and (zerop *warnings*) (zerop *style-warnings*))
     5441            (format t "~%; Compilation unit finished~%")
     5442            (unless (zerop *warnings*)
     5443              (format t ";   Caught ~D WARNING condition~P~%"
     5444                      *warnings* *warnings*))
     5445            (unless (zerop *style-warnings*)
     5446              (format t ";   Caught ~D STYLE-WARNING condition~P~%"
     5447                      *style-warnings* *style-warnings*))
     5448            (terpri))))))
    54425449
    54435450(defun %jvm-compile (name definition)
     
    54705477             (warnings-p t)
    54715478             (failure-p t))
    5472         (with-compilation-unit
     5479        (with-compilation-unit ()
    54735480          (let ((filespec (compile-defun name expr env)))
    54745481            (setf compiled-definition (sys:load-compiled-function filespec))
Note: See TracChangeset for help on using the changeset viewer.