Changeset 8314


Ignore:
Timestamp:
12/30/04 18:30:08 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

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

Legend:

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

    r8313 r8314  
    22;;;
    33;;; Copyright (C) 2004 Peter Graves
    4 ;;; $Id: compile-file.lisp,v 1.49 2004-12-29 05:33:56 piso Exp $
     4;;; $Id: compile-file.lisp,v 1.50 2004-12-30 18:30:08 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    228228         (type (pathname-type output-file))
    229229         (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
    230                                      output-file)))
     230                                     output-file))
     231         (warnings-p t)
     232         (failure-p t))
    231233    (with-open-file (in input-file :direction :input)
    232234      (let* ((*compile-file-pathname* (pathname in))
     
    237239             elapsed)
    238240        (%format t "; Compiling ~A ...~%" namestring)
    239         (with-open-file (out temp-file :direction :output :if-exists :supersede)
    240           (let ((*readtable* *readtable*)
    241                 (*package* *package*)
    242                 (jvm:*speed* jvm:*speed*)
    243                 (jvm:*safety* jvm:*safety*)
    244                 (jvm:*debug* jvm:*debug*)
    245                 (jvm::*toplevel-defuns* ())
    246                 (*fbound-names* ()))
    247             (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    248             (terpri out)
    249             (let ((*package* (find-package '#:cl)))
    250               (write (list 'init-fasl :version *fasl-version*) :stream out)
    251               (terpri out)
    252               (write (list 'setq '*fasl-source* *compile-file-truename*) :stream out)
    253               (terpri out))
    254             (loop
    255               (let* ((*source-position* (file-position in))
    256                      (form (read in nil in)))
    257                 (when (eq form in)
    258                   (return))
    259                 (process-toplevel-form form out nil)))
    260             (dolist (name *fbound-names*)
    261               (fmakunbound name))))
     241        (jvm::with-compilation-unit
     242         (with-open-file (out temp-file :direction :output :if-exists :supersede)
     243           (let ((*readtable* *readtable*)
     244                 (*package* *package*)
     245                 (jvm:*speed* jvm:*speed*)
     246                 (jvm:*safety* jvm:*safety*)
     247                 (jvm:*debug* jvm:*debug*)
     248                 (jvm::*toplevel-defuns* ())
     249                 (*fbound-names* ()))
     250             (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
     251             (terpri out)
     252             (let ((*package* (find-package '#:cl)))
     253               (write (list 'init-fasl :version *fasl-version*) :stream out)
     254               (terpri out)
     255               (write (list 'setq '*fasl-source* *compile-file-truename*) :stream out)
     256               (terpri out))
     257             (loop
     258               (let* ((*source-position* (file-position in))
     259                      (form (read in nil in)))
     260                 (when (eq form in)
     261                   (return))
     262                 (process-toplevel-form form out nil)))
     263             (dolist (name *fbound-names*)
     264               (fmakunbound name))))
     265         (cond
     266          ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
     267           (setf warnings-p nil failure-p nil))
     268          ((zerop (+ jvm::*errors* jvm::*warnings*))
     269           (setf failure-p nil))))
    262270        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
    263271        (rename-file temp-file output-file)
    264         (%format t "; Compiled ~A (~A seconds)~%" namestring elapsed))))
    265   (values (truename output-file) nil nil))
     272        (%format t "; Compiled ~A (~A seconds)~%" namestring elapsed)))
     273    (values (truename output-file) warnings-p failure-p)))
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8313 r8314  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.328 2004-12-29 05:34:14 piso Exp $
     4;;; $Id: jvm.lisp,v 1.329 2004-12-30 18:29:32 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    116116;; All variables seen so far.
    117117(defvar *all-variables* ())
     118
     119;; Undefined variables that we've already warned about.
     120(defvar *undefined-variables* ())
    118121
    119122(defvar *dump-variables* nil)
     
    925928  (emit-move-from-stack target representation))
    926929
    927 (defun require-args (form n)
     930(defvar *style-warnings* nil)
     931(defvar *warnings* nil)
     932(defvar *errors* nil)
     933
     934(defun compiler-style-warn (format-control &rest format-arguments)
     935  (incf *style-warnings*)
     936  (warn 'style-warning
     937        :format-control format-control
     938        :format-arguments format-arguments))
     939
     940(defun compiler-warn (format-control &rest format-arguments)
     941  (incf *warnings*)
     942  (warn 'warning
     943        :format-control format-control
     944        :format-arguments format-arguments))
     945
     946(defun check-args (form n)
    928947  (declare (type fixnum n))
    929   (unless (= (length form) (1+ n))
    930     (error 'program-error
    931            :format-control "Wrong number of arguments for ~A."
    932            :format-arguments (list (car form)))))
     948  (cond ((= (length form) (1+ n))
     949         t)
     950        (t
     951         (compiler-style-warn "Wrong number of arguments for ~A." (car form))
     952         nil)))
    933953
    934954(defparameter *resolvers* (make-hash-table :test #'eql))
     
    25592579           (if (and (symbolp sym)
    25602580                    (eq (symbol-package sym) (find-package "CL"))
    2561                     (not (special-operator-p sym)))
     2581                    (not (special-operator-p sym))
     2582                    (not (macro-function sym)))
    25622583               `(,(cadr fun) ,@args)
    25632584               form)))
     
    25672588(defun compile-funcall (form &key (target *val*) representation)
    25682589  (unless (> (length form) 1)
    2569     (error "Wrong number of arguments for FUNCALL."))
     2590    (compiler-style-warn "Wrong number of arguments for ~A." (car form))
     2591    (compile-function-call form target representation))
    25702592  (when (> *debug* *speed*)
    25712593    (return-from compile-funcall (compile-function-call form target representation)))
    2572   (let ((new-form (rewrite-function-call form)))
    2573     (when (neq new-form form)
    2574       (return-from compile-funcall (compile-form new-form :target target))))
     2594;;   (let ((new-form (rewrite-function-call form)))
     2595;;     (when (neq new-form form)
     2596;;       (return-from compile-funcall (compile-form new-form :target target))))
    25752597  (compile-form (cadr form) :target :stack)
    25762598  (maybe-emit-clear-values (cadr form))
     
    28982920  (when (and (consp form)
    28992921             (not (special-operator-p (car form))))
    2900     (let ((new-form (rewrite-function-call form)))
    2901       (when (neq new-form form)
    2902         (return-from compile-test (compile-test new-form negatep))))
     2922;;     (let ((new-form (rewrite-function-call form)))
     2923;;       (when (neq new-form form)
     2924;;         (return-from compile-test (compile-test new-form negatep))))
    29032925    (case (length form)
    29042926      (2
     
    36123634
    36133635(defun compile-cons (form &key (target *val*) representation)
    3614   (require-args form 2)
     3636  (unless (check-args form 2)
     3637    (compile-function-call form target representation)
     3638    (return-from compile-cons))
    36153639  (emit 'new +lisp-cons-class+)
    36163640  (emit 'dup)
     
    36853709
    36863710(defun compile-rplacd (form &key (target *val*) representation)
    3687   (let ((new-form (rewrite-function-call form)))
    3688     (when (neq new-form form)
    3689       (return-from compile-rplacd (compile-form new-form :target target))))
     3711;;   (let ((new-form (rewrite-function-call form)))
     3712;;     (when (neq new-form form)
     3713;;       (return-from compile-rplacd (compile-form new-form :target target))))
    36903714  (let ((args (cdr form)))
    36913715    (unless (= (length args) 2)
     
    39643988(defun p2-ash (form &key (target *val*) representation)
    39653989  (dformat t "p2-ash form = ~S representation = ~S~%" form representation)
    3966   (require-args form 2)
     3990  (unless (check-args form 2)
     3991    (compile-function-call form target representation)
     3992    (return-from p2-ash))
    39673993  (let* ((args (cdr form))
    39683994         (len (length args))
     
    39703996         (arg2 (second args))
    39713997         (var1 (unboxed-fixnum-variable arg1))
    3972          (var2 (unboxed-fixnum-variable arg2))
    3973          )
     3998         (var2 (unboxed-fixnum-variable arg2)))
    39743999    (cond
    39754000     ((and (numberp arg1) (numberp arg2))
     
    41094134
    41104135(defun compile-length (form &key (target *val*) representation)
    4111   (require-args form 1)
     4136  (check-args form 1)
    41124137  (let ((arg (cadr form)))
    41134138    (compile-form arg :target :stack)
     
    41274152
    41284153(defun compile-nth (form &key (target *val*) representation)
    4129   (require-args form 2)
     4154  (unless (check-args form 2)
     4155    (compile-function-call form target representation)
     4156    (return-from compile-nth))
    41304157  (let ((index-form (second form))
    41314158        (list-form (third form)))
     
    44914518            (return-from compile-variable-reference))))
    44924519      (unless (special-variable-p name)
    4493         ;; FIXME This should be a warning!
    4494         (%format t "~A Note: undefined variable ~S~%" (load-verbose-prefix) name))
     4520        (unless (memq name *undefined-variables*)
     4521          (compiler-warn "Undefined variable ~S" name)
     4522          (push name *undefined-variables*)))
    44954523      (compile-special-reference name target representation))
    44964524     ((eq (variable-representation variable) :unboxed-fixnum)
     
    49204948    (setf precompiled-form (p1 precompiled-form))
    49214949    ;; Pass 2.
    4922     (let* (
    4923 ;;            (*speed* *speed*)
    4924 ;;            (*safety* *safety*)
    4925 ;;            (*debug* *debug*)
    4926            (*declared-symbols* (make-hash-table :test 'eq))
     4950    (let* ((*declared-symbols* (make-hash-table :test 'eq))
    49274951           (*declared-functions* (make-hash-table :test 'equal))
    49284952           (*declared-strings* (make-hash-table :test 'eq))
     
    49634987
    49644988           (*visible-variables* *visible-variables*)
    4965 
    49664989           (*all-variables* *all-variables*)
     4990           (*undefined-variables* *undefined-variables*)
    49674991
    49684992           (parameters ())
     
    51635187  (unless (or (null environment) (sys::empty-environment-p environment))
    51645188    (error "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment."))
    5165   ;;   (prog1
    5166   (let ((precompiled-form (precompile-form form t)))
    5167     (compile-1 (make-compiland :name name
    5168                                :lambda-expression precompiled-form
    5169                                :classfile classfile
    5170                                :parent *current-compiland*))))
     5189  (handler-bind ((warning #'handle-warning))
     5190    (let ((precompiled-form (precompile-form form t)))
     5191      (compile-1 (make-compiland :name name
     5192                                 :lambda-expression precompiled-form
     5193                                 :classfile classfile
     5194                                 :parent *current-compiland*)))))
     5195
     5196(defun handle-warning (condition)
     5197  (fresh-line)
     5198  (format t "; Caught ~A:~%;   ~A~%" (type-of condition) condition)
     5199  (muffle-warning))
    51715200
    51725201(defun get-lambda-to-compile (definition-designator)
     
    51885217
    51895218(defvar *catch-errors* t)
     5219
     5220(defmacro with-compilation-unit (&body body)
     5221  `(let ((*style-warnings* 0)
     5222         (*warnings* 0)
     5223         (*errors* 0))
     5224     (unwind-protect
     5225      (progn ,@body)
     5226      (unless (and (zerop *warnings*) (zerop *style-warnings*))
     5227        (format t "~%; Compilation unit finished~%")
     5228        (unless (zerop *warnings*)
     5229          (format t ";   Caught ~D WARNING condition~P~%"
     5230                  *warnings* *warnings*))
     5231        (unless (zerop *style-warnings*)
     5232          (format t ";   Caught ~D STYLE-WARNING condition~P~%"
     5233                  *style-warnings* *style-warnings*))
     5234        (terpri)))))
    51905235
    51915236(defun %jvm-compile (name definition)
     
    52105255      (when (and *compile-print* name)
    52115256        (%format t "~A Already compiled ~S~%" prefix name))
    5212       (return-from %jvm-compile (values definition nil nil)))
     5257      (return-from %jvm-compile (values name nil nil)))
    52135258    (multiple-value-bind (expr env) (get-lambda-to-compile definition)
    52145259      (let* ((*package* (if (and name (symbol-package name))
    52155260                            (symbol-package name)
    52165261                            *package*))
    5217              (classfile (compile-defun name expr env))
    5218              (compiled-definition (sys:load-compiled-function classfile)))
    5219         (when (and name (functionp compiled-definition))
    5220           (sys::%set-lambda-name compiled-definition name)
    5221           (sys:set-call-count compiled-definition (sys:call-count definition))
    5222           (sys::%set-arglist compiled-definition (sys::arglist definition))
    5223           (if (macro-function name)
    5224               (setf (fdefinition name) (sys::make-macro name compiled-definition))
    5225               (setf (fdefinition name) compiled-definition)))
    5226         (when *compile-print*
    5227           (if name
    5228               (%format t "~A Compiled ~S~%" prefix name)
    5229               (%format t "~A Compiled top-level form~%" prefix)))
    5230         (values (or name compiled-definition) nil nil)))))
     5262             classfile
     5263             compiled-definition
     5264             (warnings-p t)
     5265             (failure-p t))
     5266;;              (classfile (compile-defun name expr env))
     5267;;              (compiled-definition (sys:load-compiled-function classfile)))
     5268        (with-compilation-unit
     5269          (setf classfile (compile-defun name expr env))
     5270          (setf compiled-definition (sys:load-compiled-function classfile))
     5271          (when (and name (functionp compiled-definition))
     5272            (sys::%set-lambda-name compiled-definition name)
     5273            (sys:set-call-count compiled-definition (sys:call-count definition))
     5274            (sys::%set-arglist compiled-definition (sys::arglist definition))
     5275            (if (macro-function name)
     5276                (setf (fdefinition name) (sys::make-macro name compiled-definition))
     5277                (setf (fdefinition name) compiled-definition)))
     5278          (cond
     5279           ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
     5280            (setf warnings-p nil failure-p nil))
     5281           ((zerop (+ jvm::*errors* jvm::*warnings*))
     5282            (setf failure-p nil)))
     5283          (when *compile-print*
     5284            (if name
     5285                (%format t "~A Compiled ~S~%" prefix name)
     5286                (%format t "~A Compiled top-level form~%" prefix))))
     5287        (values (or name compiled-definition) warnings-p failure-p)))))
    52315288
    52325289(defun jvm-compile (name &optional definition)
  • trunk/j/src/org/armedbear/lisp/precompiler.lisp

    r8309 r8314  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: precompiler.lisp,v 1.85 2004-12-28 12:27:44 piso Exp $
     4;;; $Id: precompiler.lisp,v 1.86 2004-12-30 18:29:23 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    101101             (symbolp (cadr callee))
    102102             (not (special-operator-p (cadr callee)))
     103             (not (macro-function (cadr callee)))
    103104             (memq (symbol-package (cadr callee))
    104105                   (list (find-package "CL") (find-package "SYS"))))
Note: See TracChangeset for help on using the changeset viewer.